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