C
C Program SRCSRC to update the source coordinates during the C simultaneous inversion of arrival times for both model and hypocentral C parameters C C Version: 5.80 C Date: 2004, April 15 C C Coded by Ludek KLimes C Department of Geophysics, Charles University Prague, C Ke Karlovu 3, 121 16 Praha 2, Czech Republic, C E-mail: klimes@seis.karlov.mff.cuni.cz C C....................................................................... C C Description of data files: C C Input data read from the standard input device (*): C The data are read by the list directed input (free format) and C consist of a single string 'SEP': C 'SEP'...String in apostrophes containing the name of the input C SEP parameter or history file with the input data. C No default, 'SEP' must be specified and cannot be blank. C C C Input data file 'SEP': C File 'SEP' has the form of the SEP C parameter file. The parameters, which do not differ from their C defaults, need not be specified in file 'SEP'. C List of parameters: C INVSRC='string'... Name of the input file containing the list of C names of NSRC source points to be updated. C No default, INVSRC must be specified and cannot be blank. C M1MOD='string'... Name of the input file containing the number NM C of model parameters (a single integer). C The file is generated by program 'invsoft.for'. C Default: M1MOD='m1mod.out' C M1='string'... Name of the input file containing the number C M1=NM+4*NSRC of model and source parameters (a single C integer). C The file is generated by program 'invtt.for'. C Default: M1='m1.out' C MODNEW='string'... Name of the input file containing M1MOD updates C of the values of model parameters and 4*NSRC updates of C coordinates of NSRC sources listed in file INVSRC. C File MODNEW C No default, MODNEW must be specified and cannot be blank. C SRC='string'... String with the name of the input data file C containing the coordinates of the source points. C No default, SRC must be specified and cannot be blank. C SRCNEW='string'... String with the name of the output data file C for the updated coordinates of the source points. C No default, SRCNEW must be specified and cannot be blank. C C======================================================================= C C External procedures: EXTERNAL LENGTH,RSEP1,RSEP3T,ERROR INTEGER LENGTH C C Filenames: CHARACTER*80 FILE1,FILE2 C C Logical unit numbers: INTEGER LU1,LU2 PARAMETER (LU1=1,LU2=2) C C Storage locations for source update data: INTEGER MSRC PARAMETER (MSRC=1000) CHARACTER*11 SRC(MSRC) REAL UPDATE(4,MSRC) COMMON/SRCT/ SRC SAVE /SRCT/ COMMON/SRCR/ UPDATE SAVE /SRCR/ C C Other storage locations: CHARACTER*16 TEXT INTEGER NSRC,M1MOD,M1,I,J REAL X1,X2,X3,X4,AUX C C....................................................................... C C Reading main input data: WRITE(*,'(A)') '+SRCSRC: Enter input filename: ' FILE1=' ' READ (*,*) FILE1 IF(FILE1.EQ.' ') THEN C SRCSRC-01 CALL ERROR('SRCSRC-01: No input SEP file specified') C Input file in the form of the SEP (Stanford Exploration Project) C parameter or history file must be specified. C There is no default filename. END IF WRITE(*,'(A)') '+SRCSRC: Working... ' CALL RSEP1(LU1,FILE1) C C Reading names of updated sources: CALL RSEP3T('INVSRC',FILE1 ,' ') IF(FILE1.EQ.' ') THEN C SRCSRC-02 CALL ERROR('SRCSRC-02: No list INVSRC of sources to update') END IF OPEN(LU1,FILE=FILE1,STATUS='OLD') NSRC=0 10 CONTINUE IF(NSRC+1.GT.MSRC) THEN C SRCSRC-03 CALL ERROR('SRCSRC-03: Small dimension MSRC of array SRC') END IF SRC(NSRC+1)='$' READ(LU1,*,END=19) SRC(NSRC+1) IF(SRC(NSRC+1).EQ.'$') THEN GO TO 19 END IF NSRC=NSRC+1 GO TO 10 19 CONTINUE CLOSE(LU1) C C Reading the numbers of model and source parameters: M1MOD=0 CALL RSEP3T('M1MOD',FILE1,'m1mod.out') IF(FILE1.NE.' ') THEN OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1MOD CLOSE(LU1) END IF M1=M1MOD CALL RSEP3T('M1',FILE1,'m1.out') IF(FILE1.NE.' ') THEN OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) M1 CLOSE(LU1) END IF IF(M1MOD+4*NSRC.NE.M1) THEN C SRCSRC-04 CALL ERROR('SRCSRC-04: Incorrect number of sources to update') END IF C C Reading the updates of the source coordinates: CALL RSEP3T('MODNEW',FILE1 ,' ') IF(FILE1.EQ.' ') THEN C SRCSRC-05 CALL ERROR('SRCSRC-05: No update file MODNEW') END IF OPEN(LU1,FILE=FILE1,STATUS='OLD') READ(LU1,*) (AUX,I=1,M1MOD),((UPDATE(I,J),I=1,4),J=1,NSRC) CLOSE(LU1) C C Updating the source coordinates: CALL RSEP3T('SRC',FILE1 ,' ') IF(FILE1.EQ.' ') THEN C SRCSRC-06 CALL ERROR('SRCSRC-06: No input file SRC with source points') END IF CALL RSEP3T('SRCNEW',FILE2 ,' ') IF(FILE2.EQ.' ') THEN C SRCSRC-07 CALL ERROR('SRCSRC-07: No output file SRCNEW for source points') END IF OPEN(LU1,FILE=FILE1,STATUS='OLD') OPEN(LU2,FILE=FILE2) READ(LU1,*) (TEXT,I=1,20) WRITE(LU2,'(A)') '/' 50 CONTINUE TEXT='$' READ(LU1,*,END=59) TEXT,X1,X2,X3,X4 IF(TEXT.EQ.'$') THEN WRITE(LU2,'(A)') '/' GO TO 59 END IF DO 51 I=1,NSRC IF(SRC(I).EQ.TEXT(1:11)) THEN X1=X1+UPDATE(1,I) X2=X2+UPDATE(2,I) X3=X3+UPDATE(3,I) X4=X4+UPDATE(4,I) GO TO 52 END IF 51 CONTINUE 52 CONTINUE WRITE(LU2,'(3A,3(1X,F10.3),1X,F10.6,A)') * '''',TEXT(1:LENGTH(TEXT)),'''',X1,X2,X3,X4,' /' GO TO 50 59 CONTINUE CLOSE(LU1) CLOSE(LU2) C WRITE(*,'(A)') '+SRCSRC: Done. ' STOP END C C======================================================================= C INCLUDE 'error.for' C error.for INCLUDE 'sep.for' C sep.for INCLUDE 'length.for' C length.for C C======================================================================= C