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

Revision 3172, 63.0 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 HYCMD
2C--CALLED BY HYPOINVERSE TO GET A COMMAND, THEN ACT ON IT.
3      INCLUDE 'common.inc'
4C--LASK IS A LOGICAL FUNCTION. THE OS2 COMPILER COMPLAINS WITHOUT THESE LINES
5C      LOGICAL LASK
6C      EXTERNAL LASK
7
8      CHARACTER TEMPSTR*80
9      PARAMETER (NCMD=92)
10      CHARACTER CMD(NCMD)*3
11      LOGICAL LINST
12      SAVE CMD
13
14C--CMD HOLDS THE NAMES OF ALL COMMANDS RECOGNIZED BY THIS ROUTINE.
15C--THE STRUCTURE OF THIS STATEMENT MATCHES THAT OF THE COMPUTED GOTO
16      DATA CMD /
17     2 'SUM','ARC','PRT','ERF','LST','KPR','TOP','REP',
18     3 'COP','DLY','CON','DAM','DUR','DIS','RMS','SWT',
19     4 'POS','ZTR','ERR','ERC','NET','SHO','CAR','APP',
20     5 'H71','STO','CRH','CRT','STA','INP','LOC','PHS',
21     6 'MIN','BUG','HEL','ATN','MOR','ST5','MAG','TAU',
22     7 'FID','JUN','MUL','ALT','NOD','SNO','DEL','MAX',
23     8 'UNK','ATE','VER','FMC','XMC','TYP','MFL','WCR',
24     9 'RCR','WST','RST','BAS','PRO','FC1','FC2','XC1',
25     1 'XC2','DU2','FCM','XCM','INI','LET','LES','DUB',
26     2 'PRE','CAL','LA0','PMA','PAC','PC1','PC2','PMC',
27     3 'LAB','KEP','WET','XCH','XTY','200','FIL','DUG',
28     4 'XMT','DIG','DID','DI1'/
29
30C++++++++++++++++++ COMMAND INTERPRETER ++++++++++++++++++++
31C--IF HYPOINVERSE IS A SUBROUTINE, WE HAVE 1 COMMAND LOADED IN CM & INST
32      IF (SUBMOD) THEN
33C--IF HYPOINV CALLED HYCMD AFTER FINISHING A STA, CRH, CRT, INP, BUG OR LOC
34C  COMMAND READ FROM A COMMAND FILE, WE HAVE NO NEW COMMAND LOADED,
35C  AND MUST READ ANOTHER COMMAND FROM THE FILE.
36        IF (ISTAT.GE.1 .AND. ISTAT.LE.7) GOTO 2
37C--IF HYPOINV CALLED HYCMD AFTER BEING GIVEN A COMMAND,
38C  THERE IS NO NEED TO READ ANOTHER
39        GOTO 4
40      END IF
41      GOTO 5
42
43C--OUTPUT A MESSAGE ON A FREE-FORMAT DECODING ERROR
443     WRITE (6,1000) CM
451000  FORMAT (' *** ERROR IN ',A3,' PARAMETERS - TRY AGAIN ***')
46      IRES=-63
47
48C--SUPPLY A PROMPT IF READING FROM THE TERMINAL
49C--IF WE JUST PROCESSED A COMMAND & ARE A SUBROUTINE, RETURN TO THE MAIN PROG
505     IF (INP.EQ.5) THEN
51        IF (SUBMOD) THEN
52          ISTAT=8
53          RETURN
54        ELSE
55          WRITE (6,1011)
561011      FORMAT (' COMMAND? ',$)
57        END IF
58      END IF
59
60C--READ A COMMAND LINE IF CM AND INST ARENT ALREADY LOADED WITH A COMMAND:
61C  1) WE ARE READING FROM A COMMAND FILE (NOT INTERACTIVE);
62C  2) OR WE ARE RUNNING AS A MAIN PROGRAM (NOT SUBROUTINE);
63C--THERE IS NO COMMAND TO READ IF THE SUBROUTINE HYPOINV (SUBMODE IS TRUE)
64C  HAS NO COMMAND FILE.
652     IF (INP.NE.5 .OR. .NOT.SUBMOD) READ (INP,1012,END=9) CM,INST
661012  FORMAT (A3,A)
67
68C--A LINE STARTING WITH * IS IGNORED AS A REMARK
694     IF (CM(1:1).EQ.'*' .OR. CM.EQ.'   ') GOTO 5
70
71C--INTERPRET A ? IN THE FIRST COLUMN AS A REQUEST FOR COMMAND LIST
72      IF (CM(1:1).EQ.'?') GOTO 84
73
74C--A STRING PRECEDED BY @ IS INTERPRETED AS A FILENAME TO HOP TO
75C  UP TO 4 NESTED COMMAND FILES ARE ALLOWED AT ONE TIME
766     IF (CM(1:1).EQ.'@') THEN
77
78C--GO TO NEXT HIGHER COMMAND FILE UNLESS DEPTH IS EXCEEDED
79        IF (INP.GE.11) THEN
80          WRITE (6,'('' *** ERROR: MAX DEPTH OF COMMAND FILES IS 4'')')
81          IRES=-64
82          GOTO 5
83        ELSE IF (INP.GE.8) THEN
84          INP=INP+1
85        ELSE IF (INP.EQ.5) THEN
86          INP=8
87        END IF
88
89        INFILE(INP-7) (1:2)=CM(2:3)
90        INFILE(INP-7) (3:60)=INST
91        CALL OPENR (INP,INFILE(INP-7),'F',IOS)
92        IF (IOS.NE.0) GOTO 32
93        GOTO 5
94      END IF
95
96C--IF THE FIRST CHARACTER IS #, EXECUTE THE SYSTEM COMMAND WHICH FOLLOWS
97      IF (CM(1:1).EQ.'#') THEN
98        TERM=(CM(2:3)//INST)
99        CALL SPAWN (TERM)
100        GOTO 5
101      END IF
102
103C--DETERMINE WHETHER THE PARAMETER FIELD IS BLANK & IF SO SUPPLY PROMPTS
104      LINST=INST(1:10).EQ.'          '
105
106C--BE SURE THE COMMAND IS UPPERCASE
107      CALL UPSTR (CM,3)
108
109C--BRANCH TO THE APPROPRIATE COMMAND PROCESSOR
110C--THIS GOTO CORRESPONDS IN STRUCTURE TO THE COMMAND LIST
111      DO 8 I=1,NCMD
112      ICMDX=I
113      IF (CM.EQ.CMD(ICMDX)) GOTO (
114     2  10, 12, 14, 16, 20, 22, 24, 26,
115     3  28, 34, 38, 42, 46, 50, 52, 54,
116     4  56, 58, 60, 62, 64, 70, 30, 74,
117     5  66,140,144,148,152,156,166,168,
118     6 176,200, 84, 88, 86, 92, 96,100,
119     7 104,108,110,114,116,118,158,180,
120     8 184,162,354,172,192,196,208,216,
121     9 220,224,228,232,236,240,244,248,
122     1 252,256,260,264,268,272,276,280,
123     2 284,160,288,292,296,300,304,308,
124     3 312,316,320,324,328,332,336,340,
125     4 344,348,352, 51), ICMDX
1268     CONTINUE
127
128C--OUTPUT AN ERROR MESSAGE
129      WRITE (6,1001) CM
1301001  FORMAT (' *** COMMAND NOT FOUND: ',A3,/
131     2 '  TYPE ? OR HEL FOR COMMAND LIST.')
132      IRES=-65
133      GOTO 5
134
135C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT COMMAND FILES
13632    INP=INP-1
137      IF (INP.EQ.7) INP=5
138      WRITE (6,1003)
1391003  FORMAT (' *** ERROR - COMMAND FILE DOES NOT EXIST ***')
140      IRES=-66
141      GOTO 5
142
143C--RETURN TO PREVIOUS COMMAND FILE OR INTERACTIVE MODE AT END OF COMMAND FILE
1449     IF (INP.EQ.5) THEN
145        ISTAT=8
146        RETURN
147      END IF
148
149      CLOSE (INP)
150      INP=INP-1
151      IF (INP.EQ.7) INP=5
152      GOTO 5
153
154C******************** COMMAND PROCESSORS *************************
155
156C--<SUM> SET SUMMARY OUTPUT FILENAME
15710    IF (LINST) THEN
158        CALL ASKC('EARTHQUAKE SUMMARY FILE (NONE FOR NONE)',SUMFIL)
159      ELSE
160        READ (INST,*,ERR=3) SUMFIL
161      END IF
162      LSUM=.NOT.(SUMFIL(1:4).EQ.'NONE' .OR. SUMFIL(1:4).EQ.'none')
163      GOTO 5
164
165C--<ARC> SET ARCHIVE OUTPUT FILENAME
16612    IF (LINST) THEN
167        CALL ASKC('ARCHIVE FILE (NONE FOR NONE)',ARCFIL)
168      ELSE
169        READ (INST,*,ERR=3) ARCFIL
170      END IF
171      LARC=.NOT.(ARCFIL(1:4).EQ.'NONE' .OR. ARCFIL(1:4).EQ.'none')
172      GOTO 5
173
174C--<PRT> SET PRINTER OUTPUT FILENAME
17514    IF (LINST) THEN
176        CALL ASKC('PRINTOUT FILE (NONE FOR NONE)',PRTFIL)
177      ELSE
178        READ (INST,*,ERR=3) PRTFIL
179      END IF
180      LPRT=.NOT.(PRTFIL(1:4).EQ.'NONE' .OR. PRTFIL(1:4).EQ.'none')
181      GOTO 5
182
183C--<ERF> SEND ERROR MESSAGES TO TERMINAL AS WELL AS PRINT FILE
18416    IF (LINST) THEN
185        LERR=LASK('SEND ERROR MESSAGES TO TERMINAL',LERR)
186      ELSE
187        READ (INST,*,ERR=3) LERR
188      END IF
189      GOTO 5
190
191C--<LST> FLAG TO LIST AVAILABLE STATIONS & CRUST ON THE PRINTER
19220    IF (LINST) THEN
193        WRITE (6,1002)
1941002    FORMAT (' PRINT CODE: 0=EQS ONLY, 1=ADD PARAMS & FILES,')
195        JST=JASK(' 2=ADD STATIONS & CRUST',JST)
196
197        IF (JST.EQ.2) THEN
198          WRITE (6,'('' QUANTITY OF STATION INFO TO PRINT:'')')
199          JST2=JASK
200     1    ('0=NO LISTING, 1=LOCATIONS & BASIC DATA, 2=ALL DELAYS',
201     2    JST2)
202          WRITE (6,'('' QUANTITY OF CRUST MODEL INFO TO PRINT:'')')
203          JST3=JASK
204     1    ('0=NO CRUST LISTING, 1=LAYERS & NODES FOR EACH MODEL',
205     2    JST3)
206        END IF
207
208      ELSE
209        READ (INST,*,ERR=3) JST
210        IF (JST.EQ.2) READ (INST,*,ERR=3) JST,JST2,JST3
211      END IF
212      GOTO 5
213
214C--<KPR> PARAMETER TO CONTROL AMOUNT OF PRINTOUT
21522    IF (LINST) THEN
216        WRITE (6,*) ' PRINT QUANTITY CONTROL (0-6) 0=FINAL.LOC'
217        WRITE (6,*) ' 1=STATION.LIST 2=ITERATIONS 3=EIGENVALUES'
218        KPRINT=JASK('6=STATION LIST EACH ITERATION',KPRINT)
219      ELSE
220        READ (INST,*,ERR=3) KPRINT
221      END IF
222      GOTO 5
223
224C--<TOP> FLAG TO PAGE EJECT BEFORE EACH EVENT
22524    IF (LINST) THEN
226        LEJCT=LASK('PRINT PAGE EJECT FOR EACH EVENT',LEJCT)
227      ELSE
228        READ (INST,*,ERR=3) LEJCT
229      END IF
230      GOTO 5
231
232C--<REP> FLAG TO REPORT EACH EVENT ON TERMINAL AS LOCATED
23326    IF (LINST) THEN
234        LREP=LASK('REPORT EACH EVENT AS LOCATED',LREP)
235        LPRALL=LASK('PRINT STATIONS WITH NO WEIGHTS IN PRINT FILE',
236     2 LPRALL)
237      ELSE
238        READ (INST,*,ERR=27) LREP,LPRALL
239      END IF
240      GOTO 5
241
242C--FORMAT ERROR
24327    READ (INST,*,ERR=3) LREP
244      WRITE (6,'('' *** WARNING: PARAMETER ADDED TO REP COMMAND'')')
245      GOTO 5
246
247C--<COP> SELECT INPUT PHASE DATA FORMAT
24828    IF (LINST) THEN
249        WRITE (6,2028)
2502028    FORMAT(' USE 200 COMMAND TO SELECT YR 2000 FORMATS.'/
251     2  '  1=OLD PHASE 3=ARCHIVE 4=SHADOW PHASE 5=ARCHIVE-SHADOW'/
252     3  '  6=ONE-CUSP-EVENT 7=CUSP-LIST')
253        JCP=JASK('PHASE FORMAT',JCP)
254        IF (JCP.EQ.6 .OR. JCP.EQ.7) THEN
255          WRITE (6,*) ' LEVEL OF MEM OUTPUT OF LOCATION TO CUSP:'
256          WRITE (6,*)' 0=NONE 1=DATA STRUCTURES 2=SHARED MEMORY REGION'
257          JCPO=JASK ('3=MEM DISK FILE',JCPO)
258        END IF
259      ELSE
260        READ (INST,*,ERR=3) JCP
261        IF (JCP.EQ.6 .OR. JCP.EQ.7) READ (INST,*,ERR=3) JCP,JCPO
262      END IF
263      GOTO 5
264
265C--<CAR> ARCHIVE DATA FORMAT
26630    IF (LINST) THEN
267        JCA=JASK
268     2  ('ARCHIVE FORMAT (1=NO SHADOWS 3=ARCHIVE-SHADOW)',JCA)
269      ELSE
270        READ (INST,*,ERR=3) JCA
271      END IF
272      GOTO 5
273
274C--<DLY> STATION DELAY PARAMETERS (SUPERCEDED BY MULTIPLE MODEL ABILITY)
275C  DELAY MODEL 1 IS ASSUMED FOR ALL STATIONS UNLESS MULTIPLE MODELS ARE
276C  INVOKED WITH THE MUL AND RELATED COMMANDS.
27734    WRITE (6,*) 'THE DLY COMMAND NO LONGER OPERATES.'
278      WRITE (6,*)
279     2 'SEE THE MUL, NOD & RELATED COMMANDS FOR MULTIPLE MODELS.'
280
281C34      IF (LINST) THEN
282C        KDLY=JASK('KDLY, DELAY MODEL CONTROL (1-4)',KDLY)
283C        IF (KDLY.LT.3) GOTO 5
284C        DLYAZ=ASKR('DLYAZ',DLYAZ)
285C        DLYWD=ASKR('DLYWD',DLYWD)
286C        DLYLON=ASKR('DLYLON',DLYLON)
287C        DLYLAT=ASKR('DLYLAT',DLYLAT)
288C      ELSE
289C        READ (INST,*,ERR=3) KDLY
290C        IF (KDLY.LT.3) GOTO 5
291C        READ (INST,*,ERR=3) KDLY,DLYAZ,DLYWD,DLYLON,DLYLAT
292C      END IF
293      GOTO 5
294
295C--<CON> TERMINATING LOCATION UPON CONVERGENCE
29638    IF (LINST) THEN
297        ITRLIM=JASK('MAX ITERATIONS',ITRLIM)
298        DQUIT=ASKR('MIN HYPOCENTER ADJUSTMENT',DQUIT)
299        DRQT=ASKR('MIN RMS CHANGE',DRQT)
300      ELSE
301        READ (INST,*,ERR=3) ITRLIM,DQUIT,DRQT
302      END IF
303      GOTO 5
304
305C--<DAM> ITERATION AND DAMPING CONTROLS
30642    IF (LINST) THEN
307        DXFIX=ASKR('DXFIX, FIX DEPTH UNTIL EPICEN. ADJ. < THIS',DXFIX)
308        DZMAX=ASKR('DZMAX, MAX. DEPTH ADJ.',DZMAX)
309        DZAIR=ASKR('DZAIR, MOVE HYPO. UP BY THIS INSTEAD OF AIR',DZAIR)
310        DAMP=ASKR('DAMP, MANDATORY DAMPING FACTOR',DAMP)
311        EIGTOL=ASKR('EIGTOL, SMALLEST EIGENVALUE PERMITTED',EIGTOL)
312        RBACK=ASKR('RBACK, IF RMS INCREASES MORE THAN THIS...',RBACK)
313        BACFAC=ASKR('BACFAC,...THEN MOVE HYPO. BACK THIS FACTOR',BACFAC)
314        DXMAX=ASKR('DXMAX, MAX. DIST ADJ.',DXMAX)
315        D2FAR=ASKR('D2FAR, STOP ITERATING WHEN 2ND STATION DIST > THIS',
316     2  D2FAR)
317      ELSE
318        READ (INST,*,ERR=3) DXFIX,DZMAX,DZAIR,DAMP,EIGTOL,RBACK,BACFAC,
319     2 DXMAX,D2FAR
320      END IF
321      GOTO 5
322
323C--<DUR> DURATION MAG CONSTANTS
32446    IF (LINST) THEN
325        WRITE (6,1004)
3261004    FORMAT (' MAG CONSTANTS FOR DUR < FMBRK:')
327        FMA1=ASKR('CONSTANT    FMA1',FMA1)
328        FMB1=ASKR('LOG TERM    FMB1',FMB1)
329        FMZ1=ASKR('DEPTH TERM  FMZ1',FMZ1)
330        FMD1=ASKR('DIST TERM   FMD1',FMD1)
331        FMF1=ASKR('LINEAR TERM FMF1',FMF1)
332        WRITE (6,1005)
3331005    FORMAT (' MAG CONSTANTS FOR DUR > FMBRK:')
334        FMA2=ASKR('CONSTANT    FMA2',FMA2)
335        FMB2=ASKR('LOG TERM    FMB2',FMB2)
336        FMZ2=ASKR('DEPTH TERM  FMZ2',FMZ2)
337        FMD2=ASKR('DIST TERM   FMD2',FMD2)
338        FMF2=ASKR('LINEAR TERM FMF2',FMF2)
339        FMBRK=ASKR('FMBRK',FMBRK)
340        FMGN=ASKR('USE GAIN CORRECTION 0=NO 1=YES',FMGN)
341      ELSE
342        READ (INST,*,ERR=48) FMA1,FMB1,FMZ1,FMD1,FMF1,
343     2  FMA2,FMB2,FMZ2,FMD2,FMF2, FMBRK,FMGN
344      END IF
345      GOTO 5
346
347C--FORMAT ERROR
34848    READ (INST,*,ERR=3) FMA1,FMB1,FMZ1,FMD1,
349     2 FMA2,FMB2,FMZ2,FMD2, FMBRK,FMGN
350      WRITE (6,'(''*** WARNING: NEW PARAMETERS ADDED TO DUR COMMAND'')')
351      GOTO 5
352
353C--<DIS> DISTANCE WEIGHT PARAMETERS
35450    IF (LINST) THEN
355        ITRDIS=JASK('ITERATION TO BEGIN MAIN DISTANCE WEIGHTING'
356     2  ,ITRDIS)
357        DISCUT=ASKR('DISCUT (KM)',DISCUT)
358        DISW1=ASKR('DISW1 FACTOR',DISW1)
359        DISW2=ASKR('DISW2 FACTOR',DISW2)
360      ELSE
361        READ (INST,*,ERR=3) ITRDIS,DISCUT,DISW1,DISW2
362      END IF
363      GOTO 5
364
365C--<DI1> DISTANCE WEIGHT PARAMETERS FOR FIRST ITERATIONS
36651    IF (LINST) THEN
367        WRITE (6,*) 'DO FIRST DISTANCE WEIGHTING ON FIRST ITERATIONS,'
368        WRITE (6,*) 'THEN USE DIS COMMAND WEIGHT PARAMETERS'
369        WRITE (6,*) 'FOR MAIN DISTANCE WEIGHTING.'
370        ITRDI1=JASK('ITERATION TO BEGIN FIRST DISTANCE WEIGHTING'
371     2  ,ITRDI1)
372        DISCU1=ASKR('DISCUT-1 (KM)',DISCU1)
373        DISW11=ASKR('DISW1 FACTOR',DISW11)
374        DISW21=ASKR('DISW2 FACTOR',DISW21)
375      ELSE
376        READ (INST,*,ERR=3) ITRDI1,DISCU1,DISW11,DISW21
377      END IF
378      GOTO 5
379
380C--<RMS> RMS WEIGHTING PARAMETERS
38152    IF (LINST) THEN
382        ITRRES=JASK('ITERATION TO BEGIN RESIDUAL WEIGHTING',ITRRES)
383        RMSCUT=ASKR('RMSCUT (SEC)',RMSCUT)
384        RMSW1=ASKR('RMSW1 FACTOR',RMSW1)
385        RMSW2=ASKR('RMSW2 FACTOR',RMSW2)
386      ELSE
387        READ (INST,*,ERR=3) ITRRES,RMSCUT,RMSW1,RMSW2
388      END IF
389      GOTO 5
390
391C--<SWT> S ARRIVAL WEIGHTING FACTOR
39254    IF (LINST) THEN
393        SWT=ASKR('S WEIGHT FACTOR',SWT)
394      ELSE
395        READ (INST,*,ERR=3) SWT
396      END IF
397      GOTO 5
398
399C--<POS> VP/VS VELOCITY RATIO
40056    IF (LINST) THEN
401        POS=ASKR('P/S VELOCITY RATIO',POS)
402      ELSE
403        READ (INST,*,ERR=3) POS
404      END IF
405      GOTO 5
406
407C--<ZTR> TRIAL DEPTH
40858    IF (LINST) THEN
409        ZTR=ASKR('TRIAL DEPTH, NEG TO FIX DEPTH',ZTR)
410      ELSE
411        READ (INST,*,ERR=3) ZTR
412      END IF
413      GOTO 5
414
415C--<ERR> ESTIMATED READING & TIMING ERROR
41660    IF (LINST) THEN
417        RDERR=ASKR('ESTIMATED READING & TIMING ERROR',RDERR)
418      ELSE
419        READ (INST,*,ERR=3) RDERR
420      END IF
421      GOTO 5
422
423C--<ERC> WEIGHTING FACTOR OF RMS IN ERROR CALCS
42462    IF (LINST) THEN
425        ERCOF=ASKR('RMS WEIGHTING FACTOR IN ERROR CALCULATIONS',ERCOF)
426      ELSE
427        READ (INST,*,ERR=3) ERCOF
428      END IF
429      GOTO 5
430
431C--<NET> NET FOR ASSIGNING 3-LET. NAMES BASED ON LOCATION
43264    IF (LINST) THEN
433        WRITE (6,*)
434     2' NET (REGION) FOR ASSIGNING EARTHQUAKE REGION NAMES:'
435        NET=JASK('0=NONE 1=HAWAII 2=N.CALIF 3=NEW.HAWAII',NET)
436      ELSE
437        READ (INST,*,ERR=3) NET
438      END IF
439      GOTO 5
440
441C--<H71> SET SUMMARY, INSTRUCTION & STATION FORMAT TYPES
44266    IF (LINST) THEN
443        IH71S=JASK
444     2  ('SUMMARY FORMAT: 1=HYPOINVERSE 2=HYPO71',IH71S)
445        IH71T=JASK
446     1  ('TERMINATOR FORMAT: 1=HINV 2=HYPO71 3=TRIAL.FR.HEADER',
447     2  IH71T)
448
449        WRITE (6,1066)
4501066    FORMAT(' OLD FORMAT BEGINS WITH 4-LET CODES,',
451     2  '  NEW BEGINS WITH 10-LET CODES:')
452        ISTFMT=JASK
453     2  ('STATION FORMAT 1=OLD.HYPOINV 2=HYPO71 3=NEW.HYPOINV',ISTFMT)
454      ELSE
455        READ (INST,*,ERR=3) IH71S,IH71T,ISTFMT
456      END IF
457      GOTO 5
458
459C--<SHO> WRITE FILENAMES
46070    WRITE (6,'(/'' INPUT FILES:''/'' COMMANDS: '',A/11X,A)')
461     2 (INFILE(I),I=1,2)
462      IF (LBSTA) THEN
463        WRITE (6,'('' BINARY STATION SNAPSHOT FILE: '',A)') BSTAFL
464      ELSE
465        WRITE (6,'('' STATIONS: '',A)') STAFIL
466      END IF
467
468      WRITE (6,1021) JSTA, DELFIL,ATNFIL,CALFIL,FMCFIL,XMCFIL,PHSFIL
4691021  FORMAT (' (',I4,' STATIONS IN MEMORY)'/' DELAYS: ',A/
470     3 ' ATTENS: ',A/' CALFAC: ',A/' FM.COR: ',A/' XM.COR: ',A/
471     4 ' PHASES: ',A)
472
473      IF (LBCRU) THEN
474        WRITE (6,'('' BINARY CRUST SNAPSHOT FILE: '',A)') BCRUFL
475      ELSE
476        DO I=1,MAXMOD
477          IF (MODTYP(I).EQ.0) WRITE (6,1022) I,CRUFIL(I)(1:50)
4781022      FORMAT (' LINEAR  GRADIENT  CRUST',I3,':  ',A)
479          IF (MODTYP(I).EQ.1) WRITE (6,1023) I,CRUFIL(I)(1:50)
4801023      FORMAT (' HOMOGENEOUS LAYER CRUST',I3,':  ',A)
481        END DO
482      END IF
483
484C--WRITE OUTPUT FILENAMES
485      WRITE (6,1029)
4861029  FORMAT (/' OUTPUT FILES:')
487      IF (LPRT) WRITE (6,1030) PRTFIL
4881030  FORMAT (' PRINTOUT: ',A)
489      IF (LSUM) WRITE (6,1031) SUMFIL
4901031  FORMAT (' SUMMARY:  ',A)
491      IF (LARC) WRITE (6,1032) ARCFIL
4921032  FORMAT (' ARCHIVE:  ',A)
493      IF (LMAG) WRITE (6,1049) MAGFIL
4941049  FORMAT (' MAGNITUDE DATA: ',A)
495      GOTO 5
496
497C--<APP> INDICATE WHETHER OUTPUT FILES SHOULD BE APPENDED TO
498C  ORDER IS 1=PRINT 2=SUMMARY 3=ARCHIVE
49974    IF (LINST) THEN
500        LAPP(1)=LASK('APPEND TO PRINT FILE',LAPP(1))
501        LAPP(2)=LASK('APPEND TO SUMMARY FILE',LAPP(2))
502        LAPP(3)=LASK('APPEND TO ARCHIVE FILE',LAPP(3))
503      ELSE
504        READ (INST,*,ERR=3) LAPP
505      END IF
506      GOTO 5
507
508C--<HEL> HELP LISTING OF COMMANDS
50984    WRITE (6,1084)
5101084  FORMAT (
511     3' ---------I/O FILES-----------  -----MISC. PARAMETERS---'/
512     4' PHS -PHASE INPUT FILENAME      ZTR -TRIAL DEPTH'/
513     5' STA -READ STATION FILE         POS -P/S VELOCITY RATIO'/
514     6' CRH -READ LAYER CRUST FILE     NET -NET FOR REGION NAMES'/
515     7' CRT -READ GRADIENT CRUST FILE  DUR,DU2,DUB -DUR. MAGS'/
516     8' PRT -PRINTOUT FILENAME         FIL -DETERMINE PHAS.FORMAT'/
517     9' SUM -SUMMARY OUTPUT FILENAME   MIN -MINIMUM NO. STATIONS'/
518     9' ARC -ARCHIVE OUTPUT FILENAME   CON -CONVERGENCE CONTROLS'/
519     1' MFL -MAGNITUDE OUTPUT FILE     DAM -DAMPING CONTROLS'/
520     2' --------I/O CONTROLS--------   ATN,CAL -ATTEN/CAL FACTOR')
521
522      WRITE (6,1085)
5231085  FORMAT (
524     3' COP -PHASE FORMAT              ----WEIGHTING & ERRORS---'/
525     4' H71 -HYPO71, STATION FORMATS   SWT -GLOBAL S-TIME WEIGHT'/
526     5' LST -LIST STAS. IN PRINTFILE   DIS -DISTANCE WEIGHTING'/
527     6' KPR -AMOUNT OF PRINT DATA      RMS -RESIDUAL WEIGHTING'/
528     7' TOP -NEW PAGE EACH EVENT       ERR -GLOBAL TIME ERROR'/
529     8' REP -REPORT EVENTS TO TERM.    ERC -RMS EFFECT ON ERROR'/
530     9' ERF -ERROR MESSAGES TO TERM.   -------DO SOMETHING-----'/
531     9' CAR -ARCHIVE FORMAT            LOC -LOCATE EVENTS'/
532     1' APP -APPEND TO OUTPUT FILES    STO -STOP THE PROGRAM'/
533     2' INP -INTERACTIVE DATA ENTRY    PRO -PROCESS INTERACTIVE'/
534     3'              (TYPE MOR FOR MORE COMMANDS)')
535      GOTO 5
536
537C--<MOR> HELP FOR MORE COMMANDS
53886    WRITE (6,1086)
5391086  FORMAT (
540     2' -------MAGNITUDE INFO ------   -------MULTIPLE MODELS-------'/
541     3' ATN -USE STATION ATTENUATION   ALT -ASSIGN STAS TO DIFF MODELS'/
542     4' FC1,FC2 -SELECT FMAG COMPS.    MUL -USE REGIONAL MODELS'/
543     5' MAG -CODA MAGNITUDE TYPE       NOD -GEOGR. NODE FOR A MODEL'/
544     6' TAU -TAU CODA MAG CONSTANTS    SNO -DISPLAY CURRENT NODES'/
545     8' XC1,XC2 -SELECT XMAG COMPS.    -------MORE STATION DATA------'/
546     7' FCM,XCM -COMPONENT MAG CORRS.  DEL -READ STATION DELAY FILE'/
547     8' PRE -SET PREFERRED MAG ORDER   UNK -STAS:NO ERROR IF MISSING'/
548     7' PMA -P AMP MAG CHOICES         LET -LENGTH OF STA. NAMES'/
549     8' PAC -PMAG COMPONENT WEIGHTS    LES -OLD 1-LET STA COMPONENTS'/
550     9' LA0 -DIST CORR TERM (AMP MAG)  ATE -READ STATION ATTEN FILE'/
551     1' XCH,XTY -AMP MAG BY INST TYP   CAL -READ STATION CAL FACTORS')
552
553      WRITE (6,1087)
5541087  FORMAT (
555     1' --------MORE COMMANDS--------  FMC -READ FMAG CORRECTIONS'/
556     2' MAX -LIST MAX ARRAY SIZES      XMC -READ XMAG CORRECTIONS'/
557     3' FID -CUSP-ID READ FORMAT       ------- BINARY FILES -------'/
558     3' SHO -SHOW CURRENT FILES        WCR -WRITE CRUST SNAPSHOT'/
559     4' BUG -DEBUG PHASE FILE          RCR -READ CRUST SNAPSHOT'/
560     9' BAS -INTERACT. PROCESSING      WST -WRITE STATION SNAPSHOT'/
561     1' JUN -FORCE EQS WITH FEW DATA   RST -READ STATION SNAPSHOT'/
562     3' INI -INITIALIZE WITH STD. COMMAND FILE'/
563     4' KEP -OUTPUT UNRECOGNIZED STATIONS'/
564     5' WET -WEIGHTS FOR PHASE WEIGHT CODES 0-3')
565      GOTO 5
566
567C--<ATN> SET FLAG TO CONVERT STATION ATTENUATION TO A CAL FACTOR
56888    IF (LINST) THEN
569        LATEN=LASK
570     1  ('ASSUME STATIONS HAVE ATTENUATIONS, NOT CAL FACTORS',
571     2  LATEN)
572      ELSE
573        READ (INST,*,ERR=3) LATEN
574      END IF
575      GOTO 5
576
577C--<ST5> USE 4 OR 5 LETTER STATION NAMES, 0, 1 OR 3 LETTER COMPONENT CODES
57892    WRITE (6,1092)
5791092  FORMAT (' *** ST5 COMMAND ELIMINATED.'/
580     2 '  USE LET COMMAND TO SET LENGTHS OF STA, NET & COMP. CODES')
581      GOTO 5
582
583C--<MAG> SELECT TRADITIONAL CODA OR TAU (ELAPSED TIME) FOR 1ST & 2ND MAGNITUDE
58496    IF (LINST) THEN
585        MAGSEL=JASK('FIRST FMAG: 1=CODA, 2=ELAPSED TIME, 3=2nd CODA',
586     2  MAGSEL)
587        LCOWT=LASK
588     1  ('T=USE ASSIGNED CODA WEIGHTS, F=GIVE ALL FULL WEIGHT',
589     2  LCOWT)
590        MAGSL2=JASK('2nd FMAG: 1=CODA, 2=ELAPSED TIME, 3=2nd CODA',
591     2  MAGSL2)
592
593        WRITE (6,1096)
5941096    FORMAT (' THE LOG(A0) RELATIONS ARE: 1=EATON 2=BAKUN & JOYNER'/
595     2 ' 3=RICHTER 4=BKY-NORDQUIST 5=P AMP MAG')
596        MLOGA0=JASK('LOG(A0) RELATION CHOICE',MLOGA0)
597
598      ELSE
599        READ (INST,*,ERR=97) MAGSEL,LCOWT,MAGSL2,MLOGA0
600      END IF
601      GOTO 5
602
603C--OLD FORMAT ERROR
60497    READ (INST,*,ERR=3) MAGSEL,LCOWT
605      WRITE (6,*)' *** WARNING: ADD NEW ARGUMENTS TO MAG COMMAND'
606      GOTO 5
607
608C--<TAU> SET CONSTANTS IN ELAPSED TIME (TAU) MAGNITUDE RELATION
609100   IF (LINST) THEN
610        WRITE (6,*)
611     2  'SET COEFFICIENTS IN ELAPSED TIME (TAU) MAG EXPRESSION:'
612        DMA0=ASKR('CONSTANT',DMA0)
613        DMA1=ASKR('COEFFICIENT OF LOG(TAU)',DMA1)
614        DMA2=ASKR('COEFFICIENT OF LOG**2(TAU)',DMA2)
615        DMLI=ASKR('COEFFICIENT OF TAU',DMLI)
616        DMZ=ASKR('COEFFICIENT OF DEPTH',DMZ)
617        DMGN=ASKR('USE GAIN CORRECTION 0=NO 1=YES',DMGN)
618      ELSE
619        READ (INST,*,ERR=3) DMA0,DMA1,DMA2,DMLI,DMZ,DMGN
620      END IF
621      GOTO 5
622
623C--<FID> FORMAT FOR READING CUSP-ID NUMBERS FROM A FILE
624104   IF (LINST) THEN
625        CALL ASKC('FORMAT FOR READING CUSP-ID NUMBERS',FORID)
626      ELSE
627        READ (INST,*,ERR=3) FORID
628      END IF
629      GOTO 5
630
631C--<JUN> FLAG TO SUPPRESS DIST & RESIDUAL WEIGHTING WHEN FEWER THAN 4 READINGS
632C  ARE LEFT
633108   IF (LINST) THEN
634        WRITE (6,*)
635     2  'T TO USE ALL READINGS (NO DISTANCE OR RESIDUAL WEIGHTING)'
636        LJUNK=LASK('WHEN TOO MANY READINGS WOULD BE WEIGHTED OUT',LJUNK)
637      ELSE
638        READ (INST,*,ERR=3) LJUNK
639      END IF
640      GOTO 5
641
642C--<MUL> SET FLAG TO SELECT MULTIPLE MODEL PROCESSING
643110   IF (LINST) THEN
644        LMULT=LASK('PROCESS EQS WITH REGION-DEPENDENT MODELS',LMULT)
645        IF (LMULT) MODDEF=JASK('DEFAULT MODEL NUMBER',MODDEF)
646      ELSE
647        READ (INST,*,ERR=3) LMULT
648        IF (LMULT) READ (INST,*,ERR=3) LMULT,MODDEF
649      END IF
650      LBCRU=.FALSE.
651      GOTO 5
652
653C--<ALT> SPECIFY AN ALTERNATE MODEL FOR STATIONS SO DESIGNATED
654114   IF (LINST) THEN
655C--LIST EXISTING ALTERNATE MODEL PAIRS:
656        WRITE (6,1114)
6571114    FORMAT (' EXISTING PAIRS OF MODEL NUMBER & ITS ALTERNATE:')
658        DO I=1,MAXMOD
659          IF (MODALT(I).GT.0) WRITE (6,'(2I4)') I,MODALT(I)
660        END DO
661
662        I=JASK('PRIMARY MODEL NUMBER TO HAVE AN ALTERNATE',1)
663        J=MODALT(I)
664        MODALT(I)=JASK('ALTERNATE MODEL NO. (0 FOR NONE)',J)
665      ELSE
666        READ (INST,*,ERR=3) I,MODALT(I)
667      END IF
668      LBCRU=.FALSE.
669      GOTO 5
670
671C--<NOD> ADD A NODE TO THE PRESENT LIST (NO DEFAULTS)
672116   IF (NNODE.GE.NODMAX) THEN
673        WRITE (6,*)'YOU HAVE',NODMAX,' NODES AND CANT HAVE MORE'
674        GOTO 5
675      END IF
676      NNODE=NNODE+1
677      IF (LINST) THEN
678        TMP1=ASKR('NODE LAT (DEG)',0.)
679        TMP2=ASKR('NODE LAT (MIN)',0.)
680        TMP3=ASKR('NODE LON (DEG - POSITIVE WEST)',0.)
681        TMP4=ASKR('NODE LON (MIN - POSITIVE WEST)',0.)
682        RAD1(NNODE)=ASKR('RADIUS FOR 100% OF THIS MODEL (KM)',0.)
683        DRAD(NNODE)=ASKR
684     2  ('TRANSITION WIDTH OUTSIDE CIRCLE (KM, >0.1)',0.)
685        MODH(NNODE)=JASK('CRUST MODEL NUMBER FOR THIS NODE',1)
686      ELSE
687        READ (INST,*,ERR=3) TMP1,TMP2,TMP3,TMP4,RAD1(NNODE),
688     2  DRAD(NNODE),MODH(NNODE)
689      END IF
690
691C--CHECK MODEL NUMBER
692      IF (MODH(NNODE).GT.LM) THEN
693        WRITE (6,*)'*** ERROR - NODE MODEL NUMBER TOO HIGH:',
694     2  MODH(NNODE)
695        NNODE=NNODE-1
696        IRES=-67
697        GOTO 5
698      END IF
699
700C--COMPLETE THE NODE DATA
701      HLAT(NNODE)=TMP1+TMP2/60.
702      HLON(NNODE)=TMP3+TMP4/60.
703      IF (DRAD(NNODE).LT..1) THEN
704        WRITE (6,*)'*** TRANSITION ZONE INCREASED TO 0.1 KM'
705        DRAD(NNODE)=.1
706      END IF
707      RAD2(NNODE)=RAD1(NNODE)+DRAD(NNODE)
708      LBCRU=.FALSE.
709      GOTO 5
710
711C--<SNO> LIST THE CURRENT NODES AT THE TERMINAL
712118   IF (NNODE.EQ.0) THEN
713        WRITE (6,*)'NO NODES ARE DEFINED'
714        GOTO 5
715      END IF
716      WRITE (6,1016)
7171016  FORMAT
718     2 (' NODE CENTER-LAT CENTER-LON MOD INNER-RADIUS RING-WIDTH')
719      WRITE (6,1017) (I,HLAT(I),HLON(I),MODH(I),RAD1(I),DRAD(I),
720     2 I=1,NNODE)
7211017  FORMAT ((I4,F10.4,F12.4,I4,F10.2,F12.2))
722      GOTO 5
723
724C--<STO> STOP THE PROGRAM
725140   ISTAT=8
726      RETURN
727
728C--<CRH> READ A HOMO LAYER CRUSTAL MODEL
729144   IF (LINST) THEN
730        MOD=JASK('HOMOGENEOUS LAYER CRUST MODEL NO. (1-20)',1)
731        IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146
732        IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD
733        CALL ASKC('CRUST MODEL FILENAME',CRUFIL(MOD))
734      ELSE
735        READ (INST,*,ERR=3) MOD
736        IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146
737        IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD
738        READ (INST,*,ERR=3) MOD,CRUFIL(MOD)
739      END IF
740C--SET THE LARGEST MODEL NUMBER
741      IF (MOD.GT.MAXMOD) MAXMOD=MOD
742
743C--OPEN FILE & READ MODEL
744      CALL OPENR (14,CRUFIL(MOD),'F',IOS)
745      IF (IOS.NE.0) GOTO 145
746      ISTAT=1
747      LBCRU=.FALSE.
748      RETURN
749
750C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT FILES
751145   WRITE (6,1455) CRUFIL(MOD)
7521455  FORMAT (' *** ERROR - CRUST FILE DOES NOT EXIST: ***'/1X,A)
753      IRES=-68
754      GOTO 5
755
756C--ERROR MESSAGE FOR BAD MODEL NUMBER
757146   WRITE (6,1014) MOD
7581014  FORMAT (' *** THIS CRUST MODEL NUMBER IS OUT OF RANGE:',I3)
759      IRES=-69
760      GOTO 5
761
762C--ERROR MESSAGE FOR PREVIOUSLY DEFINED MODEL
7631018  FORMAT (' *** WARNING: MODEL NUMBER',I3,' IS BEING REDEFINED')
764
765C--<CRT> READ ONE OF THE LINEAR GRADIENT CRUSTAL MODELS
766148   IF (LINST) THEN
767        MOD=JASK('LINEAR GRADIENT CRUST MODEL NO. (1-20)',1)
768        IF (MOD.LT.1 .OR. MOD.GT.LN) GOTO 146
769        IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD
770          CALL ASKC('CRUST MODEL FILENAME',CRUFIL(MOD))
771      ELSE
772        READ (INST,*,ERR=3) MOD
773        IF (MOD.LT.1 .OR. MOD.GT.LN) GOTO 146
774        IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD
775        READ (INST,*,ERR=3) MOD,CRUFIL(MOD)
776      END IF
777C--SET THE LARGEST MODEL NUMBER
778      IF (MOD.GT.MAXMOD) MAXMOD=MOD
779
780C--OPEN FILE & READ MODEL
781      CALL OPENR (14,CRUFIL(MOD),'F',IOS)
782      IF (IOS.NE.0) GOTO 145
783      ISTAT=2
784      LBCRU=.FALSE.
785      RETURN
786
787C--<STA> READ IN A LIST OF SEISMIC STATIONS
788152   IF (LINST) THEN
789        CALL ASKC('STATION FILENAME',STAFIL)
790      ELSE
791        READ (INST,*,ERR=3) STAFIL
792      END IF
793
794      CALL OPENR (14,STAFIL,'F',IOS)
795      IF (IOS.EQ.0) THEN
796        ISTAT=3
797        LBSTA=.FALSE.
798        RETURN
799
800      ELSE
801        WRITE (6,1153) STAFIL
8021153    FORMAT (' *** ERROR - STATION FILE DOES NOT EXIST: ***'/1X,A)
803        IRES=-70
804        GOTO 5
805      END IF
806
807C--<INP> ENTER PHASE DATA MANUALLY
808156   ISTAT=4
809      RETURN
810
811C--<DEL> READ IN STATION DELAYS
812C  READ IN ALL DELAYS FROM ONE FILE (OLD WAY), OR DELAYS FROM JUST ONE MODEL
813158   IF (LINST) THEN
814        MODB=JASK('MODEL NO. (-1=ALT.LIST, 0=ALL MODS, 1-32=MODEL NO.)'
815     2 ,1)
816        CALL ASKC('STATION DELAY FILENAME (MUST READ STAS FIRST)'
817     2 ,DELFIL)
818      ELSE
819C--WHEN NO MODEL NO. IS SUPPLIED, READ ALL DELAYS FROM ONE FILE
820        READ (INST,*,ERR=3) MODB,DELFIL
821      END IF
822
823C--OPEN FILE, READ DELAYS
824      CALL OPENR (13,DELFIL,'F',IOS)
825      IF (IOS.NE.0) THEN
826        WRITE (6,1159) DELFIL
8271159    FORMAT (' *** ERROR - DELAY FILE DOES NOT EXIST: ***'/1X,A)
828        IRES=-71
829        GOTO 5
830      END IF
831
832      CALL HYDEL(MODB)
833      LBSTA=.FALSE.
834      GOTO 5
835
836C--<CAL> READ HISTORY FILE OF STATION CAL FACTORS
837160   IF (LINST) THEN
838        CALL ASKC('STA. CAL FACTOR HISTORY FILE (INST.TYPE 3)',CALFIL)
839        WRITE (6,1600)
8401600    FORMAT (' ENTER START DATE OF CAL FACTORS TO LOAD (I.E.',/,
841     2 ' DATE OF FIRST EARTHQ.) USE 0 TO LOAD EARLIEST CAL FACTOR.')
842        ICY=JASK('START YEAR (4 DIGITS)',0)
843        IF (ICY.EQ.0) THEN
844          ICDATE=0
845          GOTO 161
846        END IF
847        ICM=JASK('START MONTH',0)
848        ICD=JASK('START   DAY',0)
849        ICH=JASK('START  HOUR',0)
850      ELSE
851        READ (INST,*,ERR=3) CALFIL,ICY
852        IF (ICY.EQ.0) THEN
853          ICDATE=0
854          GOTO 161
855        END IF
856        READ (INST,*,ERR=3) CALFIL,ICY,ICM,ICD,ICH
857      END IF
858
859      IF (ICY.LT.100) ICY=ICY+ICENT
860      ICDATE=ICH +100*ICD +10000*ICM +1000000*ICY
861161   CALL HYCAL
862      GOTO 5
863
864C--<ATE> READ HISTORY FILE OF STATION ATTENUATIONS
865162   IF (LINST) THEN
866        CALL ASKC('STA. ATTENUATION HISTORY FILE (INST.TYPE 1)',ATNFIL)
867        WRITE (6,1620)
8681620    FORMAT (' ENTER START DATE OF ATTENUATIONS TO LOAD (I.E.',/,
869     2 ' DATE OF FIRST EARTHQ.) USE 0 TO LOAD EARLIEST ATTENUATION.')
870        ICY=JASK('START YEAR (4 DIGITS)',0)
871        IF (ICY.EQ.0) THEN
872          ICDATE=0
873          GOTO 164
874        END IF
875        ICM=JASK('START MONTH',0)
876        ICD=JASK('START   DAY',0)
877        ICH=JASK('START  HOUR',0)
878      ELSE
879        READ (INST,*,ERR=3) ATNFIL,ICY
880        IF (ICY.EQ.0) THEN
881          ICDATE=0
882          GOTO 164
883        END IF
884        READ (INST,*,ERR=3) ATNFIL,ICY,ICM,ICD,ICH
885      END IF
886
887      IF (ICY.LT.100) ICY=ICY+ICENT
888      ICDATE=ICH +100*ICD +10000*ICM +1000000*ICY
889164   CALL HYATE
890      GOTO 5
891
892C--<LOC> LOCATE EVENTS
893166   ISTAT=7
894C--GET CUSP ID NUMBER IF REQUIRED
895      IF (JCP.EQ.6) THEN
896        IF (LINST) THEN
897          IDNO=JASK('CUSP-ID NUMBER',0)
898          MEMDSK=JASK('0=GET FROM MEMORY, 1=GET FROM DISK',1)
899        ELSE
900          READ (INST,*,ERR=3) IDNO,MEMDSK
901        END IF
902      END IF
903      RETURN
904
905C--<PHS> SPECIFY PHASE INPUT FILE
906168   IF (LINST) THEN
907        CALL ASKC('PHASE FILENAME',PHSFIL)
908      ELSE
909        READ (INST,*,ERR=3) PHSFIL
910      END IF
911      GOTO 5
912
913C--<FMC> SET TARGET DATE & READ FILE OF FMAG CORRECTIONS & THEIR EXPIR DATES
914172   IF (LINST) THEN
915        CALL ASKC('STA. FMAG CORRECTION HISTORY FILE',FMCFIL)
916        WRITE (6,1721)
9171721    FORMAT(' ANSWER T TO USE FMAG WEIGHTS ON STATION CARD,'/
918     2  ' F TO FORCE CORRECTION FILE TO SET ALL WEIGHTS.'/
919     3  ' IF F, STATION MUST BE IN CORRECTION FILE TO BE USED:')
920        LNOFMC=LASK('USE STATIONS NOT IN CORRECTION FILE',LNOFMC)
921
922        WRITE (6,1720)
9231720    FORMAT (' ENTER START DATE OF FMAG CORRECTIONS TO LOAD'/,
924     2  ' (I.E. DATE OF FIRST EARTHQ.)'/,
925     4  ' USE 0 TO LOAD EARLIEST FMAG CORRECTION.')
926        ICY=JASK('START YEAR (4 DIGITS)',0)
927        IF (ICY.EQ.0) THEN
928          IFDATE=0
929          GOTO 174
930        END IF
931        ICM=JASK('START MONTH',0)
932        ICD=JASK('START   DAY',0)
933        ICH=JASK('START  HOUR',0)
934
935      ELSE
936        READ (INST,*,ERR=3) FMCFIL,LNOFMC,ICY
937        IF (ICY.EQ.0) THEN
938          IFDATE=0
939          GOTO 174
940        END IF
941        READ (INST,*,ERR=3) FMCFIL,LNOFMC,ICY,ICM,ICD,ICH
942      END IF
943
944      IFDATE=ICH +100*ICD +10000*ICM +1000000*ICY
945174   CALL HYFMC
946      GOTO 5
947
948C--<MIN> SET MIN NO. OF PHASE CARDS TO ATTEMPT A LOCATION
949176   IF (LINST) THEN
950        MINSTA=JASK('MIN NO. OF PHASES TO ATTEMPT A LOCATION',
951     2  MINSTA)
952      ELSE
953        READ (INST,*,ERR=3) MINSTA
954      END IF
955
956      IF (MINSTA.LT.4) THEN
957        WRITE (6,1033)
9581033    FORMAT (' *** ERROR: MINSTA MUST BE 4 OR MORE')
959        MINSTA=4
960      END IF
961      GOTO 5
962
963C--<MAX> LIST THE MAX ARRAY SIZES ON THE TERMINAL
964180   WRITE (6,1180) MAXSTA,MAXPHS,MMAX,MAXUNK, LH,LN,LM, NODMAX,NLYR
9651180  FORMAT (' --- THE MAXIMUM SPACE OF VARIOUS ARRAYS ARE: ---'//
966     1 ' +++ STATIONS AND PHASES +++'/
967     2 I5,' = NUMBER OF STATIONS IN STATION FILE.'/
968     3 I5,' = NUMBER OF PHASE CARDS (STATIONS) PER EVENT.'/
969     4 I5,' = NUMBER OF PHASES (P OR S) PER EVENT.'/
970     5 I5,' = NUMBER OF UNKNOWN STATIONS PER EVENT',
971     3 ' (TO COPY TO ARCHIVE FILE).'/
972     4 8X   ,'(MAX OF POSSIBLE STATIONS SET WITH UNK COMMAND IS 10)'//
973     4 ' +++ MULTIPLE CRUSTAL MODELS +++'/
974     5 I5,' = NUMBER OF HOMOGENEOUS LAYER CRUST MODELS.'/
975     6 I5,' = NUMBER OF LINEAR GRADIENT CRUST MODELS.'/
976     7 I5,' = NUMBER OF CRUSTAL MODELS OF ANY TYPE.'/
977     8 I5,' = NUMBER OF NODES FOR CRUST MODEL REGIONS.'/
978     9 I5,' = NUMBER OF LAYERS PER CRUSTAL MODEL.'/)
979      GOTO 5
980
981C--<UNK> LIST STATIONS NOT TO COMPLAIN ABOUT IF NOT IN STATION FILE
982184   IF (LINST) THEN
983        WRITE (6,1184)
9841184    FORMAT (' ENTER LIST OF 4-LETTER STAS FOR WHICH NO ERROR.'/
985     2 '  MESSAGE WILL RESULT WHEN MISSING FROM STATION LIST:')
986        NLUNK=JASK('NUMBER OF STAS TO EXPECT MISSING (0-10)',NLUNK)
987        IF (NLUNK.GT.10) THEN
988        WRITE (6,*)' *** UNK: MAXIMUM NUMBER OF UNKNOWN STATIONS IS 10'
989          NLUNK=10
990        END IF
991        DO I=1,NLUNK
992          CALL ASKC('STATION',LUNK(I))
993        END DO
994      ELSE
995        READ (INST,*,ERR=3) NLUNK
996        IF (NLUNK.GT.10) THEN
997        WRITE (6,*)' *** UNK: MAXIMUM NUMBER OF UNKNOWN STATIONS IS 10'
998          NLUNK=10
999          IRES=-41
1000        END IF
1001        IF (NLUNK.GT.0) READ (INST,*,ERR=3) NLUNK,(LUNK(I),I=1,NLUNK)
1002      END IF
1003      GOTO 5
1004
1005C--<XMC> SET TARGET DATE & READ FILE OF XMAG CORRECTIONS
1006192   IF (LINST) THEN
1007        CALL ASKC('STA. XMAG CORRECTION HISTORY FILE',XMCFIL)
1008        WRITE (6,1921)
10091921    FORMAT(' ANSWER T TO USE XMAG WEIGHTS ON STATION CARD,'/
1010     2  ' F TO FORCE CORRECTION FILE TO SET ALL WEIGHTS.'/
1011     3  ' IF F, STATION MUST BE IN CORRECTION FILE TO BE USED:')
1012        LNOXMC=LASK('USE STATIONS NOT IN CORRECTION FILE',LNOXMC)
1013
1014        WRITE (6,1920)
10151920    FORMAT (' ENTER START DATE OF XMAG CORRECTIONS TO LOAD'/,
1016     2  ' (I.E. DATE OF FIRST EARTHQ.)'/,
1017     4  ' USE 0 TO LOAD EARLIEST XMAG CORRECTION.')
1018        ICY=JASK('START YEAR (4 DIGITS)',0)
1019        IF (ICY.EQ.0) THEN
1020          IXDATE=0
1021          GOTO 194
1022        END IF
1023        ICM=JASK('START MONTH',0)
1024        ICD=JASK('START   DAY',0)
1025        ICH=JASK('START  HOUR',0)
1026      ELSE
1027        READ (INST,*,ERR=3) XMCFIL,LNOXMC,ICY
1028        IF (ICY.EQ.0) THEN
1029          IXDATE=0
1030          GOTO 194
1031        END IF
1032        READ (INST,*,ERR=3) XMCFIL,LNOXMC,ICY,ICM,ICD,ICH
1033      END IF
1034
1035      IXDATE=ICH +100*ICD +10000*ICM +1000000*ICY
1036194   CALL HYXMC
1037      GOTO 5
1038
1039C--<TYP> TYPE A MESSAGE TO THE TERMINAL (OR BATCH LOG FILE)
1040196   I=LENG(INST)
1041      WRITE (6,'(1X,A)') INST (1:I)
1042      GOTO 5
1043
1044C--<BUG> READ PHASE FILE & GENERATE ONLY ERROR OUTPUT
1045C--A STATION FILE MUST HAVE BEEN READ
1046200   ISTAT=5
1047      RETURN
1048
1049C--<MFL> SET THE OUTPUT MAGNITUDE FILENAME
1050208   IF (LINST) THEN
1051        CALL ASKC('MAGNITUDE DATA OUTPUT FILE (NONE FOR NONE)',MAGFIL)
1052      ELSE
1053        READ (INST,*,ERR=3) MAGFIL
1054      END IF
1055      LMAG=MAGFIL(1:4).NE.'NONE' .AND. MAGFIL(1:4).NE.'none'
1056      GOTO 5
1057
1058C--<WCR> WRITE BINARY SNAPSHOT OF ALL CRUST MODELS
1059216   IF (LINST) THEN
1060        CALL ASKC ('CRUST MODEL SNAPSHOT FILE TO WRITE',BCRUFL)
1061      ELSE
1062        READ (INST,*,ERR=3) BCRUFL
1063      END IF
1064
1065      CALL OPENW (14,BCRUFL,'U',IOS,'S')
1066      WRITE (14) MODTYP,LAY,MODNAM,CRODE,VEL,VSQ,D,THK,REDV
1067      WRITE (14) DD1,ND1,ND,DD2,ND2,GD1,GD2
1068      WRITE (14) DZ1,NZ1,NZ,DZ2,NZ2,GZ1,GZ2
1069      WRITE (14) KDHR,MAXMOD
1070      WRITE (14) KT
1071      WRITE (14) NNODE,HLAT,HLON,RAD1,RAD2,DRAD,MODH
1072      WRITE (14) MODALT,LMULT,MODDEF
1073      CLOSE (14)
1074      GOTO 5
1075
1076C--<RCR> READ BINARY SNAPSHOT OF ALL CRUST MODELS (REPLACES CRT,CRH,NOD,MUL,ALT)
1077220   IF (LINST) THEN
1078        CALL ASKC ('CRUST MODEL SNAPSHOT FILE TO READ',BCRUFL)
1079      ELSE
1080        READ (INST,*,ERR=3) BCRUFL
1081      END IF
1082
1083      CALL OPENR (14,BCRUFL,'U',IOS)
1084      IF (IOS.NE.0) THEN
1085        WRITE (6,'('' *** ERROR - CRUST SNAPSHOT FILE NOT FOUND'')')
1086        IRES=-72
1087        GOTO 5
1088      END IF
1089
1090      READ (14) MODTYP,LAY,MODNAM,CRODE,VEL,VSQ,D,THK,REDV
1091      READ (14) DD1,ND1,ND,DD2,ND2,GD1,GD2
1092      READ (14) DZ1,NZ1,NZ,DZ2,NZ2,GZ1,GZ2
1093      READ (14) KDHR,MAXMOD
1094      READ (14) KT
1095      READ (14) NNODE,HLAT,HLON,RAD1,RAD2,DRAD,MODH
1096      READ (14) MODALT,LMULT,MODDEF
1097
1098      LBCRU=.TRUE.
1099      WRITE (6,'(I6,'' CRUST MODELS READ IN BINARY'')') MAXMOD
1100      CLOSE (14)
1101      GOTO 5
1102
1103C--<WST> WRITE BINARY SNAPSHOT OF ALL STATION DATA
1104224   IF (LINST) THEN
1105        CALL ASKC ('STATION DATA SNAPSHOT FILE TO WRITE',BSTAFL)
1106      ELSE
1107        READ (INST,*,ERR=3) BSTAFL
1108      END IF
1109
1110      CALL OPENW (14,BSTAFL,'U',IOS,'S')
1111      WRITE (14) JSTA,STANAM,JNET,JCOMP1,JCOMP3,JLATD,JLATM,JLOND,
1112     2 JLONM,JPER,JCAL,JLMOD,JFCOR,JXCOR,JPSWT,JXWT,JFWT,STRMK,JPD,
1113     3 JTYPE,JSLOC,JSLOC2,JFGWT,JCOMPA
1114      CLOSE (14)
1115      GOTO 5
1116
1117C--<RST> READ BINARY SNAPSHOT OF ALL STATION DATA (REPLACES STA, DEL COMMANDS)
1118228   IF (LINST) THEN
1119        CALL ASKC ('STATION DATA SNAPSHOT FILE TO READ',BSTAFL)
1120      ELSE
1121        READ (INST,*,ERR=3) BSTAFL
1122      END IF
1123
1124      CALL OPENR (14,BSTAFL,'U',IOS)
1125      IF (IOS.NE.0) THEN
1126        WRITE (6,'('' *** ERROR - STATION SNAPSHOT FILE NOT FOUND'')')
1127        IRES=-73
1128        GOTO 5
1129      END IF
1130
1131      READ (14) JSTA,STANAM,JNET,JCOMP1,JCOMP3,JLATD,JLATM,JLOND,
1132     2 JLONM,JPER,JCAL,JLMOD,JFCOR,JXCOR,JPSWT,JXWT,JFWT,STRMK,JPD,
1133     3 JTYPE,JSLOC,JSLOC2,JFGWT,JCOMPA
1134      LBSTA=.TRUE.
1135      WRITE (6,'(I6,'' STATIONS READ IN BINARY'')') JSTA
1136      CLOSE (14)
1137      GOTO 5
1138
1139C--<BAS> SET STRINGS FOR READING & MAKING INTERACTIVE PROCESSING FILENAMES
1140232   IF (LINST) THEN
1141        WRITE (6,1232)
11421232    FORMAT (' I/O FILENAMES ARE MADE FROM A BASE NAME AND',
1143     2 ' AND EXTENSION.'/' USE THE EXTENSION "NONE" TO DISABLE.')
1144        CALL ASKC ('FILE TO READ BASE EVENT NAMES',LSTFIL)
1145        NCBASE=JASK('NO. OF CHARS TO READ FOR BASE NAMES',NCBASE)
1146        CALL ASKC ('FORMAT FOR READING BASE EVENT NAMES',LSTFOR)
1147        CALL ASKC ('PHASE FILE EXTENSION',EXTPHS)
1148        CALL ASKC ('ARCHIVE FILE EXTENSION',EXTARC)
1149        CALL ASKC ('SUMMARY FILE EXTENSION',EXTSUM)
1150        CALL ASKC ('PRINTOUT FILE EXTENSION',EXTPRT)
1151        WRITE (6,1233)
11521233    FORMAT (' VAX EDITOR: 1=EDT 2=GENERAL ED'/
1153     2 ' SUN EDITOR: 1=DTPAD 2=VI 3=TEXTEDIT')
1154        IEDFLG=JASK('EDITOR',IEDFLG)
1155      ELSE
1156        READ (INST,*,ERR=3) LSTFIL,NCBASE,LSTFOR, EXTPHS,EXTARC,
1157     2  EXTSUM,EXTPRT,IEDFLG
1158      END IF
1159
1160      LARC=EXTARC(1:4).NE.'NONE' .AND. EXTARC(1:4).NE.'none'
1161      LSUM=EXTSUM(1:4).NE.'NONE' .AND. EXTSUM(1:4).NE.'none'
1162      LPRT=EXTPRT(1:4).NE.'NONE' .AND. EXTPRT(1:4).NE.'none'
1163      GOTO 5
1164
1165C--<PRO> GO DO INTERACTIVE PROCESSING
1166236   CALL HYPRO
1167      GOTO 5
1168
1169C--<FC1> GET STATION COMPONENTS TO USE FOR 1ST DURATION MAGNITUDE
1170240   IF (LINST) THEN
1171        CALL ASKC('1-LETTER LABEL CODE FOR FMAG1',LABF1)
1172        IF (NCPF1.EQ.0) THEN
1173          WRITE (6,
1174     2    '('' NO COMPONENTS USED TO CALCULATE FIRST DUR MAG'')')
1175        ELSE IF (NCPF1.GT.0) THEN
1176          WRITE (6,2400) NCPF1,(COMPF1(I),I=1,NCPF1)
11772400      FORMAT (I3,' COMPONENTS USED TO CALCULATE FIRST DUR MAG:'/,
1178     2    20(1X,A3))
1179        ELSE
1180          WRITE (6,*)' ALL COMPONENTS USED TO CALCULATE FIRST DUR MAG'
1181        END IF
1182
1183        NCPF1=JASK
1184     1  ('NO. OF COMPONENTS TO USE FOR FMAG1 (-1=ALL, OR 0-20)'
1185     2  ,NCPF1)
1186        IF (NCPF1.GT.20) THEN
1187          WRITE (6,*) ' *** ERROR-TOO MANY FC1 COMPONENTS REQUESTED'
1188          GOTO 5
1189        END IF
1190        IF (NCPF1.GT.0) THEN
1191          DO I=1,NCPF1
1192            CALL ASKC('COMPONENT FOR FMAG1 (I.E. VHZ)',COMPF1(I))
1193          END DO
1194        END IF
1195      ELSE
1196
1197        READ (INST,*,ERR=3) LABF1,NCPF1
1198        IF (NCPF1.GT.20) THEN
1199          WRITE (6,*) ' *** ERROR-TOO MANY FC1 COMPONENTS REQUESTED'
1200          GOTO 5
1201        END IF
1202        IF (NCPF1.GT.0) READ (INST,*,ERR=3) LABF1,NCPF1,
1203     2  (COMPF1(I),I=1,NCPF1)
1204      END IF
1205
1206C--BLANK OUT REMAINING COMPONENTS TO SELECT ON
1207      IF (NCPF1.GE.0) THEN
1208        DO I=NCPF1+1,20
1209          COMPF1(I)=' '
1210        END DO
1211      END IF
1212      GOTO 5
1213
1214C--<FC2> GET STATION COMPONENTS TO USE FOR 2ND DURATION MAGNITUDE
1215244   IF (LINST) THEN
1216        CALL ASKC('1-LETTER LABEL CODE FOR FMAG2',LABF2)
1217        IF (NCPF2.EQ.0) THEN
1218          WRITE (6,
1219     2   '('' NO COMPONENTS USED TO CALCULATE SECOND DUR MAG'')')
1220        ELSE IF (NCPF2.GT.0) THEN
1221          WRITE (6,2400) NCPF2,(COMPF2(I),I=1,NCPF2)
12222440      FORMAT (I3,' COMPONENTS USED TO CALCULATE SECOND DUR MAG:'/,
1223     2   20(1X,A3))
1224        ELSE
1225          WRITE (6,
1226     2   '('' ALL COMPONENTS USED TO CALCULATE SECOND DUR MAG'')')
1227        END IF
1228
1229        NCPF2=JASK
1230     1  ('NO. OF COMPONENTS TO USE FOR FMAG2 (-1=ALL, OR 0-20)'
1231     2 ,NCPF2)
1232        IF (NCPF2.GT.20) THEN
1233          WRITE (6,*) ' *** ERROR-TOO MANY FC2 COMPONENTS REQUESTED'
1234          GOTO 5
1235        END IF
1236        IF (NCPF2.GT.0) THEN
1237          DO I=1,NCPF2
1238            CALL ASKC('COMPONENT FOR FMAG2 (I.E. VLZ)',COMPF2(I))
1239          END DO
1240        END IF
1241      ELSE
1242
1243        READ (INST,*,ERR=3) LABF2,NCPF2
1244        IF (NCPF2.GT.20) THEN
1245          WRITE (6,*) ' *** ERROR-TOO MANY FC2 COMPONENTS REQUESTED'
1246          GOTO 5
1247        END IF
1248        IF (NCPF2.GT.0) READ (INST,*,ERR=3) LABF2,NCPF2,
1249     2  (COMPF2(I),I=1,NCPF2)
1250      END IF
1251
1252C--BLANK OUT REMAINING COMPONENTS TO SELECT ON
1253      IF (NCPF2.GE.0) THEN
1254        DO I=NCPF2+1,20
1255          COMPF2(I)=' '
1256        END DO
1257      END IF
1258      GOTO 5
1259
1260C--<XC1> GET STATION COMPONENTS TO USE FOR 1ST AMPLITUDE MAGNITUDE
1261248   IF (LINST) THEN
1262        CALL ASKC('1-LETTER LABEL CODE FOR XMAG1',LABX1)
1263        IF (NCPX1.EQ.0) THEN
1264          WRITE (6,
1265     2   '('' NO COMPONENTS USED TO CALCULATE FIRST AMP MAG'')')
1266        ELSE IF (NCPX1.GT.0) THEN
1267          WRITE (6,2400) NCPX1,(COMPX1(I),I=1,NCPX1)
12682480      FORMAT (I3,' COMPONENTS USED TO CALCULATE FIRST AMP MAG: '/,
1269     2    20(1X,A3))
1270        ELSE
1271          WRITE (6,
1272     2   '('' ALL COMPONENTS USED TO CALCULATE FIRST AMP MAG'')')
1273        END IF
1274
1275        NCPX1=JASK
1276     1  ('NO. OF COMPONENTS TO USE FOR XMAG1 (-1=ALL, OR 0-20)'
1277     2  ,NCPX1)
1278        IF (NCPX1.GT.20) THEN
1279          WRITE (6,*) ' *** ERROR-TOO MANY XC1 COMPONENTS REQUESTED'
1280          GOTO 5
1281        END IF
1282        IF (NCPX1.GT.0) THEN
1283          DO I=1,NCPX1
1284            CALL ASKC('COMPONENT FOR XMAG1 (I.E. VHZ)',COMPX1(I))
1285          END DO
1286        END IF
1287      ELSE
1288
1289        READ (INST,*,ERR=3) LABX1,NCPX1
1290        IF (NCPX1.GT.20) THEN
1291          WRITE (6,*) ' *** ERROR-TOO MANY XC1 COMPONENTS REQUESTED'
1292          GOTO 5
1293        END IF
1294        IF (NCPX1.GT.0) READ (INST,*,ERR=3) LABX1,NCPX1,
1295     2  (COMPX1(I),I=1,NCPX1)
1296      END IF
1297
1298C--BLANK OUT REMAINING COMPONENTS TO SELECT ON
1299      IF (NCPX1.GE.0) THEN
1300        DO I=NCPX1+1,20
1301          COMPX1(I)=' '
1302        END DO
1303      END IF
1304      GOTO 5
1305
1306C--<XC2> GET STATION COMPONENTS TO USE FOR 2ND AMPLITUDE MAGNITUDE
1307252   IF (LINST) THEN
1308        CALL ASKC('1-LETTER LABEL CODE FOR XMAG2',LABX2)
1309        IF (NCPX2.EQ.0) THEN
1310          WRITE (6,
1311     2    '('' NO COMPONENTS USED TO CALCULATE SECOND AMP MAG'')')
1312        ELSE IF (NCPX2.GT.0) THEN
1313          WRITE (6,2400) NCPX2,(COMPX2(I),I=1,NCPX2)
13142520      FORMAT (I3,' COMPONENTS USED TO CALCULATE SECOND AMP MAG:'/,
1315     2    20(1X,A3))
1316        ELSE
1317          WRITE (6,
1318     2    '('' ALL COMPONENTS USED TO CALCULATE SECOND AMP MAG'')')
1319        END IF
1320
1321        NCPX2=JASK
1322     1  ('NO. OF COMPONENTS TO USE FOR XMAG2 (-1=ALL, OR 0-20)'
1323     2  ,NCPX2)
1324        IF (NCPX2.GT.20) THEN
1325          WRITE (6,*) ' *** ERROR-TOO MANY XC2 COMPONENTS REQUESTED'
1326          GOTO 5
1327        END IF
1328        IF (NCPX2.GT.0) THEN
1329          DO I=1,NCPX2
1330            CALL ASKC('COMPONENT FOR XMAG2 (I.E. WLN)',COMPX2(I))
1331          END DO
1332        END IF
1333      ELSE
1334
1335        READ (INST,*,ERR=3) LABX2,NCPX2
1336        IF (NCPX2.GT.20) THEN
1337          WRITE (6,*) ' *** ERROR-TOO MANY XC2 COMPONENTS REQUESTED'
1338          GOTO 5
1339        END IF
1340        IF (NCPX2.GT.0) READ (INST,*,ERR=3) LABX2,NCPX2,
1341     2  (COMPX2(I),I=1,NCPX2)
1342      END IF
1343
1344C--BLANK OUT REMAINING COMPONENTS TO SELECT ON
1345      IF (NCPX2.GE.0) THEN
1346        DO I=NCPX2+1,20
1347          COMPX2(I)=' '
1348        END DO
1349      END IF
1350      GOTO 5
1351
1352C--<DU2> ADDITIONAL TERMS FOR CODA MAGNITUDE RELATION
1353256   IF (LINST) THEN
1354        DCOFM1=ASKR('COEFF. OF D<DBRKM1 FMAG DIST TERM',DCOFM1)
1355        DBRKM1=ASKR('MAX DIST OF D<DBRKM1 FMAG DIST TERM',DBRKM1)
1356        DCOFM2=ASKR('COEFF. OF D>DBRKM2 FMAG DIST TERM',DCOFM2)
1357        DBRKM2=ASKR('START DIST OF D>DBRKM2 FMAG DIST TERM',DBRKM2)
1358        ZCOFM=ASKR('COEFF. OF Z>ZBRKM FMAG DEPTH TERM',ZCOFM)
1359        ZBRKM=ASKR('START DEPTH OF Z>ZBRKM FMAG DEPTH TERM',ZBRKM)
1360      ELSE
1361        READ (INST,*,ERR=3) DCOFM1,DBRKM1,DCOFM2,DBRKM2,ZCOFM,ZBRKM
1362      END IF
1363      GOTO 5
1364
1365C--<FCM> COMPONENT CORRECTIONS FOR CODA MAGNITUDES
1366260   IF (LINST) THEN
1367        NFCM=JASK(
1368     2 'NO. (0-10) OF COMPONENTS TO HAVE INDEP. FMAG CORRECTIONS',NFCM)
1369        IF (NFCM.GT.10) THEN
1370          WRITE (6,*) ' *** ERROR-TOO MANY XCM COMPONENTS REQUESTED'
1371          GOTO 5
1372        END IF
1373        DO I=1,NFCM
1374          CALL ASKC('COMPONENT TO CORRECT',CFCM(I))
1375          AFCM(I)=ASKR('CORRECTION FOR ABOVE COMPONENT',AFCM(I))
1376        END DO
1377
1378      ELSE
1379        READ (INST,*,ERR=3) NFCM
1380        IF (NFCM.GT.10) THEN
1381          WRITE (6,*) ' *** ERROR-TOO MANY XCM COMPONENTS REQUESTED'
1382          GOTO 5
1383        END IF
1384        IF (NFCM.GT.0)
1385     2  READ (INST,*,ERR=3) NFCM,(CFCM(I),AFCM(I),I=1,NFCM)
1386      END IF
1387      GOTO 5
1388
1389C--<XCM> COMPONENT CORRECTIONS FOR AMPLITUDE MAGNITUDES
1390264   IF (LINST) THEN
1391        NXCM=JASK(
1392     2 'NO. (0-10) OF COMPONENTS TO HAVE INDEP. XMAG CORRECTIONS',NXCM)
1393        IF (NXCM.GT.10) THEN
1394          WRITE (6,*) ' *** ERROR-TOO MANY XCM COMPONENTS REQUESTED'
1395          GOTO 5
1396        END IF
1397        DO I=1,NXCM
1398          CALL ASKC('COMPONENT TO CORRECT',CXCM(I))
1399          AXCM(I)=ASKR('CORRECTION FOR ABOVE COMPONENT',AXCM(I))
1400        END DO
1401
1402      ELSE
1403        READ (INST,*,ERR=3) NXCM
1404        IF (NXCM.GT.10) THEN
1405          WRITE (6,*) ' *** ERROR-TOO MANY XCM COMPONENTS REQUESTED'
1406          GOTO 5
1407        END IF
1408        IF (NXCM.GT.0)
1409     2  READ (INST,*,ERR=3) NXCM,(CXCM(I),AXCM(I),I=1,NXCM)
1410      END IF
1411      GOTO 5
1412
1413c--<INI> INITIALIZE HYPOINVERSE BY EXECUTING A STANDARD COMMAND FILE.
1414C  THE NAME OF THE COMMAND FILE IS ASSIGNED BY THE ENVIRONMENT VARIABLE
1415C  "HYPINITFILE".
1416268   CALL GETENV ('HYPINITFILE',TEMPSTR)
1417      IF (TEMPSTR.EQ.'    ') THEN
1418        WRITE (6,1268)
14191268    FORMAT (' ENVIRONMENT VARIABLE "HYPINITFILE" FOR STARTUP FILE ',
1420     2  ' NOT FOUND.'/' LETS TRY A STANDARD FILENAME.'/
1421     3  ' IN THE FUTURE YOU SHOULD DEFINE IT LIKE THIS:'/
1422C     4  ' On andreas:'/
1423C     5  '  setenv HYPINITFILE /we/calnet/klein/hypfiles/cal2000.hyp'/
1424     6  ' On swave:'/
1425     7  '  setenv HYPINITFILE /home1/calnet/klein/hypfiles/cal2000.hyp')
1426        TEMPSTR=INFILE(0)
1427      END IF
1428
1429C--THIS CASE SHOULD ONLY OCCUR IN THE VAX VERSION, WITH NO ENV. VARIABLE SET
1430      IF (TEMPSTR.EQ.'VAX') THEN
1431        TEMPSTR=INFILE(0)
1432      END IF
1433
1434      WRITE (6,'('' INITIALIZING WITH COMMAND FILE:''/1X,A)') TEMPSTR
1435      CM=('@'//TEMPSTR(1:2))
1436      INST=TEMPSTR(3:60)
1437      GOTO 6
1438
1439C--<LET> SET THE NUMBER OF LETTERS TO MATCH IN STA, NET & COMP CODES
1440272   IF (LINST) THEN
1441        NSTLET=JASK
1442     2  ('NUMBER OF LETTERS TO CHECK IN STATION SITE CODE (2-5)',NSTLET)
1443        NETLET=JASK
1444     2  ('NUMBER OF LETTERS TO CHECK IN STATION NET CODE (0-2)',
1445     3  NETLET)
1446        NCOMP=JASK
1447     2  ('NO. OF LETTERS TO CHECK IN STATION COMPONENT CODE (0-3)',
1448     3  NCOMP)
1449
1450        NSLOC=JASK
1451     2  ('NO. OF LETS TO CHECK IN LOCATION CODE IN PHASE FILES (0-2)',
1452     3  NSLOC)
1453        NSLOC2=JASK
1454     2  ('NO. OF LETS TO CHECK IN LOCATION CODE IN OTHER FILES (0-2)',
1455     3  NSLOC2)
1456      ELSE
1457C--IF NSLOC IS NOT SUPPLIED, ASSUME IT IS ZERO AND DO NOT ISSUE WARNING YET
1458        READ (INST,*,ERR=273) NSTLET, NETLET, NCOMP, NSLOC, NSLOC2
1459        GOTO 274
1460273     READ (INST,*,ERR=3) NSTLET, NETLET, NCOMP
1461        WRITE (6,*)
1462     2  ' * WARNING: SUPPLY NO. OF LOCATION LETTERS IN LET COMMAND'
1463        NSLOC=0
1464      END IF
1465274   IF (NSLOC.LT.NSLOC2) THEN
1466        WRITE (6,*)
1467     2 ' *** ERROR: MUST CHECK AS MANY LOCATION LETTERS IN PHASE FILES'
1468        WRITE (6,*)' AS IN MAG CORRECTION AND CALIBRATION FILES (LET).'
1469      END IF
1470      GOTO 5
1471
1472C--<LES> ASK WHETHER COMPONENT IS FROM 1-LET OR 3-LET FIELD.
1473276   WRITE (6,*) '*** LES COMMAND NO LONGER USED'
1474      GOTO 5
1475     
1476C      IF (LINST) THEN
1477C        WRITE (6,*) ' IF USING 1-LETTER STATION COMPONENTS,'
1478C        LCOMP1=LASK
1479C     2  ('T=USE 1-LET COMP. FIELD, F=USE FIRST LET OF 3-LET FIELD',
1480C     3  LCOMP1)
1481C      ELSE
1482C        READ (INST,*,ERR=3) LCOMP1
1483C      END IF
1484
1485C--CHECK TO SEE IF 1-LETTER STATION CODES ARE BEING USED CONSISTENTLY
1486C      IF (LCOMP1 .AND. NCOMP.NE.1) THEN
1487C        WRITE (6,*) ' *** YOU CANT READ THE 1-LETTER STATION'
1488C        WRITE (6,*) ' COMPONENT FIELD BECAUSE YOU HAVE ASKED FOR',
1489C     2  NCOMP,' COMPONENT LETTERS'
1490C        LCOMP1=.FALSE.
1491C        IRES=-74
1492C      END IF
1493
1494C--IN CASE STATION FILE HAS ALREADY BEEN READ IN AND MATCHING IS TO BE DONE
1495C  WITH 1-LETTER COMPONENT FIELD, TRANSFER 1-LET COMPS TO 3-LETT ARRAY,
1496C  BECAUSE MATCHING IS ACTUALLY ONLY DONE WITH 3-LET ARRAY.
1497C      IF (LCOMP1 .AND. JSTA.GT.0) THEN
1498C        DO J=1,JSTA
1499C          JCOMP3(J)=JCOMP1(J)
1500C        END DO
1501C      END IF
1502C      GOTO 5
1503
1504C--<DUB> SECOND DURATION MAG CONSTANTS
1505280   IF (LINST) THEN
1506        WRITE (6,1272)
15071272    FORMAT (' CONSTANTS FOR SECOND DUR MAG. NOTE: NO COMPONENT,'/
1508     2  ' ADDITIONAL DEPTH OR DISTANCE CORRECTIONS USED.')
1509        WRITE (6,1274)
15101274    FORMAT (' MAG CONSTANTS FOR DUR < FMBRKB:')
1511        FMA1B=ASKR('CONSTANT    FMA1B',FMA1B)
1512        FMB1B=ASKR('LOG TERM    FMB1B',FMB1B)
1513        FMZ1B=ASKR('DEPTH TERM  FMZ1B',FMZ1B)
1514        FMD1B=ASKR('DIST TERM   FMD1B',FMD1B)
1515        FMF1B=ASKR('LINEAR TERM FMF1B',FMF1B)
1516        WRITE (6,1273)
15171273    FORMAT (' MAG CONSTANTS FOR DUR > FMBRKB:')
1518        FMA2B=ASKR('CONSTANT    FMA2B',FMA2B)
1519        FMB2B=ASKR('LOG TERM    FMB2B',FMB2B)
1520        FMZ2B=ASKR('DEPTH TERM  FMZ2B',FMZ2B)
1521        FMD2B=ASKR('DIST TERM   FMD2B',FMD2B)
1522        FMF2B=ASKR('LINEAR TERM FMF2B',FMF2B)
1523
1524        FMBRK=ASKR('FMBRKB',FMBRKB)
1525        FMGNB=ASKR('USE GAIN CORRECTION 0=NO 1=YES',FMGNB)
1526      ELSE
1527        READ (INST,*,ERR=3) FMA1B,FMB1B,FMZ1B,FMD1B,FMF1B,
1528     2  FMA2B,FMB2B,FMZ2B,FMD2B,FMF2B, FMBRKB,FMGNB
1529      END IF
1530      GOTO 5
1531
1532C--<PRE> SET MAGNITUDE PREFERENCE ORDER FOR PREFERRED MAGNITUDE
1533284   IF (LINST) THEN
1534        WRITE (6,*) ' SET MAGNITUDE PREFERENCE ORDER. THE MAGS ARE:'
1535        WRITE (6,*)
1536     2  ' 1=FMAG 2=XMAG 3=BMAG 4=XMAG2 5=FMAG2 6=PAMAG1 7=PAMAG2'
1537        NMAGS=JASK
1538     2  ('NUMBER OF MAGNITUDES ELIGIBLE FOR PREFERRED MAG (0-10)',
1539     3  NMAGS)
1540        DO I=1,NMAGS
1541          WRITE (6,*)
1542          WRITE (6,*) ' MAGNITUDE FOR CHOICE NUMBER',I,':'
1543          MPREF(I)=JASK('MAGNITUDE CHOICE (I.E. 1=FMAG)',MPREF(I))
1544          MNPREF(I)=JASK('MINIMUM READINGS TO CHOOSE THIS MAG',
1545     2    MNPREF(I))
1546          AMPREF(I)=ASKR('MINIMUM MAG VALUE TO CHOOSE THIS MAG',
1547     2    AMPREF(I))
1548          AXPREF(I)=ASKR('MAXIMUM MAG VALUE TO CHOOSE THIS MAG',
1549     2    AXPREF(I))
1550        END DO
1551      ELSE
1552        READ (INST,*,ERR=3) NMAGS
1553        IF (NMAGS.GT.0) READ (INST,*,ERR=3) NMAGS,
1554     2  (MPREF(I),MNPREF(I),AMPREF(I),AXPREF(I),I=1,NMAGS)
1555      END IF
1556      GOTO 5
1557
1558C--<LA0> SELECT COMPONENTS FOR UNIQUE LOGA0 RELATIONS IN AMP MAGS
1559288   IF (LINST) THEN
1560        NLA0=JASK('NUMBER OF COMPS WITH UNIQUE LOGA0s (0-20)',NLA0)
1561        IF (NLA0.GT.0) THEN
1562          WRITE (6,1096)
1563          DO I=1,NLA0
1564            WRITE (6,*) ' COMPONENT NUMBER ',I
1565            CALL ASKC('COMPONENT CODE',CLA0(I))
1566            MLA0(I)=JASK('LOG(A0) RELATION FOR THIS COMPONENT',MLA0(I))
1567          END DO
1568        END IF
1569      ELSE
1570
1571        READ (INST,*,ERR=3) NLA0
1572        IF (NLA0.GT.0) READ(INST,*,ERR=3)NLA0,(CLA0(I),MLA0(I),I=1,NLA0)
1573      END IF
1574      GOTO 5
1575
1576C--<PMA> SET FLAGS FPR PMAG PROCESSING
1577292   IF (LINST) THEN
1578        LPMAG =LASK('COMPUTE PMAG FROM P AMPS ON SHADOW CARDS',LPMAG)
1579        LPPRT =LASK('PRINT PMAG INFO IN PRINT FILE STATION LISTING',
1580     2  LPPRT)
1581        WRITE (6,
1582     2  '('' ENTER DEVELOCORDER MM PER COUNT UNIT FOR P-MAGS'')')
1583        CNT2MD=ASKR('DEFAULT VALUE (RTP=.04, EARTHWORM=.0488)',CNT2MD)
1584
1585        WRITE (6,2920)
15862920    FORMAT (' FRACTION OF CLIPPED PMAGS FOR DECLARING EVENT PMAG')
1587        CLPRAT=ASKR('A MINIMUM (CLIPPED) VALUE',CLPRAT)
1588        WRITE (6,1096)
1589        LATYPP=JASK('LOG(A0) RELATION FOR P MAGS',LATYPP)
1590      ELSE
1591        READ (INST,*,ERR=3) LPMAG,LPPRT,CNT2MD,CLPRAT,LATYPP
1592      END IF
1593
1594C--ERROR TO PRINT MAG WITHOUT COMPUTING IT
1595      IF (LPPRT .AND. .NOT.LPMAG) WRITE (6,1293)
15961293  FORMAT (' *** ERROR: YOU MUST COMPUTE PMAGS BEFORE',
1597     2 ' YOU CAN PRINT THEM')
1598
1599C--IF PMAG PROCESSING IS SELECTED, CHECK WHETHER SHADOW CARDS ARE USED
1600      IF (LPMAG .AND. JCP.NE.5) WRITE (6,1292)
16011292  FORMAT (' *** WARNING: TO COMPUTE PMAGS, BE SURE ARCHIVE SHADOW'/
1602     2 ' FORMATS ARE SELECTED WITH "COP 5" AND "CAR 3".')
1603      GOTO 5
1604
1605C--<PAC> PRIMARY P AMPLITUDE MAGNITUDE COMPONENT WEIGHTS
1606296   IF (LINST) THEN
1607        WRITE (6,1296)
16081296    FORMAT (' SET COMPONENTS WITH PRIMARY PMAG WEIGHTS',
1609     2  ' DIFFERENT FROM 1.0')
1610        NPWM=JASK
1611     1  ('NO. OF COMPONENTS WITH DEFINED PMAG WEIGHTS (0-10)'
1612     2  ,NPWM)
1613        IF (NPWM.GT.0) THEN
1614          DO I=1,NPWM
1615            WRITE (6,'('' COMPONENT NUMBER'',I3)') I
1616            CALL ASKC('COMPONENT CODE (I.E. VHZ)',CPWM(I))
1617            WPWM(I)=ASKR('WEIGHT FOR THIS COMPONENT (0.-5.)',
1618     2      WPWM(I))
1619          END DO
1620        END IF
1621      ELSE
1622
1623        READ (INST,*,ERR=3) NPWM
1624        IF (NPWM.GT.0) READ (INST,*,ERR=3) NPWM,
1625     2  (CPWM(I),WPWM(I),I=1,NPWM)
1626      END IF
1627      GOTO 5
1628
1629C--<PC1> PRIMARY P AMP MAGNITUDE SELECTION BY COMPONENT
1630300   IF (LINST) THEN
1631        CALL ASKC('1-LETTER LABEL CODE FOR PRIMARY PMAG',LABP1)
1632
1633        PMA1=ASKR('A VALUE IN PMAG1(OUT)= A +B*PMAG1(CALC)',PMA1)
1634        PMB1=ASKR('B VALUE IN PMAG1(OUT)= A +B*PMAG1(CALC)',PMB1)
1635
1636        IF (NCPP1.EQ.0) THEN
1637          WRITE (6,
1638     2    '('' NO COMPONENTS NOW USED TO CALCULATE PRIMARY P MAG'')')
1639        ELSE IF (NCPP1.GT.0) THEN
1640          WRITE (6,3000) NCPP1,(COMPP1(I),I=1,NCPP1)
16413000      FORMAT (I3,' COMPONENTS USED TO CALCULATE FIRST DUR MAG:'/,
1642     2    10(1X,A3))
1643        ELSE
1644          WRITE (6,
1645     2    '('' ALL COMPONENTS NOW USED TO CALCULATE PRIMARY P MAG'')')
1646        END IF
1647
1648        NCPP1=JASK(
1649     2 'NO. OF COMPONENTS TO USE FOR PMAG1 (-1=ALL, OR 0-10)',NCPP1)
1650        IF (NCPP1.GT.0) THEN
1651          DO I=1,NCPP1
1652            CALL ASKC('COMPONENT FOR PMAG1 (I.E. VHZ)',COMPP1(I))
1653          END DO
1654        END IF
1655      ELSE
1656
1657        READ (INST,*,ERR=3) LABP1,PMA1,PMB1,NCPP1
1658        IF (NCPP1.GT.0) READ (INST,*,ERR=3) LABP1,PMA1,PMB1,NCPP1,
1659     2  (COMPP1(I),I=1,NCPP1)
1660      END IF
1661
1662C--BLANK OUT REMAINING COMPONENTS TO SELECT ON
1663      IF (NCPP1.GE.0) THEN
1664        DO I=NCPP1+1,10
1665          COMPP1(I)='   '
1666        END DO
1667      END IF
1668      GOTO 5
1669
1670C--<PC2> PRIMARY P AMP MAGNITUDE SELECTION BY COMPONENT
1671304   IF (LINST) THEN
1672        CALL ASKC('1-LETTER LABEL CODE FOR SECONDARY PMAG',LABP2)
1673
1674        PMA2=ASKR('A VALUE IN PMAG2(OUT)= A +B*PMAG2(CALC)',PMA2)
1675        PMB2=ASKR('B VALUE IN PMAG2(OUT)= A +B*PMAG2(CALC)',PMB2)
1676
1677        IF (NCPP2.EQ.0) THEN
1678          WRITE (6,
1679     2    '('' NO COMPONENTS NOW USED TO CALCULATE SECONDARY P MAG'')')
1680        ELSE IF (NCPP2.GT.0) THEN
1681          WRITE (6,3040) NCPP2,(COMPP2(I),I=1,NCPP2)
16823040      FORMAT (I3,' COMPONENTS USED TO CALC. SECONDARY DUR MAG:'/,
1683     2    10(1X,A3))
1684        ELSE
1685          WRITE (6,
1686     2    '('' ALL COMPONENTS NOW USED TO CALCULATE SECONDARY P MAG'')')
1687        END IF
1688
1689        NCPP2=JASK(
1690     2 'NO. OF COMPONENTS TO USE FOR PMAG2 (-1=ALL, OR 0-10)',NCPP2)
1691        IF (NCPP2.GT.0) THEN
1692          DO I=1,NCPP2
1693            CALL ASKC('COMPONENT FOR PMAG2 (I.E. VLZ)',COMPP2(I))
1694          END DO
1695        END IF
1696      ELSE
1697
1698        READ (INST,*,ERR=3) LABP2,PMA2,PMB2,NCPP2
1699        IF (NCPP2.GT.0) READ (INST,*,ERR=3) LABP2,PMA2,PMB2,NCPP2,
1700     2  (COMPP2(I),I=1,NCPP2)
1701      END IF
1702
1703C--BLANK OUT REMAINING COMPONENTS TO SELECT ON
1704      IF (NCPP2.GE.0) THEN
1705        DO I=NCPP2+1,10
1706          COMPP2(I)='   '
1707        END DO
1708      END IF
1709      GOTO 5
1710
1711C--<PMC> SPECIFY COUNT-TO-MM CONVERSION FACTORS BY DATA SOURCES
1712308   IF (LINST) THEN
1713        WRITE (6,3080)
17143080    FORMAT (' ENTER DEVELOCORDER MM PER COUNT UNIT (C-FACTORS)',
1715     2  ' FOR P-MAGS, BY DATA SOURCE.'/
1716     3  ' ENTER NUMBER OF DATA-SOURCE SPECIFIC C-FACTORS (0-10).')
1717        NCNTMM=JASK(
1718     2  ' ENTER 0 TO USE DEFAULT VALUE FROM PMA COMMAND FOR ALL COMPS',
1719     3  NCNTMM)
1720        DO I=1,NCNTMM
1721          WRITE (6,*) ' DATA SOURCE NUMBER',I,':'
1722          CALL ASKC('DATA SOURCE CODE (IE. W)',CCNTMM(I))
1723          CNT2MM(I)=ASKR
1724     2    ('C-FACTOR VALUE (RTP=.04, EARTHWORM=.0488)',CNT2MM(I))
1725        END DO
1726
1727      ELSE
1728        READ (INST,*,ERR=3) NCNTMM
1729        IF (NCNTMM.GT.0) READ (INST,*,ERR=3) NCNTMM,
1730     2  (CCNTMM(I),CNT2MM(I),I=1,NCNTMM)
1731      END IF
1732      GOTO 5
1733
1734C--<LAB> SET A LABEL FOR ENTIRE RUN TO INCLUDE IN OUTPUT FILES
1735312   IF (LINST) THEN
1736        CALL ASKC('1-LETTER LABEL FOR RUN, INCLUDED IN OUTPUT FILES',
1737     2  RUNLAB)
1738        LP153=LASK(
1739     2  'F=PUT RUN LABEL IN SUMMARY COL 153, T=PASS COL 153 THRU',LP153)
1740      ELSE
1741        READ (INST,*,ERR=3) RUNLAB,LP153
1742      END IF
1743      GOTO 5
1744
1745C--<KEP> DECIDE WHETHER TO KEEP UNRECOGNIZED STATIONS IN ARC OUTPUT FILE
1746316   IF (LINST) THEN
1747        LKEEP=LASK('WRITE UNRECOGNIZED STATIONS TO ARCHIVE FILE',LKEEP)
1748      ELSE
1749        READ (INST,*,ERR=3) LKEEP
1750      END IF
1751      GOTO 5
1752
1753C--<WET> SET WEIGHTS FOR PHASE WEIGHT CODES 0-3
1754320   IF (LINST) THEN
1755        WRITE (6,*) 'ENTER NUMERICAL WEIGHTS FOR PHASE WEIGHT CODES.'
1756        WRITE (6,*) 'CODES 4-9 ALWAYS HAVE ZERO WEIGHT.'
1757        DO I=1,4
1758          WRITE (6,*) 'CODE',I-1
1759          WTVALS(I)=ASKR('NUMERICAL WEIGHT FOR PHASE',WTVALS(I))
1760        END DO
1761      ELSE
1762        READ (INST,*,ERR=3) WTVALS
1763      END IF
1764      GOTO 5
1765
1766C--<XCH> CHOOSE STATIONS FOR THE 2 AMP MAGS BY COMPONENT OR TYPE
1767324   IF (LINST) THEN
1768        WRITE (6,*) 'CHOOSE WAY TO SELECT STATIONS FOR 2 AMP MAGS:'
1769        WRITE (6,*) 'USE XTY COMMAND TO SELECT INST TYPES.'
1770        LXCH=LASK('T=BY COMPONENT LETTER, F=BY INST TYPE',LXCH)
1771      ELSE
1772        READ (INST,*,ERR=3) LXCH
1773      END IF
1774      GOTO 5
1775
1776C--<XTY> SET INSTRUMENT TYPE CODES FOR THE 2 AMP MAGS
1777328   IF (LINST) THEN
1778        NXTYP1=JASK(
1779     2 'NUMBER OF INTRUMENT CODES FOR AMP MAG 1 (0-3, -1=ALL)',NXTYP1)
1780        DO I=1,3
1781          WRITE (6,*) 'CODE NUMBER',I
1782          IXTYP1(I)=JASK(
1783     2    'INSTRUMENT CODE (0=WA, 1=NET, 2=SPRENG 3=NET)',IXTYP1(I))
1784        END DO
1785
1786        NXTYP2=JASK(
1787     2 'NUMBER OF INTRUMENT CODES FOR AMP MAG 2 (0-3, -1=ALL)',NXTYP2)
1788        DO I=1,3
1789          WRITE (6,*) 'CODE NUMBER',I
1790          IXTYP2(I)=JASK(
1791     2    'INSTRUMENT CODE (0=WA, 1=NET, 2=SPRENG 3=NET)',IXTYP2(I))
1792        END DO
1793
1794      ELSE
1795        READ (INST,*,ERR=3)  NXTYP1,(IXTYP1(I),I=1,3),
1796     2  NXTYP2,(IXTYP2(I),I=1,3)
1797      END IF
1798      GOTO 5
1799
1800C--<200> INVOKE YR 2000 FORMATS
1801332   IF (LINST) THEN
1802        L2000=LASK('T FOR YR 2000 FORMATS, F=OLD FORMATS',L2000)
1803        ICENT=JASK('DEFAULT CENTURY FOR OLD PHASE INPUT',ICENT)
1804        IAMPU=JASK('DEFAULT AMP UNITS CODE FOR OLD PHASE INPUT',
1805     2  IAMPU)
1806      ELSE
1807
1808        READ (INST,*,ERR=3) L2000,ICENT,IAMPU
1809      END IF
1810      GOTO 5
1811
1812C--<FIL> DETERMINE THE PHASE FILE TYPE AND CHANGE I/O FORMATS
1813336   WRITE (6,*)
1814     2' FIND INPUT PHASE FILE TYPE & SET PHS(COP) & ARC(CAR) FORMATS'
1815      CALL OPENR (14,PHSFIL,'F',IOS)
1816      IF (IOS.NE.0) THEN
1817        WRITE (6,*) ' *** ERROR - PHASE FILE DOES NOT EXIST ***'
1818        WRITE (6,*) ' YOU MUST SPECIFY FILE WITH THE PHS COMMAND FIRST'
1819        GOTO 5
1820      END IF
1821     
1822C--DETERMINE FORMAT BY READING FIRST RECORD OR 2. ALSO FINDS SUMMARY FORMATS.
1823      CALL HYFILE (14,ITYPE)
1824      CLOSE (14)
1825      IF (ITYPE.EQ.-1) THEN
1826        WRITE (6,*) ' *** ERROR: INPUT PHASE FILE IS EMPTY'
1827      ELSE IF (ITYPE.EQ.0) THEN
1828        WRITE (6,*) ' *** ERROR: INPUT PHASE FILE HAS AN UNKNOWN FORMAT'
1829      ELSE IF (ITYPE.EQ.1) THEN
1830        WRITE (6,*)
1831     2' *** ERROR: INPUT FILE IS A HYPOINVERSE (PRE 2000) SUMMARY FILE'
1832      ELSE IF (ITYPE.EQ.2) THEN
1833        WRITE (6,*)
1834     2' *** ERROR: INPUT FILE IS A HYPOINVERSE-2000 SUMMARY FILE'
1835      ELSE IF (ITYPE.EQ.3) THEN
1836        WRITE (6,*)
1837     2' *** ERROR: INPUT FILE IS A HYPO71 (PRE 2000) SUMMARY FILE'
1838      ELSE IF (ITYPE.EQ.4) THEN
1839        WRITE (6,*)
1840     2' *** ERROR: INPUT FILE IS A HYPO71-2000 SUMMARY FILE'
1841      ELSE IF (ITYPE.EQ.5) THEN
1842        WRITE (6,*)
1843     2' INPUT IS A TRADITIONAL HYPO71-HYPOINVERSE PHASE FILE'
1844        WRITE (6,*) ' SETTING FORMATS COP 1, CAR 1'
1845        JCP=1
1846        JCA=1
1847      ELSE IF (ITYPE.EQ.6) THEN
1848        WRITE (6,*)
1849     2' INPUT IS A HYPO71-HYPOINVERSE PHASE FILE WITH SHADOW CARDS'
1850        WRITE (6,*) ' SETTING FORMATS COP 4, CAR 3'
1851        JCP=4
1852        JCA=3
1853 
1854      ELSE IF (ITYPE.EQ.7) THEN
1855        WRITE (6,*)
1856     2' INPUT IS A HYPOINVERSE ARCHIVE FILE (PRE 2000), NO SHADOWS'
1857        IF (L2000) THEN
1858          WRITE (6,*)
1859     2' *** ERROR: YOU SHOULD RERUN PROGRAM WITHOUT Y2000 FORMATS'
1860        ELSE
1861          WRITE (6,*) ' SETTING FORMATS COP 3, CAR 1'
1862          JCP=3
1863          JCA=1
1864        END IF
1865
1866      ELSE IF (ITYPE.EQ.8) THEN
1867        WRITE (6,*)
1868     2' INPUT IS A HYPOINVERSE ARCHIVE-2000 FILE, NO SHADOWS'
1869        IF (.NOT.L2000) THEN
1870          WRITE (6,*)
1871     2' *** ERROR: YOU SHOULD RERUN PROGRAM WITH Y2000 FORMATS'
1872        ELSE
1873          WRITE (6,*) ' SETTING FORMATS COP 3, CAR 1'
1874          JCP=3
1875          JCA=1
1876        END IF
1877
1878      ELSE IF (ITYPE.EQ.9) THEN
1879        WRITE (6,*)
1880     2' INPUT IS A HYPOINVERSE ARCHIVE FILE (PRE 2000), WITH SHADOWS'
1881        IF (L2000) THEN
1882          WRITE (6,*)
1883     2' *** ERROR: YOU SHOULD RERUN PROGRAM WITHOUT Y2000 FORMATS'
1884        ELSE
1885          WRITE (6,*) ' SETTING FORMATS COP 5, CAR 3'
1886          JCP=5
1887          JCA=3
1888        END IF
1889
1890      ELSE IF (ITYPE.EQ.10) THEN
1891        WRITE (6,*)
1892     2' INPUT IS A HYPOINVERSE ARCHIVE-2000 FILE, WITH SHADOWS'
1893        IF (.NOT.L2000) THEN
1894          WRITE (6,*)
1895     2' *** ERROR: YOU SHOULD RERUN PROGRAM WITH Y2000 FORMATS'
1896        ELSE
1897          WRITE (6,*) ' SETTING FORMATS COP 5, CAR 3'
1898          JCP=5
1899          JCA=3
1900        END IF
1901      END IF
1902      GOTO 5
1903
1904C--<DUG> GET COMPONENTS TO APPLU DURATION GAIN CORRECTION TO
1905340   IF (LINST) THEN
1906        WRITE (6,*) ' -1 APPLY GAIN CORR TO ALL COMPS; 0 NO COMPS;'
1907        WRITE (6,*) ' 1-10 NUMBER OF COMPONENTS TO CORRECT:'
1908        IDUG=JASK('NUMBER OF DUR GAIN CORRECTION COMPONENTS',IDUG)
1909        DO I=1,IDUG
1910          CALL ASKC('COMPONENT TO APPLY DUR GAIN CORRECTION TO: ',
1911     2    CDUG(I))
1912        END DO
1913      ELSE
1914
1915        READ (INST,*,ERR=3) IDUG
1916        IF (IDUG.GT.0) READ (INST,*,ERR=3) IDUG,(CDUG(I),I=1,IDUG)
1917      END IF
1918      GOTO 5
1919     
1920C--<XMT> CHOOSE WHICH MAGNITUDE TYPES GO WITH XMAG1 AND XMAG2
1921344   IF (LINST) THEN
1922        WRITE (6,*)' CHOOSE TYPES FOR AMP MAGNITUDES 0=ANY 1=ML 2=MX:'
1923        MAG1TYPX=JASK('TYPE FOR XMAG1',MAG1TYPX)
1924        MAG2TYPX=JASK('TYPE FOR XMAG2',MAG2TYPX)
1925      ELSE
1926        READ (INST,*,ERR=3) MAG1TYPX, MAG2TYPX
1927      END IF
1928      GOTO 5
1929     
1930C--<DIG> SET SOME DIGITIZER CODES (3-LET IN, 1-LET OUT)
1931348   IF (LINST) THEN
1932        WRITE (6,*)' ENTER DIGITIZER CODES (3-LET IN, 1-LET OUT):'
1933        IDIG=JASK('FIRST DIGITIZER CODE TO SET',0)
1934        IF (IDIG.LT.1) THEN
1935          WRITE (6,*)' CANT BE LESS THAN 1'
1936          GOTO 5
1937        END IF
1938
1939        JDIG=JASK(' LAST DIGITIZER CODE TO SET',0)
1940        IF (JDIG.GT.MAXDIG) THEN
1941          WRITE (6,*)' CANT BE MORE THAN ',MAXDIG
1942          GOTO 5
1943        END IF
1944       
1945        DO I=IDIG,JDIG
1946          WRITE (6,*)' CODE ',I,' :'
1947          CALL ASKC ('INPUT CUSP 3-LETTER CODE:',DIG3(I))
1948          CALL ASKC ('OUTPUT 1-LETTER DATA SOURCE CODE:',DIG1(I))
1949        END DO
1950        GOTO 5
1951       
1952      ELSE
1953        READ (INST,*,ERR=3) IDIG,JDIG
1954        IF (IDIG.LT.1) THEN
1955          WRITE (6,*)' IDIG CANT BE LESS THAN 1'
1956          GOTO 5
1957        END IF
1958
1959        IF (JDIG.GT.MAXDIG) THEN
1960          WRITE (6,*)' JDIG CANT BE MORE THAN ',MAXDIG
1961          GOTO 5
1962        END IF
1963       
1964        READ (INST,*,ERR=3) IDIG,JDIG,(DIG3(I),DIG1(I),I=IDIG,JDIG)
1965      END IF
1966      GOTO 5
1967
1968C--<DID> SET NUMBER OF DIGITIZER CODES & DEFAULT CODE
1969352   IF (LINST) THEN
1970        NDIG=JASK('TOTAL NUMBER OF DIGITIZER CODES (MAX 50)',NDIG)
1971        CALL ASKC('DEFAULT SOURCE CODE WHEN DIGITIZER NOT DEFINED',
1972     2  DIGDEF)
1973      ELSE
1974        READ (INST,*,ERR=3) NDIG,DIGDEF
1975      END IF
1976      GOTO 5
1977
1978C--<VER> PROCESSING DOMAIN & VERSION FOR SUMMARY CARDS & PRINT FILE
1979354   IF (LINST) THEN
1980        CALL ASKC ('2-CHAR PROCESSING DOMAIN',CDOMAN)
1981        CALL ASKC ('2-CHAR PROCESSING VERSION',CPVERS)
1982      ELSE
1983        READ (INST,*,ERR=3) CDOMAN,CPVERS
1984      END IF
1985      GOTO 5
1986     
1987      END     
Note: See TracBrowser for help on using the repository browser.