source: trunk/src/seismic_processing/hyp2000/hypro.for @ 3172

Revision 3172, 11.8 KB checked in by paulf, 13 years ago (diff)

changes for g77

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1      SUBROUTINE HYPRO
2C--INTERACTIVELY PROCESS EVENTS IN INDIVIDUAL FILES.
3      LOGICAL LR,KILLS, LTEMP, LKILL
4      CHARACTER BASE*20,C13*15,CP*1,CC*1,CS*1,SCD*1,TRY(20)*103
5      CHARACTER STA*5, SNET*2, SCOMP*3, SLOC*2
6      CHARACTER PRVSTA*5, PRVNET*2, PRVCMP*3, PRVLOC*2
7      INCLUDE 'common.inc'
8      LOGICAL FOUNDIT
9C--LASK IS A LOGICAL FUNCTION. THE OS2 COMPILER COMPLAINS WITHOUT THESE LINES
10c      LOGICAL LASK
11c      EXTERNAL LASK
12
13      BASE=' '
14      ISEQ=0
15
16C--BLANK OUT STATION CODES
17      STA=' '
18      SNET=' '
19      SCOMP=' '
20      SLOC=' '
21      PRVSTA=' '
22      PRVNET=' '
23      PRVCMP=' '
24      PRVLOC=' '
25
26C--IF ALL SUBSEQUENT STATIONS ARE WEIGHTED OUT USING !, KLAST REMEMBERS LAST
27C  STATION KEPT
28      KLAST=0
29
30C--OPEN THE EVENT ID FILE WHICH LISTS BASE FILENAMES TO BE PROCESSED.
31      CALL OPENR (17,LSTFIL,'F',IOS)
32      IF (IOS.NE.0) GOTO 32
33
34C****************** BEGIN EVENT LOOP **********************************
35C--READ THE BASE ID STRING FROM THE EVENT LIST FILE
362     READ (17,LSTFOR,ERR=2,END=70) BASE(1:NCBASE)
37C--IGNORE BLANK LINES OR ONES COMMENTED OUT WITH * IN COL 1
38      IF (BASE.EQ.'                    ' .OR. BASE(1:1).EQ.'*') GOTO 2
39C--TURN ANY BLANKS IN THE FILENAME TO ZEROS
40      DO I=1,NCBASE
41        IF (BASE(I:I).EQ.' ') BASE(I:I)='0'
42      END DO
43
44C--FORM THE I/O FILENAMES FROM THE BASE STRING
45      PHSFIL=' '
46      ARCFIL=' '
47      SUMFIL=' '
48      PRTFIL=' '
49      PHSFIL=(BASE(1:NCBASE)//EXTPHS)
50      ARCFIL=(BASE(1:NCBASE)//EXTARC)
51      SUMFIL=(BASE(1:NCBASE)//EXTSUM)
52      PRTFIL=(BASE(1:NCBASE)//EXTPRT)
53
54C--INITIALIZE SOME VARIABLES. DONT CALL HYOPEN OR HYSTL.
55      ISEQ=ISEQ+1
56      CALL HYINIT
57      GOTO 38
58
59C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT EVENT LIST FILES
6032    WRITE (6,*)' *** ERROR - EVENT LIST FILE DOES NOT EXIST ***'
61      RETURN
62
63C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT PHASE FILES
6433    WRITE (6,1010) PHSFIL
651010      FORMAT (' *** ERROR - PHASE FILE DOES NOT EXIST:'/1X,A)
66      GOTO 2
67
68C--ERROR MESSAGE FOR NON-EXISTENT PRINT FILES
6934    WRITE (6,1003) PRTFIL
701003      FORMAT (' *** ERROR - PRINT FILE DOES NOT EXIST:'/1X,A)
71      GOTO 42
72
73C********************** BEGIN EVENT PROCESSING LOOP *******************
74C--OPEN PHASE FILE & READ IT
7538    KEND=0
76      IF (JCP.LT.6) THEN
77        CALL OPENR (14,PHSFIL,'F',IOS)
78        IF (IOS.NE.0) GOTO 33
79      ELSE
80        WRITE (6,'('' *** CANNOT PROCESS CUSP EVENTS INTERACTIVELY'')')
81        RETURN
82      END IF
83
84C--GO READ THE EVENT
85      CALL HYPHS
86C--CLOSE FILE UNLESS IT IS A LARGE EVENT AND MORE PHASES REMAIN
87      IF (.NOT.LTBIG) CLOSE (14)
88
89C--INITIALIZE SOME VALUES
90      INUM=0
91
92C--KEND IS SET BY HYPHS DEPENDING ON END-OF-FILE STATUS
93C  =-1  END OF FILE, STOP RIGHT AWAY
94C  = 0  LOCATE THIS EVENT, THEN READ ANOTHER
95C  = 1  END OF FILE, LOCATE THIS EVENT THEN STOP
96      IF (KEND.LT.0) THEN
97        WRITE (6,1004) BASE(1:NCBASE)
981004    FORMAT (' *** CANNOT FIND DATA FOR ',A)
99        GOTO 2
100      END IF
101
102C--SET THE TRIAL HYPOCENTER
103C--RETURN HERE IF ONLY THE WEIGHTS WERE CHANGED IN THE PRINT FILE
10442    CALL HYTRL
105
106C--OPEN OUTPUT FILES
107      IF (LSUM) CALL OPENW (12,SUMFIL,'F',IOS,'S')
108      IF (LARC) CALL OPENW (7,ARCFIL,'F',IOS,'S')
109      IF (LPRT) CALL OPENW (15,PRTFIL,'F',IOS,'S')
110
111C--WRITE HEADER
112      IF (LPRT) WRITE (15,1005) ISEQ,INUM,IDNO
1131005  FORMAT (I6,'=SEQUENCE',I4,'=TRY',I10,'=ID')
114C--LOCATE THE EVENT
115      CALL HYLOC
116
117C--ASSIGN A 3-LETTER CODE AND NAME BASED ON LOCATION
118C  I IS THE REGION NUMBER, PRESENTLY UNUSED
119      IF (NET.GT.0) I=KLAS (NET,CLAT,-CLON,Z1,REMK,FULNAM)
120
121C--CALCULATE THE EARTHQUAKE'S MAGNITUDE
122      CALL HYMAG
123
124C--CALCULATE THE EARTHQUAKE'S P AMPLITUDE MAGNITUDE
125      CALL HYMAGP
126
127C--SELECT PREFERRED MAGNITUDE
128      CALL HYPREF
129
130C--TABULATE DATA SOURCE CODES
131      CALL HYSOU
132
133C--WRITE PAST LOCATION TRIES, IF ANY
134      IF (INUM.GT.1 .AND. LPRT) THEN
135        WRITE (15,1000)
136        DO I=1,INUM-1
137          WRITE (15,'(A)') TRY(I)
138        END DO
139      END IF
140
141C--GENERATE PRINTED AND ARCHIVE OUTPUT
142      CALL HYLST
143
144C--ABORT THE LOOP IF THERE ARE NOT ENOUGH READINGS
145      IF (NWR.LT.MINSTA) THEN
146        WRITE (6,1002) NWR,KYEAR2,KMONTH,KDAY,KHOUR,KMIN
147        IF (LPRT) WRITE (15,1002) NWR,KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1481002    FORMAT (' *** ABANDON EVENT WITH ONLY',I2,' READINGS:',I4,4I3)
149        GOTO 2
150      END IF
151
152C--OUTPUT SUMMARY DATA USING UNIT NUMBER FOR SUMMARY FILE
153      IF (LSUM) CALL HYSUM (12)
154
155C--COPY THE REST OF A LARGE EVENT TO OUTPUT FILES
156      IF (LTBIG) THEN
157        CALL HYPHS
158        CLOSE (14)
159      END IF
160
161C--RECORD THIS LOCATION TRY
162      IT=NINT(XLTM)
163      IN=NINT(XLNM)
164      IDMIN=NINT(DMIN)
165      WRITE (TRY(INUM),1011) ISEQ,INUM,KYEAR2,KMONTH,KDAY,
166     2 KHOUR,KMIN,REMK, RMK1,RMK2, LAT,IT,LON,IN,
167     3 Z1,RMS,PMAG,LABPR,NWR, ERH,ERZ,IDMIN,IDNO
168
1691011  FORMAT (1X,I4,I3,I5,'/',I2,'/',I2,
170     2 I3,':',I2.2, 1X,A3, 2A1, 1X,2I3,I5,I3,
171     3 F7.2,F5.2,F5.1,A1,I3, 2F5.1,I5,I10)
172
173C--OUTPUT A MESSAGE ON THE CONSOLE FOR EACH EVENT SO FAR
174      IF (LREP) THEN
175        WRITE (6,1000)
1761000    FORMAT ('  SEQ TRY ---DATE--  TIME REMARK -LAT-  --LON-  ',
177     2 'DEPTH  RMS PMAG NUM  ERH  ERZ DMIN')
178        DO I=1,INUM
179          WRITE (6,'(A)') TRY(I)
180        END DO
181      END IF
182
183C--CLOSE FILES
184      CLOSE (12)
185      CLOSE (7)
186      CLOSE (15)
187
188C--NOW GO EDIT THE PRINT FILE TO LOOK AT THE EVENT
189      IF (LPRT) THEN
190C--IF THE EDITOR AUTOMATICALLY ERASES THE SCREEN, IT MAY BE GOOD TO HAVE A
191C  DELAY OR PAUSE HERE, LIKE THIS:
192C        WRITE (6,*)' PRESS RETURN TO CONTINUE'
193C        READ (5,*)
194        CALL HYEDIT (IEDFLG,PRTFIL)
195      END IF
196
197C--DECIDE WHETHER TO RELOCATE, ISSUE A COMMAND OR CONTINUE TO NEXT EVENT
19848    INST=' '
199      KILLS=.FALSE.
200      WRITE(6,*)' T=RELOCATE, RETURN=CONTINUE, KS=KILL S & RELOCATE,'
201      CALL ASKC(
202     2 'KA=KILL P&S & CONTINUE, ZXZ=DELETE, ELSE SYSTEM COMMAND',INST)
203      IF (INST.EQ.' ') GOTO 2
204
205C--DELETE ENTIRE EVENT
206      IF (INST.EQ.'ZXZ ' .OR. INST.EQ.'zxz ') THEN
207        LX=LENG(EXTPHS)
208        CALL HYDELT (BASE,NCBASE, EXTPHS,LX)
209        LX=LENG(EXTARC)
210        CALL HYDELT (BASE,NCBASE, EXTARC,LX)
211        LX=LENG(EXTPRT)
212        CALL HYDELT (BASE,NCBASE, EXTPRT,LX)
213        LX=LENG(EXTSUM)
214        CALL HYDELT (BASE,NCBASE, EXTSUM,LX)
215        GOTO 48
216      END IF
217
218C--KILL (UPWEIGHT) ALL P & S
219      IF (INST.EQ.'KA  ' .OR. INST.EQ.'ka  ') THEN
220C--UPWEIGHT P&S WEIGHTS. DATA SHOULD STILL BE IN MEMORY
221        DO K=1,KSTA
222          KWT(K)=99
223        END DO
224
225C--OPEN ARC FILE, BUT OMIT PRINT FILE
226        IF (LARC) CALL OPENW (7,ARCFIL,'F',IOS,'S')
227        LTEMP=LPRT
228        LPRT=.FALSE.
229        CALL HYLST
230        LPRT=LTEMP
231C--CLOSE FILE & GO TO NEXT EVENT
232        CLOSE (7)
233        GOTO 2
234      END IF
235
236C--ISSUE A COMMAND
237      IF (INST.NE.'T    ' .AND. INST.NE.'t    ' .AND.
238     2  INST.NE.'KS  ' .AND. INST.NE.'ks  ') THEN
239        CALL SPAWN (INST)
240        GOTO 48
241      END IF
242
243C--SET FLAG TO KILL S WEIGHTS AFTER REREADING EVENT
244      KILLS= INST.EQ.'KS  ' .OR. INST.EQ.'ks  '
245
246C--RELOCATE THE EVENT
247C--DECIDE WHETHER TO EDIT PHASE FILE TO MAKE MORE CHANGES THAN JUST WEIGHTING
248      LR=LASK('EDIT THE INPUT PHASE FILE',.FALSE.)
249      IF (LR)  CALL HYEDIT (IEDFLG,PHSFIL)
250
251C--READ THE PHASE FILE EVEN IF IT WAS NOT CHANGED TO RESET TRIAL HYPO, ETC.
252      KEND=0
253      CALL OPENR (14,PHSFIL,'F',IOS)
254      CALL HYPHS
255      CLOSE (14)
256      IF (KEND.LT.0) THEN
257        WRITE (6,1004) BASE(1:NCBASE)
258        GOTO 2
259      END IF
260
261C--UPWEIGHT (KILL) ALL S READINGS
262      IF (KILLS) THEN
263        DO K=1,KSTA
264          IF (KSRK(K).NE.'  ') THEN
265            LSWT=KWT(K)/10
266            LPWT=KWT(K)-10*LSWT
267            IF (LSWT.LT.5) LSWT=LSWT+5
268            KWT(K)=LPWT+10*LSWT
269          END IF
270        END DO
271      END IF
272
273C--READ THE PRINT FILE TO SEE IF ANY WEIGHTS WERE CHANGED. THESE CHANGES WILL
274C  OVERRIDE ANY MADE IN THE PHASE FILE. USE THE PHASE UNIT NUMBER.
275      IF (LPRT) THEN
276        CALL OPENR (14,PRTFIL,'F',IOS)
277        IF (IOS.NE.0) GOTO 34
278
279C--SEARCH THE PRINT FILE FOR THE BEGINNING OF THE STATION LIST
28051      READ (14,'(A15)',END=59) C13
281        IF (C13.NE.' STA NET COM L ') GOTO 51
282
283C--SEARCH FOR STATIONS WITH NEW WEIGHTS IN COLS 1 & 6. NEW WEIGHT CODES:
284C  BLANK: NO CHANGE
285C  0-9  : NEW WEIGHT CODE
286C  "-"  : ADD 5 TO WEIGHT CODE (WEIGHT OUT)
287C  "+"  : SUBTRACT 5 FROM WEIGHT CODE (RESTORE)
288C  "!"  : WEIGHT OUT THIS AND ALL FOLLOWING P & S READINGS
289C
290C  COL  1: P WEIGHT CODE
291C  COL  9: CODA WEIGHT CODE
292C  COL 13: S WEIGHT CODE
293
294C--LKILL SIGNALS WHETHER ALL SUBSEQUENT STATIONS ARE TO BE WEIGHTED OUT
295        LKILL=.FALSE.
296
29753      READ (14,'(A15,T72,A1)',END=59) C13,SCD
298        CP=C13(1:1)
299        CC=C13(9:9)
300        CS=C13(13:13)
301        STA=C13(2:6)
302        SNET=C13(7:8)
303        SCOMP=C13(10:12)
304        SLOC=C13(14:15)
305
306C--IF STATION CODE WAS LEFT OUT, GET IT FROM PREVIOUS LINE (PRVSTA
307C  SHOULD NEVER BE BLANK WHEN STA IS BLANK)
308        IF (STA.EQ.'     ') THEN
309          STA=PRVSTA
310          SNET=PRVNET
311          SCOMP=PRVCMP
312          SLOC=PRVLOC
313        END IF
314        PRVSTA=STA
315        PRVNET=SNET
316        PRVCMP=SCOMP
317        PRVLOC=SLOC
318        FOUNDIT=.FALSE.
319
320C--WEIGHT OUT THIS AND ALL SUBSEQUENT STATIONS
321        IF (CP.EQ.'!') LKILL=.TRUE.
322
323        IF (CP.EQ.' ' .AND. CC.EQ.' ' .AND.
324     2  (CS.LT.'+' .OR. CS.GT.'9') .AND. .NOT.LKILL) GOTO 53
325
326C--FIND STATION CODE IN STATION TABLE, THEN IN PHASE TABLE
327        DO J=1,JSTA
328          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
329     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
330     3    (SLOC(1:NSLOC2) .EQ. JSLOC(J)(1:NSLOC2) .OR.
331     3    SLOC(1:NSLOC2) .EQ. JSLOC2(J)(1:NSLOC2)) .AND.
332     4    SCOMP(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
333            DO K=1,KSTA
334C--CONTINUE SEARCHING UNTIL DATA SOURCE CODES ALSO MATCH (IN CASE OF DUP. DATA)
335              IF (KINDX(K).EQ.J .AND. SCD.EQ.KSOU(K)) THEN
336                KLAST=K
337
338C--GET PREVIOUS WEIGHT CODES
339                LSWT=KWT(K)/10
340                LPWT=KWT(K)-10*LSWT
341
342C--WEIGHT OUT P & S WITHOUT CHECKING WHATS MARKED FOR THIS STATION
343                IF (LKILL) THEN
344                  IF (LPWT.LT.5) LPWT=LPWT+5
345                  IF (KSRK(K).NE.'  ' .AND. LSWT.LT.5) LSWT=LSWT+5
346                  GOTO 55
347                END IF
348
349C--DECODE NEW P WEIGHT CODE
350                IF (CP.GE.'0' .AND. CP.LE.'9') THEN
351                  READ (CP,'(I1)') LPWT
352                ELSE IF (CP.EQ.'-') THEN
353                  IF (LPWT.LT.5) LPWT=LPWT+5
354                ELSE IF (CP.EQ.'+') THEN
355                  LPWT=LPWT-5
356                  IF (LPWT.LT.0) LPWT=0
357                END IF
358
359C--DECODE NEW S WEIGHT CODE
360                IF (CS.GE.'0' .AND. CS.LE.'9') THEN
361                  READ (CS,'(I1)') LSWT
362                ELSE IF (CS.EQ.'-') THEN
363                  IF (LSWT.LT.5) LSWT=LSWT+5
364                ELSE IF (CS.EQ.'+') THEN
365                  LSWT=LSWT-5
366                  IF (LSWT.LT.0) LSWT=0
367                END IF
368
369C--DECODE NEW CODA WEIGHT CODE
37055              IF (CC.GE.'0' .AND. CC.LE.'9') THEN
371                  READ (CC,'(I1)') KFWT(K)
372                ELSE IF (CC.EQ.'-') THEN
373                  IF (KFWT(K).LT.5) KFWT(K)=KFWT(K)+5
374                ELSE IF (CC.EQ.'+') THEN
375                  KFWT(K)=KFWT(K)-5
376                  IF (KFWT(K).LT.0) KFWT(K)=0
377                END IF
378
379C--RELOAD NEW P & S WEIGHTS
380                KWT(K)=LPWT+10*LSWT
381                FOUNDIT=.TRUE.
382C--THIS STATION IN THE PHASE LIST IS DONE
383C--CONTINUE SEARCHING THE PHASE LIST FOR MORE OCCURRENCES OF THE SAME STATION
384C                GOTO 53 !STATEMENT COMMENTED OUT TO CONTINUE SEARCHING PHASES
385              END IF
386            END DO
387            IF (.NOT.FOUNDIT) WRITE (6,1059) STA,SCD
3881059        FORMAT (' *** CANNOT CHANGE STATION ',A5,1X,A1,
389     2      '. NOT USED IN THIS EVENT')
390            GOTO 53
391          END IF
392        END DO
393        WRITE (6,1060) STA
3941060    FORMAT (' *** CANNOT CHANGE STATION ',A5,
395     2  ' WAS NEVER IN STATION FILE')
396        GOTO 53
397
39859      CLOSE (14)
399      END IF
400
401C--NOW GO RELOCATE THE EVENT USING THE DATA IN MEMORY
402      GOTO 42
403
404C--END OF EVENT LIST TO BE PROCESSED
40570    CLOSE (17)
406      RETURN
407      END
Note: See TracBrowser for help on using the repository browser.