c c implemented for seisan by jh c c all files put into this one c include file integer.for put into common.inc c maxsta increased to 25000 in common.inc c c 2015.06.02 pv: change DATA FN1 input to length 25 as declared. c C--HYP IS THE VAX/SUN VERSION OF THE LOCATION PROGRAM HYPOINVERSE. THE PROGRAM C IS DESIGNED TO BE FAST, FILE ORIENTED AND COMMAND DRIVEN. C--WRITTEN BY FRED KLEIN. SEE GREETING IN HYBDA.FOR FOR VERSION # C++++++++++++++++ LIST OF REQUIRED SUBROUTINES +++++++++++++++++ C--SUBROUTINES MARKED WITH * REQUIRE THE COMMON BLOCK INCLUDE FILE 'common.inc' C 'common.inc' INCLUDES THE FILE 'integer.for' WHERE ARRAYS ARE DECLARED C INTEGER*2 AND LOGICAL*2. *4 VARIABLES MAY BE USED IF NECESSARY. C--SUBROUTINES MARKED WITH & HAVE DIFFERENT VERSIONS ON THE SUN AND VAX. C--USE *.FOR ON ALL SYSTEMS IF IT IS THE ONLY FILE THAT EXISTS. C--USE *.F ON SUN AND *.FOR ON THE VAX IF BOTH EXIST. C HYP * MAIN PROGRAM. C HYBDA * BLOCK DATA INITIALIZATION OF COMMON. C HYBEG &* INITIALIZATION OF OTHER VARIABLES. C HYCMD * GETS AND PROCESSES COMMANDS. C HYSTA * READS IN STATIONS. C HYDEL * READS IN STATION DELAYS (FOR MULTIPLE MODELS). C HYATE * READS IN STATION ATTENUATION HISTORY. C HYCAL * READS IN STATION CALIBRATION FACTOR HISTORY. C HYFMC * READS IN STATION FMAG CORRECTIONS. C HYXMC * READS IN STATION XMAG CORRECTIONS. C HYCRH * READS IN HOMOGENOUS LAYER CRUSTAL MODELS. C HYCRT * READS IN TRAVEL-TIME-TABLE CRUSTAL MODELS. C HYCRE * READS LAYER CRUSTAL MODEL FOR HYPOELLIPSE TT CALCULATION C HYSTL * OUTPUTS STATIONS, CRUST & PARAMETERS TO PRINT FILE. C HYOPEN * OPENS FILES FOR LOCATION RUN. C HYINIT * INITIALIZES SOME VARIABLES FOR LOCATION RUN. C HYPHS * READS IN PHASE DATA FOR ONE EVENT. C HYCIN &* INPUTS PHASE DATA FROM CUSP MEM FILES (ALTERNATE TO HYPHS) C HYCOUT &* OUTPUTS RESULTS TO THE CUSP MEM FILE C (HYCIN & HYCOUT ARE NO LONGER CALLED) C HYTRL * SETS TRIAL HYPOCENTER. C HYLOC * LOCATES ONE EVENT. C HYSOL * PERFORMS INVERSION FOR ONE ITERATION. C HYSVD & CANNED SINGLE-VALUE-DECOMPOSITION ROUTINE. C (SEE NOTES IN HYSVD.F AND FPE-TRAPS COMMENT FOR SPECIAL SUN MODS) C HYTRA * MANAGE CRUST MODEL CHOICE & AVERAGING. C HYTRH * CALC TRAVEL TIMES AND DERIVS FOR HOMO LAYER MODEL. C HYTRT * CALC TRAVEL TIMES AND DERIVS FROM TRAV-TIME TABLE. C HYTRE * CALC TRAVEL TIMES AND DERIVS FOR LAYER HYPOELLIPSE MODEL C TRVCON CALLED BY HYTRE, ORIGINAL HYPOELLIPSE TT CALCULATION CODE C HYLINV * CALC TT AND DERIVS FOR GRADIENT LAYER OVER HALFSPACE (HYPOELLIPSE). C HYLIN * CALC TT AND DERIVS FOR GRADIENT LAYER (HYPOELLIPSE). C THESE ROUTINES CALL LINVOL AND LINV RESPECTIVELY, C CODE DIRECTLY FROM HYPOELLIPSE C HYMAG * COMPUTES ALL MAGNITUDES. C HYMAGP * COMPUTES P AMPLITUDE MAGNITUDES. C HYPREF * SELECTS THE PREFERRED MAGNITUDE FROM ALL AVAILABLE. C HYREP * REPORTS A LOCATION ON THE TERMINAL. C HYSOU * TABULATES MOST COMMON DATA SOURCE CODES C HYLST * OUTPUTS DATA BY STATION TO PRINT & ARCHIVE FILES. C HYSUM * OUTPUTS SUMMARY RECORD (FINAL LOCATION). C HYINP FOR INTERACTIVE ENTRY OF PHASE DATA. C HYPRO * INTERACTIVELY PROCESSES A SERIES OF EVENTS. C HYDATUM * COMPUTES THE DEPTH DATUM FROM THE 5 CLOSEST STATIONS. C MEDWT COMPUTES THE WEIGHTED MEDIAN OF A SERIES OF MAGNITUDES. C HYDELT & DELETES FILES IN INTERACTIVE PROCESSING C HYEDIT & RUNS AN EDTIOR WITHIN A PROCESS C HYTIME & GETS CURRENT SYSTEM TIME FOR LABELING PRINT FILE C HYFILE DETERMINES FORMAT OF PHASE FILE BY READING FIRST FEW LINES C UTMCAL COMPUTES STATION DISTANCES ON A UTM GRID C--GENERAL PURPOSE SUBROUTINES C ALLSUBS FILE THAT CONTAINS ALL THESE GENERAL PURPOSE SUBS C KLAS ASSIGNS A NAME AND NUMBER TO AN EVENT BASED ON LOCATION. C KLASS (NET 1), BOX2 (NET2), BOX3 (NET3), KSIC - USED BY KLAS. C UPSTR CONVERTS A STRING TO UPPER CASE. C JASK INTERACTIVE PROMPT & ENTRY OF AN INTEGER. C ASKC INTERACTIVE PROMPT AND ENTRY OF A STRING. C ASKR INTERACTIVE PROMPT AND ENTRY OF A REAL VALUE. C LASK INTERACTIVE PROMPT AND ENTRY OF A LOGICAL VALUE. C LENG DETERMINES THE NON-BLANK LENGTH OF A STRING. C DAYJL RETURNS PERPETUAL JULIAN DAY FOR A DATE. C JDATE RETURNS DATE FOR A PERPETUAL JULIAN DAY. C OPENR & OPENS A FILE FOR READING. C OPENW & OPENS A FILE FOR WRITING. C ERRSET & VAX SYSTEM SUBROUTINE ONLY: CONTROLS ERROR MESSAGES ON OVERFLOWS. C (A DUMMY ERRSET.F IS SUPPLIED WITH THE UNIX VERSION) C SPAWN & SPAWNS AN OPERATING SYSTEM COMMAND. C READQ & READS AN ASCII RECORD AND RETURNS ITS LENGTH. C GETENV & ON UNIX, RETURNS ENVIRONMENT VAR W/NAME OF INI COMMAND FILE C (A DUMMY GETENV.VAX IS SUPPLIED FOR VAX & OS2 VERSIONS) C--CUSP SUBROUTINES (NO LONGER NEEDED) C MEM_DUMP READS A CUSP MEM FILE AND PUTS DATA INTO STRUCTURES C OPHASE PARSES REMARK, WEIGHT & FIRST MOT FROM PHASE DESCRIPTOR C MEM_EQ_UPDATE PUTS HYPOCENTER & STA INFO INTO CUSP MEMORY (& MEM FILE) C--DIFFERENCES BETWEEN THE VAX AND SUN/UNIX VERSIONS: C--WHERE THEY DIFFER, THE SUBROUTINE SOURCE CODE FILES THAT END IN .F ARE C FOR SUN; THOSE ENDING IN .FOR ARE FOR VAX. FILES FOR WHICH THERE IS C ONLY A .FOR VERSION WILL COMPILE ON EITHER MACHINE. C--ROUTINES WITH DIFFERENT VERSIONS ARE HYBEG, HYDELT, HYEDIT, HYTIME, C SPAWN, INIT_EVENT, HYCIN, OPENR AND OPENW. C--HYBEG INITIALIZES FILENAMES AND DEVICES THAT ARE SYSTEM SPECIFIC. C--THE FOLLOWING "NON-ANSI" FORTRAN FEATURES ARE USED (THESE WERE FLAGGED C BY SUN'S FORTRAN COMPILER WHEN THE -ansi COMMAND FLAG WAS USED): C OPTIONAL INTEGER*2 AND LOGICAL*2 VARIABLES IN COMMON (SEE INTEGER.FOR) C INCLUDE STATEMENT C DO ... END DO STATEMENTS C ! TO BEGIN END OF LINE COMMENTS ('common.' FILE ONLY) C SUBROUTINE NAMES (HYPOINV) LONGER THAN 6 CHARACTERS C LIST-DIRECTED FORMATTING FROM AN INTERNAL STRING C CHARACTER*(*) IN CONCATENATION C--FPE (FLOATING POINT EXCEPTION) TRAPS. C THE SUN VERSION, WHEN PRESENTED WITH UNDERDETERMINED EARTHQUAKES WITH FEW C READINGS, WOULD SOMETIMES ATTEMPT A ZERO / ZERO OPERATION IN HYSVD. THE C SOLUTION PROGRAMMED INTO HYSVD.F WAS TO TEST THE DIVIDEND AND DIVISOR C BEFORE DIVISION AND TO RETURN A ZERO QUOTIENT IF BOTH WERE 0. THE VAX DOES C THIS AUTOMATICALLY. 0/0 ON THE SUN YIELDS AN IEEE NaN (NOT A NUMBER) WHICH C CONTAMINATES ALL SUCCEEDING VARIABLES THAT DEPEND ON THIS NUMBER. WHEN C EVENTUALLY USED AS A SUBSCRIPT, THE PROGRAM HANGS UNTIL STOPPED WITH ^C. C--HERE ARE SUGGESTIONS TO TRAP FPE'S THAT WERE USED TO DETECT THIS 0/0 FPE. C ON THE SUN, COMPILE f77 WITH THE -g OPTION TO STORE LINE NUMBERS IN THE C SOURCE CODE. SUN DOES NOT PERMIT COMPILING THE MAIN PROGRAM WITH BOTH -g C AND A COMMON BLOCK, SO USE A DUMMY MAIN PROGRAM HYPMAIN.F: C CALL TRAPFPE C CALL HYPM C END C--THE TRAPFPE SUBROUTINE ENABLES A IEEE HANDLER WHICH IS CALLED WHEN AN FPE C EXCEPTION OCCURS (0/0, OVERFLOW, ETC). THE HANDLER PRINTS THE HEX ADDRESS OF C THE CODE GENERATING THE EXCEPTION, THEN USE THE dbx DEBUGGER TO FIND THE C SOURCE CODE LINE NUMBER. ALTERNATIVELY, USE THE dbxtool WITH CODE COMPILED C WITH THE -g OPTION, AND GIVE THE dbx COMMAND c catch FPE C dbxenv case insensitive ALLOWS EXAMINING HI VARIABLES WITH dbxtool. C--SEE SUN'S DEBUGGING TOOLS AND FORTRAN NUMERICAL COMPUTATION DOCUMENTATION C FOR MORE INFO. C--REMOVAL OF UNNEEDED SUBROUTINES AND DATA TO SAVE MEMORY SPACE: C--IF CUSP DATA WILL NOT BE USED (JCP 6 OR 7): C ELIMINATE THE CALLS TO INIT_EVENT AND HYCIN FROM HYP. ALSO ELIMINATE THE C SUBROUTINES CALLED BY HYCIN (SUCH AS GET_* & THE CUSP LIBRARY). C THE COMMAND FID WILL NOT THEN BE NEEDED. ALSO ELIMINATE THE VARIABLES C IRES, LCUSP & FORID FROM COMMON. C--IF SHADOW PHASE FORMATS WILL NOT BE USED (JCP 4 & 5): C ELIMINATE THE VARIABLES KSHAD, KLSHA, LENSHA, SHADO, LSHA1 & SHAD1 C FROM COMMON, AND REFERENCES TO THEM IN HYPHS AND HYLST. C--THE NUMBER OF STATIONS ARE CONTROLED BY THE COMMON PARAMETERS C MAXSTA > MAXPHS > MMAX. THESE CAN BE MADE SMALLER FOR SMALL NETWORKS. C--VERY PARTIAL VERSION HISTORY C C 1978 VERSION 0.x (Eclipse computer, simple & compact) C 1985 VERSION 0.x (VAX and pro-350 computer, compact) C 1989 VERSION 0.x (multiple crust models) C 2002 VERSION 1.0 (Full documentation, completely Y2000 capable) C 2/2007 VERSION 1.1 (Can fix origin time, many other changes) C 5/2007 VERSION 1.11 (Can fix origin time, greeting) C 1/2008 VERSION 1.2 (f77/g77 compiler) C 7/2010 VERSION 1.3 (HYPOELLIPSE GRADIENT MODELS, POS FOR EACH MODEL) C 6/2011 VERSION 1.34 (VERSION 1.3 AFTER TESTING & INCORPORATING COMMENTS) C 6/2014 VERSION 1.40 COMPUTES DEPTH DATUM FOR CRT AND CRH MODELS C++++++++++++++++ I/O DEVICE NUMBERS USED ++++++++++++++++++++++ C 5 TERMINAL INPUT. C 6 TERMINAL OUTPUT. C 7 ARCHIVE OUTPUT FILE. C 8,9,10,11 INPUT COMMAND FILES. C 12 SUMMARY OUTPUT FILE. C 13 STATION DATA FILES (ATTEN, DELAY, FMAG & XMAG CORRECTIONS). C 14 CRUST, STATION & PHASE INPUT FILES. C 15 PRINT OUTPUT FILE. C 16 MAGNITUDE DATA OUTPUT FILE. C 17 EVENT LIST FILE FOR INTERACTIVE PROCESSING INCLUDE 'common.inc' CHARACTER XMON(12)*3,CC*1 DATA XMON/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP', 2 'OCT','NOV','DEC'/ C--DONT GIVE ERROR MESSAGES WHEN DATA OVERFLOW OUTPUT FIELDS CALL ERRSET (63,.TRUE.,.FALSE.,.FALSE.,.FALSE.) C--DONT GIVE ERROR MESSAGES WHEN INTEGERS OVERFLOW (BUSTED EVENTS THAT ARE C KICKED OUTSIDE THE NETWORK) CALL ERRSET (70,.TRUE.,.FALSE.,.FALSE.,.FALSE.) C--INITIALIZE FLAG TO SUCCESS IRES=1 C--SEND A MESSAGE TO THE TERMINAL. THIS ALSO ASSIGNS UNIT 5 TO TERMINAL WRITE (6,1000) 1000 FORMAT (' HYPOINVERSE 2000 STARTING') WRITE (6,'(A)') GREETING C--INITIALIZE VARIABLES NOT INITIALIZED IN BLOCK DATA CALL HYBEG C--OPEN AND BEGIN READING THE OPTIONAL STARTUP COMMAND FILE HYPINST INP=5 CALL OPENR (8,INFILE(1),'F',IOS) IF (IOS.NE.0) GOTO 5 INP=8 C--GO GET A COMMAND AND EXECUTE IT. RETURN HERE IF CALLING A SUBROUTINE. 5 CALL HYCMD C--ISTAT DIRECTS WHICH SUBROUTINE OR SECTION TO INVOKE. C ISTAT IS ONLY ASSIGNED A VALUE BY HYCMD. C 1 CRH READ LAYER CRUST MODEL C 2 CRT READ GRADIENT TRAVEL TIME TABLE C 3 STA READ STATION FILE C 4 INP INPUT PHASE DATA INTERACTIVELY C 5 BUG READ A PHASE FILE ONLY TO CHECK FOR ERRORS C 7 LOC LOCATE A PHASE FILE C 8 STO STOP HYPOINVERSE, OR RETURN TO MASTER CALLING PROGRAM C 9 CRE READ HYPOELLIPSE LAYER CRUST MODEL GOTO (10,12,14,74,78,5,84,13,11), ISTAT !84 FOR LOC COMMAND GOTO 5 C-- READ A HOMOGENEOUS LAYER CRUSTAL MODEL 10 CALL HYCRH CLOSE (14) GOTO 5 C-- READ A HYPOELLIPSE LAYER CRUSTAL MODEL 11 CALL HYCRE CLOSE (14) GOTO 5 C-- READ A LINEAR GRADIENT CRUSTAL MODEL 12 CALL HYCRT CLOSE (14) GOTO 5 C-- STOP THE PROGRAM, OR EXIT TO MAIN PROGRAM IF A SUBROUTINE 13 IF (SUBMOD) THEN CONTINUE ELSE STOP END IF GOTO 5 C-- READ STATION FILE 14 CALL HYSTA CLOSE (14) GOTO 5 C-- ENTER PHASE DATA MANUALLY INTO A CONDENSED FORMAT FILE. 74 CALL HYINP GOTO 5 C-- READ PHASE FILE ONLY TO CHECK FOR ERRORS C--OPEN PRINT OUTPUT FILE 78 LPRT=.TRUE. IF (PRTFIL(1:4).EQ.' ') PRTFIL=TERMIN IF (LAPP(1)) THEN CALL OPENW (15,PRTFIL,'F',IOS,'A') ELSE CALL OPENW (15,PRTFIL,'F',IOS,'S') END IF C--OPEN PHASE FILE CALL OPENR (15,PHSFIL,'F',IOS) IF (IOS.NE.0) THEN WRITE (6,1008) 1008 FORMAT (' *** ERROR - PHASE FILE NOT FOUND') CLOSE (15) IRES=-61 GOTO 5 END IF C--LOOP TO READ EVENTS 80 CALL HYPHS IF (KEND.EQ.0) GOTO 80 CLOSE (15) CLOSE (14) GOTO 5 C++++++++++++++++++++ EARTHQUAKE LOCATION SECTION ++++++++++++++++++ C--ATE ALL EARTHQUAKES IN THE SPECIFIED FILE, USING PRESENT PARAMETERS C--INITIALIZE SOME VARIABLES 84 CALL HYINIT C--OPEN FILES CALL HYOPEN C--STOP NOW IF THERE IS NO PHASE FILE IF (ISTAT2.EQ.0) GOTO 5 C--LIST AVAILABLE STATIONS & MODELS IN PRINT FILE CALL HYSTL C--READ IN PHASE DATA FOR ONE EVENT 50 CALL HYPHS C LCUSP=JCP.EQ.6 .OR. JCP.EQ.7 C--READ IN PHASE DATA FOR ONE EVENT- CALLS TO CUSP ROUTINES NO LONGER MADE C50 IF (LCUSP) THEN C CALL HYCIN C ELSE C CALL HYPHS C END IF C--KEND IS SET BY HYPHS DEPENDING ON END-OF-FILE STATUS C =-1 END OF FILE, STOP RIGHT AWAY C = 0 LOCATE THIS EVENT, THEN READ ANOTHER C = 1 END OF FILE, LOCATE THIS EVENT THEN STOP C--CLOSE FILES & QUIT IF END OF FILE OCCURRED IN PHASE FILE IF (KEND.LT.0) GOTO 70 C--SET THE TRIAL HYPOCENTER CALL HYTRL C--PRINT THE EVENT DATE AND TIME AS HEADING IF (LPRT .AND. KPRINT.GT.0) THEN IF (LEJCT) THEN CC='1' ELSE CC=' ' WRITE (15,'(1X,21(''####''))') END IF WRITE (15,1005) CC,KDAY,XMON(KMONTH), 2 KYEAR2,KHOUR,KMIN,INUM,IDNO 1005 FORMAT (A1,I3,1X,A3,I5,',',I3,':',I2.2,' SEQUENCE NO.', 2 I5,', ID NO.',I10) END IF C--LOCATE THE EVENT CALL HYLOC C--ASSIGN A 3-LETTER CODE AND NAME BASED ON LOCATION C I IS THE REGION NUMBER, PRESENTLY UNUSED IF (NET.GT.0) I=KLAS (NET,CLAT,-CLON,Z1,REMK,FULNAM) C--FIND THE DEPTH DATUM & OPTIONALLY ADJUST THE REPORTED DEPTH CALL HYDATUM C--CALCULATE THE EARTHQUAKE'S MAGNITUDE CALL HYMAG C--CALCULATE THE EARTHQUAKE'S P AMPLITUDE MAGNITUDE C CALL HYMAGP C--SELECT PREFERRED MAGNITUDE CALL HYPREF C--TABULATE DATA SOURCE CODES CALL HYSOU C--GENERATE PRINTED AND ARCHIVE OUTPUT CALL HYLST C--ABORT THE LOOP IF THERE ARE NOT ENOUGH READINGS IF (NWR.LT.MINSTA) THEN WRITE (6,1002) NWR,KYEAR2,KMONTH,KDAY,KHOUR,KMIN IF (LPRT) WRITE (15,1002) NWR,KYEAR,KMONTH,KDAY,KHOUR,KMIN 1002 FORMAT (' *** ABANDON EVENT WITH ONLY',I2,' READINGS:',I4,4I3) IRES=-51 GOTO 50 !FOR HYP (MAIN PROGRAM) ONLY END IF C--WRITE RESULTS TO CUSP MEM FILE C--JCPO CONTROLS TO WHAT EXTENT RESULTS ARE WRITTEN OUT TO CUSP C =0 NOTHING WRITTEN ANYWHERE C =1 STRUTURES UPDATED C =2 ABOVE PLUS SHARED MEMORY UPDATED C =3 ABOVE PLUS MEM FILE RE-WRITTEN C IF (LCUSP .AND. JCPO.GT.0) CALL HYCOUT C--OUTPUT SUMMARY DATA USING UNIT NUMBER FOR SUMMARY FILE IF (LSUM) CALL HYSUM (12) C--OUTPUT A MESSAGE ON THE CONSOLE FOR EACH EVENT IF (LREP) CALL HYREP C--END OF LOCATION LOOP IF (KEND.EQ.0) GOTO 50 C--CLOSE FILES THEN GET ANOTHER COMMAND 70 CLOSE (12) CLOSE (7) CLOSE (15) CLOSE (14) CLOSE (16) GOTO 5 END SUBROUTINE ASKC (PROMPT, STRING) C ASKC PROMPTS THEN READS A CHARACTER STRING FROM THE TERMINAL. C THE ORIGINAL VALUE IS UNCHANGED BY A CR RESPONSE. CHARACTER PROMPT*(*) ! PROMPT STRING CHARACTER STRING*(*) ! CHARACTER RESPONSE, OR ORIGINAL STRING ON CR. CHARACTER TEMP*80 ! SCRATCH INTEGER LENG ! FUNCTION INTEGER NCH ! NUMBER OF CHARACTERS INTEGER OUNIT ! LOGICAL UNIT FOR OUTPUT (0 FOR UNIX, 6 FOR VMS) PARAMETER (OUNIT = 6) C PARAMETER (OUNIT = 0) NCH = LENG(STRING) 10 WRITE (OUNIT, 20) PROMPT 20 FORMAT (1X, A) IF (NCH .LT. 20) THEN WRITE (OUNIT, 30) STRING(1:NCH) 30 FORMAT (' [CR = ', A, ']? ', $) ELSE WRITE (OUNIT, 40) STRING(1:NCH) 40 FORMAT (' [CR = ', A, ']?') END IF READ (5, '(A)', ERR = 10, END = 50) TEMP IF (LENG(TEMP) .GT. 0) STRING = TEMP 50 RETURN END REAL FUNCTION ASKR (PROMPT, DFLT) C ASKR PROMPTS THEN READS A REAL VALUE FROM THE TERMINAL. C THE DEFAULT VALUE IS RETURNED ON A CR RESPONSE. REAL DFLT ! DEFAULT SUPPLIED ON CARRIAGE RETURN AND DISPLAYED IN PROMPT CHARACTER PROMPT*(*) ! PROMPT STRING INTEGER I ! LOOP INDEX INTEGER J ! LOOP INDEX INTEGER LENG ! FUNCTION CHARACTER TEMP*20 ! SCRATCH INTEGER OUNIT ! LOGICAL UNIT FOR OUTPUT (0 FOR UNIX, 6 FOR VMS) PARAMETER (OUNIT = 6) WRITE (TEMP, 10) DFLT 10 FORMAT (G20.5) DO 20 I = 1, 20 IF (TEMP(I:I) .NE. ' ') GOTO 30 20 CONTINUE 30 DO 40 J = 20, 1, -1 IF (TEMP(J:J) .NE. ' ') GOTO 50 40 CONTINUE 50 WRITE (OUNIT, 60) PROMPT, TEMP(I:J) 60 FORMAT (1X, A, ' [cr = ', A, ']? ', $) READ (5, '(A)', ERR = 50, END = 70) TEMP IF (LENG(TEMP) .GT. 0) THEN READ (TEMP, *, ERR = 50) ASKR ELSE ASKR = DFLT END IF 70 RETURN END LOGICAL FUNCTION BOX2 (Y,X,Z,KLAS,NAME,FULNAM) C--DETERMINES WHETHER A POINT IS IN THE REGION NUMBER KLAS. C ONLY ONE REGION IS TESTED. FOR NET 2 (NORTHERN CALIF) C--INPUTS: C Y LATITUDE, DECIMAL DEGREES C X LONGITUDE, DECIMAL DEGREES, POSITIVE EAST C Z DEPTH, KM C KLAS REGION NUMBER TO TEST C--OUTPUTS: C BOX2 TRUE IF POINT IS IN REGION OR ON EDGE, FALSE OTHERWISE C NAME 3-LETTER NAME FOR REGION IF INSIDE C FULNAM THE FULL (25 CHAR. MAX) REGION NAME PARAMETER (NVEXS=242) !NUMBER OF VERTEX POINTS PARAMETER (NREGS=103) !NUMBER OF DEFINED REGIONS PARAMETER (NLIST=636) !NUMBER OF VERTICIES IN LIST PARAMETER (NLP1=637) !NLIST + 1 DIMENSION PX(NVEXS), PY(NVEXS) !VERTEX COORDS CHARACTER*3 NAME, NAM(NREGS) !SHORT REGION NAMES CHARACTER*25 FULNAM,FN(NREGS) !LONG REGION NAMES INTEGER JVEX(NLIST) !ORDERED LIST OF VERTICIES FOR EACH REGION C--POINTER TO FIRST VERTEX IN JVEX LIST FOR EACH REGION DIMENSION NS(NREGS+1) C--FICTITIOUS POINTER TO LAST VERTEX PLUS 1 DATA NS(NREGS+1) /NLP1/ INCLUDE 'box2.inc' C--ACCUMULATE THE SIGNED CROSSING NUMBERS WITH INSID INSID=0 C--FIRST VERTEX NUMBERS OF THIS AND NEXT REGION N1=NS(KLAS) N2=NS(KLAS+1) C--LOOP OVER POLYGON EDGES TO SEE IF -X AXIS IS CROSSED DO 20 I=N1,N2-2 C--THESE ARE THE TWO VERTEX NUMBERS FOR THIS SEGMENT J1=JVEX(I) J2=JVEX(I+1) C--CALC THE CROSSING NUMBER, TRANSLATING TEST POINT TO ORIGIN ISIC=KSIC (PX(J1)-X, PY(J1)-Y, PX(J2)-X, PY(J2)-Y) C--WE WILL SAY WE ARE IN THE REGION IF TEST POINT IS ON EDGE IF (ISIC.EQ.4) GOTO 55 20 INSID=INSID+ISIC C--CHECK THE SEGMENT FROM THE LAST BACK TO THE FIRST VERTEX J1=JVEX(N2-1) J2=JVEX(N1) ISIC=KSIC (PX(J1)-X, PY(J1)-Y, PX(J2)-X, PY(J2)-Y) IF (ISIC.EQ.4) GOTO 55 INSID=INSID+ISIC C--IF INSID=0, THE POINT IS OUTSIDE C IF INSID= +/- 1, THE POINT IS INSIDE IF (INSID.NE.0) GOTO 55 BOX2=.FALSE. RETURN C--POINT IS INSIDE BOX OR ON EDGE 55 BOX2=.TRUE. NAME=NAM(KLAS) FULNAM=FN(KLAS) RETURN END LOGICAL FUNCTION BOX2A (Y,X,Z,KLAS,NAME,FULNAM) C--DETERMINES WHETHER A POINT IS IN THE REGION NUMBER KLAS. C CALLS THE SUBROUTINE BOX2. C ONLY ONE REGION IS TESTED. FOR NET 2 (NORTH CALIF) C THE REGION NUMBER NREGS+1 IS OUTSIDE ALL OF THE NREG REGIONS. UNLIKE BOX2, C BOX2A WILL TEST THIS REGION BY EXCLUDING THE EVENT FROM ALL THE OTHER C REGIONS. C--INPUTS: C Y LATITUDE, DECIMAL DEGREES C X LONGITUDE, DECIMAL DEGREES, POSITIVE EAST C Z DEPTH, KM C KLAS REGION NUMBER TO TEST C--OUTPUTS: C BOX2A TRUE IF POINT IS IN REGION OR ON EDGE, FALSE OTHERWISE C NAME 3-LETTER NAME FOR REGION IF INSIDE C FULNAM THE FULL (25 CHAR. MAX) REGION NAME PARAMETER (NREGS=103) !NUMBER OF DEFINED REGIONS CHARACTER NAME*3, FULNAM*25 LOGICAL BOX2 IF (KLAS .GT. NREGS) THEN C--TEST ALL REGIONS. IF EVENT IS NOT IN ANY IT IS IN REGION NREGS+1 BOX2A=.FALSE. DO I=1,NREGS IF (BOX2 (Y,X,Z,I,NAME,FULNAM)) RETURN END DO BOX2A=.TRUE. NAME='DIS' FULNAM='Distant' C--THE RESULT IS THAT FOR THE SINGLE REGION ELSE BOX2A = BOX2 (Y,X,Z,KLAS,NAME,FULNAM) END IF RETURN END FUNCTION DAYJL(JY,JM,JD) C--RETURNS THE PERPETUAL JULIAN DAY RELATIVE TO JAN 1, 1960 C--FOR YEARS JY FROM 0 TO 99 (INCLUSIVE) IN THE 20TH CENTURY C--OR YEARS JY LARGER THAN 1582. C--THE JULIAN DAY ON JAN 1, 1960 AT 0H U.T. WAS 2436934.5, C--BUT THIS FUNCTION RETURNS DAYJL (60,1,1) = 0. K=JY IF (K.LT.300) K=K+1900 L=JM IF (L.GT.2) GOTO 10 K=K-1 L=L+12 10 A=365.25*(K-1960) I=.01*K B=30.6001*(L+1) DAYJL=AINT(A)+AINT(B)+(JD-I-48)+AINT(.25*I) C--CORRECT DAY IF AINT TOOK THE INTEGER PART OF A NEGATIVE NO. IF (A.LT.0.) DAYJL=DAYJL-1. RETURN END SUBROUTINE GETREC (REC, IUNIT, ISTAT) C--GETREC READS A BUFFER OF ASCII RECORDS, THE RETURNS THEM ONE AT A TIME SAVE NSIZE ! NUMBER OF RECORDS IN BUFFER (PRESENTLY 500 MAX) CHARACTER*(*) REC ! RECORD TO BE "READ" INTEGER IUNIT ! INPUT UNIT NUMBER INTEGER ISTAT ! 0 FOR NORMAL RETURN OF A RECORD C 1 END OF FILE REACHED, NO MORE RECORDS SAVE NREC DATA NREC /0/ ! CURRENT POSITION OF LAST RECORD RETURNED IN BUFFER CHARACTER*138 BUF(500) ! CHARACTER BUFFER C--READ IN A NEW BUFFER IF ITS EMPTY IF (NREC.EQ.0 .OR. NREC.EQ.NSIZE) THEN NREC=0 READ (IUNIT, END=9) NSIZE, (BUF(I),I=1,NSIZE) END IF ISTAT=0 C--GRAB THE NEXT RECORD FROM THE BUFFER NREC = NREC +1 REC = BUF(NREC) RETURN C--END OF FILE 9 ISTAT=1 RETURN END FUNCTION KLAS (NET,Y,X,Z,NAME,FULNAM) C--USED BY HYPOINVERSE TO DETERMINE THE REGION NUMBER OF A HYPOCENTER. C--INPUT: C NET -THE NETWORK NUMBER AS FOLLOWS: C 1 OLD HAWAII C 2 NORTHERN CALIFORNIA C 3 NEW HAWAII C Y -LATITUDE, DECIMAL DEGREES C X -LONGITUDE, DECIMAL DEGREES, POSITIVE EAST C Z -DEPTH IN KM C--OUTPUT: C KLAS -THE REGION NUMBER WITHIN THE NETWORK ABOVE. C NAME -THE REGION NAME OF THE HYPOCENTER (3 CHAR.) C FULNAM-THE FULL REGION NAME (25 CHAR. MAX) C--THE NUMBER OF REGIONS HERE IS THE NUMBER OF SMALLER REGIONS TO BE SEARCHED, C EXCLUDING THE REGIONS WHICH AGGLOMERATE OTHERS TOGETHER PARAMETER (NREG1=30,NREG2=98) !OF 103 REGIONS, 98 ARE TO BE SEARCHED PARAMETER (NREG3=51) LOGICAL BOX2, BOX3 EXTERNAL BOX2, BOX3 CHARACTER NAME*3,FULNAM*25 C--UNTIL THE BOX1 FUNCTION IS WRITTEN, THESE HOLD THE HAWAII REGION NAMES CHARACTER N1(NREG1)*3,FN1(NREG1)*25 DATA N1 / 2'SNC','SSC','SEC','SER','SME','KOA','SSF','SLE','SF1','SF2', 3'SF3','SF4','SF5','LER','MLO','LSW','GLN','SWR','INT','KAO', 4'DEP','DLS','DML','LOI','KON','HUA','KOH','KEA','HIL','DIS'/ DATA FN1 / 2'SHALLOW NORTH CALDERA ','SHALLOW SOUTH CALDERA ', 3'SHALLOW EAST CALDERA ','SHALLOW EAST RIFT ', 4'SHALLOW MIDDLE ERZ ','KOAE FAULT ZONE ', 5'SHALLOW SOUTH FLANK ','SHALLOW LOWER EAST RIFT ', 6'SOUTH FLANK 1 ','SOUTH FLANK 2 ', 6'SOUTH FLANK 3 ','SOUTH FLANK 4 ', 7'SOUTH FLANK 5 ','LOWER EAST RIFT ', 8'MAUNA LOA SUMMIT ','LOWER SOUTHWEST RIFT ', 8'GLENWOOD ','SOUTHWEST RIFT ', 9'INTERMED. DEPTH CALDERA ','KAOIKI ', 9'DEEP KILAUEA ','DEEP LOWER SOUTHWEST RIFT', 1'DEEP MAUNA LOA ','LOIHI ', 1'KONA ','HUALALAI ', 2'KOHALA ','MAUNA KEA ', 3'HILO ','DISTANT '/ C--THIS IS THE ORDERED SEARCH LIST FOR THE N. CALIF (NET 2) REGIONS C DONT SEARCH REGIONS 63, 64, 66, 67, 68 BECAUSE THEY AGGLOMERATE OTHER REGIONS DIMENSION ISRCH2(NREG2) DATA ISRCH2 / 1 8, 7, 12, 43, 11, 4, 22, 23, 24, 21, 2 31, 90, 96, 98, 79, 25, 9, 5, 10, 6, 3 13, 14, 26, 19, 16, 18, 27, 17, 20, 29, 4 28, 30, 15, 2, 1, 3, 48, 42, 46, 45, 5 39, 37, 38, 36, 35, 34, 49, 44, 47, 41, 6 57, 58, 56, 62, 93, 92, 50, 52, 51, 33, 7 32, 59, 60, 61, 65, 53, 55, 54, 40, 72, 8 73, 69, 70, 71, 74, 75, 76, 77, 78, 80, 9 81, 82, 83, 84, 85, 86, 87, 88, 89, 91, 9 94, 95, 97, 99,100,101,102,103/ C--THIS IS THE SEARCH LIST FOR NEW HAWAII REGIONS DIMENSION ISRCH3(NREG3) DATA ISRCH3 / 1 27, 28, 29, 15, 5, 2, 3, 26, 16, 9, 2 10, 30, 1, 6, 7, 25, 35, 11, 31, 8, 3 14, 32, 4, 36, 44, 12, 13, 24, 33, 34, 4 23, 17, 18, 19, 51, 21, 22, 20, 38, 39, 5 37, 42, 40, 43, 41, 50, 45, 46, 47, 48, 6 49/ C--USE THE APPROPRIATE CODE FOR EACH NET GOTO (100, 200, 300), NET C--NET IS UNDEFINED KLAS=0 NAME=' ' RETURN C****************** HAWAII NETWORK (1) ******************************* C USE OLD KLASS SUBROUTINE FOR NOW, REPLACE WITH BOX1 ROUTINE LATER. 100 K=KLASS (1,Y,X,Z) KLAS=K NAME=N1(K) FULNAM=FN1(K) RETURN C********************* NO. CALIFORNIA NETWORK (2) *********************** C--TEST EACH REGION UNTIL THE RIGHT ONE IS FOUND C--SEARCH REGIONS IN THE ORDER GIVEN BY ISRCH2 200 DO 220 I=1,NREG2 K=ISRCH2(I) KLAS=K IF (BOX2(Y,X,Z,K,NAME,FULNAM)) RETURN 220 CONTINUE C--POINT IS OUTSIDE ALL REGIONS KLAS=NREG2+1 NAME='DIS' FULNAM='Distant' RETURN C********************* NEW HAWAII NETWORK (3) *********************** C--TEST EACH REGION UNTIL THE RIGHT ONE IS FOUND C--SEARCH REGIONS IN THE ORDER GIVEN BY ISRCH3 300 DO 320 I=1,NREG3 K=ISRCH3(I) KLAS=K IF (BOX3(Y,X,Z,K,NAME,FULNAM)) RETURN 320 CONTINUE C--POINT IS OUTSIDE ALL REGIONS KLAS=NREG3+1 NAME='DIS' FULNAM='Distant' RETURN END FUNCTION KLASS (NET,Y,X,Z) C--ASSIGNS AN INTEGER CODE TO A HYPOCENTER BASED ON LOCATION & DEPTH. C C--ARGUMENTS: C NET=NETWORK NUMBER C NET=1 FOR HAWAII C Y=LAT IN DEG (POS NORTH) C X=LON IN DEG (POS EAST, NEG WEST) C Z=DEPTH IN KM C C---------------------------------------------------------- C************* NETWORK 1 = HAWAII ***************** C--ALL EARTHQUAKES ARE IN ONE OF THE FOLLOWING GROUPS, C--IDENTIFIED BY A NUMERICAL CLASS OR 3-LETTER CODE: C C--SHALLOW: C 1 SNC - SHALLOW NORTH CALDERA (0-5 KM) C 2 SSC - SHALLOW SOUTH CALDERA (0-5 KM) C 3 SEC - SHALLOW EAST CALDERA (0-5 KM) C 4 SER - SHALLOW EAST RIFT (0-5 KM) C 5 SME - SHALLOW MIDDLE EAST RIFT (0-5 KM) C 6 KOA - KOAE FAULT ZONE (0-5 KM) C 7 SSF - SHALLOW SOUTH FLANK (0-5 KM) C 8 SLE - SHALLOW LOWER EAST RIFT (0-5 KM) C C--INTERMEDIATE DEPTH: C 9 SF1 - KILAUEA SOUTH FLANK (5-13 KM) (WEST END) C 10 SF2 - KILAUEA SOUTH FLANK (5-13 KM) C 11 SF3 - KILAUEA SOUTH FLANK (5-13 KM) C 12 SF4 - KILAUEA SOUTH FLANK (5-13 KM) C 13 SF5 - KILAUEA SOUTH FLANK (5-13 KM) (EAST END) C 14 LER - LOWER EAST RIFT (5-99 KM) C 15 MLO - MAUNA LOA (0-13 KM) C 16 LSW - LOWER SW RIFTS OF KILAUEA & MAUNA LOA (0-13 KM) C 17 GLN - GLENWOOD (0-13 KM) C 18 SWR - SW RIFT (0-13 KM) C 19 INT - INTERMEDIATE CALDERA (5-13 KM) C 20 KAO - KAOIKI (0-13 KM) C C--DEEP: C 21 DEP - DEEP KILAUEA (>13 KM) (BELOW REGIONS 1-13,17-19) C 22 DLS - DEEP LOWER SW RIFT (>13 KM) (BELOW REGION 16) C 23 DML - DEEP MAUNA LOA (>13 KM) (BELOW REGIONS 15,20) C C--OUTER REGIONS, ALL DEPTHS: C 24 LOI - LOIHI (ALL DEPTHS) C 25 KON - SOUTH KONA (ALL DEPTHS) C 26 HUA - HUALALAI (ALL DEPTHS) C 27 KOH - KOHALA (ALL DEPTHS) C 28 KEA - MAUNA KEA (ALL DEPTHS) C 29 HIL - HILO (ALL DEPTHS) C 30 DIS - DISTANT, EVERYWHERE ELSE C C--------------------------------------------------------- C--THE LATITUDE AND LONGITUDE LIMITS OF THE REGIONS ARE GIVEN BELOW. C--WHEN THE COORDINATES IMPLY AN OVERLAP, PRECEDENCE IS GIVEN AS IN THE MAPS. C C NO. CODE N.LAT. S.LAT. W.LON. E.LON. C 1 SNC 19 28 19 24.5 155 19 155 14 C 2 SSC 19 24.5 19 22 155 19 155 16.5 C 3 SEC 19 24.5 19 22 155 16.5 155 14 C 4 SER 19 26 19 20.5 155 14 155 07.2 C 5 SME 19 26 ----- 155 07.2 155 00 C 6 KOA 19 22 19 20.5 155 17 155 14 C 7 SSF ----- 19 10 155 17 155 00 C 8 SLE 19 32 19 16 155 00 154 40 C 9 SF1 19 22 19 10 155 17 155 14.5 C 10 SF2 19 26 19 10 155 14.5 155 12.3 C 11 SF3 19 26 19 10 155 12.3 155 09.1 C 12 SF4 19 26 19 10 155 09.1 155 05.3 C 13 SF5 19 26 19 10 155 05.3 155 00 C 14 LER 19 32 19 16 155 00 154 40 C 15 MLO 19 43 19 19 155 35 155 19 C 16 LSW 19 19 18 40 155 43 155 25 C 17 GLN 19 43 19 26 155 19 155 00 C 18 SWR 19 22 19 10 155 25 155 17 C 19 INT 19 28 19 22 155 19 155 14 C 20 KAO 19 30 19 19 155 32 155 19 C 21 DEP 19 43 19 10 155 25 155 00 C 22 DLS 19 19 18 40 155 43 155 25 C 23 DML 19 43 19 19 155 35 155 19 C 24 LOI 19 10 18 40 155 25 155 00 C 25 KON 19 39 19 00 156 20 155 43 C 26 HUA 19 55 19 39 156 20 155 43 C 27 KOH 20 25 19 55 156 20 155 34 C 28 KEA 20 25 19 43 155 43 154 40 C 29 HIL 19 47 19 32 155 09 154 40 C--------------------------------------------------- C C********** HAWAII ************ C IF (Y.GT.19.467 .OR. Y.LT.19.367 .OR. X.GT.-155.233 2 .OR. X.LT.-155.317) GO TO 10 C--KILAUEA CALDERA C--DEP KLASS=21 IF (Z.GT.13.) RETURN C--INT KLASS=19 IF (Z.GT.5.) RETURN C--SNC KLASS=1 IF (Y.GT.19.409) RETURN C--SSC KLASS=2 IF (X.LT.-155.275) RETURN C--SEC KLASS=3 RETURN C---------------------------------------------------------- 10 IF (Y.GT.19.433 .OR. Y.LT.19.167 .OR. X.GT.-155. 2 .OR. X.LT.-155.283) GO TO 30 C--EAST RIFT OR SOUTH FLANK C--DEP KLASS=21 IF (Z.GT.13.) RETURN IF (Z.GT.5.) GO TO 20 C--SHALLOW EAST RIFT C--SSF KLASS=7 IF (Y.LT.19.342 .OR. Y.LT.70.1+.3271*X) RETURN C--KOA KLASS=6 IF (X.LT.-155.233) RETURN C--SER KLASS=4 IF (X.LT.-155.12) RETURN C--SME KLASS=5 RETURN C------------------------------------------------------ C--SOUTH FLANK C--SF1 20 KLASS=9 IF (X.LT.-155.242) RETURN C--SF2 KLASS=10 IF (X.LT.-155.205) RETURN C--SF3 KLASS=11 IF (X.LT.-155.152) RETURN C--SF4 KLASS=12 IF (X.LT.-155.088) RETURN C--SF5 KLASS=13 RETURN C----------------------------------------------------- C--OUTER REGIONS WITH DEPTH DISCRIMINATION C 30 IF (X.LT.-155.417 .OR. X.GT.-155.283 .OR. Y.GT.19.367 2 .OR. Y.LT.19.167) GO TO 35 C--SWR KLASS=18 IF (Z.LT.13.) RETURN C--DEP KLASS=21 RETURN C 35 IF (Y.GT.19.5 .OR. Y.LT.19.317 .OR. X.GT.-155.317 2 .OR. X.LT.-155.533) GO TO 40 C--KAO KLASS=20 IF (Z.LT.13.) RETURN C--DML KLASS=23 RETURN C 40 IF (Y.GT.19.533 .OR. Y.LT.19.267 .OR. X.GT.-154.667 2 .OR. X.LT.-155.) GO TO 45 C--SLE KLASS=8 IF (Z.LT.5.) RETURN C--LER KLASS=14 RETURN C 45 IF (Y.GT.19.317 .OR. Y.LT.18.667 .OR. X.GT.-155.417 2 .OR. X.LT.-155.717) GO TO 50 C--LSW KLASS=16 IF (Z.LT.13.) RETURN C--DLS KLASS=22 RETURN C 50 IF (X.LT.-155.717 .OR. X.GT.-155.317 .OR. Y.LT.19.317 2 .OR. Y.GT.19.583) GO TO 55 C--MLO KLASS=15 IF (Z.LT.13.) RETURN C--DML KLASS=23 RETURN C--------------------------------------------------------- C--TESTS FOR OUTER REGIONS INCLUDING ALL DEPTHS C--KON 55 KLASS=25 IF (Y.LT.19.650 .AND. Y.GT.19. .AND. X.GT.-156.333 2 .AND. X.LT.-155.717) RETURN C--HUA KLASS=26 IF (Y.LT.19.917 .AND. Y.GT.19.650 .AND. X.GT.-156.333 2 .AND. X.LT.-155.717) RETURN C--KOH KLASS=27 IF (Y.LT.20.417 .AND. Y.GT.19.917 .AND. X.GT.-156.333 2 .AND. X.LT.-155.567) RETURN C--LOI KLASS=24 IF (Y.LT.19.167 .AND. Y.GT.18.667 .AND. X.GT.-155.417 2 .AND. X.LT.-155.) RETURN C--HIL KLASS=29 IF (Y.LT.19.783 .AND. Y.GT.19.533 .AND. X.GT.-155.15 2 .AND. X.LT.-154.667) RETURN C IF (Y.GT.19.583 .OR. Y.LT.19.43 .OR. X.LT.-155.317 2 .OR. X.GT.-155.) GO TO 60 C--GLN KLASS=17 IF (Z.LT.13.) RETURN C--DEP KLASS=21 RETURN C--KEA 60 KLASS=28 IF (Y.LT.20.417 .AND. Y.GT.19.583 .AND. X.GT.-155.717 2 .AND. X.LT.-154.667) RETURN C--DIS, EVERYTHING ELSE KLASS=30 RETURN END C******************************** KSIC ******************************* FUNCTION KSIC (X1,Y1,X2,Y2) C--COMPUTES THE SIGNED CROSSING NUMBER FOR THE KLAS FUNCTION C--IF BOTH POINTS ARE ON THE SAME SIDE OF THE X AXIS, RETURN 0 IF (Y1*Y2 .GT. 0.) GOTO 60 S=X1*Y2-X2*Y1 C--CHECK IF SEGMENT CROSSES THRU ORIGIN IF (S.EQ.0. .AND. X1*X2 .LE. 0.) THEN KSIC=4 RETURN END IF C--CHECK FOR COMPLETE CROSSING IF (Y1*Y2 .LT. 0.) GOTO 30 C--ONE END OF SEGMENT TOUCHES X AXIS - WHICH END? IF (Y2.EQ.0.) GOTO 20 C--SINCE Y1=0, CHECK IF SEGMENT TOUCHES +X AXIS IF (X1.GT.0.) GOTO 60 C--UPWARD OR DOWNWARD? IF (Y2.GT.0.) GOTO 70 GOTO 80 C--SINCE Y2=0, CHECK IF SEGMENT TOUCHES +X AXIS 20 IF (Y1.EQ.0. .OR. X2.GT.0.) GOTO 60 C--UPWARD OR DOWNWARD? IF (Y1.GT.0.) GOTO 80 GOTO 70 C--COMPLETE CROSSING OF -X AXIS? BREAK INTO CASES ACCORDING TO DIRECTION 30 IF (Y1.GT.0.) GOTO 40 C--HERE IS THE CASE OF Y1 < 0 < Y2 IF (S.GE.0.) GOTO 60 C--WE HAVE AN UPWARD CROSSING KSIC=2 RETURN C--HERE IS THE CASE OF Y1 > 0 > Y2 40 IF (S.LE.0.) GOTO 60 C--WE HAVE A DOWNWARD CROSSING KSIC=-2 RETURN C--THERE IS NO CROSSING 60 KSIC=0 RETURN C--THERE IS AN UPWARD HALF CROSSING 70 KSIC=1 RETURN C--THERE IS A DOWNWARD HALF CROSSING 80 KSIC=-1 RETURN END SUBROUTINE OPENR (IUNIT,FIL,FOR,IOS) C--OPEN A FILE FOR READING ON THE SUN OR THE VAX (SAME SUBROUTINE). C--THE FILE MUST EXIST TO AVOID AN ERROR. C--THE ARGUMENTS ARE: C IUNIT UNIT NUMBER (INTEGER) C FIL CHAR STRING CONTAINING FILENAME C FOR CHAR STRING FOR THE FORM SPECIFIER: C 'F' OR 'FORMATTED' ASCII FILE TO READ FORMATTED C 'U' OR 'UNFORMATTED' BINARY FILE TO READ UNFORMATTED C IOS ERROR RETURN: C 0 OPEN WAS OK C >0 AN ERROR OCCURRED CHARACTER FIL*(*), FOR*(*), FSTR*11 INTEGER IUNIT,IOS FSTR='formatted' IF (FOR(1:1).EQ.'u' .OR. FOR(1:1).EQ.'U') FSTR='unformatted' C--VAX VERSION C OPEN (IUNIT,FILE=FIL,FORM=FSTR,IOSTAT=IOS,STATUS='OLD', C 2 BLANK='ZERO', SHARED, READONLY, RECL=256) C--SUN & OS2 VERSION OPEN (IUNIT,FILE=FIL,FORM=FSTR,IOSTAT=IOS,STATUS='OLD', 2 BLANK='ZERO') RETURN END SUBROUTINE OPENW (IUNIT,FIL,FOR,IOS,ACC) C--OPEN A FILE FOR WRITING C--THE ARGUMENTS ARE: C IUNIT UNIT NUMBER (INTEGER) C FIL CHAR STRING CONTAINING FILENAME C FOR CHAR STRING FOR THE FORM SPECIFIER: C 'F' OR 'FORMATTED' ASCII FILE TO READ FORMATTED C 'U' OR 'UNFORMATTED' BINARY FILE TO READ UNFORMATTED C 'P' OR 'PRINT' ASCII FILE TO WRITE WITH CARRIAGECONTROL C CHARACTER C IOS ERROR RETURN: C 0 OPEN WAS OK C >0 AND ERROR OCCURRED C ACC ACCESS SPECIFIER C 'S' OR 'SEQUENTIAL' NORMAL ACCESS, WRITE FROM BEGINNING OF FILE C 'A' OR 'APPEND' WRITE AT END OF FILE IF IT EXISTS CHARACTER FIL*(*), FOR*(*), ACC*(*), FSTR*12, ASTR*11 C CHARACTER CC*9 INTEGER IUNIT,IOS FSTR='formatted ' IF (FOR(1:1).EQ.'u' .or. FOR(1:1).EQ.'U') FSTR='unformatted ' C--SUN & OS2 IF (FOR(1:1).EQ.'p' .or. FOR(1:1).EQ.'P') FSTR='print ' C--VAX C CC='list ' C IF (FOR(1:1).EQ.'p' .OR. FOR(1:1).EQ.'P') CC='FORTRAN ' ASTR='sequential ' IF (ACC(1:1).EQ.'a' .OR. ACC(1:1).EQ.'A') ASTR='append ' C--SUN OPEN (IUNIT,FILE=FIL, FORM=FSTR, IOSTAT=IOS, STATUS='unknown', 2 ACCESS=ASTR) C--OS2 C OPEN (IUNIT,FILE=FIL, FORM=FSTR, IOSTAT=IOS, STATUS='UNKNOWN', C 2 ACCESS=ASTR) C--VAX C OPEN (IUNIT,FILE=FIL, FORM=FSTR, IOSTAT=IOS, STATUS='NEW', C 2 ACCESS=ASTR, CARRIAGECONTROL=CC, RECL=256) RETURN END INTEGER FUNCTION JASK (PROMPT, IDFLT) C C JASK PROMPTS THEN READS AN INTEGER VALUE FROM THE TERMINAL. C THE DEFAULT VALUE IS RETURNED ON A CR RESPONSE. C IDFLT IS DEFAULT SUPPLIED ON CARRIAGE RETURN AND DISPLAYED IN PROMPT INTEGER IDFLT CHARACTER PROMPT*(*) ! PROMPT STRING CHARACTER TEMP*20 ! SCRATCH INTEGER I ! LOOP INDEX INTEGER LENG ! FUNCTION INTEGER OUNIT ! LOGICAL UNIT FOR OUTPUT (0 FOR UNIX, 6 FOR VMS) PARAMETER (OUNIT = 6) WRITE (TEMP, 10) IDFLT 10 FORMAT (I20) DO 20 I = 1, 20 IF (TEMP(I:I) .NE. ' ') GOTO 30 20 CONTINUE 30 WRITE (OUNIT, 40) PROMPT, TEMP(I:20) 40 FORMAT (1X, A, ' [cr = ', A, ']? ', $) READ (5, '(A)', ERR = 30, END = 50) TEMP IF (LENG(TEMP) .GT. 0) THEN READ (TEMP, *, ERR = 30) JASK ELSE JASK = IDFLT END IF 50 RETURN END SUBROUTINE JDATE (W,JY,JM,JD,JH,JN) C--FOR THE PERPETUAL JULIAN DAY D (DBL PREC) RELATIVE TO JAN 1, 1960, C--JDATE RETURNS THE DATE AND TIME AS 5 INTEGERS. C--THE YEAR IS 4 DIGITS. C--THE JULIAN DAY CAN BE CALCULATED FROM A DATE BY THE ROUTINE DAYJL. DOUBLE PRECISION D,E,F,T,A,B,C,W D=W+1.D0 !THIS MOD SEEMS TO BE NECESSARY E=DINT(D) IF (D.LT.0.D0) E=E-1.D0 F=D-E T=E/365.25D0+.8355D0 A=DINT(T) IF (T.LT.0.D0) A=A-1.D0 T=365.25D0*A+.75D0 B=DINT(T) IF (T.LT.0.D0) B=B-1.D0 C=DINT((E-B+428.D0)/30.6001D0) JD=E-B+428.1D0-DINT(30.6001D0*C) C JD=E-B+429.1D0-DINT(30.6001D0*C) JM=C-.9D0 IF (JM.GT.12) JM=JM-12 JY=A+59.1D0 IF (JM.LT.3) JY=JY+1 jy=jy+1900 JH=24.D0*F+.001D0 JN=1440.D0*(F-JH/24.D0) IF (JH.LT.24) RETURN JH=JH-24 JD=JD+1 RETURN END LOGICAL FUNCTION ISITIN (NET,Y,X,Z,KLAS) C--USED BY QPLOT & SELECT TO DETERMINE IF A HYPOCENTER IS IN A REGION C--INPUT: C NET -THE NETWORK NUMBER AS FOLLOWS: C 1 HAWAII C 2 NORTHERN CALIFORNIA C 3 NEW HAWAII C Y -LATITUDE, DECIMAL DEGREES C X -LONGITUDE, DECIMAL DEGREES, POSITIVE EAST C Z -DEPTH IN KM C KLAS -THE REGION NUMBER WITHIN THE NETWORK ABOVE. C--OUTPUT: C ISITIN TRUE WHEN EVENT IS IN THE REGION KLAS LOGICAL BOX2, BOX3A CHARACTER NAME*3,FULNAM*25 C--USE THE APPROPRIATE CODE FOR EACH NET GOTO (100, 200, 300), NET C--NET IS UNDEFINED ISITIN=.FALSE. RETURN C****************** HAWAII NETWORK (1) ******************************* C USE OLD KLASS SUBROUTINE FOR NOW, REPLACE WITH BOX1 ROUTINE LATER. 100 ISITIN=KLAS .EQ. KLASS(1,Y,X,Z) RETURN C********************* NO. CALIFORNIA NETWORK (2) *********************** 200 IF (KLAS.EQ.104) THEN DO I=1,103 IF (BOX2 (Y,X,Z,I,NAME,FULNAM)) THEN ISITIN=.FALSE. RETURN END IF END DO ELSE ISITIN = BOX2 (Y,X,Z,KLAS,NAME,FULNAM) END IF RETURN C********************* NEW HAWAII NETWORK (3) *********************** C--BOX3A HANDLES THE CASE OF ANY REGION, INCLUDING DISTANT (OUTSIDE C ALL DEFINED REGIONS). 300 ISITIN = BOX3A (Y,X,Z,KLAS,NAME,FULNAM) RETURN END LOGICAL FUNCTION LASK (PROMPT,LDFLT) C--LASK PROMPTS USING THE STRING "PROMPT", THEN READS A LOGICAL VALUE C--FROM THE TERMINAL. THE DEFAULT VALUE LDFLT IS RETURNED ON A CR RESPONSE. C LASK= LOGICAL RESPONSE. C PROMPT= PROMPT STRING. CHARACTER PROMPT*(*), TEMP*20 LOGICAL LDFLT 5 WRITE (6,1001) PROMPT,LDFLT 1001 FORMAT (1X,A,' [t or f, cr=',l1,']? ',$) READ (5,'(A)',ERR=5,END=9) TEMP IF (LENG(TEMP).GT.0) THEN READ (TEMP,*,ERR=5) LASK ELSE LASK=LDFLT END IF 9 RETURN END INTEGER FUNCTION LENG (STRING) C C THE NON-BLANK LENGTH OF STRING WHOSE PHYSICAL LENGTH IS MAXLEN C (RETURNS THE POSITION OF THE LAST NON-BLANK CHARACTER) C CHARACTER STRING*(*) ! STRING C INTEGER I ! CHARACTER POSITION INTEGER MAXLEN ! LENGTH OF STRING MAXLEN = LEN(STRING) DO 10 I = MAXLEN,1,-1 IF (STRING(I:I) .NE. ' ') GOTO 20 10 CONTINUE I = 0 20 LENG = I RETURN END subroutine putrec (nsize, rec, ounit, istat) c subroutine putrec (nsize, rec, ounit, istat, lwrit) c--Putrec collects ASCII records in a buffer, then writes them out when the c buffer is full. integer nsize c max number of records in buffer (presently 500) character*(*) rec c record to be "written" integer ounit c output unit number integer istat c -1 to initialize buffer c 0 to grab a record c 1 to write final buffer, dont add a new record c logical lwrit c t if this call wrote out the buffer save nrec c total number of lines in buffer character*138 buf(500) c character buffer c--Initialize (clear) buffer if (istat.lt.0) then if (nsize.gt.500) then print *,' Max size of record buffer is 500' stop end if nrec = 0 c lwrit = .false. return end if c--Write out last buffer if (istat.gt.0) then write (ounit) nrec, (buf(i),i=1,nrec) c lwrit = .true. return end if c--Accumulate the record in the buffer nrec = nrec +1 buf(nrec) = rec c lwrit = .false. c--Write buffer out if its full if (nrec.eq.nsize) then write (ounit) nrec, (buf(i),i=1,nrec) c lwrit = .true. nrec = 0 end if return end subroutine putrec2 (nsize, rec, ounit, istat) c--Putrec collects ASCII records in a buffer, then writes them out when the c buffer is full. integer nsize c max number of records in buffer (presently 500) character*(*) rec c record to be "written" integer ounit c output unit number integer istat c -1 to initialize buffer c 0 to grab a record c 1 to write final buffer, dont add a new record c logical lwrit c t if this call wrote out the buffer save nrec c total number of lines in buffer character*138 buf(500) c character buffer c--Initialize (clear) buffer if (istat.lt.0) then if (nsize.gt.500) then print *,' Max size of record buffer is 500' stop end if nrec = 0 c lwrit = .false. return end if c--Write out last buffer if (istat.gt.0) then write (ounit) nrec, (buf(i),i=1,nrec) c lwrit = .true. return end if c--Accumulate the record in the buffer nrec = nrec +1 buf(nrec) = rec c lwrit = .false. c--Write buffer out if its full if (nrec.eq.nsize) then write (ounit) nrec, (buf(i),i=1,nrec) c lwrit = .true. nrec = 0 end if return end SUBROUTINE UPSTR (STR, LEN) C C UPSTR CONVERTS THE CHARACTER STRING STR TO UPPER CASE. C LEN IS THE NUMBER OF CHARACTERS TO CONVERT, NOT TO EXCEED THE C ACTUAL LENGTH OF STR. C C AUTHOR: FRED KLEIN (U.S.G.S) C CHARACTER STR*(*) INTEGER I INTEGER J INTEGER LEN DO I = 1, LEN J = ICHAR(STR(I:I)) IF (J .GT. 96 .AND. J .LT. 123) STR(I:I) = CHAR(J - 32) END DO RETURN END SUBROUTINE IOFL C--PROMPTS FOR AND OPENS AN INPUT (UNIT 2) AND OUTPUT (UNIT 3) FILE C--NO CARRIAGE CONTROL CHARACTER IS EXPECTED ON OUTPUT. CHARACTER IFL*80 WRITE (6,1000) 1000 FORMAT (' INPUT FILENAME? ',$) READ (5,1001) IFL 1001 FORMAT (A) call openr (2,ifl,'f',ios) if (ios.ne.0) then print *,'*** Error: cant open input file' stop end if WRITE (6,1002) 1002 FORMAT (' OUTPUT FILENAME? ',$) READ (5,1001) IFL call openw (3,ifl,'f',ios,'s') if (ios.ne.0) then print *,'*** Error: cant open output file' stop end if RETURN END SUBROUTINE IFL C--PROMPTS FOR AND OPENS AN INPUT FILE AS UNIT 2. CHARACTER INFL*80 WRITE (6,1000) 1000 FORMAT (' INPUT FILENAME? ',$) READ (5,1001) INFL 1001 FORMAT (A) call openr (2,infl, 'f',ios) if (ios.ne.0) then print *,'*** Error: cant open input file' stop end if RETURN END SUBROUTINE OFL C--PROMPTS FOR AND OPENS AN OUTPUT FILE AS UNIT 3. C--NO CARRIAGE CONTROL CHARACTER IS EXPECTED ON OUTPUT. CHARACTER IFL*80 WRITE (6,1000) 1000 FORMAT (' OUTPUT FILENAME? ',$) READ (5,1001) IFL 1001 FORMAT (A) call openw (3,ifl,'f',ios,'s') if (ios.ne.0) then print *,'*** Error: cant open output file' stop end if RETURN END SUBROUTINE SPAWN (MESS) C--SPAWN A SUBPROCESS OR ISSUE A SYSTEM COMMAND FROM WITHIN A PROGRAM CHARACTER MESS*(*) C--VAX: C CALL LIB$SPAWN (MESS) C--SUN: I = SYSTEM (MESS) WRITE (*,*) I C--OS2: C INCLUDE 'FSUBLIB.FI' C I = FSYSTEM (MESS) C WRITE (*,*) I RETURN END SUBROUTINE ERRSET (I,L1,L2,L3,L4) C--DUMMY ROUTINE SO SUN AND VAX SOURCE CODE ARE IDENTICAL C--TAKES PLACE OF VAX ERROR CONTROL ROUTINE SO OVERFLOW CONDITION ON C OUTPUT FIELDS DOESN'T GENERATE AN ERROR MESSAGE LOGICAL L1,L2,L3,L4 RETURN END LOGICAL FUNCTION BOX3 (Y,X,Z,KLAS,NAME,FULNAM) C--DETERMINES WHETHER A POINT IS IN THE REGION NUMBER KLAS. C CALLED BY THE SUBROUTINE BOX3A. C ONLY ONE REGION IS TESTED. FOR NET 3 (New Hawaii) C THE REGION NUMBER NREGS+1 IS OUTSIDE ALL OF THE NREG REGIONS. UNLIKE BOX3, C BOX3A WILL TEST THIS REGION BY EXCLUDING THE EVENT FROM ALL THE OTHER C REGIONS. C--INPUTS: C Y LATITUDE, DECIMAL DEGREES C X LONGITUDE, DECIMAL DEGREES, POSITIVE EAST C Z DEPTH, KM C KLAS REGION NUMBER TO TEST C--OUTPUTS: C BOX3 TRUE IF POINT IS IN REGION OR ON EDGE, FALSE OTHERWISE C NAME 3-LETTER NAME FOR REGION IF INSIDE C FULNAM THE FULL (25 CHAR. MAX) REGION NAME PARAMETER (NVEXS=82) !NUMBER OF VERTEX POINTS PARAMETER (NREGS=65) !NUMBER OF DEFINED REGIONS, ALSO BOX3A PARAMETER (NLIST=389) !NUMBER OF VERTICIES IN LIST PARAMETER (NLP1=390) !NLIST + 1 DIMENSION PX(NVEXS), PY(NVEXS) !VERTEX COORDS CHARACTER*3 NAME, NAM(NREGS) !SHORT REGION NAMES CHARACTER*25 FULNAM,FN(NREGS) !LONG REGION NAMES INTEGER JVEX(NLIST) !ORDERED LIST OF VERTICIES FOR EACH REGION C--POINTER TO FIRST VERTEX IN JVEX LIST FOR EACH REGION DIMENSION NS(NREGS+1) C--FICTITIOUS POINTER TO LAST VERTEX PLUS 1 DATA NS(NREGS+1) /NLP1/ INCLUDE 'box3.inc' BOX3=.FALSE. C--TEST WHETHER REGION IS ALLOWED FOR THIS DEPTH RANGE C--0-4.5 IF (Z.LT.4.5) THEN IF ((KLAS.GE.25 .AND. KLAS.LE.50) .OR. KLAS.GE.61) RETURN C--4.5-14 ELSE IF (Z.GE.4.5 .AND. Z.LT.14.) THEN IF ((KLAS.LE.14) .OR. KLAS.EQ.23 .OR. 2 (KLAS.GE.36 .AND. KLAS.LE.50) .OR. KLAS.GE.61) RETURN C--14-20 ELSE IF (Z.GE.14. .AND. Z.LT.20) THEN IF (KLAS.LE.23 .OR. (KLAS.GE.25 .AND. KLAS.LE.43) .OR. 2 KLAS.EQ.51 .OR. KLAS.EQ.52 .OR. KLAS.GE.61) RETURN C--20-70 ELSE IF (Z.GE.20.) THEN IF (KLAS.LE.35 .OR. (KLAS.GE.44 .AND. KLAS.LE.56) .OR. 2 KLAS.EQ.58 .OR. KLAS.EQ.59) RETURN END IF C--ACCUMULATE THE SIGNED CROSSING NUMBERS WITH INSID INSID=0 C--FIRST VERTEX NUMBERS OF THIS AND NEXT REGION N1=NS(KLAS) N2=NS(KLAS+1) C--LOOP OVER POLYGON EDGES TO SEE IF -X AXIS IS CROSSED DO 20 I=N1,N2-2 C--THESE ARE THE TWO VERTEX NUMBERS FOR THIS SEGMENT J1=JVEX(I) J2=JVEX(I+1) C--CALC THE CROSSING NUMBER, TRANSLATING TEST POINT TO ORIGIN ISIC=KSIC (PX(J1)-X, PY(J1)-Y, PX(J2)-X, PY(J2)-Y) C--WE WILL SAY WE ARE IN THE REGION IF TEST POINT IS ON EDGE IF (ISIC.EQ.4) GOTO 55 20 INSID=INSID+ISIC C--CHECK THE SEGMENT FROM THE LAST BACK TO THE FIRST VERTEX J1=JVEX(N2-1) J2=JVEX(N1) ISIC=KSIC (PX(J1)-X, PY(J1)-Y, PX(J2)-X, PY(J2)-Y) IF (ISIC.EQ.4) GOTO 55 INSID=INSID+ISIC C--IF INSID=0, THE POINT IS OUTSIDE C IF INSID= +/- 1, THE POINT IS INSIDE IF (INSID.NE.0) GOTO 55 BOX3=.FALSE. RETURN C--POINT IS INSIDE BOX OR ON EDGE 55 BOX3=.TRUE. NAME=NAM(KLAS) FULNAM=FN(KLAS) RETURN END LOGICAL FUNCTION BOX3A (Y,X,Z,KLAS,NAME,FULNAM) C--DETERMINES WHETHER A POINT IS IN THE REGION NUMBER KLAS. C CALLS THE SUBROUTINE BOX3. C ONLY ONE REGION IS TESTED. FOR NET 3 (New Hawaii) C THE REGION NUMBER NREGS+1 IS OUTSIDE ALL OF THE NREG REGIONS. UNLIKE BOX3, C BOX3A WILL TEST THIS REGION BY EXCLUDING THE EVENT FROM ALL THE OTHER C REGIONS. C--INPUTS: C Y LATITUDE, DECIMAL DEGREES C X LONGITUDE, DECIMAL DEGREES, POSITIVE EAST C Z DEPTH, KM C KLAS REGION NUMBER TO TEST C--OUTPUTS: C BOX3A TRUE IF POINT IS IN REGION OR ON EDGE, FALSE OTHERWISE C NAME 3-LETTER NAME FOR REGION IF INSIDE C FULNAM THE FULL (25 CHAR. MAX) REGION NAME PARAMETER (NREGS=65) !NUMBER OF DEFINED REGIONS CHARACTER NAME*3, FULNAM*25 LOGICAL BOX3 IF (KLAS .GT. NREGS) THEN C--TEST ALL REGIONS. IF EVENT IS NOT IN ANY IT IS IN REGION NREGS+1 BOX3A=.FALSE. DO I=1,NREGS IF (BOX3 (Y,X,Z,I,NAME,FULNAM)) RETURN END DO BOX3A=.TRUE. NAME='DIS' FULNAM='Distant' C--THE RESULT IS THAT FOR THE SINGLE REGION ELSE BOX3A = BOX3 (Y,X,Z,KLAS,NAME,FULNAM) END IF RETURN END SUBROUTINE READQ (IUNIT,STRING,LEN,IOS) C--READS A STRING FROM AN EXTERNAL FILE, ALSO TELLING HOW LONG THE RECORD IS. C--THIS IS SOMEWHAT SYSTEM DEPENDENT BECAUSE NOT ALL COMPILERS HAVE Q FORMATS. C--INPUT: C IUNIT -LOGICAL UNIT TO READ C--RETURNS: C STRING -ASCII CHARACTER STRING READ C LEN -LENGTH OF RECORD (OR ITS NON-BLANK LENGTH IF THAT IS ALL WE KNOW) C IOS 0 IF A NORMAL READ OCCURRED C 1 IF AN ERROR OR END-OF-FILE OCCURRED CHARACTER STRING*(*) IOS=0 C--VAX AND SUNS C READ (IUNIT,'(Q,A)',ERR=9,END=9) LEN,STRING C RETURN C--OS2 AND G77 READ (IUNIT,'(A)',ERR=9,END=9) STRING LEN=LENG(STRING) RETURN C--ERROR OR EOF 9 IOS=1 RETURN END SUBROUTINE DOWNSTR (STR, LEN) C C UPSTR CONVERTS THE CHARACTER STRING STR TO LOWER CASE. C LEN IS THE NUMBER OF CHARACTERS TO CONVERT, NOT TO EXCEED THE C ACTUAL LENGTH OF STR. C C AUTHOR: FRED KLEIN (U.S.G.S) C CHARACTER STR*(*) INTEGER I INTEGER J INTEGER LEN DO I = 1, LEN J = ICHAR(STR(I:I)) IF (J .GT. 64 .AND. J .LT. 91) STR(I:I) = CHAR(J + 32) END DO RETURN END SUBROUTINE HYATE C--CALLED FROM HYCMD TO INITIALLY READ FILE OF STATION ATTENUATIONS AND C THEIR EXPIRATION DATES. INCLUDE 'common.inc' CHARACTER STN*5, SNET*2, SCOMP*3, SLOC*2 DIMENSION IATN(7),IAEXP(7),ITEXP(7),IYEARI(7) KOUNT=0 IF (JSTA.EQ.0) THEN WRITE (6,1001) 1001 FORMAT (' *** ERROR: YOU CANT READ ATTENUATIONS BEFORE', 2 ' READING THE STATION FILE') IRES=-35 RETURN END IF C--OPEN THE STATION ATTENUATION FILE CALL OPENR (13,ATNFIL,'F',IOS) IF (IOS.NE.0) GOTO 90 C--LOOP TO READ STATION ATTENUATIONS 5 IF (L2000) THEN READ (13,1020,END=80) STN, SNET, SLOC, SCOMP, 2 (IATN(I),IYEARI(I),ITEXP(I),I=1,7) 1020 FORMAT (A5,1X, A2,A2, A3,1X, 7(I2,1X,I4,I6,1X)) ELSE READ (13,1000,END=80) STN, SNET, SCOMP, 2 (IATN(I),IYEARI(I),ITEXP(I),I=1,7) 1000 FORMAT (A5,1X, A2,2X, A3,1X, 7(I2,1X,I2,I6,3X)) SLOC=' ' END IF C--ATTENUATIONS: 0 6 12 18 24 30 36 42 C DATA CALSV/23.2, 11.6, 5.58, 2.8, 1.4, .7, .352, .176, C 48 54 60 66 72 78 C 2 .089, .044, .0224, .0112, .0056, .0028/ C--CHECK ALL ATTENUATIONS TO BE A VALID MULTIPLE OF 6 DO I=1,7 KTEMP=IATN(I)/6 IF (IATN(I).LT.0 .OR. IATN(I).GT.78 2 .OR. (IATN(I)-KTEMP*6) .NE.0) THEN WRITE (6,1108) STN,SNET,SCOMP, IATN(I),IYEARI(I),ITEXP(I) 1108 FORMAT (' *** ILLEGAL ATTENUATION VALUE FOR ',A5,A3,A4, 2 ':',I4,' EXPIRES ',I4,I6) IRES=-93 STOP END IF IF (IYEARI(I).EQ.0 .AND. ITEXP(I).EQ.0) GOTO 8 END DO 8 CONTINUE C--SEARCH STATION LIST IN MEMORY FOR A MATCH DO J=1,JSTA IF (STN(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND. 2 SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND. 3 (SLOC(1:NSLOC2) .EQ. JSLOC(J)(1:NSLOC2) .OR. 3 SLOC(1:NSLOC2) .EQ. JSLOC2(J)(1:NSLOC2)) .AND. 4 SCOMP(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN C--MAKE SURE IYEARI IS THE FULL 4-DIGIT YEAR C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE DATE DO I=1,7 IF (IYEARI(I).LT.100 .AND. IYEARI(I).GT.0) 2 IYEARI(I)=IYEARI(I)+ICENT IF (IYEARI(I).GT.2146) THEN WRITE (6,1200) STN, SNET, SCOMP, IYEARI(I) 1200 FORMAT ('*** ATTEN EXPIRATION YEAR TOO LARGE,', 2 ' RESET TO 2146:'/1X,A5,1X,A2,1X,A3,1X,I4) IYEARI(I)=2146 END IF IAEXP(I)=IYEARI(I)*1000000 +ITEXP(I) END DO C--IF THE TARGET DATE IS 0, JUST TAKE THE FIRST ATTEN & EXPIRATION DATE IF (ICDATE.EQ.0) THEN I=1 ELSE C--SEARCH FOR THE FIRST EXPIRATION DATE AFTER THE TARGET DATE DO I=1,7 IF (IAEXP(I).EQ.0 .OR. IAEXP(I).GT.ICDATE) GOTO 10 END DO IAEXP(7)=0 END IF C--ISSUE A WARNING IF INSTRUMENT TYPE IS NOT 1 10 IF (JTYPE(J).NE.1) WRITE (6,1030) STN,SNET,SCOMP 1030 FORMAT (' *** WARNING: SHOULD BE READING ', 1 'ATTENUATIONS ONLY FOR'/ 2 ' TYPE 1 STATIONS, NOT ',A,'-',A,'-',A) C--STORE THE CAL FACTOR & ITS EXPIRATION DATE JCEXP(J)=IAEXP(I) KTEMP=IATN(I)/6 JCAL(J)=CALSV(KTEMP)*1000. KOUNT=KOUNT+1 C GOTO 5 !COMMENT OUT TO STORE DATA FOR ALL CHANNELS THAT APPLY END IF END DO GOTO 5 C--END OF ATTENUATION FILE 80 CLOSE (13) WRITE (6,1002) KOUNT 1002 FORMAT (I6,' STATION ATTENUATIONS SET') RETURN C--ERROR FOR NON-EXISTENT FILE 90 WRITE (6,1010) 1010 FORMAT (' *** ERROR: STATION ATTENUATION FILE DOES NOT EXIST') IRES=-36 RETURN END BLOCK DATA C--DATA INITIALIZATION FOR HYPOINV INCLUDE 'common.inc' C--GENERAL PARAMETERS DATA GREETING 2 /'6/2014 VERSION 1.40 (geoid depth possible)'/ DATA PI,RDEG,LJUNK,LMULT /3.14159,57.2958,2*.FALSE./ DATA NSTLET,NETLET,NCOMP,NSLOC,NSLOC2 /4,4*0/ C DATA LCOMP1,SUBMOD, CDOMAN,CPVERS /2*.FALSE.,'NC','01'/ C--FILES AND OUTPUT CONTROLS DATA LBSTA,LBCRU,LMAG,LSUM,LARC,LPRT,LERR,LAPP /10*.FALSE./ DATA JCP,JCA,LEJCT,LREP /2*1,2*.TRUE./ DATA KPRINT,JST,JST2,JST3 /3,1,0,0/ DATA IH71S,IH71T,ISTFMT,LBLANKMAG /1,1,3,.TRUE./ DATA NRDMAG, MRDMAG, SWITCH12 /3, 1,3,5,0,0, .FALSE./ DATA FORID,IE,IS /'(I10)',2*' '/ DATA MAGFIL,SUMFIL,ARCFIL,PRTFIL,STAFIL,ATNFIL,CALFIL,DELFIL, 2 PHSFIL,XMCFIL,FMCFIL,CRUFIL,BSTAFL,BCRUFL /11*' ',LM*' ',2*' '/ DATA INFILE /5*' '/ C--MISCELLANEOUS DATA FOR THIS EVENT DATA CP1,CP2,CP3,FULNAM,RUNLAB,LP153 /5*' ',.TRUE./ C--TERMINATING LOCATION UPON CONVERGENCE DATA ITRLIM,DQUIT,DRQT /20,.04,.001/ C--ITERATION & DAMPING CONTROLS DATA DXFIX,DZMAX,DZAIR,DAMP,EIGTOL,RBACK,BACFAC,DXMAX,D2FAR 2 /7.,30.,.5,.9,.012,.02,.6, 50.,250./ C--DURATION MAG CONSTANTS DATA FMA1,FMB1,FMZ1,FMD1,FMA2,FMB2,FMZ2,FMD2,FMBRK,FMF1,FMF2 2 /-5.2,3.89,.013,.0037,-.905,2.026,.013,.0037,210.,2*0./ DATA FMA1B,FMB1B,FMZ1B,FMD1B,FMA2B,FMB2B,FMZ2B,FMD2B,FMBRKB 2 /-5.2,3.89,.013,.0037,-.905,2.026,.013,.0037,210./ DATA LATEN,FMGN,NOMAGV,VNOMAG /.FALSE.,0.,0,0./ DATA MAGSEL,MAGSL2,MLOGA0,LCOWT, LNOFMC,LNOXMC,LMED /3*1,4*.TRUE./ DATA DMA0,DMA1,DMA2,DMLI,DMZ,DMGN /-1.03,2.10,0.,.00268,0.,1./ DATA NCPF1,NCPF2,COMPF1,COMPF2,LABF1,LABF2 /-1,0,40*' ',2*' '/ DATA NCPX1,NCPX2,COMPX1,COMPX2,LABX1,LABX2 /-1,0,40*' ',2*' '/ DATA DCOFM1,DBRKM1,DCOFM2,DBRKM2,ZCOFM,ZBRKM /6*0/ DATA NFCM,CFCM,AFCM /0,10*' ',10*0./ DATA NXCM,CXCM,AXCM /0,10*' ',10*0./ DATA LXCH /.TRUE./ DATA NXTYP1,IXTYP1, NXTYP2,IXTYP2 /0,3*0, 0,3*1/ DATA IDUG,CDUG,USEMAR /-1,10*' ',.FALSE./ DATA YLATMX,YLATMN,XLONMX,XLONMN /90.,-90.,180.,-180./ C--THESE ARE THE CAL FACTORS FOR EACH ATTENUATION SETTING C--IT APPEARS THAT: ATTEN = -20 * LOG(CAL) + 27 C--ALSO G = -LOG (CAL/3.95) C--ATTENUATIONS: 0 6 12 18 24 30 36 42 DATA CALSV/25.2, 11.65, 5.576, 2.795, 1.4, .702, .352, .176, C GAIN CORRECTION:-.80 -.47 -.15 +.15 +.45 +.75 +1.05 +1.35 C C 48 54 60 66 72 78 2 .0885, .044, .0222, .0111, .00557, .00279/ C +1.65 +1.95 +2.25 +2.55 +2.85 +3.15 C--MISCELLANEOUS PARAMETERS DATA DISCUT,DISW1,DISW2 /50.,1.,3./ DATA DISCU1,DISW11,DISW21 /50.,3.,6./ DATA RMSCUT,RMSW1,RMSW2 /.16,1.5,3./ DATA SWT,ZTR,DEPFIXA,RDERR,ERCOF,NET,MINSTA,ITRDIS,ITRRES,ITRDI1 2 /1.,7.,.FALSE.,.15,1.,0,4,2*4,100/ DATA LTBIG,ISTAT /.FALSE.,0/ DATA IFDATE,IXDATE,ICDATE /3*0/ DATA LKEEP, WTVALS, LGEOID /.TRUE.,1.,.75,.5,.25,.FALSE./ C--CRUST MODEL PARAMETERS DATA MAXMOD,MODDEF /1,1/ DATA NMOD,MODS,WMOD /1,1,0,0,3*0./ DATA NNODE /0/ C--UNKNOWN STATIONS DATA NLUNK,LUNK,SUNK /0,10*' ',MAXUNK*' '/ C--INTERACTIVE PROCESSING DATA LSTFIL,NCBASE,LSTFOR,IEDFLG /'listfil.',12,'(A12)',1/ DATA EXTPHS,EXTARC,EXTSUM,EXTPRT /'.phs','.arc','.sum','.prt'/ C--P MAGNITUDE PARAMETERS DATA LPMAG,LPPRT,LABP1,LABP2 /2*.FALSE.,2*' '/ DATA NCPP1,NCPP2,COMPP1,COMPP2 /-1,0,20*' '/ DATA NCNTMM,CCNTMM,CNT2MM,CNT2MD,CLPRAT /0,10*' ',11*.04,0.4/ DATA NPWM,CPWM,WPWM /0,10*' ',10*1./ DATA LATYPP,PMA1,PMB1,PMA2,PMB2 /5, 0.,1., 0.,1./ C--YR 2000 DATA L2000,ICENT,IAMPU /.TRUE.,1900,0/ C--DIGITIZER CODE TABLES DATA NDIG,DIGDEF,DIG1,DIG3 /0,' ',MAXDIG*' ',MAXDIG*' '/ END SUBROUTINE HYBEG C--BEGIN HYPOINVERSE BY INITIALIZING CERTAIN STRINGS. C--THIS IS EQUIVALENT TO INITIALIZATION IN A DATA STATEMENT. INCLUDE 'common.inc' C--THINGS FORMERLY SET IN BLOCK DATA LCOMP1=.FALSE. SUBMOD=.FALSE. CDOMAN='NC' CPVERS='01' C--SUN/UNIX TERMIN='/dev/tty' INFILE(1)='hypinst' INFILE(0)='/home/calnet/klein/hypfiles/cal2000.hyp' STAFIL='/home/calnet/klein/hypfiles/all2.sta' C ATNFIL='/home/calnet/klein/hypfiles/all2.atn' C FMCFIL='/home/calnet/klein/hypfiles/all2.fmc' C XMCFIL='/home/calnet/klein/hypfiles/all2.xmc' BSTAFL='/home/calnet/klein/hypfiles/allsta2.bin' BCRUFL='/home/calnet/klein/hypfiles/multmod2.bin' ATNFIL=' ' FMCFIL=' ' XMCFIL=' ' C--VAX C TERMIN='TT:' C INFILE(1)='HYPINST.' C INFILE(0)='HOME:[KLEIN.HYPFILES]CAL2000.HYP' CC INFILE(0)='HYPOINV$MODELS' !CUSP LOGICAL NAME C--STATION DATA DO J=1,MAXSTA JCEXP(J)=0 JCAL(J)=0 JLMOD(J)=.FALSE. END DO C--PHASE DATA DO K=1,MAXPHS KRMK6(K)=' ' KCAL(K)=0 END DO C--NODE DATA DO I=1,NODMAX MODH(I)=0 END DO C--CRUST MODEL DATA DO I=1,LH POSM(I)=1.75 POSB(I)=0. MODTYP(I)=-1 MODALT(I)=0 MODSAL(I)=0 ELEVMX(I)=0. LELEV(I)=.FALSE. END DO DO I=1,LM CRODE(I)=' ' END DO RETURN END SUBROUTINE HYCAL C--CALLED FROM HYCMD TO INITIALLY READ FILE OF STATION CAL FACTORS AND C THEIR EXPIRATION DATES. INCLUDE 'common.inc' CHARACTER STN*5, SNET*2, SCOMP*3, SLOC*2 DIMENSION RCAL(7),IAEXP(7),ITEXP(7),IYEARI(7) KOUNT=0 IF (JSTA.EQ.0) THEN WRITE (6,1001) 1001 FORMAT (' *** ERROR: YOU CANT READ CAL FACTORS BEFORE', 2 ' READING THE STATION FILE') IRES=-35 RETURN END IF C--OPEN THE STATION CAL FACTOR FILE CALL OPENR (13,CALFIL,'F',IOS) IF (IOS.NE.0) GOTO 90 C--LOOP TO READ STATION CAL FACTORS 5 IF (L2000) THEN READ (13,1020,END=80) STN, SNET, SLOC, SCOMP, 2 (RCAL(I),IYEARI(I),ITEXP(I),I=1,7) 1020 FORMAT (A5,1X, A2,A2, A3,1X, 7(F7.3,1X,I4,I6,1X)) ELSE READ (13,1000,END=80) STN, SNET, SCOMP, 2 (RCAL(I),IYEARI(I),ITEXP(I),I=1,7) 1000 FORMAT (A5,1X, A2,2X, A3,1X, 7(F7.2,1X,I2,I6,1X)) SLOC=' ' END IF C--SEARCH STATION LIST IN MEMORY FOR A MATCH DO J=1,JSTA IF (STN(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND. 2 SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND. 3 (SLOC(1:NSLOC2) .EQ. JSLOC(J)(1:NSLOC2) .OR. 3 SLOC(1:NSLOC2) .EQ. JSLOC2(J)(1:NSLOC2)) .AND. 4 SCOMP(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN C--MAKE SURE IYEARI IS THE FULL 4-DIGIT YEAR C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE STATE DO I=1,7 IF (IYEARI(I).LT.100 .AND. IYEARI(I).GT.0) 2 IYEARI(I)=IYEARI(I)+ICENT IF (IYEARI(I).GT.2146) THEN WRITE (6,1200) STN, SNET, SCOMP, IYEARI(I) 1200 FORMAT ('*** CAL EXPIRATION YEAR TOO LARGE,', 2 ' RESET TO 2146:'/1X,A5,1X,A2,1X,A3,1X,I4) IYEARI(I)=2146 END IF IAEXP(I)=IYEARI(I)*1000000 +ITEXP(I) END DO C--IF THE TARGET DATE IS 0, JUST TAKE THE FIRST CAL & EXPIRATION DATE IF (ICDATE.EQ.0) THEN I=1 ELSE C--SEARCH FOR THE FIRST EXPIRATION DATE AFTER THE TARGET DATE DO I=1,7 IF (IAEXP(I).EQ.0 .OR. IAEXP(I).GT.ICDATE) GOTO 10 END DO IAEXP(7)=0 END IF C--STORE THE CAL FACTOR & ITS EXPIRATION DATE 10 JCEXP(J)=IAEXP(I) JCAL(J)=RCAL(I)*1000. KOUNT=KOUNT+1 C GOTO 5 !COMMENT OUT TO STORE DATA FOR ALL CHANNELS THAT APPLY END IF END DO GOTO 5 C--END OF CAL FACTOR FILE 80 CLOSE (13) WRITE (6,1002) KOUNT 1002 FORMAT (I6,' STATION CAL FACTORS SET') RETURN C--ERROR FOR NON-EXISTENT FILE 90 WRITE (6,1010) 1010 FORMAT (' *** ERROR: STATION CAL FACTOR FILE DOES NOT EXIST') IRES=-36 RETURN END SUBROUTINE HYCMD C--CALLED BY HYPOINVERSE TO GET A COMMAND, THEN ACT ON IT. INCLUDE 'common.inc' C--LASK IS A LOGICAL FUNCTION. THE OS2 COMPILER COMPLAINS WITHOUT THESE LINES C LOGICAL LASK C EXTERNAL LASK CHARACTER TEMPSTR*80 PARAMETER (NCMD=101) CHARACTER CMD(NCMD)*3 LOGICAL LINST SAVE CMD DATA POS/1.75/ C--CMD HOLDS THE NAMES OF ALL COMMANDS RECOGNIZED BY THIS ROUTINE. C--THE STRUCTURE OF THIS STATEMENT MATCHES THAT OF THE COMPUTED GOTO DATA CMD / 2 'SUM','ARC','PRT','ERF','LST','KPR','TOP','REP', 3 'COP','DLY','CON','DAM','DUR','DIS','RMS','SWT', 4 'POS','ZTR','ERR','ERC','NET','SHO','CAR','APP', 5 'H71','STO','CRH','CRT','STA','INP','LOC','PHS', 6 'MIN','BUG','HEL','ATN','MOR','ST5','MAG','TAU', 7 'FID','JUN','MUL','ALT','NOD','SNO','DEL','MAX', 8 'UNK','ATE','VER','FMC','XMC','TYP','MFL','WCR', 9 'RCR','WST','RST','BAS','PRO','FC1','FC2','XC1', 1 'XC2','DU2','FCM','XCM','INI','LET','LES','DUB', 2 'PRE','CAL','LA0','PMA','PAC','PC1','PC2','PMC', 3 'LAB','KEP','WET','XCH','XTY','200','FIL','DUG', 4 'XMT','DIG','DID','DI1','PSM','CRL','CRV','SAL', 5 'MA2','CRE','MAR','RDM','GEO'/ C++++++++++++++++++ COMMAND INTERPRETER ++++++++++++++++++++ C--IF HYPOINVERSE IS A SUBROUTINE, WE HAVE 1 COMMAND LOADED IN CM & INST C HYPOINV IS THE MASTER SUBROUTINE NAME MADE FROM THE HYPOINVERSE MAIN PROGRAM IF (SUBMOD) THEN C--IF HYPOINV CALLED HYCMD AFTER FINISHING A STA, CRH, CRT, INP, BUG OR LOC C COMMAND READ FROM A COMMAND FILE, WE HAVE NO NEW COMMAND LOADED, C AND MUST READ ANOTHER COMMAND FROM THE FILE. IF ((ISTAT.GE.1 .AND. ISTAT.LE.7).OR. ISTAT.EQ.9) GOTO 2 C--IF HYPOINV CALLED HYCMD AFTER BEING GIVEN A COMMAND, C THERE IS NO NEED TO READ ANOTHER GOTO 4 END IF GOTO 5 C--OUTPUT A MESSAGE ON A FREE-FORMAT DECODING ERROR 3 WRITE (6,1000) CM 1000 FORMAT (' *** ERROR IN ',A3,' PARAMETERS - TRY AGAIN ***') IRES=-63 C--SUPPLY A PROMPT IF READING FROM THE TERMINAL C--IF WE JUST PROCESSED A COMMAND & ARE A SUBROUTINE, RETURN TO THE MAIN PROG 5 IF (INP.EQ.5) THEN IF (SUBMOD) THEN ISTAT=8 RETURN ELSE WRITE (6,1011) 1011 FORMAT (' COMMAND? ',$) END IF END IF C--READ A COMMAND LINE IF CM AND INST ARENT ALREADY LOADED WITH A COMMAND: C 1) WE ARE READING FROM A COMMAND FILE (NOT INTERACTIVE); C 2) OR WE ARE RUNNING AS A MAIN PROGRAM (NOT SUBROUTINE); C--THERE IS NO COMMAND TO READ IF THE SUBROUTINE HYPOINV (SUBMODE IS TRUE) C HAS NO COMMAND FILE. 2 IF (INP.NE.5 .OR. .NOT.SUBMOD) READ (INP,1012,END=9) CM,INST 1012 FORMAT (A3,A) C--A LINE STARTING WITH * IS IGNORED AS A REMARK 4 IF (CM(1:1).EQ.'*' .OR. CM.EQ.' ') GOTO 5 C--INTERPRET A ? IN THE FIRST COLUMN AS A REQUEST FOR COMMAND LIST IF (CM(1:1).EQ.'?') GOTO 84 C--A STRING PRECEDED BY @ IS INTERPRETED AS A FILENAME TO HOP TO C UP TO 4 NESTED COMMAND FILES ARE ALLOWED AT ONE TIME 6 IF (CM(1:1).EQ.'@') THEN C--GO TO NEXT HIGHER COMMAND FILE UNLESS DEPTH IS EXCEEDED IF (INP.GE.11) THEN WRITE (6,'('' *** ERROR: MAX DEPTH OF COMMAND FILES IS 4'')') IRES=-64 GOTO 5 ELSE IF (INP.GE.8) THEN INP=INP+1 ELSE IF (INP.EQ.5) THEN INP=8 END IF INFILE(INP-7) (1:2)=CM(2:3) INFILE(INP-7) (3:60)=INST CALL OPENR (INP,INFILE(INP-7),'F',IOS) IF (IOS.NE.0) GOTO 32 GOTO 5 END IF C--IF THE FIRST CHARACTER IS #, EXECUTE THE SYSTEM COMMAND WHICH FOLLOWS IF (CM(1:1).EQ.'#') THEN TERM=(CM(2:3)//INST) CALL SPAWN (TERM) GOTO 5 END IF C--DETERMINE WHETHER THE PARAMETER FIELD IS BLANK & IF SO SUPPLY PROMPTS LINST=INST(1:10).EQ.' ' C--BE SURE THE COMMAND IS UPPERCASE CALL UPSTR (CM,3) C--BRANCH TO THE APPROPRIATE COMMAND PROCESSOR C--THIS GOTO CORRESPONDS IN STRUCTURE TO THE COMMAND LIST DO 8 I=1,NCMD ICMDX=I IF (CM.EQ.CMD(ICMDX)) GOTO ( 2 10, 12, 14, 16, 20, 22, 24, 26, 3 28, 34, 38, 42, 46, 50, 52, 54, 4 56, 58, 60, 62, 64, 70, 30, 74, 5 66,140,144,148,152,156,166,168, 6 176,200, 84, 88, 86, 92, 96,100, 7 104,108,110,114,116,118,158,180, 8 184,162,354,172,192,196,208,216, 9 220,224,228,232,236,240,244,248, 1 252,256,260,264,268,272,276,280, 2 284,160,288,292,296,300,304,308, 3 312,316,320,324,328,332,336,340, 4 344,348,352, 51, 57,358,362,366, 5 98,142,370,374,376), ICMDX 8 CONTINUE C--OUTPUT AN ERROR MESSAGE WRITE (6,1001) CM 1001 FORMAT (' *** COMMAND NOT FOUND: ',A3,/ 2 ' TYPE ? OR HEL FOR COMMAND LIST.') IRES=-65 GOTO 5 C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT COMMAND FILES 32 INP=INP-1 IF (INP.EQ.7) INP=5 WRITE (6,1003) 1003 FORMAT (' *** ERROR - COMMAND FILE DOES NOT EXIST ***') IRES=-66 GOTO 5 C--RETURN TO PREVIOUS COMMAND FILE OR INTERACTIVE MODE AT END OF COMMAND FILE 9 IF (INP.EQ.5) THEN ISTAT=8 RETURN END IF CLOSE (INP) INP=INP-1 IF (INP.EQ.7) INP=5 GOTO 5 C******************** COMMAND PROCESSORS ************************* C-- SET SUMMARY OUTPUT FILENAME 10 IF (LINST) THEN CALL ASKC('EARTHQUAKE SUMMARY FILE (NONE FOR NONE)',SUMFIL) ELSE READ (INST,*,ERR=3) SUMFIL END IF LSUM=.NOT.(SUMFIL(1:4).EQ.'NONE' .OR. SUMFIL(1:4).EQ.'none') GOTO 5 C-- SET ARCHIVE OUTPUT FILENAME 12 IF (LINST) THEN CALL ASKC('ARCHIVE FILE (NONE FOR NONE)',ARCFIL) ELSE READ (INST,*,ERR=3) ARCFIL END IF LARC=.NOT.(ARCFIL(1:4).EQ.'NONE' .OR. ARCFIL(1:4).EQ.'none') GOTO 5 C-- SET PRINTER OUTPUT FILENAME 14 IF (LINST) THEN CALL ASKC('PRINTOUT FILE (NONE FOR NONE)',PRTFIL) ELSE READ (INST,*,ERR=3) PRTFIL END IF LPRT=.NOT.(PRTFIL(1:4).EQ.'NONE' .OR. PRTFIL(1:4).EQ.'none') GOTO 5 C-- SEND ERROR MESSAGES TO TERMINAL AS WELL AS PRINT FILE 16 IF (LINST) THEN LERR=LASK('SEND ERROR MESSAGES TO TERMINAL',LERR) ELSE READ (INST,*,ERR=3) LERR END IF GOTO 5 C-- FLAG TO LIST AVAILABLE STATIONS & CRUST ON THE PRINTER 20 IF (LINST) THEN WRITE (6,1002) 1002 FORMAT (' PRINT CODE: 0=EQS ONLY, 1=ADD PARAMS & FILES,') JST=JASK(' 2=ADD STATIONS & CRUST',JST) IF (JST.EQ.2) THEN WRITE (6,'('' QUANTITY OF STATION INFO TO PRINT:'')') JST2=JASK 1 ('0=NO LISTING, 1=LOCATIONS & BASIC DATA, 2=ALL DELAYS', 2 JST2) WRITE (6,'('' QUANTITY OF CRUST MODEL INFO TO PRINT:'')') JST3=JASK 1 ('0=NO CRUST LISTING, 1=LAYERS & NODES FOR EACH MODEL', 2 JST3) END IF ELSE READ (INST,*,ERR=3) JST IF (JST.EQ.2) THEN READ (INST,*,IOSTAT=IOS) JST,JST2,JST3 IF (IOS.NE.0) GOTO 3 END IF END IF GOTO 5 C-- PARAMETER TO CONTROL AMOUNT OF PRINTOUT 22 IF (LINST) THEN WRITE (6,*) ' PRINT QUANTITY CONTROL (0-6) 0=FINAL.LOC' WRITE (6,*) ' 1=STATION.LIST 2=ITERATIONS 3=EIGENVALUES' KPRINT=JASK('6=STATION LIST EACH ITERATION',KPRINT) ELSE READ (INST,*,ERR=3) KPRINT END IF GOTO 5 C-- FLAG TO PAGE EJECT BEFORE EACH EVENT 24 IF (LINST) THEN LEJCT=LASK('PRINT PAGE EJECT FOR EACH EVENT',LEJCT) ELSE READ (INST,*,ERR=3) LEJCT END IF GOTO 5 C-- FLAG TO REPORT EACH EVENT ON TERMINAL AS LOCATED 26 IF (LINST) THEN LREP=LASK('REPORT EACH EVENT AS LOCATED',LREP) LPRALL=LASK('PRINT STATIONS WITH NO WEIGHTS IN PRINT FILE', 2 LPRALL) ELSE READ (INST,*,IOSTAT=IOS) LREP,LPRALL IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- SELECT INPUT PHASE DATA FORMAT 28 IF (LINST) THEN WRITE (6,2028) 2028 FORMAT(' USE 200 COMMAND TO SELECT YR 2000 FORMATS.'/ 2 ' 1=OLD PHASE 3=ARCHIVE 4=SHADOW PHASE 5=ARCHIVE-SHADOW') C 3 ' 6=ONE-CUSP-EVENT 7=CUSP-LIST') JCP=JASK('PHASE FORMAT',JCP) C IF (JCP.EQ.6 .OR. JCP.EQ.7) THEN C WRITE (6,*) ' LEVEL OF MEM OUTPUT OF LOCATION TO CUSP:' C WRITE (6,*)' 0=NONE 1=DATA STRUCTURES 2=SHARED MEMORY REGION' C JCPO=JASK ('3=MEM DISK FILE',JCPO) C END IF ELSE READ (INST,*,ERR=3) JCP END IF IF (JCP.EQ.6 .OR. JCP.EQ.7) THEN WRITE (6,*) ' *** ERROR: CUSP INPUT NO LONGER SUPPORTED.' WRITE (6,*) ' TRY AGAIN.' JCP=3 END IF GOTO 5 C-- ARCHIVE DATA FORMAT 30 IF (LINST) THEN JCA=JASK 2 ('ARCHIVE FORMAT (1=NO SHADOWS 3=ARCHIVE-SHADOW)',JCA) ELSE READ (INST,*,ERR=3) JCA END IF GOTO 5 C-- STATION DELAY PARAMETERS (SUPERCEDED BY MULTIPLE MODEL ABILITY) C DELAY MODEL 1 IS ASSUMED FOR ALL STATIONS UNLESS MULTIPLE MODELS ARE C INVOKED WITH THE MUL AND RELATED COMMANDS. 34 WRITE (6,*) 'THE DLY COMMAND NO LONGER OPERATES.' WRITE (6,*) 2 'SEE THE MUL, NOD & RELATED COMMANDS FOR MULTIPLE MODELS.' GOTO 5 C-- TERMINATING LOCATION UPON CONVERGENCE 38 IF (LINST) THEN ITRLIM=JASK('MAX ITERATIONS',ITRLIM) DQUIT=ASKR('MIN HYPOCENTER ADJUSTMENT',DQUIT) DRQT=ASKR('MIN RMS CHANGE',DRQT) ELSE READ (INST,*,IOSTAT=IOS) ITRLIM,DQUIT,DRQT IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- ITERATION AND DAMPING CONTROLS 42 IF (LINST) THEN DXFIX=ASKR('DXFIX, FIX DEPTH UNTIL EPICEN. ADJ. < THIS',DXFIX) DZMAX=ASKR('DZMAX, MAX. DEPTH ADJ.',DZMAX) DZAIR=ASKR('DZAIR, MOVE HYPO. UP BY THIS INSTEAD OF AIR',DZAIR) DAMP=ASKR('DAMP, MANDATORY DAMPING FACTOR',DAMP) EIGTOL=ASKR('EIGTOL, SMALLEST EIGENVALUE PERMITTED',EIGTOL) RBACK=ASKR('RBACK, IF RMS INCREASES MORE THAN THIS...',RBACK) BACFAC=ASKR('BACFAC,...THEN MOVE HYPO. BACK THIS FACTOR',BACFAC) DXMAX=ASKR('DXMAX, MAX. DIST ADJ.',DXMAX) D2FAR=ASKR('D2FAR, STOP ITERATING WHEN 2ND STATION DIST > THIS', 2 D2FAR) ELSE READ (INST,*,IOSTAT=IOS) DXFIX,DZMAX,DZAIR,DAMP,EIGTOL,RBACK, 2 BACFAC,DXMAX,D2FAR IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- DURATION MAG CONSTANTS 46 IF (LINST) THEN WRITE (6,1004) 1004 FORMAT (' MAG CONSTANTS FOR DUR < FMBRK:') FMA1=ASKR('CONSTANT FMA1',FMA1) FMB1=ASKR('LOG TERM FMB1',FMB1) FMZ1=ASKR('DEPTH TERM FMZ1',FMZ1) FMD1=ASKR('DIST TERM FMD1',FMD1) FMF1=ASKR('LINEAR TERM FMF1',FMF1) WRITE (6,1005) 1005 FORMAT (' MAG CONSTANTS FOR DUR > FMBRK:') FMA2=ASKR('CONSTANT FMA2',FMA2) FMB2=ASKR('LOG TERM FMB2',FMB2) FMZ2=ASKR('DEPTH TERM FMZ2',FMZ2) FMD2=ASKR('DIST TERM FMD2',FMD2) FMF2=ASKR('LINEAR TERM FMF2',FMF2) FMBRK=ASKR('FMBRK',FMBRK) FMGN=ASKR('USE GAIN CORRECTION 0=NO 1=YES',FMGN) ELSE READ (INST,*,IOSTAT=IOS) FMA1,FMB1,FMZ1,FMD1,FMF1, 2 FMA2,FMB2,FMZ2,FMD2,FMF2, FMBRK,FMGN IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- DISTANCE WEIGHT PARAMETERS 50 IF (LINST) THEN ITRDIS=JASK('ITERATION TO BEGIN MAIN DISTANCE WEIGHTING' 2 ,ITRDIS) DISCUT=ASKR('DISCUT (KM)',DISCUT) DISW1=ASKR('DISW1 FACTOR',DISW1) DISW2=ASKR('DISW2 FACTOR',DISW2) ELSE READ (INST,*,IOSTAT=IOS) ITRDIS,DISCUT,DISW1,DISW2 IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- DISTANCE WEIGHT PARAMETERS FOR FIRST ITERATIONS 51 IF (LINST) THEN WRITE (6,*) 'DO FIRST DISTANCE WEIGHTING ON FIRST ITERATIONS,' WRITE (6,*) 'THEN USE DIS COMMAND WEIGHT PARAMETERS' WRITE (6,*) 'FOR MAIN DISTANCE WEIGHTING.' ITRDI1=JASK('ITERATION TO BEGIN FIRST DISTANCE WEIGHTING' 2 ,ITRDI1) DISCU1=ASKR('DISCUT-1 (KM)',DISCU1) DISW11=ASKR('DISW1 FACTOR',DISW11) DISW21=ASKR('DISW2 FACTOR',DISW21) ELSE READ (INST,*,IOSTAT=IOS) ITRDI1,DISCU1,DISW11,DISW21 IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- RMS WEIGHTING PARAMETERS 52 IF (LINST) THEN ITRRES=JASK('ITERATION TO BEGIN RESIDUAL WEIGHTING',ITRRES) RMSCUT=ASKR('RMSCUT (SEC)',RMSCUT) RMSW1=ASKR('RMSW1 FACTOR',RMSW1) RMSW2=ASKR('RMSW2 FACTOR',RMSW2) ELSE READ (INST,*,IOSTAT=IOS) ITRRES,RMSCUT,RMSW1,RMSW2 IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- S ARRIVAL WEIGHTING FACTOR 54 IF (LINST) THEN SWT=ASKR('S WEIGHT FACTOR',SWT) ELSE READ (INST,*,ERR=3) SWT END IF GOTO 5 C-- VP/VS VELOCITY RATIO FOR ALL MODELS 56 IF (LINST) THEN WRITE (6,*) 2 ' POS COMMAND SETS POS FOR ALL MODELS TO SAME VALUE' WRITE (6,*) 3 ' PSM COMMAND WILL SET POS FOR INDIVIDUAL MODELS' POS=ASKR('P/S VELOCITY RATIO FOR ALL MODELS',POS) ELSE READ (INST,*,ERR=3) POS END IF DO I=1,LM C--LEAVE POSM SET AT 1 IF IT WAS PREVIOUSLY DEFINED AS AN S MODEL IF (MODSAL(I).EQ.0) POSM(I)=POS POSB(I)=0. END DO GOTO 5 C-- VP/VS VELOCITY RATIO & CONSTANT FOR ONE MODEL C S(TT)= POSM*P(TT) +POSB 57 IF (LINST) THEN IM=JASK('MODEL NUMBER TO SET P/S VELOCITY RATIO',1) IF (IM.LT.1 .OR. IM.GT.LM) THEN WRITE (6,*) ' *** PSM ERROR: MODEL NUMBER OUT OF RANGE' GOTO 57 END IF WRITE (6,*) 'MODEL NAME: ',CRODE(IM) POSM(IM)=ASKR('P/S VELOCITY RATIO FOR THIS MODEL',POSM(IM)) POSB(IM)=ASKR('Stt CONSTANT POSB (Stt= POSM*Ptt +POSB)', 2 POSB(IM)) ELSE READ (INST,*,ERR=3) IM IF (IM.LT.1 .OR. IM.GT.LM) THEN WRITE (6,*) ' ***PSM ERROR: MODEL NUMBER OUT OF RANGE',IM GOTO 5 END IF READ (INST,*,IOSTAT=IOS) IM,POSM(IM),POSB(IM) IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- TRIAL DEPTH 58 IF (LINST) THEN ZTR=ASKR('TRIAL DEPTH FOR RUN',ZTR) DEPFIXA=LASK('FIX ALL DEPTHS FOR THIS RUN? (T OR F)',DEPFIXA) ELSE READ (INST,*,IOSTAT=IOS) ZTR,DEPFIXA IF (IOS.NE.0) GOTO 59 END IF GOTO 5 C--ASSUME DEPTHS NOT FIXED IF NOT SUPPLIED 59 WRITE (6,*) 2' *** NOW MUST SUPPLY FIX-DEPTH FLAG WITH ZTR COMMAND' DEPFIXA=.FALSE. GOTO 3 C-- ESTIMATED READING & TIMING ERROR 60 IF (LINST) THEN RDERR=ASKR('ESTIMATED READING & TIMING ERROR',RDERR) ELSE READ (INST,*,ERR=3) RDERR END IF GOTO 5 C-- WEIGHTING FACTOR OF RMS IN ERROR CALCS 62 IF (LINST) THEN ERCOF=ASKR('RMS WEIGHTING FACTOR IN ERROR CALCULATIONS',ERCOF) ELSE READ (INST,*,ERR=3) ERCOF END IF GOTO 5 C-- NET FOR ASSIGNING 3-LET. NAMES BASED ON LOCATION 64 IF (LINST) THEN WRITE (6,*) 2' NET (REGION) FOR ASSIGNING EARTHQUAKE REGION NAMES:' NET=JASK('0=NONE 1=HAWAII 2=N.CALIF 3=NEW.HAWAII',NET) ELSE READ (INST,*,ERR=3) NET END IF GOTO 5 C-- SET SUMMARY, INSTRUCTION & STATION FORMAT TYPES 66 IF (LINST) THEN WRITE (6,1067) 1067 FORMAT ('SUMMARY FORMAT: 1=HYPOINVERSE 2=HYPO71') IH71S=JASK 2 ('3=READABLE 4=COMMA-DELIM',IH71S) IH71T=JASK 1 ('TERMINATOR FORMAT: 1=HINV 2=HYPO71 3=TRIAL.FR.HEADER', 2 IH71T) WRITE (6,1066) 1066 FORMAT(' OLD FORMAT BEGINS WITH 4-LET CODES,', 2 ' NEW BEGINS WITH 10-LET CODES:') ISTFMT=JASK 2 ('STATION FORMAT 1=OLD.HYPOINV 2=HYPO71 3=NEW.HYPOINV',ISTFMT) ELSE READ (INST,*,IOSTAT=IOS) IH71S,IH71T,ISTFMT IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- WRITE FILENAMES 70 WRITE (6,'(/'' INPUT FILES:''/'' COMMANDS: '',A/11X,A)') 2 (INFILE(I),I=1,2) IF (LBSTA) THEN WRITE (6,'('' BINARY STATION SNAPSHOT FILE: '',A)') BSTAFL ELSE WRITE (6,'('' STATIONS: '',A)') STAFIL END IF WRITE (6,1021) JSTA, DELFIL,ATNFIL,CALFIL,FMCFIL,XMCFIL,PHSFIL 1021 FORMAT (' (',I4,' STATIONS IN MEMORY)'/' DELAYS: ',A/ 3 ' ATTENS: ',A/' CALFAC: ',A/' FM.COR: ',A/' XM.COR: ',A/ 4 ' PHASES: ',A) IF (LBCRU) THEN WRITE (6,'('' BINARY CRUST SNAPSHOT FILE: '',A)') BCRUFL ELSE DO I=1,MAXMOD IF (MODTYP(I).EQ.0) WRITE (6,1022) I,CRUFIL(I)(1:50) 1022 FORMAT (' LINEAR GRADIENT CRUST',I3,': ',A) IF (MODTYP(I).EQ.1) WRITE (6,1023) I,CRUFIL(I)(1:50) 1023 FORMAT (' HOMOGENEOUS LAYER CRUST',I3,': ',A) END DO END IF C--WRITE OUTPUT FILENAMES WRITE (6,1029) 1029 FORMAT (/' OUTPUT FILES:') IF (LPRT) WRITE (6,1030) PRTFIL 1030 FORMAT (' PRINTOUT: ',A) IF (LSUM) WRITE (6,1031) SUMFIL 1031 FORMAT (' SUMMARY: ',A) IF (LARC) WRITE (6,1032) ARCFIL 1032 FORMAT (' ARCHIVE: ',A) IF (LMAG) WRITE (6,1049) MAGFIL 1049 FORMAT (' MAGNITUDE DATA: ',A) GOTO 5 C-- INDICATE WHETHER OUTPUT FILES SHOULD BE APPENDED TO C ORDER IS 1=PRINT 2=SUMMARY 3=ARCHIVE 74 IF (LINST) THEN LAPP(1)=LASK('APPEND TO PRINT FILE',LAPP(1)) LAPP(2)=LASK('APPEND TO SUMMARY FILE',LAPP(2)) LAPP(3)=LASK('APPEND TO ARCHIVE FILE',LAPP(3)) ELSE READ (INST,*,ERR=3) LAPP END IF GOTO 5 C-- HELP LISTING OF COMMANDS 84 WRITE (6,1084) 1084 FORMAT ( 3' ---------I/O FILES----------- -----MISC. PARAMETERS---'/ 4' PHS -PHASE INPUT FILENAME ZTR -TRIAL DEPTH'/ 5' STA -READ STATION FILE POS -P/S VELOCITY RATIO'/ 6' CRH -READ LAYER CRUST FILE NET -NET FOR REGION NAMES'/ 7' CRT -READ GRADIENT CRUST FILE DUR,DU2,DUB -DUR. MAGS'/ 8' PRT -PRINTOUT FILENAME FIL -DETERMINE PHAS.FORMAT'/ 9' SUM -SUMMARY OUTPUT FILENAME MIN -MINIMUM NO. STATIONS'/ 9' ARC -ARCHIVE OUTPUT FILENAME CON -CONVERGENCE CONTROLS'/ 1' MFL -MAGNITUDE OUTPUT FILE DAM -DAMPING CONTROLS'/ 2' --------I/O CONTROLS-------- ATN,CAL -ATTEN/CAL FACTOR') WRITE (6,1085) 1085 FORMAT ( 3' COP -PHASE FORMAT ----WEIGHTING & ERRORS---'/ 4' H71 -HYPO71, STATION FORMATS SWT -GLOBAL S-TIME WEIGHT'/ 5' LST -LIST STAS. IN PRINTFILE DIS -DISTANCE WEIGHTING'/ 6' KPR -AMOUNT OF PRINT DATA RMS -RESIDUAL WEIGHTING'/ 7' TOP -NEW PAGE EACH EVENT ERR -GLOBAL TIME ERROR'/ 8' REP -REPORT EVENTS TO TERM. ERC -RMS EFFECT ON ERROR'/ 9' ERF -ERROR MESSAGES TO TERM. -------DO SOMETHING-----'/ 9' CAR -ARCHIVE FORMAT LOC -LOCATE EVENTS'/ 1' APP -APPEND TO OUTPUT FILES STO -STOP THE PROGRAM'/ 2' INP -INTERACTIVE DATA ENTRY PRO -PROCESS INTERACTIVE'/ 3' (TYPE MOR FOR MORE COMMANDS)') GOTO 5 C-- HELP FOR MORE COMMANDS 86 WRITE (6,1086) 1086 FORMAT ( 2' -------MAGNITUDE INFO ------ -------MULTIPLE MODELS-------'/ 3' ATN -USE STATION ATTENUATION ALT -ASSIGN STAS TO DIFF MODELS'/ 4' FC1,FC2 -SELECT FMAG COMPS. MUL -USE REGIONAL MODELS'/ 5' MAG -CODA MAGNITUDE TYPE NOD -GEOGR. NODE FOR A MODEL'/ 6' TAU -TAU CODA MAG CONSTANTS SNO -DISPLAY CURRENT NODES'/ 8' XC1,XC2 -SELECT XMAG COMPS. -------MORE STATION DATA------'/ 7' FCM,XCM -COMPONENT MAG CORRS. DEL -READ STATION DELAY FILE'/ 8' PRE -SET PREFERRED MAG ORDER UNK -STAS:NO ERROR IF MISSING'/ 7' PMA -P AMP MAG CHOICES LET -LENGTH OF STA. NAMES'/ 8' PAC -PMAG COMPONENT WEIGHTS LES -OLD 1-LET STA COMPONENTS'/ 9' LA0 -DIST CORR TERM (AMP MAG) ATE -READ STATION ATTEN FILE'/ 1' XCH,XTY -AMP MAG BY INST TYP CAL -READ STATION CAL FACTORS') WRITE (6,1087) 1087 FORMAT ( 1' --------MORE COMMANDS-------- FMC -READ FMAG CORRECTIONS'/ 2' MAX -LIST MAX ARRAY SIZES XMC -READ XMAG CORRECTIONS'/ 3' FID -CUSP-ID READ FORMAT ------- BINARY FILES -------'/ 3' SHO -SHOW CURRENT FILES WCR -WRITE CRUST SNAPSHOT'/ 4' BUG -DEBUG PHASE FILE RCR -READ CRUST SNAPSHOT'/ 9' BAS -INTERACT. PROCESSING WST -WRITE STATION SNAPSHOT'/ 1' JUN -FORCE EQS WITH FEW DATA RST -READ STATION SNAPSHOT'/ 3' INI -INITIALIZE WITH STD. COMMAND FILE'/ 4' KEP -OUTPUT UNRECOGNIZED STATIONS'/ 5' WET -WEIGHTS FOR PHASE WEIGHT CODES 0-3') GOTO 5 C-- SET FLAG TO CONVERT STATION ATTENUATION TO A CAL FACTOR 88 IF (LINST) THEN LATEN=LASK 1 ('ASSUME STATIONS HAVE ATTENUATIONS, NOT CAL FACTORS', 2 LATEN) ELSE READ (INST,*,ERR=3) LATEN END IF GOTO 5 C-- USE 4 OR 5 LETTER STATION NAMES, 0, 1 OR 3 LETTER COMPONENT CODES 92 WRITE (6,1092) 1092 FORMAT (' *** ST5 COMMAND ELIMINATED.'/ 2 ' USE LET COMMAND TO SET LENGTHS OF STA, NET & COMP. CODES') GOTO 5 C-- SELECT TRADITIONAL CODA OR TAU (ELAPSED TIME) FOR 1ST & 2ND MAGNITUDE 96 IF (LINST) THEN MAGSEL=JASK('FIRST FMAG: 1=CODA, 2=ELAPSED TIME, 3=2nd CODA', 2 MAGSEL) LCOWT=LASK 1 ('T=USE ASSIGNED CODA WEIGHTS, F=GIVE ALL FULL WEIGHT', 2 LCOWT) MAGSL2=JASK('2nd FMAG: 1=CODA, 2=ELAPSED TIME, 3=2nd CODA', 2 MAGSL2) WRITE (6,1096) 1096 FORMAT (' THE LOG(A0) RELATIONS ARE: 1=EATON 2=BAKUN & JOYNER'/ 2 ' 3=RICHTER 4=BKY-NORDQUIST 5=RICHTER TABLE') MLOGA0=JASK('LOG(A0) RELATION CHOICE',MLOGA0) ELSE READ (INST,*,IOSTAT=IOS) MAGSEL,LCOWT,MAGSL2,MLOGA0 IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- SELECT MINIMUM MAGNITUDE (NO MAGNITUDE VALUE) & MEDIAN FLAG 98 IF (LINST) THEN WRITE (6,1097) 1097 FORMAT (' CODE FOR NO-MAG (MINIMUM) VALUE: ') NOMAGV=JASK('0 FOR 0.0, 1 FOR -1.0, 2 FOR -9.0',NOMAGV) LMED=LASK('T FOR WEIGHED MEDIAN, F FOR WEIGHED MEAN',LMED) ELSE READ (INST,*,IOSTAT=IOS) NOMAGV,LMED IF (IOS.NE.0) GOTO 3 END IF IF (NOMAGV.EQ.0) THEN VNOMAG=0. MINMAG=0 ELSE IF (NOMAGV.EQ.1) THEN VNOMAG=-1. MINMAG=-100 ELSE IF (NOMAGV.EQ.2) THEN VNOMAG=-9. MINMAG=-900 ELSE WRITE (6,*) '*** ERROR: NOMAGV MUST BE 0, 1, OR 2' NOMAGV=0 VNOMAG=0. MINMAG=0 END IF GOTO 5 C-- SET CONSTANTS IN ELAPSED TIME (TAU) MAGNITUDE RELATION 100 IF (LINST) THEN WRITE (6,*) 2 'SET COEFFICIENTS IN ELAPSED TIME (TAU) MAG EXPRESSION:' DMA0=ASKR('CONSTANT',DMA0) DMA1=ASKR('COEFFICIENT OF LOG(TAU)',DMA1) DMA2=ASKR('COEFFICIENT OF LOG**2(TAU)',DMA2) DMLI=ASKR('COEFFICIENT OF TAU',DMLI) DMZ=ASKR('COEFFICIENT OF DEPTH',DMZ) DMGN=ASKR('USE GAIN CORRECTION 0=NO 1=YES',DMGN) ELSE READ (INST,*,IOSTAT=IOS) DMA0,DMA1,DMA2,DMLI,DMZ,DMGN IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- FORMAT FOR READING CUSP-ID NUMBERS FROM A FILE 104 WRITE (6,*) ' ***FID: CUSP PROCESSING NO LONGER SUPPORTED' C104 IF (LINST) THEN C CALL ASKC('FORMAT FOR READING CUSP-ID NUMBERS',FORID) C ELSE C READ (INST,*,ERR=3) FORID C END IF GOTO 5 C-- FLAG TO SUPPRESS DIST & RESIDUAL WEIGHTING WHEN FEWER THAN 4 READINGS C ARE LEFT 108 IF (LINST) THEN WRITE (6,*) 2 'T TO USE ALL READINGS (NO DISTANCE OR RESIDUAL WEIGHTING)' LJUNK=LASK('WHEN TOO MANY READINGS WOULD BE WEIGHTED OUT',LJUNK) ELSE READ (INST,*,ERR=3) LJUNK END IF GOTO 5 C-- SET FLAG TO SELECT MULTIPLE MODEL PROCESSING 110 IF (LINST) THEN LMULT=LASK('PROCESS EQS WITH REGION-DEPENDENT MODELS',LMULT) IF (LMULT) MODDEF=JASK('DEFAULT MODEL NUMBER',MODDEF) ELSE READ (INST,*,ERR=3) LMULT IF (LMULT) THEN READ (INST,*,IOSTAT=IOS) LMULT,MODDEF IF (IOS.NE.0) GOTO 3 END IF END IF LBCRU=.FALSE. GOTO 5 C-- SPECIFY AN ALTERNATE MODEL FOR STATIONS SO DESIGNATED 114 IF (LINST) THEN C--LIST EXISTING ALTERNATE MODEL PAIRS: WRITE (6,1114) 1114 FORMAT (' EXISTING PAIRS OF MODEL NUMBER & ITS ALTERNATE:') DO I=1,MAXMOD IF (MODALT(I).GT.0) WRITE (6,'(2I4)') I,MODALT(I) END DO I=JASK('PRIMARY MODEL NUMBER TO HAVE AN ALTERNATE',1) J=MODALT(I) MODALT(I)=JASK('ALTERNATE MODEL NO. (0 FOR NONE)',J) ELSE READ (INST,*,IOSTAT=IOS) I,MODALT(I) IF (IOS.NE.0) GOTO 3 END IF LBCRU=.FALSE. GOTO 5 C-- ADD A NODE TO THE PRESENT LIST (NO DEFAULTS) 116 IF (NNODE.GE.NODMAX) THEN WRITE (6,*)'YOU HAVE',NODMAX,' NODES AND CANT HAVE MORE' GOTO 5 END IF NNODE=NNODE+1 IF (LINST) THEN TMP1=ASKR('NODE LAT (DEG)',0.) TMP2=ASKR('NODE LAT (MIN)',0.) TMP3=ASKR('NODE LON (DEG - POSITIVE WEST)',0.) TMP4=ASKR('NODE LON (MIN - POSITIVE WEST)',0.) RAD1(NNODE)=ASKR('RADIUS FOR 100% OF THIS MODEL (KM)',0.) DRAD(NNODE)=ASKR 2 ('TRANSITION WIDTH OUTSIDE CIRCLE (KM, >0.1)',0.) MODH(NNODE)=JASK('CRUST MODEL NUMBER FOR THIS NODE',1) ELSE READ (INST,*,IOSTAT=IOS) TMP1,TMP2,TMP3,TMP4,RAD1(NNODE), 2 DRAD(NNODE),MODH(NNODE) IF (IOS.NE.0) GOTO 3 END IF C--CHECK MODEL NUMBER IF (MODH(NNODE).GT.LM) THEN WRITE (6,*)'*** ERROR - NODE MODEL NUMBER TOO HIGH:', 2 MODH(NNODE) NNODE=NNODE-1 IRES=-67 GOTO 5 END IF C--COMPLETE THE NODE DATA HLAT(NNODE)=TMP1+TMP2/60. HLON(NNODE)=TMP3+TMP4/60. IF (DRAD(NNODE).LT..1) THEN WRITE (6,*)'*** TRANSITION ZONE INCREASED TO 0.1 KM' DRAD(NNODE)=.1 END IF RAD2(NNODE)=RAD1(NNODE)+DRAD(NNODE) LBCRU=.FALSE. GOTO 5 C-- LIST THE CURRENT NODES AT THE TERMINAL 118 IF (NNODE.EQ.0) THEN WRITE (6,*)'NO NODES ARE DEFINED' GOTO 5 END IF WRITE (6,1016) 1016 FORMAT 2 (' NODE CENTER-LAT CENTER-LON MOD INNER-RADIUS RING-WIDTH') WRITE (6,1017) (I,HLAT(I),HLON(I),MODH(I),RAD1(I),DRAD(I), 2 I=1,NNODE) 1017 FORMAT ((I4,F10.4,F12.4,I4,F10.2,F12.2)) GOTO 5 C-- STOP THE PROGRAM 140 ISTAT=8 RETURN C-- READ A HYPOELLIPSE LAYER CRUSTAL MODEL 142 IF (LINST) THEN MOD=JASK('HYPOELLIPSE LAYER CRUST MODEL NO. (1-35)',1) IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146 IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD CALL ASKC('HYPOELLIPSE LAYER MODEL FILENAME',CRUFIL(MOD)) ELEVMX(MOD)=ASKR('REFERENCE (MAX) ELEV ABOVE S.L. IN KM', 2 ELEVMX(MOD)) LELEV(MOD)=LASK('T TO USE STA ELEVS, F ALL AT REF ELEV', 2 LELEV(MOD)) ELSE READ (INST,*,ERR=3) MOD IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146 IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD READ (INST,*,IOSTAT=IOS) MOD,CRUFIL(MOD),ELEVMX(MOD), 2 LELEV(MOD) IF (IOS.NE.0) GOTO 3 END IF C--SET THE LARGEST MODEL NUMBER IF (MOD.GT.MAXMOD) MAXMOD=MOD C--OPEN FILE & READ MODEL CALL OPENR (14,CRUFIL(MOD),'F',IOS) IF (IOS.NE.0) GOTO 145 ISTAT=9 LBCRU=.FALSE. RETURN C-- READ A HOMO LAYER CRUSTAL MODEL 144 IF (LINST) THEN MOD=JASK('HOMOGENEOUS LAYER CRUST MODEL NO. (1-35)',1) IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146 IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD CALL ASKC('CRUST MODEL FILENAME',CRUFIL(MOD)) ELSE READ (INST,*,ERR=3) MOD IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146 IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD READ (INST,*,IOSTAT=IOS) MOD,CRUFIL(MOD) IF (IOS.NE.0) GOTO 3 END IF C--SET THE LARGEST MODEL NUMBER, AND REFERENCE ELEVATION IF (MOD.GT.MAXMOD) MAXMOD=MOD ELEVMX(MOD)=0. !FWK 1.37 C--OPEN FILE & READ MODEL CALL OPENR (14,CRUFIL(MOD),'F',IOS) IF (IOS.NE.0) GOTO 145 ISTAT=1 LBCRU=.FALSE. RETURN C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT FILES 145 WRITE (6,1455) CRUFIL(MOD) 1455 FORMAT (' *** ERROR - CRUST FILE DOES NOT EXIST: ***'/1X,A) IRES=-68 GOTO 5 C--ERROR MESSAGE FOR BAD MODEL NUMBER 146 WRITE (6,1014) MOD 1014 FORMAT (' *** THIS CRUST MODEL NUMBER IS OUT OF RANGE:',I3) IRES=-69 GOTO 5 C--ERROR MESSAGE FOR PREVIOUSLY DEFINED MODEL 1018 FORMAT (' *** WARNING: MODEL NUMBER',I3,' IS BEING REDEFINED') C-- READ ONE OF THE LINEAR GRADIENT CRUSTAL MODELS 148 IF (LINST) THEN MOD=JASK('LINEAR GRADIENT CRUST MODEL NO. (1-20)',1) IF (MOD.LT.1 .OR. MOD.GT.LN) GOTO 146 IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD CALL ASKC('CRUST MODEL FILENAME',CRUFIL(MOD)) ELSE READ (INST,*,ERR=3) MOD IF (MOD.LT.1 .OR. MOD.GT.LN) GOTO 146 IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD READ (INST,*,IOSTAT=IOS) MOD,CRUFIL(MOD) IF (IOS.NE.0) GOTO 3 END IF C--SET THE LARGEST MODEL NUMBER, AND REFERENCE ELEVATION IF (MOD.GT.MAXMOD) MAXMOD=MOD ELEVMX(MOD)=0. !FWK 1.37 C--OPEN FILE & READ MODEL CALL OPENR (14,CRUFIL(MOD),'F',IOS) IF (IOS.NE.0) GOTO 145 ISTAT=2 LBCRU=.FALSE. RETURN C-- READ IN A LIST OF SEISMIC STATIONS 152 IF (LINST) THEN CALL ASKC('STATION FILENAME',STAFIL) ELSE READ (INST,*,ERR=3) STAFIL END IF CALL OPENR (14,STAFIL,'F',IOS) IF (IOS.EQ.0) THEN ISTAT=3 LBSTA=.FALSE. RETURN ELSE WRITE (6,1153) STAFIL 1153 FORMAT (' *** ERROR - STATION FILE DOES NOT EXIST: ***'/1X,A) IRES=-70 GOTO 5 END IF C-- ENTER PHASE DATA MANUALLY 156 ISTAT=4 RETURN C-- READ IN STATION DELAYS C READ IN ALL DELAYS FROM ONE FILE (OLD WAY), OR DELAYS FROM JUST ONE MODEL 158 IF (LINST) THEN MODB=JASK('MODEL NO. (-1=ALT.LIST, 0=ALL MODS, 1-32=MODEL NO.)' 2 ,1) CALL ASKC('STATION DELAY FILENAME (MUST READ STAS FIRST)' 2 ,DELFIL) ELSE C--WHEN NO MODEL NO. IS SUPPLIED, READ ALL DELAYS FROM ONE FILE READ (INST,*,IOSTAT=IOS) MODB,DELFIL IF (IOS.NE.0) GOTO 3 END IF C--OPEN FILE, READ DELAYS CALL OPENR (13,DELFIL,'F',IOS) IF (IOS.NE.0) THEN WRITE (6,1159) DELFIL 1159 FORMAT (' *** ERROR - DELAY FILE DOES NOT EXIST: ***'/1X,A) IRES=-71 GOTO 5 END IF CALL HYDEL(MODB) LBSTA=.FALSE. GOTO 5 C-- READ HISTORY FILE OF STATION CAL FACTORS 160 IF (LINST) THEN CALL ASKC('STA. CAL FACTOR HISTORY FILE (INST.TYPE 3)',CALFIL) WRITE (6,1600) 1600 FORMAT (' ENTER START DATE OF CAL FACTORS TO LOAD (I.E.',/, 2 ' DATE OF FIRST EARTHQ.) USE 0 TO LOAD EARLIEST CAL FACTOR.') ICY=JASK('START YEAR (4 DIGITS)',0) IF (ICY.EQ.0) THEN ICDATE=0 GOTO 161 END IF ICM=JASK('START MONTH',0) ICD=JASK('START DAY',0) ICH=JASK('START HOUR',0) ELSE READ (INST,*,IOSTAT=IOS) CALFIL,ICY IF (IOS.NE.0) GOTO 3 IF (ICY.EQ.0) THEN ICDATE=0 GOTO 161 END IF READ (INST,*,IOSTAT=IOS) CALFIL,ICY,ICM,ICD,ICH IF (IOS.NE.0) GOTO 3 END IF IF (ICY.LT.100) ICY=ICY+ICENT ICDATE=ICH +100*ICD +10000*ICM +1000000*ICY 161 CALL HYCAL GOTO 5 C-- READ HISTORY FILE OF STATION ATTENUATIONS 162 IF (LINST) THEN CALL ASKC('STA. ATTENUATION HISTORY FILE (INST.TYPE 1)',ATNFIL) WRITE (6,1620) 1620 FORMAT (' ENTER START DATE OF ATTENUATIONS TO LOAD (I.E.',/, 2 ' DATE OF FIRST EARTHQ.) USE 0 TO LOAD EARLIEST ATTENUATION.') ICY=JASK('START YEAR (4 DIGITS)',0) IF (ICY.EQ.0) THEN ICDATE=0 GOTO 164 END IF ICM=JASK('START MONTH',0) ICD=JASK('START DAY',0) ICH=JASK('START HOUR',0) ELSE READ (INST,*,IOSTAT=IOS) ATNFIL,ICY IF (IOS.NE.0) GOTO 3 IF (ICY.EQ.0) THEN ICDATE=0 GOTO 164 END IF READ (INST,*,IOSTAT=IOS) ATNFIL,ICY,ICM,ICD,ICH IF (IOS.NE.0) GOTO 3 END IF IF (ICY.LT.100) ICY=ICY+ICENT ICDATE=ICH +100*ICD +10000*ICM +1000000*ICY 164 CALL HYATE GOTO 5 C-- LOCATE EVENTS 166 ISTAT=7 C--GET CUSP ID NUMBER IF REQUIRED C IF (JCP.EQ.6) THEN C IF (LINST) THEN C IDNO=JASK('CUSP-ID NUMBER',0) C MEMDSK=JASK('0=GET FROM MEMORY, 1=GET FROM DISK',1) C ELSE C READ (INST,*,ERR=3) IDNO,MEMDSK C END IF C END IF RETURN C-- SPECIFY PHASE INPUT FILE 168 IF (LINST) THEN CALL ASKC('PHASE FILENAME',PHSFIL) ELSE READ (INST,*,ERR=3) PHSFIL END IF GOTO 5 C-- SET TARGET DATE & READ FILE OF FMAG CORRECTIONS & THEIR EXPIR DATES 172 IF (LINST) THEN CALL ASKC('STA. FMAG CORRECTION HISTORY FILE',FMCFIL) WRITE (6,1721) 1721 FORMAT(' ANSWER T TO USE FMAG WEIGHTS ON STATION CARD,'/ 2 ' F TO FORCE CORRECTION FILE TO SET ALL WEIGHTS.'/ 3 ' IF F, STATION MUST BE IN CORRECTION FILE TO BE USED:') LNOFMC=LASK('USE STATIONS NOT IN CORRECTION FILE',LNOFMC) WRITE (6,1720) 1720 FORMAT (' ENTER START DATE OF FMAG CORRECTIONS TO LOAD'/, 2 ' (I.E. DATE OF FIRST EARTHQ.)'/, 4 ' USE 0 TO LOAD EARLIEST FMAG CORRECTION.') ICY=JASK('START YEAR (4 DIGITS)',0) IF (ICY.EQ.0) THEN IFDATE=0 GOTO 174 END IF ICM=JASK('START MONTH',0) ICD=JASK('START DAY',0) ICH=JASK('START HOUR',0) ELSE READ (INST,*,IOSTAT=IOS) FMCFIL,LNOFMC,ICY IF (IOS.NE.0) GOTO 3 IF (ICY.EQ.0) THEN IFDATE=0 GOTO 174 END IF READ (INST,*,IOSTAT=IOS) FMCFIL,LNOFMC,ICY,ICM,ICD,ICH IF (IOS.NE.0) GOTO 3 END IF IFDATE=ICH +100*ICD +10000*ICM +1000000*ICY 174 CALL HYFMC GOTO 5 C-- SET MIN NO. OF PHASE CARDS TO ATTEMPT A LOCATION 176 IF (LINST) THEN MINSTA=JASK('MIN NO. OF PHASES TO ATTEMPT A LOCATION', 2 MINSTA) ELSE READ (INST,*,ERR=3) MINSTA END IF IF (MINSTA.LT.4) THEN WRITE (6,1033) 1033 FORMAT (' *** ERROR: MINSTA MUST BE 4 OR MORE') MINSTA=4 END IF GOTO 5 C-- LIST THE MAX ARRAY SIZES ON THE TERMINAL 180 WRITE (6,1180) MAXSTA,MAXPHS,MMAX,MAXUNK, LH,LN,LM, NODMAX,NLYR 1180 FORMAT (' --- THE MAXIMUM SPACE OF VARIOUS ARRAYS ARE: ---'// 1 ' +++ STATIONS AND PHASES +++'/ 2 I5,' = NUMBER OF STATIONS IN STATION FILE.'/ 3 I5,' = NUMBER OF PHASE CARDS (STATIONS) PER EVENT.'/ 4 I5,' = NUMBER OF PHASES (P OR S) PER EVENT.'/ 5 I5,' = NUMBER OF UNKNOWN STATIONS PER EVENT', 3 ' (TO COPY TO ARCHIVE FILE).'/ 4 8X ,'(MAX OF POSSIBLE STATIONS SET WITH UNK COMMAND IS 10)'// 4 ' +++ MULTIPLE CRUSTAL MODELS +++'/ 5 I5,' = NUMBER OF HOMOGENEOUS LAYER CRUST MODELS.'/ 6 I5,' = NUMBER OF LINEAR GRADIENT CRUST MODELS.'/ 7 I5,' = NUMBER OF CRUSTAL MODELS OF ANY TYPE.'/ 8 I5,' = NUMBER OF NODES FOR CRUST MODEL REGIONS.'/ 9 I5,' = NUMBER OF LAYERS PER CRUSTAL MODEL.'/) GOTO 5 C-- LIST STATIONS NOT TO COMPLAIN ABOUT IF NOT IN STATION FILE 184 IF (LINST) THEN WRITE (6,1184) 1184 FORMAT (' ENTER LIST OF 4-LETTER STAS FOR WHICH NO ERROR.'/ 2 ' MESSAGE WILL RESULT WHEN MISSING FROM STATION LIST:') NLUNK=JASK('NUMBER OF STAS TO EXPECT MISSING (0-10)',NLUNK) IF (NLUNK.GT.10) THEN WRITE (6,*)' *** UNK: MAXIMUM NUMBER OF UNKNOWN STATIONS IS 10' NLUNK=10 END IF DO I=1,NLUNK CALL ASKC('STATION',LUNK(I)) END DO ELSE READ (INST,*,ERR=3) NLUNK IF (NLUNK.GT.10) THEN WRITE (6,*)' *** UNK: MAXIMUM NUMBER OF UNKNOWN STATIONS IS 10' NLUNK=10 IRES=-41 END IF IF (NLUNK.GT.0) THEN READ (INST,*,IOSTAT=IOS) NLUNK,(LUNK(I),I=1,NLUNK) IF (IOS.NE.0) GOTO 3 END IF END IF GOTO 5 C-- SET TARGET DATE & READ FILE OF XMAG CORRECTIONS 192 IF (LINST) THEN CALL ASKC('STA. XMAG CORRECTION HISTORY FILE',XMCFIL) WRITE (6,1921) 1921 FORMAT(' ANSWER T TO USE XMAG WEIGHTS ON STATION CARD,'/ 2 ' F TO FORCE CORRECTION FILE TO SET ALL WEIGHTS.'/ 3 ' IF F, STATION MUST BE IN CORRECTION FILE TO BE USED:') LNOXMC=LASK('USE STATIONS NOT IN CORRECTION FILE',LNOXMC) WRITE (6,1920) 1920 FORMAT (' ENTER START DATE OF XMAG CORRECTIONS TO LOAD'/, 2 ' (I.E. DATE OF FIRST EARTHQ.)'/, 4 ' USE 0 TO LOAD EARLIEST XMAG CORRECTION.') ICY=JASK('START YEAR (4 DIGITS)',0) IF (ICY.EQ.0) THEN IXDATE=0 GOTO 194 END IF ICM=JASK('START MONTH',0) ICD=JASK('START DAY',0) ICH=JASK('START HOUR',0) ELSE READ (INST,*,IOSTAT=IOS) XMCFIL,LNOXMC,ICY IF (IOS.NE.0) GOTO 3 IF (ICY.EQ.0) THEN IXDATE=0 GOTO 194 END IF READ (INST,*,IOSTAT=IOS) XMCFIL,LNOXMC,ICY,ICM,ICD,ICH IF (IOS.NE.0) GOTO 3 END IF IXDATE=ICH +100*ICD +10000*ICM +1000000*ICY 194 CALL HYXMC GOTO 5 C-- TYPE A MESSAGE TO THE TERMINAL (OR BATCH LOG FILE) 196 I=LENG(INST) WRITE (6,'(1X,A)') INST (1:I) GOTO 5 C-- READ PHASE FILE & GENERATE ONLY ERROR OUTPUT C--A STATION FILE MUST HAVE BEEN READ 200 ISTAT=5 RETURN C-- SET THE OUTPUT MAGNITUDE FILENAME 208 IF (LINST) THEN CALL ASKC('MAGNITUDE DATA OUTPUT FILE (NONE FOR NONE)',MAGFIL) ELSE READ (INST,*,ERR=3) MAGFIL END IF LMAG=MAGFIL(1:4).NE.'NONE' .AND. MAGFIL(1:4).NE.'none' GOTO 5 C-- WRITE BINARY SNAPSHOT OF ALL CRUST MODELS 216 IF (LINST) THEN CALL ASKC ('CRUST MODEL SNAPSHOT FILE TO WRITE',BCRUFL) ELSE READ (INST,*,ERR=3) BCRUFL END IF CALL OPENW (14,BCRUFL,'U',IOS,'S') WRITE (14) MODTYP,MODNAM,CRODE,MAXMOD !MODEL INFO WRITE (14) MODALT,LMULT,MODDEF WRITE (14) LAY,VEL,VSQ,D,THK !LAYER MODELS WRITE (14) DD1,ND1,ND,DD2,ND2,GD1,GD2 !TRAVEL TIME TABLES WRITE (14) DZ1,NZ1,NZ,DZ2,NZ2,GZ1,GZ2,REDV WRITE (14) KDHR WRITE (14) KT WRITE (14) NNODE,HLAT,HLON,RAD1,RAD2,DRAD,MODH !NODES WRITE (14) ELEVMX,VREF,VGRAD,VSEA,THICK,VHALF !LIN GRADIENT MODELS WRITE (14) POSM,POSB,MODSAL !P/S VELOCITY RELATION WRITE (14) LELEV !HYPOELLIPSE MODEL INFO CLOSE (14) GOTO 5 C-- READ BINARY SNAPSHOT OF ALL CRUST MODELS C--(REPLACES CRT,CRH,CRE,CRL,CRV,NOD,MUL,ALT,POS,PSM) 220 IF (LINST) THEN CALL ASKC ('CRUST MODEL SNAPSHOT FILE TO READ',BCRUFL) ELSE READ (INST,*,ERR=3) BCRUFL END IF CALL OPENR (14,BCRUFL,'U',IOS) IF (IOS.NE.0) THEN WRITE (6,'('' *** ERROR - CRUST SNAPSHOT FILE NOT FOUND'')') IRES=-72 GOTO 5 END IF READ (14) MODTYP,MODNAM,CRODE,MAXMOD !MODEL INFO READ (14) MODALT,LMULT,MODDEF READ (14) LAY,VEL,VSQ,D,THK !LAYER MODELS READ (14) DD1,ND1,ND,DD2,ND2,GD1,GD2 !TRAVEL TIME TABLES READ (14) DZ1,NZ1,NZ,DZ2,NZ2,GZ1,GZ2,REDV READ (14) KDHR READ (14) KT READ (14) NNODE,HLAT,HLON,RAD1,RAD2,DRAD,MODH !NODES READ (14) ELEVMX,VREF,VGRAD,VSEA,THICK,VHALF !LIN GRADIENT MODELS READ (14) POSM,POSB,MODSAL !P/S VELOCITY RELATION READ (14) LELEV !HYPOELLIPSE MODEL INFO LBCRU=.TRUE. WRITE (6,'(I6,'' CRUST MODELS READ IN BINARY'')') MAXMOD CLOSE (14) C--COMPUTE ARRAYS FOR REFRACTION CALCULATIONS (FROM HYPOEL INPUT SUB) C THAT ARE NOT STORED IN THE BINARY FILE. THESE ARRAYS ALSO CALCULATED C IN HYCRE WHEN MODEL READ IN C DO THIS FOR ALL MODELS OF TYPE 4. MOD IS THE MODEL # PASSED THRU COMMON DO I=1,MAXMOD MOD=I IF (MODTYP(MOD).EQ.4) CALL HYCRE2 END DO GOTO 5 C-- WRITE BINARY SNAPSHOT OF ALL STATION DATA 224 IF (LINST) THEN CALL ASKC ('STATION DATA SNAPSHOT FILE TO WRITE',BSTAFL) ELSE READ (INST,*,ERR=3) BSTAFL END IF CALL OPENW (14,BSTAFL,'U',IOS,'S') WRITE (14) JSTA,STANAM,JNET,JCOMP1,JCOMP3 WRITE (14) JLATD,JLATM,JLOND,JLONM WRITE (14) JCAL,JLMOD,JFCOR,JXCOR,JPSWT,JXWT,JFWT,STRMK,JPD WRITE (14) JTYPE,JSLOC,JSLOC2,JFGWT,JCOMPA WRITE (14) JELEV,JPER CLOSE (14) GOTO 5 C-- READ BINARY SNAPSHOT OF ALL STATION DATA (REPLACES STA, DEL COMMANDS) 228 IF (LINST) THEN CALL ASKC ('STATION DATA SNAPSHOT FILE TO READ',BSTAFL) ELSE READ (INST,*,ERR=3) BSTAFL END IF CALL OPENR (14,BSTAFL,'U',IOS) IF (IOS.NE.0) THEN WRITE (6,'('' *** ERROR - STATION SNAPSHOT FILE NOT FOUND'')') IRES=-73 GOTO 5 END IF READ (14) JSTA,STANAM,JNET,JCOMP1,JCOMP3 READ (14) JLATD,JLATM,JLOND,JLONM READ (14) JCAL,JLMOD,JFCOR,JXCOR,JPSWT,JXWT,JFWT,STRMK,JPD READ (14) JTYPE,JSLOC,JSLOC2,JFGWT,JCOMPA READ (14) JELEV,JPER LBSTA=.TRUE. WRITE (6,'(I6,'' STATIONS READ IN BINARY'')') JSTA CLOSE (14) GOTO 5 C-- SET STRINGS FOR READING & MAKING INTERACTIVE PROCESSING FILENAMES 232 IF (LINST) THEN WRITE (6,1232) 1232 FORMAT (' I/O FILENAMES ARE MADE FROM A BASE NAME AND', 2 ' AND EXTENSION.'/' USE THE EXTENSION "NONE" TO DISABLE.') CALL ASKC ('FILE TO READ BASE EVENT NAMES',LSTFIL) NCBASE=JASK('NO. OF CHARS TO READ FOR BASE NAMES',NCBASE) CALL ASKC ('FORMAT FOR READING BASE EVENT NAMES',LSTFOR) CALL ASKC ('PHASE FILE EXTENSION',EXTPHS) CALL ASKC ('ARCHIVE FILE EXTENSION',EXTARC) CALL ASKC ('SUMMARY FILE EXTENSION',EXTSUM) CALL ASKC ('PRINTOUT FILE EXTENSION',EXTPRT) WRITE (6,1233) 1233 FORMAT (' VAX EDITOR: 1=EDT 2=GENERAL ED'/ 2 ' SUN EDITOR: 1=DTPAD 2=VI 3=TEXTEDIT') IEDFLG=JASK('EDITOR',IEDFLG) ELSE READ (INST,*,IOSTAT=IOS) LSTFIL,NCBASE,LSTFOR, EXTPHS, 2 EXTARC,EXTSUM,EXTPRT,IEDFLG IF (IOS.NE.0) GOTO 3 END IF LARC=EXTARC(1:4).NE.'NONE' .AND. EXTARC(1:4).NE.'none' LSUM=EXTSUM(1:4).NE.'NONE' .AND. EXTSUM(1:4).NE.'none' LPRT=EXTPRT(1:4).NE.'NONE' .AND. EXTPRT(1:4).NE.'none' GOTO 5 C-- GO DO INTERACTIVE PROCESSING 236 CALL HYPRO GOTO 5 C-- GET STATION COMPONENTS TO USE FOR 1ST DURATION MAGNITUDE 240 IF (LINST) THEN CALL ASKC('1-LETTER LABEL CODE FOR FMAG1',LABF1) IF (NCPF1.EQ.0) THEN WRITE (6, 2 '('' NO COMPONENTS USED TO CALCULATE FIRST DUR MAG'')') ELSE IF (NCPF1.GT.0) THEN WRITE (6,2400) NCPF1,(COMPF1(I),I=1,NCPF1) 2400 FORMAT (I3,' COMPONENTS USED TO CALCULATE FIRST DUR MAG:'/, 2 20(1X,A3)) ELSE WRITE (6,*)' ALL COMPONENTS USED TO CALCULATE FIRST DUR MAG' END IF NCPF1=JASK 1 ('NO. OF COMPONENTS TO USE FOR FMAG1 (-1=ALL, OR 0-20)' 2 ,NCPF1) IF (NCPF1.GT.20) THEN WRITE (6,*) ' *** ERROR-TOO MANY FC1 COMPONENTS REQUESTED' GOTO 5 END IF IF (NCPF1.GT.0) THEN DO I=1,NCPF1 CALL ASKC('COMPONENT FOR FMAG1 (I.E. VHZ)',COMPF1(I)) END DO END IF ELSE READ (INST,*,IOSTAT=IOS) LABF1,NCPF1 IF (IOS.NE.0) GOTO 3 IF (NCPF1.GT.20) THEN WRITE (6,*) ' *** ERROR-TOO MANY FC1 COMPONENTS REQUESTED' GOTO 5 END IF IF (NCPF1.GT.0) READ (INST,*,IOSTAT=IOS) LABF1,NCPF1, 2 (COMPF1(I),I=1,NCPF1) IF (IOS.NE.0) GOTO 3 END IF C--BLANK OUT REMAINING COMPONENTS TO SELECT ON IF (NCPF1.GE.0) THEN DO I=NCPF1+1,20 COMPF1(I)=' ' END DO END IF GOTO 5 C-- GET STATION COMPONENTS TO USE FOR 2ND DURATION MAGNITUDE 244 IF (LINST) THEN CALL ASKC('1-LETTER LABEL CODE FOR FMAG2',LABF2) IF (NCPF2.EQ.0) THEN WRITE (6, 2 '('' NO COMPONENTS USED TO CALCULATE SECOND DUR MAG'')') ELSE IF (NCPF2.GT.0) THEN WRITE (6,2400) NCPF2,(COMPF2(I),I=1,NCPF2) 2440 FORMAT (I3,' COMPONENTS USED TO CALCULATE SECOND DUR MAG:'/, 2 20(1X,A3)) ELSE WRITE (6, 2 '('' ALL COMPONENTS USED TO CALCULATE SECOND DUR MAG'')') END IF NCPF2=JASK 1 ('NO. OF COMPONENTS TO USE FOR FMAG2 (-1=ALL, OR 0-20)' 2 ,NCPF2) IF (NCPF2.GT.20) THEN WRITE (6,*) ' *** ERROR-TOO MANY FC2 COMPONENTS REQUESTED' GOTO 5 END IF IF (NCPF2.GT.0) THEN DO I=1,NCPF2 CALL ASKC('COMPONENT FOR FMAG2 (I.E. VLZ)',COMPF2(I)) END DO END IF ELSE READ (INST,*,IOSTAT=IOS) LABF2,NCPF2 IF (IOS.NE.0) GOTO 3 IF (NCPF2.GT.20) THEN WRITE (6,*) ' *** ERROR-TOO MANY FC2 COMPONENTS REQUESTED' GOTO 5 END IF IF (NCPF2.GT.0) READ (INST,*,IOSTAT=IOS) LABF2,NCPF2, 2 (COMPF2(I),I=1,NCPF2) IF (IOS.NE.0) GOTO 3 END IF C--BLANK OUT REMAINING COMPONENTS TO SELECT ON IF (NCPF2.GE.0) THEN DO I=NCPF2+1,20 COMPF2(I)=' ' END DO END IF GOTO 5 C-- GET STATION COMPONENTS TO USE FOR 1ST AMPLITUDE MAGNITUDE 248 IF (LINST) THEN CALL ASKC('1-LETTER LABEL CODE FOR XMAG1',LABX1) IF (NCPX1.EQ.0) THEN WRITE (6, 2 '('' NO COMPONENTS USED TO CALCULATE FIRST AMP MAG'')') ELSE IF (NCPX1.GT.0) THEN WRITE (6,2400) NCPX1,(COMPX1(I),I=1,NCPX1) 2480 FORMAT (I3,' COMPONENTS USED TO CALCULATE FIRST AMP MAG: '/, 2 20(1X,A3)) ELSE WRITE (6, 2 '('' ALL COMPONENTS USED TO CALCULATE FIRST AMP MAG'')') END IF NCPX1=JASK 1 ('NO. OF COMPONENTS TO USE FOR XMAG1 (-1=ALL, OR 0-20)' 2 ,NCPX1) IF (NCPX1.GT.20) THEN WRITE (6,*) ' *** ERROR-TOO MANY XC1 COMPONENTS REQUESTED' GOTO 5 END IF IF (NCPX1.GT.0) THEN DO I=1,NCPX1 CALL ASKC('COMPONENT FOR XMAG1 (I.E. VHZ)',COMPX1(I)) END DO END IF ELSE READ (INST,*,IOSTAT=IOS) LABX1,NCPX1 IF (IOS.NE.0) GOTO 3 IF (NCPX1.GT.20) THEN WRITE (6,*) ' *** ERROR-TOO MANY XC1 COMPONENTS REQUESTED' GOTO 5 END IF IF (NCPX1.GT.0) READ (INST,*,IOSTAT=IOS) LABX1,NCPX1, 2 (COMPX1(I),I=1,NCPX1) IF (IOS.NE.0) GOTO 3 END IF C--BLANK OUT REMAINING COMPONENTS TO SELECT ON IF (NCPX1.GE.0) THEN DO I=NCPX1+1,20 COMPX1(I)=' ' END DO END IF GOTO 5 C-- GET STATION COMPONENTS TO USE FOR 2ND AMPLITUDE MAGNITUDE 252 IF (LINST) THEN CALL ASKC('1-LETTER LABEL CODE FOR XMAG2',LABX2) IF (NCPX2.EQ.0) THEN WRITE (6, 2 '('' NO COMPONENTS USED TO CALCULATE SECOND AMP MAG'')') ELSE IF (NCPX2.GT.0) THEN WRITE (6,2400) NCPX2,(COMPX2(I),I=1,NCPX2) 2520 FORMAT (I3,' COMPONENTS USED TO CALCULATE SECOND AMP MAG:'/, 2 20(1X,A3)) ELSE WRITE (6, 2 '('' ALL COMPONENTS USED TO CALCULATE SECOND AMP MAG'')') END IF NCPX2=JASK 1 ('NO. OF COMPONENTS TO USE FOR XMAG2 (-1=ALL, OR 0-20)' 2 ,NCPX2) IF (NCPX2.GT.20) THEN WRITE (6,*) ' *** ERROR-TOO MANY XC2 COMPONENTS REQUESTED' GOTO 5 END IF IF (NCPX2.GT.0) THEN DO I=1,NCPX2 CALL ASKC('COMPONENT FOR XMAG2 (I.E. WLN)',COMPX2(I)) END DO END IF ELSE READ (INST,*,IOSTAT=IOS) LABX2,NCPX2 IF (IOS.NE.0) GOTO 3 IF (NCPX2.GT.20) THEN WRITE (6,*) ' *** ERROR-TOO MANY XC2 COMPONENTS REQUESTED' GOTO 5 END IF IF (NCPX2.GT.0) READ (INST,*,IOSTAT=IOS) LABX2,NCPX2, 2 (COMPX2(I),I=1,NCPX2) IF (IOS.NE.0) GOTO 3 END IF C--BLANK OUT REMAINING COMPONENTS TO SELECT ON IF (NCPX2.GE.0) THEN DO I=NCPX2+1,20 COMPX2(I)=' ' END DO END IF GOTO 5 C-- ADDITIONAL TERMS FOR CODA MAGNITUDE RELATION 256 IF (LINST) THEN DCOFM1=ASKR('COEFF. OF DDBRKM2 FMAG DIST TERM',DCOFM2) DBRKM2=ASKR('START DIST OF D>DBRKM2 FMAG DIST TERM',DBRKM2) ZCOFM=ASKR('COEFF. OF Z>ZBRKM FMAG DEPTH TERM',ZCOFM) ZBRKM=ASKR('START DEPTH OF Z>ZBRKM FMAG DEPTH TERM',ZBRKM) ELSE READ (INST,*,IOSTAT=IOS) DCOFM1,DBRKM1,DCOFM2,DBRKM2, 2 ZCOFM,ZBRKM IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- COMPONENT CORRECTIONS FOR CODA MAGNITUDES 260 IF (LINST) THEN NFCM=JASK( 2 'NO. (0-10) OF COMPONENTS TO HAVE INDEP. FMAG CORRECTIONS',NFCM) IF (NFCM.GT.10) THEN WRITE (6,*) ' *** ERROR-TOO MANY XCM COMPONENTS REQUESTED' GOTO 5 END IF DO I=1,NFCM CALL ASKC('COMPONENT TO CORRECT',CFCM(I)) AFCM(I)=ASKR('CORRECTION FOR ABOVE COMPONENT',AFCM(I)) END DO ELSE READ (INST,*,ERR=3) NFCM IF (NFCM.GT.10) THEN WRITE (6,*) ' *** ERROR-TOO MANY XCM COMPONENTS REQUESTED' GOTO 5 END IF IF (NFCM.GT.0) 2 READ (INST,*,IOSTAT=IOS) NFCM,(CFCM(I),AFCM(I),I=1,NFCM) IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C-- COMPONENT CORRECTIONS FOR AMPLITUDE MAGNITUDES 264 IF (LINST) THEN NXCM=JASK( 2 'NO. (0-10) OF COMPONENTS TO HAVE INDEP. XMAG CORRECTIONS',NXCM) IF (NXCM.GT.10) THEN WRITE (6,*) ' *** ERROR-TOO MANY XCM COMPONENTS REQUESTED' GOTO 5 END IF DO I=1,NXCM CALL ASKC('COMPONENT TO CORRECT',CXCM(I)) AXCM(I)=ASKR('CORRECTION FOR ABOVE COMPONENT',AXCM(I)) END DO ELSE READ (INST,*,ERR=3) NXCM IF (NXCM.GT.10) THEN WRITE (6,*) ' *** ERROR-TOO MANY XCM COMPONENTS REQUESTED' GOTO 5 END IF IF (NXCM.GT.0) 2 READ (INST,*,IOSTAT=IOS) NXCM,(CXCM(I),AXCM(I),I=1,NXCM) IF (IOS.NE.0) GOTO 3 END IF GOTO 5 c-- INITIALIZE HYPOINVERSE BY EXECUTING A STANDARD COMMAND FILE. C THE NAME OF THE COMMAND FILE IS ASSIGNED BY THE ENVIRONMENT VARIABLE C "HYPINITFILE1.3". 268 CALL GETENV ('HYPINITFILE1.3',TEMPSTR) IF (TEMPSTR.EQ.' ') THEN WRITE (6,1268) 1268 FORMAT(' ENVIRONMENT VARIABLE "HYPINITFILE1.3" FOR STARTUP FILE ', 2 ' NOT FOUND.'/' LETS TRY A STANDARD FILENAME.'/ 3 ' IN THE FUTURE YOU SHOULD DEFINE IT LIKE THIS:'/ 4 ' On andreas:'/ 5 ' setenv HYPINITFILE1.3 /home/ehz/klein/hypfiles/cal20001.3.hyp') c 6 ' On swave:'/ c 7 ' setenv HYPINITFILE /home1/calnet/klein/hypfiles/cal2000.hyp') TEMPSTR=INFILE(0) END IF C--THIS CASE SHOULD ONLY OCCUR IN THE VAX VERSION, WITH NO ENV. VARIABLE SET IF (TEMPSTR.EQ.'VAX') THEN TEMPSTR=INFILE(0) END IF WRITE (6,'('' INITIALIZING WITH COMMAND FILE:''/1X,A)') TEMPSTR CM=('@'//TEMPSTR(1:2)) INST=TEMPSTR(3:60) GOTO 6 C-- SET THE NUMBER OF LETTERS TO MATCH IN STA, NET & COMP CODES 272 IF (LINST) THEN NSTLET=JASK 2 ('NUMBER OF LETTERS TO CHECK IN STATION SITE CODE (2-5)',NSTLET) NETLET=JASK 2 ('NUMBER OF LETTERS TO CHECK IN STATION NET CODE (0-2)', 3 NETLET) NCOMP=JASK 2 ('NO. OF LETTERS TO CHECK IN STATION COMPONENT CODE (0-3)', 3 NCOMP) NSLOC=JASK 2 ('NO. OF LETS TO CHECK IN LOCATION CODE IN PHASE FILES (0-2)', 3 NSLOC) NSLOC2=JASK 2 ('NO. OF LETS TO CHECK IN LOCATION CODE IN OTHER FILES (0-2)', 3 NSLOC2) ELSE C--IF NSLOC IS NOT SUPPLIED, ASSUME IT IS ZERO AND DO NOT ISSUE WARNING YET READ (INST,*,ERR=273) NSTLET, NETLET, NCOMP, NSLOC, NSLOC2 GOTO 274 273 READ (INST,*,IOSTAT=IOS) NSTLET, NETLET, NCOMP IF (IOS.NE.0) GOTO 3 WRITE (6,*) 2 ' * WARNING: SUPPLY NO. OF LOCATION LETTERS IN LET COMMAND' NSLOC=0 END IF 274 IF (NSLOC.LT.NSLOC2) THEN WRITE (6,*) 2 ' *** ERROR: MUST CHECK AS MANY LOCATION LETTERS IN PHASE FILES' WRITE (6,*)' AS IN MAG CORRECTION AND CALIBRATION FILES (LET).' END IF GOTO 5 C-- ASK WHETHER COMPONENT IS FROM 1-LET OR 3-LET FIELD. 276 WRITE (6,*) '*** LES COMMAND NO LONGER USED' GOTO 5 C-- SECOND DURATION MAG CONSTANTS 280 IF (LINST) THEN WRITE (6,1272) 1272 FORMAT (' CONSTANTS FOR SECOND DUR MAG. NOTE: NO COMPONENT,'/ 2 ' ADDITIONAL DEPTH OR DISTANCE CORRECTIONS USED.') WRITE (6,1274) 1274 FORMAT (' MAG CONSTANTS FOR DUR < FMBRKB:') FMA1B=ASKR('CONSTANT FMA1B',FMA1B) FMB1B=ASKR('LOG TERM FMB1B',FMB1B) FMZ1B=ASKR('DEPTH TERM FMZ1B',FMZ1B) FMD1B=ASKR('DIST TERM FMD1B',FMD1B) FMF1B=ASKR('LINEAR TERM FMF1B',FMF1B) WRITE (6,1273) 1273 FORMAT (' MAG CONSTANTS FOR DUR > FMBRKB:') FMA2B=ASKR('CONSTANT FMA2B',FMA2B) FMB2B=ASKR('LOG TERM FMB2B',FMB2B) FMZ2B=ASKR('DEPTH TERM FMZ2B',FMZ2B) FMD2B=ASKR('DIST TERM FMD2B',FMD2B) FMF2B=ASKR('LINEAR TERM FMF2B',FMF2B) FMBRK=ASKR('FMBRKB',FMBRKB) FMGNB=ASKR('USE GAIN CORRECTION 0=NO 1=YES',FMGNB) ELSE READ (INST,*,IOSTAT=IOS) FMA1B,FMB1B,FMZ1B,FMD1B,FMF1B, 2 FMA2B,FMB2B,FMZ2B,FMD2B,FMF2B, FMBRKB,FMGNB IF (IOS.NE.0) GOTO 3 END IF GOTO 5 C--
 SET MAGNITUDE PREFERENCE ORDER FOR PREFERRED MAGNITUDE
284   IF (LINST) THEN
        WRITE (6,*) ' SET MAGNITUDE PREFERENCE ORDER. THE MAGS ARE:'
        WRITE (6,*)
     2  ' 1=FMAG 2=XMAG 3=BMAG 4=XMAG2 5=FMAG2'
C     2  ' 1=FMAG 2=XMAG 3=BMAG 4=XMAG2 5=FMAG2 6=PAMAG1 7=PAMAG2'
        NMAGS=JASK
     2  ('NUMBER OF MAGNITUDES ELIGIBLE FOR PREFERRED MAG (0-10)',
     3  NMAGS)
        DO I=1,NMAGS
          WRITE (6,*)
          WRITE (6,*) ' MAGNITUDE FOR CHOICE NUMBER',I,':'
          MPREF(I)=JASK('MAGNITUDE CHOICE (I.E. 1=FMAG)',MPREF(I))
          MNPREF(I)=JASK('MINIMUM READINGS TO CHOOSE THIS MAG',
     2    MNPREF(I))
          AMPREF(I)=ASKR('MINIMUM MAG VALUE TO CHOOSE THIS MAG',
     2    AMPREF(I))
          AXPREF(I)=ASKR('MAXIMUM MAG VALUE TO CHOOSE THIS MAG',
     2    AXPREF(I))
        END DO
      ELSE
        READ (INST,*,ERR=3) NMAGS
        IF (NMAGS.GT.0) THEN
          READ (INST,*,IOSTAT=IOS) NMAGS,
     2    (MPREF(I),MNPREF(I),AMPREF(I),AXPREF(I),I=1,NMAGS)
          IF (IOS.NE.0) GOTO 3
        END IF
      END IF
      GOTO 5

C-- SELECT COMPONENTS FOR UNIQUE LOGA0 RELATIONS IN AMP MAGS
288   IF (LINST) THEN
        NLA0=JASK('NUMBER OF COMPS WITH UNIQUE LOGA0s (0-20)',NLA0)
        IF (NLA0.GT.0) THEN
          WRITE (6,1096) 
          DO I=1,NLA0
            WRITE (6,*) ' COMPONENT NUMBER ',I
            CALL ASKC('COMPONENT CODE',CLA0(I))
            MLA0(I)=JASK('LOG(A0) RELATION FOR THIS COMPONENT',MLA0(I))
          END DO
        END IF
      ELSE

        READ (INST,*,ERR=3) NLA0
        IF (NLA0.GT.0) THEN
          READ(INST,*,IOSTAT=IOS)NLA0,(CLA0(I),MLA0(I),I=1,NLA0)
          IF (IOS.NE.0) GOTO 3
        END IF
      END IF
      GOTO 5

C-- SET FLAGS FPR PMAG PROCESSING
292   IF (LINST) THEN
        LPMAG =LASK('COMPUTE PMAG FROM P AMPS ON SHADOW CARDS',LPMAG)
        LPPRT =LASK('PRINT PMAG INFO IN PRINT FILE STATION LISTING',
     2  LPPRT)
        WRITE (6,
     2  '('' ENTER DEVELOCORDER MM PER COUNT UNIT FOR P-MAGS'')')
        CNT2MD=ASKR('DEFAULT VALUE (RTP=.04, EARTHWORM=.0488)',CNT2MD)

        WRITE (6,2920)
2920    FORMAT (' FRACTION OF CLIPPED PMAGS FOR DECLARING EVENT PMAG')
        CLPRAT=ASKR('A MINIMUM (CLIPPED) VALUE',CLPRAT)
        WRITE (6,1096)
        LATYPP=JASK('LOG(A0) RELATION FOR P MAGS',LATYPP)
      ELSE
        READ (INST,*,IOSTAT=IOS) LPMAG,LPPRT,CNT2MD,CLPRAT,LATYPP
        IF (IOS.NE.0) GOTO 3
      END IF

C--ERROR TO PRINT MAG WITHOUT COMPUTING IT
      IF (LPPRT .AND. .NOT.LPMAG) WRITE (6,1293)
1293  FORMAT (' *** ERROR: YOU MUST COMPUTE PMAGS BEFORE',
     2 ' YOU CAN PRINT THEM')

C--IF PMAG PROCESSING IS SELECTED, CHECK WHETHER SHADOW CARDS ARE USED
      IF (LPMAG .AND. JCP.NE.5) WRITE (6,1292)
1292  FORMAT (' *** WARNING: TO COMPUTE PMAGS, BE SURE ARCHIVE SHADOW'/
     2 ' FORMATS ARE SELECTED WITH "COP 5" AND "CAR 3".')
      GOTO 5

C-- PRIMARY P AMPLITUDE MAGNITUDE COMPONENT WEIGHTS
296   IF (LINST) THEN
        WRITE (6,1296)
1296    FORMAT (' SET COMPONENTS WITH PRIMARY PMAG WEIGHTS',
     2  ' DIFFERENT FROM 1.0')
        NPWM=JASK
     1  ('NO. OF COMPONENTS WITH DEFINED PMAG WEIGHTS (0-10)'
     2  ,NPWM)
        IF (NPWM.GT.0) THEN
          DO I=1,NPWM
            WRITE (6,'('' COMPONENT NUMBER'',I3)') I
            CALL ASKC('COMPONENT CODE (I.E. VHZ)',CPWM(I))
            WPWM(I)=ASKR('WEIGHT FOR THIS COMPONENT (0.-5.)',
     2      WPWM(I))
          END DO
        END IF
      ELSE

        READ (INST,*,ERR=3) NPWM
        IF (NPWM.GT.0) THEN
          READ (INST,*,IOSTAT=IOS) NPWM,
     2    (CPWM(I),WPWM(I),I=1,NPWM)
          IF (IOS.NE.0) GOTO 3
        END IF
      END IF
      GOTO 5

C-- PRIMARY P AMP MAGNITUDE SELECTION BY COMPONENT
300   IF (LINST) THEN
        CALL ASKC('1-LETTER LABEL CODE FOR PRIMARY PMAG',LABP1)

        PMA1=ASKR('A VALUE IN PMAG1(OUT)= A +B*PMAG1(CALC)',PMA1)
        PMB1=ASKR('B VALUE IN PMAG1(OUT)= A +B*PMAG1(CALC)',PMB1)

        IF (NCPP1.EQ.0) THEN
          WRITE (6,
     2    '('' NO COMPONENTS NOW USED TO CALCULATE PRIMARY P MAG'')')
        ELSE IF (NCPP1.GT.0) THEN
          WRITE (6,3000) NCPP1,(COMPP1(I),I=1,NCPP1)
3000      FORMAT (I3,' COMPONENTS USED TO CALCULATE FIRST DUR MAG:'/,
     2    10(1X,A3))
        ELSE
          WRITE (6,
     2    '('' ALL COMPONENTS NOW USED TO CALCULATE PRIMARY P MAG'')')
        END IF

        NCPP1=JASK(
     2 'NO. OF COMPONENTS TO USE FOR PMAG1 (-1=ALL, OR 0-10)',NCPP1)
        IF (NCPP1.GT.0) THEN
          DO I=1,NCPP1
            CALL ASKC('COMPONENT FOR PMAG1 (I.E. VHZ)',COMPP1(I))
          END DO
        END IF
      ELSE

        READ (INST,*,ERR=3) LABP1,PMA1,PMB1,NCPP1
        IF (NCPP1.GT.0) READ (INST,*,ERR=3) LABP1,PMA1,PMB1,NCPP1,
     2  (COMPP1(I),I=1,NCPP1)
      END IF

C--BLANK OUT REMAINING COMPONENTS TO SELECT ON
      IF (NCPP1.GE.0) THEN
        DO I=NCPP1+1,10
          COMPP1(I)='   '
        END DO
      END IF
      GOTO 5

C-- PRIMARY P AMP MAGNITUDE SELECTION BY COMPONENT
304   IF (LINST) THEN
        CALL ASKC('1-LETTER LABEL CODE FOR SECONDARY PMAG',LABP2)

        PMA2=ASKR('A VALUE IN PMAG2(OUT)= A +B*PMAG2(CALC)',PMA2)
        PMB2=ASKR('B VALUE IN PMAG2(OUT)= A +B*PMAG2(CALC)',PMB2)

        IF (NCPP2.EQ.0) THEN
          WRITE (6,
     2    '('' NO COMPONENTS NOW USED TO CALCULATE SECONDARY P MAG'')')
        ELSE IF (NCPP2.GT.0) THEN
          WRITE (6,3040) NCPP2,(COMPP2(I),I=1,NCPP2)
3040      FORMAT (I3,' COMPONENTS USED TO CALC. SECONDARY DUR MAG:'/,
     2    10(1X,A3))
        ELSE
          WRITE (6,
     2    '('' ALL COMPONENTS NOW USED TO CALCULATE SECONDARY P MAG'')')
        END IF

        NCPP2=JASK(
     2 'NO. OF COMPONENTS TO USE FOR PMAG2 (-1=ALL, OR 0-10)',NCPP2)
        IF (NCPP2.GT.0) THEN
          DO I=1,NCPP2
            CALL ASKC('COMPONENT FOR PMAG2 (I.E. VLZ)',COMPP2(I))
          END DO
        END IF
      ELSE

        READ (INST,*,ERR=3) LABP2,PMA2,PMB2,NCPP2
        IF (NCPP2.GT.0) READ (INST,*,ERR=3) LABP2,PMA2,PMB2,NCPP2,
     2  (COMPP2(I),I=1,NCPP2)
      END IF

C--BLANK OUT REMAINING COMPONENTS TO SELECT ON
      IF (NCPP2.GE.0) THEN
        DO I=NCPP2+1,10
          COMPP2(I)='   '
        END DO
      END IF
      GOTO 5

C-- SPECIFY COUNT-TO-MM CONVERSION FACTORS BY DATA SOURCES
308   IF (LINST) THEN
        WRITE (6,3080)
3080    FORMAT (' ENTER DEVELOCORDER MM PER COUNT UNIT (C-FACTORS)',
     2  ' FOR P-MAGS, BY DATA SOURCE.'/
     3  ' ENTER NUMBER OF DATA-SOURCE SPECIFIC C-FACTORS (0-10).')
        NCNTMM=JASK(
     2  ' ENTER 0 TO USE DEFAULT VALUE FROM PMA COMMAND FOR ALL COMPS',
     3  NCNTMM)
        DO I=1,NCNTMM
          WRITE (6,*) ' DATA SOURCE NUMBER',I,':'
          CALL ASKC('DATA SOURCE CODE (IE. W)',CCNTMM(I))
          CNT2MM(I)=ASKR
     2    ('C-FACTOR VALUE (RTP=.04, EARTHWORM=.0488)',CNT2MM(I))
        END DO

      ELSE
        READ (INST,*,ERR=3) NCNTMM
        IF (NCNTMM.GT.0) THEN
          READ (INST,*,IOSTAT=IOS) NCNTMM, 
     2    (CCNTMM(I),CNT2MM(I),I=1,NCNTMM)
          IF (IOS.NE.0) GOTO 3
        END IF
      END IF
      GOTO 5

C-- SET A LABEL FOR ENTIRE RUN TO INCLUDE IN OUTPUT FILES
312   IF (LINST) THEN
        CALL ASKC('1-LETTER LABEL FOR RUN, INCLUDED IN OUTPUT FILES',
     2  RUNLAB)
        LP153=LASK(
     2  'F=PUT RUN LABEL IN SUMMARY COL 153, T=PASS COL 153 THRU',LP153)
      ELSE
        READ (INST,*,IOSTAT=IOS) RUNLAB,LP153
        IF (IOS.NE.0) GOTO 3
      END IF
      GOTO 5

C-- DECIDE WHETHER TO KEEP UNRECOGNIZED STATIONS IN ARC OUTPUT FILE
316   IF (LINST) THEN
        LKEEP=LASK('WRITE UNRECOGNIZED STATIONS TO ARCHIVE FILE',LKEEP)
      ELSE
        READ (INST,*,ERR=3) LKEEP
      END IF
      GOTO 5

C-- SET WEIGHTS FOR PHASE WEIGHT CODES 0-3
320   IF (LINST) THEN
        WRITE (6,*) 'ENTER NUMERICAL WEIGHTS FOR PHASE WEIGHT CODES.'
        WRITE (6,*) 'CODES 4-9 ALWAYS HAVE ZERO WEIGHT.'
        DO I=1,4
          WRITE (6,*) 'CODE',I-1
          WTVALS(I)=ASKR('NUMERICAL WEIGHT FOR PHASE',WTVALS(I))
        END DO
      ELSE
        READ (INST,*,ERR=3) WTVALS
      END IF
      GOTO 5

C-- CHOOSE STATIONS FOR THE 2 AMP MAGS BY COMPONENT OR TYPE
324   IF (LINST) THEN
        WRITE (6,*) 'CHOOSE WAY TO SELECT STATIONS FOR 2 AMP MAGS:'
        WRITE (6,*) 'USE XTY COMMAND TO SELECT INST TYPES.'
        LXCH=LASK('T=BY COMPONENT LETTER, F=BY INST TYPE',LXCH)
      ELSE
        READ (INST,*,ERR=3) LXCH
      END IF
      GOTO 5

C-- SET INSTRUMENT TYPE CODES FOR THE 2 AMP MAGS
328   IF (LINST) THEN
        NXTYP1=JASK(
     2 'NUMBER OF INTRUMENT CODES FOR AMP MAG 1 (0-3, -1=ALL)',NXTYP1)
        DO I=1,3
          WRITE (6,*) 'CODE NUMBER',I
          IXTYP1(I)=JASK(
     2    'INSTRUMENT CODE (0=WA, 1=NET, 2=SPRENG 3=NET)',IXTYP1(I))
        END DO

        NXTYP2=JASK(
     2 'NUMBER OF INTRUMENT CODES FOR AMP MAG 2 (0-3, -1=ALL)',NXTYP2)
        DO I=1,3
          WRITE (6,*) 'CODE NUMBER',I
          IXTYP2(I)=JASK(
     2    'INSTRUMENT CODE (0=WA, 1=NET, 2=SPRENG 3=NET)',IXTYP2(I))
        END DO

      ELSE
        READ (INST,*,IOSTAT=IOS)  NXTYP1,(IXTYP1(I),I=1,3),
     2  NXTYP2,(IXTYP2(I),I=1,3)
        IF (IOS.NE.0) GOTO 3
      END IF
      GOTO 5

C--<200> INVOKE YR 2000 FORMATS
332   IF (LINST) THEN
        L2000=LASK('T FOR YR 2000 FORMATS, F=OLD FORMATS',L2000)
        ICENT=JASK('DEFAULT CENTURY FOR OLD PHASE INPUT',ICENT)
        IAMPU=JASK('DEFAULT AMP UNITS CODE FOR OLD PHASE INPUT',
     2  IAMPU)
      ELSE

        READ (INST,*,IOSTAT=IOS) L2000,ICENT,IAMPU
        IF (IOS.NE.0) GOTO 3
      END IF
      GOTO 5

C-- DETERMINE THE PHASE FILE TYPE AND CHANGE I/O FORMATS
336   WRITE (6,*)
     2' FIND INPUT PHASE FILE TYPE & SET PHS(COP) & ARC(CAR) FORMATS'
      CALL OPENR (14,PHSFIL,'F',IOS)
      IF (IOS.NE.0) THEN
        WRITE (6,*) ' *** ERROR - PHASE FILE DOES NOT EXIST ***'
        WRITE (6,*) ' YOU MUST SPECIFY FILE WITH THE PHS COMMAND FIRST'
        GOTO 5
      END IF
      
C--DETERMINE FORMAT BY READING FIRST RECORD OR 2. ALSO FINDS SUMMARY FORMATS.
      CALL HYFILE (14,ITYPE)
      CLOSE (14)
      IF (ITYPE.EQ.-1) THEN
        WRITE (6,*) ' *** ERROR: INPUT PHASE FILE IS EMPTY'
      ELSE IF (ITYPE.EQ.0) THEN
        WRITE (6,*) ' *** ERROR: INPUT PHASE FILE HAS AN UNKNOWN FORMAT'
      ELSE IF (ITYPE.EQ.1) THEN
        WRITE (6,*) 
     2' *** ERROR: INPUT FILE IS A HYPOINVERSE (PRE 2000) SUMMARY FILE'
      ELSE IF (ITYPE.EQ.2) THEN
        WRITE (6,*) 
     2' *** ERROR: INPUT FILE IS A HYPOINVERSE-2000 SUMMARY FILE'
      ELSE IF (ITYPE.EQ.3) THEN
        WRITE (6,*)
     2' *** ERROR: INPUT FILE IS A HYPO71 (PRE 2000) SUMMARY FILE'
      ELSE IF (ITYPE.EQ.4) THEN
        WRITE (6,*) 
     2' *** ERROR: INPUT FILE IS A HYPO71-2000 SUMMARY FILE'
      ELSE IF (ITYPE.EQ.5) THEN
        WRITE (6,*) 
     2' INPUT IS A TRADITIONAL HYPO71-HYPOINVERSE PHASE FILE'
        WRITE (6,*) ' SETTING FORMATS COP 1, CAR 1'
        JCP=1
        JCA=1
      ELSE IF (ITYPE.EQ.6) THEN
        WRITE (6,*) 
     2' INPUT IS A HYPO71-HYPOINVERSE PHASE FILE WITH SHADOW CARDS'
        WRITE (6,*) ' SETTING FORMATS COP 4, CAR 3'
        JCP=4
        JCA=3
 
      ELSE IF (ITYPE.EQ.7) THEN
        WRITE (6,*) 
     2' INPUT IS A HYPOINVERSE ARCHIVE FILE (PRE 2000), NO SHADOWS'
        IF (L2000) THEN
          WRITE (6,*)
     2' *** ERROR: YOU SHOULD RERUN PROGRAM WITHOUT Y2000 FORMATS'
        ELSE
          WRITE (6,*) ' SETTING FORMATS COP 3, CAR 1'
          JCP=3
          JCA=1
        END IF

      ELSE IF (ITYPE.EQ.8) THEN
        WRITE (6,*) 
     2' INPUT IS A HYPOINVERSE ARCHIVE-2000 FILE, NO SHADOWS'
        IF (.NOT.L2000) THEN
          WRITE (6,*)
     2' *** ERROR: YOU SHOULD RERUN PROGRAM WITH Y2000 FORMATS'
        ELSE
          WRITE (6,*) ' SETTING FORMATS COP 3, CAR 1'
          JCP=3
          JCA=1
        END IF

      ELSE IF (ITYPE.EQ.9) THEN
        WRITE (6,*) 
     2' INPUT IS A HYPOINVERSE ARCHIVE FILE (PRE 2000), WITH SHADOWS'
        IF (L2000) THEN
          WRITE (6,*)
     2' *** ERROR: YOU SHOULD RERUN PROGRAM WITHOUT Y2000 FORMATS'
        ELSE
          WRITE (6,*) ' SETTING FORMATS COP 5, CAR 3'
          JCP=5
          JCA=3
        END IF

      ELSE IF (ITYPE.EQ.10) THEN
        WRITE (6,*) 
     2' INPUT IS A HYPOINVERSE ARCHIVE-2000 FILE, WITH SHADOWS'
        IF (.NOT.L2000) THEN
          WRITE (6,*)
     2' *** ERROR: YOU SHOULD RERUN PROGRAM WITH Y2000 FORMATS'
        ELSE
          WRITE (6,*) ' SETTING FORMATS COP 5, CAR 3'
          JCP=5
          JCA=3
        END IF
      END IF
      GOTO 5

C-- GET COMPONENTS TO APPLU DURATION GAIN CORRECTION TO
340   IF (LINST) THEN
        WRITE (6,*) ' -1 APPLY GAIN CORR TO ALL COMPS; 0 NO COMPS;'
        WRITE (6,*) ' 1-10 NUMBER OF COMPONENTS TO CORRECT:'
        IDUG=JASK('NUMBER OF DUR GAIN CORRECTION COMPONENTS',IDUG)
        DO I=1,IDUG
          CALL ASKC('COMPONENT TO APPLY DUR GAIN CORRECTION TO: ',
     2    CDUG(I))
        END DO
      ELSE

        READ (INST,*,ERR=3) IDUG
        IF (IDUG.GT.0) THEN
          READ (INST,*,IOSTAT=IOS) IDUG,(CDUG(I),I=1,IDUG)
          IF (IOS.NE.0) GOTO 3
        END IF
      END IF
      GOTO 5
      
C-- CHOOSE WHICH MAGNITUDE TYPES GO WITH XMAG1 AND XMAG2
344   IF (LINST) THEN
        WRITE (6,*)' CHOOSE TYPES FOR AMP MAGNITUDES 0=ANY 1=ML 2=MX:'
        MAG1TYPX=JASK('TYPE FOR XMAG1',MAG1TYPX)
        MAG2TYPX=JASK('TYPE FOR XMAG2',MAG2TYPX)
      ELSE
        READ (INST,*,IOSTAT=IOS) MAG1TYPX, MAG2TYPX
        IF (IOS.NE.0) GOTO 3
      END IF
      GOTO 5
      
C-- SET SOME DIGITIZER CODES (3-LET IN, 1-LET OUT)
348   WRITE (6,*) ' ***DIG: CUSP PROCESSING NO LONGER SUPPORTED'
C348   IF (LINST) THEN
C        WRITE (6,*)' ENTER DIGITIZER CODES (3-LET IN, 1-LET OUT):'
C        IDIG=JASK('FIRST DIGITIZER CODE TO SET',0)
C        IF (IDIG.LT.1) THEN
C          WRITE (6,*)' CANT BE LESS THAN 1'
C          GOTO 5
C        END IF

C        JDIG=JASK(' LAST DIGITIZER CODE TO SET',0)
C        IF (JDIG.GT.MAXDIG) THEN
C          WRITE (6,*)' CANT BE MORE THAN ',MAXDIG
C          GOTO 5
C        END IF
        
C        DO I=IDIG,JDIG
C          WRITE (6,*)' CODE ',I,' :'
C          CALL ASKC ('INPUT CUSP 3-LETTER CODE:',DIG3(I))
C          CALL ASKC ('OUTPUT 1-LETTER DATA SOURCE CODE:',DIG1(I))
C        END DO
C        GOTO 5
        
C      ELSE
C        READ (INST,*,ERR=3) IDIG,JDIG
C        IF (IDIG.LT.1) THEN
C          WRITE (6,*)' IDIG CANT BE LESS THAN 1'
C          GOTO 5
C        END IF

C        IF (JDIG.GT.MAXDIG) THEN
C          WRITE (6,*)' JDIG CANT BE MORE THAN ',MAXDIG
C          GOTO 5
C        END IF
        
C        READ (INST,*,ERR=3) IDIG,JDIG,(DIG3(I),DIG1(I),I=IDIG,JDIG)
C      END IF
      GOTO 5

C-- SET NUMBER OF DIGITIZER CODES & DEFAULT CODE
352   WRITE (6,*) ' ***DID: CUSP PROCESSING NO LONGER SUPPORTED'
C352   IF (LINST) THEN
C        NDIG=JASK('TOTAL NUMBER OF DIGITIZER CODES (MAX 50)',NDIG)
C        CALL ASKC('DEFAULT SOURCE CODE WHEN DIGITIZER NOT DEFINED',
C     2  DIGDEF)
C      ELSE
C        READ (INST,*,ERR=3) NDIG,DIGDEF
C      END IF
      GOTO 5

C-- PROCESSING DOMAIN & VERSION FOR SUMMARY CARDS & PRINT FILE
354   IF (LINST) THEN
        CALL ASKC ('2-CHAR PROCESSING DOMAIN',CDOMAN)
        CALL ASKC ('2-CHAR PROCESSING VERSION',CPVERS)
      ELSE
        READ (INST,*,IOSTAT=IOS) CDOMAN,CPVERS
        IF (IOS.NE.0) GOTO 3
      END IF
      GOTO 5
      
C-- PARAMETERS FOR A LINEAR GRAD CRUSTAL MODEL (HYPOELLIPSE)
C--MAY NOT NEED THIS OPTION BECAUSE CRV CASE INCLUDES THIS
358   IF (LINST) THEN
        MOD=JASK('SINGLE LINEAR GRADIENT CRUST MODEL NO. (1-36)',1)
        IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146
        IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD

        CALL ASKC('MODEL NAME',MODNAM(MOD))
        ELEVMX(MOD)=ASKR('REFERENCE (MAX) ELEV ABOVE S.L. IN KM',
     2  ELEVMX(MOD))
        VREF(MOD)=ASKR('VELOCITY AT REFERENCE ELEV',VREF(MOD))
        VGRAD(MOD)=ASKR('VELOCITY GRADIENT OF ENTIRE MODEL',VGRAD(MOD))
        LELEV(MOD)=LASK('T TO USE STA ELEVS, F ALL AT REF ELEV',
     2  LELEV(MOD))
      ELSE
        READ (INST,*,ERR=3) MOD
        IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146
        IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD
        READ (INST,*,IOSTAT=IOS) MOD,MODNAM(MOD),ELEVMX(MOD),
     2  VREF(MOD),VGRAD(MOD),LELEV(MOD)
        IF (IOS.NE.0) GOTO 3
      END IF
      CRODE(MOD)=MODNAM(MOD)(1:3)
      MODTYP(MOD)=3
C--SET THE LARGEST MODEL NUMBER
      IF (MOD.GT.MAXMOD) MAXMOD=MOD
      GOTO 5

C-- PARAMETERS FOR A LINEAR GRAD OVER HALFSPACE MODEL (HYPOELLIPSE)
362   IF (LINST) THEN
        MOD=JASK('LINEAR GRADIENT OVER HALFSPACE MODEL NO. (1-36)',1)
        IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146
        IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD

        CALL ASKC('MODEL NAME',MODNAM(MOD))
        VSEA(MOD)=ASKR('VELOCITY AT SEA LEVEL ELEV (KM/S)',VSEA(MOD))
        VGRAD(MOD)=ASKR('VELOCITY GRADIENT OF LAYER',VGRAD(MOD))
        THICK(MOD)=ASKR('THICKNESS OF GRADIENT LAYER (KM)',THICK(MOD))
        VHALF(MOD)=ASKR('VELOCITY OF HALFSPACE',VHALF(MOD))
        ELEVMX(MOD)=ASKR('REFERENCE (MAX) ELEV ABOVE S.L. IN KM',
     2  ELEVMX(MOD))
        LELEV(MOD)=LASK('T TO USE STA ELEVS, F ALL AT SEA LEVEL',
     2  LELEV(MOD))
      ELSE
        READ (INST,*,ERR=3) MOD
        IF (MOD.LT.1 .OR. MOD.GT.LH) GOTO 146
        IF (MODTYP(MOD).GE.0) WRITE (6,1018) MOD
        READ(INST,*,IOSTAT=IOS) MOD,MODNAM(MOD),VSEA(MOD),
     2  VGRAD(MOD),THICK(MOD),VHALF(MOD),ELEVMX(MOD),LELEV(MOD)
        IF (IOS.NE.0) GOTO 3
      END IF
      CRODE(MOD)=MODNAM(MOD)(1:3)
      MODTYP(MOD)=2

C--SET THE LARGEST MODEL NUMBER
      IF (MOD.GT.MAXMOD) MAXMOD=MOD
C--WARN THAT THERE IS A LOW VELOCITY ZONE BELOW THE GRADIENT LAYER
      TEMP=VSEA(MOD) +VGRAD(MOD)*THICK(MOD)
      IF (TEMP.GT.VHALF(MOD)) THEN
        WRITE (6,*) ' *** VELOCITY AT BASE OF GRADIENT LAYER: ',TEMP
        WRITE (6,*) ' EXCEEDS HALF SPACE VELOCITY: ',VHALF(MOD)
      END IF
      GOTO 5

C-- SPECIFY AN S MODEL ALTERNATE TO A P MODEL
366   IF (LINST) THEN
C--LIST EXISTING P AND S MODEL PAIRS:
        WRITE (6,1366)
1366    FORMAT 
     2  (' EXISTING PAIRS, IF ANY, OF P MODEL NUMBER & ITS S MODEL:')
        DO I=1,MAXMOD
          IF (MODSAL(I).GT.0) WRITE (6,'(2I4)') I,MODSAL(I)
        END DO

        I=JASK('PRIMARY P MODEL NUMBER TO HAVE AN S MODEL',1)
        J=MODSAL(I)
        MODSAL(I)=JASK('S MODEL NO. (0 FOR NONE)',J)
      ELSE
        READ (INST,*,IOSTAT=IOS) I,MODSAL(I)
        IF (IOS.NE.0) GOTO 3
      END IF

C--BE SURE THE P/S VELOCITY RATIO IS SET TO 1 FOR S MODELS
      IF (MODSAL(I).GT.0) THEN
        POSM(I)=1.
        POSB(I)=0.
      END IF
C--TEST TO BE SURE P AND S MODELS ARE OF THE SAME TYPE
      IF (MODSAL(I).NE.0) THEN
        IF (MODTYP(I) .NE. MODTYP(MODSAL(I))) THEN
          WRITE (6,2366) I,MODNAM(I),MODSAL(I),MODNAM(MODSAL(I))
2366      FORMAT ('*** WARNING. P & S MODELS',2(/,I3,2X,A),/,
     2    ' ARE OF DIFFERENT TYPES')
        END IF
      END IF
      GOTO 5

C-- PARAMETERS FOR 2ND FMAG (FMAG2) IN GEOGRAPHIC BOX
370   IF (LINST) THEN
        USEMAR=LASK ('T FOR FMAG2 IN A LAT/LON BOX',USEMAR)
        WRITE (6,*) 'T TO SWITCH FMAGS 1 & 2 FOR EQS IN BOX'
        SWITCH12=LASK ('ONLY FOR READABLE SUMMARY FORMAT',SWITCH12)

        IF (USEMAR) THEN
C--DO NOT SELECT COMPONENTS FOR FMAG2
          NCPF2=0
          YLATMX=ASKR('MAX LAT FOR FMAG2 BOX',YLATMX)
          YLATMN=ASKR('MIN LAT FOR FMAG2 BOX',YLATMN)
          XLONMX=ASKR('MAX LON FOR FMAG2 BOX, POSITIVE W',XLONMX)
          XLONMN=ASKR('MIN LON FOR FMAG2 BOX, POSITIVE W',XLONMN)
        END IF
      ELSE
        READ (INST,*,ERR=3) USEMAR
        IF (USEMAR) THEN
          READ(INST,*,IOSTAT=IOS) USEMAR,SWITCH12,
     2   YLATMX,YLATMN,XLONMX,XLONMN
          IF (IOS.NE.0) GOTO 3
        END IF
      END IF
      GOTO 5

C-- CONTROLS FOR MAGS IN READABLE SUMMARY FORMATS
374   IF (LINST) THEN

        LBLANKMAG=LASK (
     1  'T TO BLANK-OUT UNCALC MAGS IN READABLE SUMMARY FILES',
     2  LBLANKMAG)
        NRDMAG=JASK(
     1   'NO. OF INDIVIDUAL MAGS IN READABLE SUMMARY OUTPUT (0-5)',
     2   NRDMAG)
        IF (NRDMAG.GT.0) WRITE (6,*)
     1   'MAG TYPES ARE 1=FMAG1 2=FMAG2 3=XMAG1 4=XMAG2 5=EXT-MAG'
        DO I=1,NRDMAG
          WRITE (6,*) 'MAG TYPE IN POS NUMBER ',I,':'
          MRDMAG(I)=JASK('MAGNITUDE TYPE',MRDMAG(I))
        END DO

      ELSE
        READ (INST,*,IOSTAT=IOS) LBLANKMAG,NRDMAG
        IF (IOS.NE.0) GOTO 3
        IF (NRDMAG.GT.0) THEN
          READ(INST,*,IOSTAT=IOS)
     1    LBLANKMAG,NRDMAG,(MRDMAG(I),I=1,NRDMAG)
          IF (IOS.NE.0) GOTO 3
        END IF
      END IF
      GOTO 5


C-- TRUE TO CORRECT REPORTED CRT & CRH DEPTHS TO THE GEOID
376   IF (LINST) THEN
        LGEOID=LASK('CORRECT REPORTED CRT & CRH DEPTHS TO GEOID'
     2 ,LGEOID)
      ELSE
        READ (INST,*,ERR=3) LGEOID
      END IF
      GOTO 5
      END      
      SUBROUTINE HYCRE
C--READS A HYPOELLIPSE LAYER CRUSTAL MODEL FOR HYPOINVERSE
      INCLUDE 'common.inc'

      MODTYP(MOD)=4
      LAY(MOD)=0
      READ (14,1002,END=20,ERR=20) MODNAM(MOD)
1002  FORMAT (A)
      CRODE(MOD)=MODNAM(MOD)(1:3)

C--READ VELOCITY & DEPTH OF EACH LAYER
      DO L=1,NLYR
        READ (14,1000,END=20) VEL(L,MOD),D(L,MOD)
1000    FORMAT (2F5.2)
C--COMPUTE THICKNESS & V**2 FOR LAYER
        LAY(MOD)=L
        IF (L.GT.1) THEN
          DD=D(L,MOD)-D(L-1,MOD)
          THK(L-1,MOD)=DD
          DV=VEL(L,MOD)-VEL(L-1,MOD)
c          IF (DV.LT.0. .OR. DD.LE.0.) GOTO 22	!version 1.39 change
          IF (DD.LE.0.) GOTO 22
        END IF
        VSQ(L,MOD)=VEL(L,MOD)**2
        VELI(L,MOD)=1./VEL(L,MOD)
      END DO

C--DEFINE THK FOR HALFSPACE
20    THK(LAY(MOD),MOD)=999.

C--COMPUTE ARRAYS FOR REFRACTION CALCULATIONS (FROM HYPOEL INPUT SUB)
C  DO THIS FOR THE MODEL MOD
      CALL HYCRE2
      RETURN

C--BAD DATA
22    WRITE (6,1001) MOD
1001  FORMAT (' *** BAD DATA FOR LAYER CRUST MODEL',I2)
      IRES=-95
      STOP
      END

      SUBROUTINE HYCRE2
C--COMPUTE ARRAYS FOR REFRACTION CALCULATIONS (FROM HYPOEL INPUT SUB)
C  DO THIS FOR THE MODEL MOD, GOTTEN FROM THE COMMON AREA
      INCLUDE 'common.inc'

C--L IS THE LAYER, MREF IS THE REFRACTOR LAYER
      DO L=1,LAY(MOD)
        DO MREF=1,LAY(MOD)
          VRAT=VEL(MREF,MOD)/VEL(L,MOD)
          IF (MREF.GT.L .AND. VRAT.GT.1.) THEN
            VSQDE(MREF,L,MOD)=SQRT((VRAT-1.)*(VRAT+1.))
          ELSE
            VSQDE(MREF,L,MOD)=0.
          END IF
C--NOTE SUBSCRIPT ORDER REVERSES
          IF (L.GE.MREF) THEN
            FREF(L,MREF,MOD)=2.
          ELSE
            FREF(L,MREF,MOD)=1.
          END IF
        END DO
      END DO

C--COMPUTE MORE ARRAYS FOR REFRACTION CALCULATIONS (FROM HYPOEL INPUT SUB)
      DO L=1,LAY(MOD)
        DO MREF=L,LAY(MOD)
          IF (MREF.GT.1) THEN
            SUMT=0.
            SUMD=0.
C--LOOP FROM TOP LAYER TO LAYER ABOVE REFRACTOR
C--SKIP IF REFRACTOR VELOCITY LE ANY OVERLYING VELOCITY
            DO I=1,MREF-1
              IF (VEL(MREF,MOD) .LE. VEL(I,MOD)) GOTO 60
            END DO
C--THIS STATEMENT LABELS LAYERS CAPABLE OF BEING REFRACTORS, ALLOWING FOR LOW
C  VEL ZONES. BECAUSE HI DOES NOT HAVE LVZS, ALL LAYERS EX #1 CAN BE REFRACTORS.
C--SET JREF IN HYTRE.FOR WITH A DATA STATEMENT.
C            jref(mrefr + lbeg(imod) - 1) = 1

            DO I=1,MREF-1
              SUMT=SUMT +FREF(I,L,MOD)*THK(I,MOD)*VSQDE(MREF,I,MOD)
              SUMD=SUMD +FREF(I,L,MOD)*THK(I,MOD)/VSQDE(MREF,I,MOD)
            END DO
60          TIDE(L,MREF,MOD)=SUMT*VELI(MREF,MOD)
            DIDE(L,MREF,MOD)=SUMD
          END IF
        END DO
      END DO
      RETURN
      END
c--hypoellipse notes
c  lmax is the total number of layers of all models
c  lmmax is the max no of layers for one model
c  mmax is max number of models
      SUBROUTINE HYCRH
C--READS A HOMOGENEOUS LAYER CRUSTAL MODEL FOR HYPOINVERSE
      INCLUDE 'common.inc'

      MODTYP(MOD)=1
      LAY(MOD)=0
      READ (14,1002,END=20,ERR=20) MODNAM(MOD)
1002  FORMAT (A)
      CRODE(MOD)=MODNAM(MOD)(1:3)

C--READ VELOCITY & DEPTH OF EACH LAYER
      DO 10 L=1,NLYR
      READ (14,1000,END=20) VEL(L,MOD),D(L,MOD)
1000  FORMAT (2F5.2)
C--COMPUTE THICKNESS & V**2 FOR LAYER
      LAY(MOD)=L
      IF (L.GT.1) THEN
        DD=D(L,MOD)-D(L-1,MOD)
        THK(L-1,MOD)=DD
        DV=VEL(L,MOD)-VEL(L-1,MOD)
        IF (DV.LT.0. .OR. DD.LE.0.) GOTO 22
      END IF
10    VSQ(L,MOD)=VEL(L,MOD)**2

C--DEFINE THK FOR HALFSPACE
20    THK(LAY(MOD),MOD)=999.
      RETURN

C--BAD DATA
22    WRITE (6,1001) MOD
1001  FORMAT (' *** BAD DATA FOR LAYER CRUST MODEL',I2)
      IRES=-95
      STOP
      END
      SUBROUTINE HYCRT
C--READS A TRAVEL TIME TABLE FOR A LINEAR GRADIENT CRUST MODEL FOR HYPOINVERSE
      INCLUDE 'common.inc'

C--IDENTIFY THE MODEL MOD AS A LINEAR GRADIENT TABLE
      MODTYP(MOD)=0

C--READ HEADER INFO
      READ (14,1000) MODNAM(MOD),LAY(MOD),REDV(MOD)
1000  FORMAT (A20,I2,F8.4)
      CRODE(MOD)=MODNAM(MOD)(1:3)

C--READ DEPTHS & VELOCITIES OF MODEL
      READ (14,1001) (D(I,MOD),I=1,LAY(MOD))
      READ (14,1001) (VEL(I,MOD),I=1,LAY(MOD))
1001  FORMAT (15F5.2)

C--READ DISTANCE & DEPTH GRID INFO
      READ (14,1003) DD1(MOD),ND1(MOD),DD2(MOD),ND2(MOD),
     2 DZ1(MOD),NZ1(MOD),DZ2(MOD),NZ2(MOD)
1003  FORMAT (2(F7.4,I3))
      ND(MOD)=ND1(MOD)+ND2(MOD)+1
      NZ(MOD)=NZ1(MOD)+NZ2(MOD)+1

C--READ REDUCED TRAVEL TIMES, GROUPED BY DEPTH
      DO 20 J=1,NZ(MOD)
      READ (14,1004) KDHR(MOD,J)
1004  FORMAT (20X,I10)
20    READ (14,1005) (KT(MOD,J,I),I=1,ND(MOD))
1005  FORMAT (15I6)
      GD1(MOD)=ND1(MOD).NE.0 .AND. DD1(MOD).NE.0
      GD2(MOD)=ND2(MOD).NE.0 .AND. DD2(MOD).NE.0
      GZ1(MOD)=NZ1(MOD).NE.0 .AND. DZ1(MOD).NE.0
      GZ2(MOD)=NZ2(MOD).NE.0 .AND. DZ2(MOD).NE.0
      RETURN
      END
      SUBROUTINE HYDATUM
C--COMPUTES DEPTH DATUM FOR CRT AND CRH MODELS

      INCLUDE 'common.inc'
C--TEMPORARY STATION ARRAYS FOR SORTING & 5 CLOSEST UNIQUE STATIONS
      CHARACTER STASO*9,STASU*9
      DIMENSION STASO(MAXPHS), DISSO(MAXPHS), IELSO(MAXPHS)
      DIMENSION STASU(5), DISSU(5), IELSU(5)

C--DECIDE OF DOMINANT MODEL TYPE (CRT,CRH) NEEDS A DD CALCULATION
      IF (MODTYP(MODS(1)) .GT.1) THEN
C--CRE,CRV,CRL MODELS HAVE A DEPTH DATUM OF 0 (SEA LEVEL OR GEOID)
C--THE DOMINANT MODEL NUMBER IS MODS(1)
        IDEPDAT=0
        JDSTA=0
        IMODG=1
        GOTO 50
      END IF
      IMODG=0

C--GET AVERAGE ELEVATIONS OF THE 5 CLOSEST STATIONS
C--GET STATIONS AND DISTANCES FROM HI ARRAYS. THEY ARE NOT IN DISTANCE ORDER.
C--FILL ARRAYS AND SORT THEM BY DISTANCE, ARRAYS WILL BE REARRANGED IN SORTING
C--USE EACH STATION SNL ONLY ONCE, REGARDLESS OF COMPONENT C
      DO K=1,KSTA
        JINDXX=KINDX(K)
        STASO(K)=(STANAM(JINDXX)//JNET(JINDXX)//JSLOC(JINDXX))
        DISSO(K)=DIS(K)
        IELSO(K)=JELEV(JINDXX)
      END DO
      KKSTA=KSTA
      CALL SORT3 (KKSTA,DISSO,STASO,IELSO)

c--we now have a sorted station list, but there may be duplicate stations
c  or ones with 0 (unknown) elevations
c--put the 5 "unique" stations into the u arrays
c--KS is the index of sorted stations, J is the index of the 5 unique stations
c--every earthquake must have 3 stations
      J=0
      DO KSZ=1,KSTA
c--SKIP STATIONS WITH UNKNOWN ELEVATIONS
        IF (IELSO(KSZ).EQ.0) GOTO 30
        IF (J.EQ.0) THEN
          STASU(1)=STASO(KSZ)
          DISSU(1)=DISSO(KSZ)
          IELSU(1)=IELSO(KSZ)
          J=1
          JDSTA=1
          GOTO 30
        END IF

C--WE HAVE THE CLOSEST STATION AND J.GE.1
C--SEARCH FOR CURRENT STASO STATION IN STASU CLOSE LIST, SKIP IF WE HAVE IT
        DO JJ=1,J
          IF (STASO(KSZ) .EQ. STASU(JJ)) GOTO 30
        END DO

C--WE HAVE A NEW STATION STASO, SO ADD IT TO CLOSEST LIST
        J=J+1
        JDSTA=J
        STASU(J)=STASO(KSZ)
        DISSU(J)=DISSO(KSZ)
        IELSU(J)=IELSO(KSZ)
        IF (J.EQ.5) GOTO 40 !WE NOW HAVE 5 CLOSE, UNIQUE STATIONS, NEED NO MORE
        
30    CONTINUE
      END DO	!END OF LIST OF STATION PHASES

C--PROGRAM MAY REACH THIS POINT BEFORE J = 5
40    CONTINUE

C--FOR DEBUGGING, LIST OUT THE 5 CLOSEST STATIONS & THEIR ELEVATIONS
C      WRITE (6,*) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
C      DO J=1,JDSTA
C        WRITE (6,1030) STASU(J),DISSU(J),IELSU(J)
C1030    FORMAT (A9,' DIS=',F7.2,' EL=',I5)
C      END DO


C--DEPTH DATAUM IS AVERAGE OF JDSTA (MAX 5) CLOSEST STATIONS
      IDEPDAT=0
      DO J=1,JDSTA
        IDEPDAT=IDEPDAT+IELSU(J)
      END DO
      IDEPDAT=NINT(1.*IDEPDAT/JDSTA)
      
C--GET GEOID DEPTH & SET FLAG OF WHAT REPORTED DEPTH IS
50    ZGEOID=Z1-IDEPDAT/1000.
      IF (IMODG.EQ.1) THEN	!CRE,CRV,CRL MODELS
        CZFLAG='G'
        ZREP=Z1
      ELSE IF (IMODG.EQ.0) THEN	!CRT,CRH MODELS
        IF (LGEOID) THEN
          CZFLAG='G'
          ZREP=ZGEOID	!FOR TRADITIONAL MODELS, MAKE DEPTH DATUM CORRECTION
        ELSE
          CZFLAG='M'
          ZREP=Z1	!FOR HYPOELLIPSE MODELS, DEPTH IS ALREADY TO GEOID
        END IF
      END IF
      
      RETURN
      END

	subroutine sort3 (n,ra,rb,irc)
c--heapsort subroutine from numerical recipes book
C--SORTS ENTRIES OF RA (NUMBERS) AND RB (9 CHARACTERS) IN ASCENDING ORDER
C  OF RA. RA, RB & IRC ARE REPLACED WITH SORTED VALUES. N VALUES ARE SORTED.
	character rb*9, rrb*9
	dimension ra(n), rb(n), irc(n)
	l=n/2+1
	ir=n
10	continue
	if (l.gt.1) then
	  l=l-1
	  rra=ra(l)
	  rrb=rb(l)
	  iirc=irc(l)
	else
	  rra=ra(ir)
	  rrb=rb(ir)
	  iirc=irc(ir)
	  ra(ir)=ra(1)
	  rb(ir)=rb(1)
	  irc(ir)=irc(1)
	  ir=ir-1
	  if (ir.eq.1) then
	    ra(1)=rra
	    rb(1)=rrb
	    irc(1)=iirc
	    return
	  end if
	end if
	i=l
	j=l+l

20	if (j.le.ir) then
	  if (j.lt.ir) then
	    if (ra(j) .lt. ra(j+1)) j=j+1
	  end if
	  if (rra.lt.ra(j)) then
	    ra(i)=ra(j)
	    rb(i)=rb(j)
	    irc(i)=irc(j)
	    i=j
	    j=j+j
	  else
	    j=ir+1
	  end if
	  goto 20
	end if
	ra(i)=rra
	rb(i)=rrb
	irc(i)=iirc
	goto 10
	end
      SUBROUTINE HYDEL (MODB)
C--READ IN STATION DELAYS FOR HYPOINVERSE AFTER READING IN MAIN STATION FILE
C--USE ONLY STATION SITE AND NET CODES SO ALL COMPONENTS & LOCS WILL MATCH

C--MODB IS AN INSTRUCTION CODE:
C  -1    READ IN LIST OF ALTERNATE STATIONS (INDICATED BY A IN COL. 7)
C   0    READ IN ALL DELAY MODELS FROM ONE FILE
C   1-LM READ IN DELAYS FOR THIS MODEL NUMBER ONLY

      INCLUDE 'common.inc'
C--MAX OF 31 DELAYS READABLE IF ALL DELAYS ARE IN ONE FILE
      DIMENSION PD(31)
      CHARACTER STA*5,SNET*2,CH*1
      NDLZ=0
      LMM=LM
      IF (LMM.GT.31) LMM=31

C--ERROR MESSAGE
      IF (JSTA.EQ.0) THEN
        WRITE (6,1002)
1002    FORMAT (' *** ERROR: YOU CANT READ DELAYS BEFORE ',
     2  'READING THE STATION FILE')
        CLOSE (13)
        IRES=-42
        RETURN
      END IF

      IF (MODB.EQ.-1) THEN
C++++++++++++ READ IN THE LIST OF STATIONS TO USE ALTERNATE MODEL +++++++++++
C--LOOP TO READ IN THE STATION CODES AND ALTERNATE FLAGS
10      READ (13,1010,ERR=80,END=90) STA,SNET,CH
1010    FORMAT (A5,1X,A2,2X,A1)

C--LOOK FOR STATION IN MASTER TABLE. CHANGE ALL COMPONENTS IN TABLE.
C--REPORT NO MISMATCH ERRORS
        DO J=1,JSTA
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3    CH.EQ.'A') THEN

            JLMOD(J)=.TRUE.
            NDLZ=NDLZ+1
          END IF
        END DO
        GOTO 10

      ELSE IF (MODB.EQ.0) THEN
C++++++++++++ READ IN ALTERNATE STATIONS & DELAYS FOR ALL MODELS +++++++++++
C--LOOP TO READ IN THE ARRAY OF DELAYS
20      READ (13,1020,ERR=80,END=90) STA,SNET,CH,PD
1020    FORMAT (A5,1X,A2,2X,A1,40F4.2)

C--LOOK FOR STATION IN MASTER TABLE. 
C--REQUIRE A 4-LETTER MATCH BUT REPORT NO MISMATCH ERRORS
        DO J=1,JSTA
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET)) THEN
            IF (CH.EQ.'A') JLMOD(J)=.TRUE.
            DO I=1,LMM
              JPD(I,J)=NINT(PD(I)*100.)
            END DO
            NDLZ=NDLZ+1
          END IF
        END DO
        GOTO 20
      ELSE

C++++++++++++ READ IN DELAYS FOR ONE MODEL +++++++++++
C--LOOP TO READ IN DELAYS
30      READ (13,1030,ERR=80,END=90) STA,SNET,PD1
1030    FORMAT (A5,1X,A2,1X,F5.2)

C--LOOK FOR STATION IN MASTER TABLE. 
C--REPORT NO MISMATCH ERRORS
        DO J=1,JSTA
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET)) THEN
            JPD(MODB,J)=NINT(PD1*100.)
            NDLZ=NDLZ+1
          END IF
        END DO
        GOTO 30
      END IF

C--DATA FORMAT OR READ ERROR
80    WRITE (6,1001) STA
1001  FORMAT (' *** ERROR READING DELAY FILE AT STATION ',A)
      IRES=-75

C--DONE READING FILE
90    CLOSE (13)
      IF (MODB.GE.0) WRITE (6,
     2 '(I6,'' STATION DELAYS SET FOR MODEL'',I3)') NDLZ,MODB
      IF (MODB.LT.0) WRITE (6,
     2 '('' ALTERNATE STATUS SET FOR'',I4,'' STATIONS'')') NDLZ
      RETURN
      END
      SUBROUTINE HYDELT (STR1,LEN1,STR2,LEN2)
C--DELETES A FILE FOR HYPOINVERSE USED WITH INTERACTIVE PROCESSING
C--THE FILENAME IS THE CONCATENATION OF STR1 & STR2.
C--LEN1 AND LEN2 ARE THE LENGTHS OF THE ACTUAL FILE NAMES WITHIN THE 
C  CHARACTER STRINGS.  IF LEN2=0, ONLY THE FIRST STRING IS USED.

      CHARACTER STR1*(*),STR2*(*), CTEMP*100
      CTEMP=' '

C--VAX
C      IF (LEN2.EQ.0) THEN
C        CALL LIB$DELETE_FILE ((STR1(1:LEN1)//';*'))
C      ELSE
C        CALL LIB$DELETE_FILE ((STR1(1:LEN1)//STR2(1:LEN2)//';*'))
C      END IF

C--SUN/UNIX
      IF (LEN2.EQ.0) THEN
        CTEMP=('rm '//STR1(1:LEN1))
      ELSE
        CTEMP=('rm '//STR1(1:LEN1)//STR2(1:LEN2))
      END IF
      I = SYSTEM (CTEMP)
      WRITE (*,*) I

C--OS2
C      INCLUDE 'fsublib.fi'
C      CHARACTER STRING*80
C      IF (LEN2.EQ.0) THEN
C        STRING = ('rm ' // STR1(1:LEN1))
C      ELSE
C        STRING = ('rm ' // STR1(1:LEN1) // STR2(1:LEN2))
C      END IF
C      I = FSYSTEM (STRING)
C      WRITE (*,*) I

      RETURN
      END
      SUBROUTINE HYEDIT (IEDFLG,FILE)
C--RUN AN EDITOR WITHIN HYPOINVERSE. USED TO INTERACTIVELY PROCESS EVENTS.
      CHARACTER FILE*(*),CTEMP*80
      CTEMP=' '

C--VAX
C      IF (IEDFLG.EQ.1) THEN
C        CALL EDT$EDIT (FILE)
C      ELSE IF (IEDFLG.EQ.2) THEN
C        CALL SPAWN (('ED '//FILE))
C      END IF

C--SUN/UNIX
      IF (IEDFLG.EQ.1) THEN
        CTEMP=('dtpad '//FILE)
      ELSE IF (IEDFLG.EQ.2) THEN
        CTEMP=('vi '//FILE)
      ELSE IF (IEDFLG.EQ.3) THEN
        CTEMP=('textedit '//FILE)
      END IF
      CALL SPAWN (CTEMP)

      RETURN
      END
      SUBROUTINE HYFILE (IUNIT,ITYPE)
C--DETERMINE THE FILE TYPE AND FORMAT OF A HYPOINVERSE PHASE/ARC/SUM FILE
C--THE FILE MUST ALREADY BE OPENED ON UNIT IUNIT

C--INPUT:  IUNIT - THE UNIT NUMBER OF THE FILE
C--OUTPUT: ITYPE - THE HYPOINVERSE FILE TYPE JUDGED FROM THE FIRST 2 LINES
C  1 HYPOINVERSE (PRE 2000) SUMMARY
C  2 HYPOINVERSE-2000 SUMMARY
C  3 HYPO71 (PRE 2000) SUMMARY
C  4 HYPO71-2000 SUMMARY
C  5 TRADITIONAL HYPO71-HYPOINVERSE PHASE (PRE 2000)
C  6 HYPO71-HYPOINVERSE PHASE (PRE 2000) WITH SHADOW CARDS
C  7 HYPOINVERSE (PRE 2000) ARCHIVE
C  8 HYPOINVERSE-2000 ARCHIVE
C  9 HYPOINVERSE (PRE 2000) ARCHIVE WITH SHADOW CARDS
C 10 HYPOINVERSE-2000 ARCHIVE WITH SHADOW CARDS

C  0 NOT ONE OF THESE FILE TYPES
C -1 EMPTY FILE


C--THE FILE TYPE CAN ONLY BE DISCRIMINATED FROM THESE 10 TYPES
C  (SOME OTHER FILE TYPES MAY PASS ONE OF THESE TESTS, OR
C  AN ERRONEOUS HYPOINVERSE FILE MAY FAIL ALL TESTS)

      CHARACTER REC1*21,REC2*21
      LOGICAL LDIG17,LDIG14,LDIG6,LDIG,LALPH1,LALPH2
      ITYPE=0
      REC2=' '

CC--DETERMINE INPUT FILE FORMAT
C	CALL OPENR (IUNIT, INFIL(1), 'F', IOS)
C	IF (IOS.GT.0) GOTO XXX

C--READ THE FIRST RECORD
C--ALL FILE TYPES EXCEPT PHASE BEGIN WITH A SUMMARY CARD
      READ (IUNIT,'(A17)',END=200) REC1
      IDIG17=ICHAR (REC1(17:17))
      LDIG17=IDIG17.GT.47 .AND. IDIG17.LT.58   !T IF A NUMERICAL DIGIT

      IDIG14=ICHAR (REC1(14:14))
      LDIG14=IDIG14.GT.47 .AND. IDIG14.LT.58   !T IF A NUMERICAL DIGIT

      IDIG6=ICHAR (REC1(6:6))
      LDIG6=IDIG6.GT.47 .AND. IDIG6.LT.58   !T IF A NUMERICAL DIGIT

C--------------------------------
C--FIRST TEST FOR TOO MANY BLANKS
      IF (REC1(1:4).EQ.'    ' .OR. REC1(10:13).EQ.'    ') GOTO 202
C--TEST FOR TOO MANY LETTERS
C--SET FLAG IF A NON-DIGIT OR NON-BLANK CHARACTER IS FOUND
C--SUMMARY CARDS HAVE NO LETTERS IN COLS 1-12, PHASE NO LETTERS IN COLS 10-21
      LALPH1=.FALSE.
      DO I=1,12
        IDIG=ICHAR (REC1(I:I))
        LDIG=(IDIG.GT.47 .AND. IDIG.LT.58) .OR. IDIG.EQ.32 !T IF DIGIT OR BLANK
        IF (.NOT.LDIG) LALPH1=.TRUE.
      END DO
      LALPH2=.FALSE.
      DO I=10,21
        IDIG=ICHAR (REC1(I:I))
        LDIG=(IDIG.GT.47 .AND. IDIG.LT.58) .OR. IDIG.EQ.32 !T IF DIGIT OR BLANK
        IF (.NOT.LDIG) LALPH2=.TRUE.
      END DO
      IF (LALPH1 .AND. LALPH2) GOTO 202

C--------------------------------
C--TEST FOR PHASE CARDS
C  A PHASE CARD ON THE FIRST LINE MEANS ITS A PHASE FILE.
      IF (.NOT.LDIG6) THEN
        READ (IUNIT,'(A1)',END=202) REC2
        IF (REC2(1:1).EQ.'$') THEN
C==PHASE SHADOW FORMAT
          ITYPE=6
          RETURN
        END IF
C==PHASE FORMAT
        ITYPE=5
        RETURN
      END IF

C---------------------------------------
C--THESE 4 SUMMARY TESTS COULD BE DONE IN ANY ORDER, BUT DO MOST COMMON FIRST:
C--HYPOINV-2000
      IF (LDIG17 .AND. REC1(12:12).NE.' ') THEN
        READ (IUNIT,'(A)',END=204) REC2
        IF (REC2(1:1).EQ.'$') THEN
C==ARCHIVE-2000 SHADOW FORMAT
          ITYPE=10
          RETURN
        END IF

C--THE FILE IS EITHER AN ARCHIVE-2000 OR AN HI SUMMARY-2000
C--A STATION ARCHIVE LINE IS BLANK IN COLS 8 & 13
        IF (REC2(8:8).EQ.' ' .AND. REC2(13:13).EQ.' ') THEN
C==ARCHIVE-2000 FORMAT
          ITYPE=8
          RETURN
        END IF
C==HYPOINVERSE-2000 SUMMARY
        ITYPE=2
        RETURN

C--------------------------------------
C--OLD HYPOINVERSE SUMMARY
      ELSE IF (.NOT.LDIG17 .AND. LDIG14) THEN
C      ELSE IF (.NOT.LDIG17 .AND. REC1(9:9).NE.' ') THEN  !INCORRECT
        READ (IUNIT,'(A)',END=206) REC2
        IF (REC2(1:1).EQ.'$') THEN
C==ARCHIVE SHADOW FORMAT
          ITYPE=9
          RETURN
        END IF

C--THE FILE IS EITHER AN ARCHIVE OR AN HI SUMMARY
C--COL 6 IS THE P REMARK (OR BLANK) ; OR THE DAY OF THE MONTH 
        IDIG6=ICHAR (REC2(6:6))
        LDIG6=IDIG6.GT.47 .AND. IDIG6.LT.58   !T IF A NUMERICAL DIGIT
        IF (.NOT.LDIG6) THEN
C==ARCHIVE FORMAT
          ITYPE=7
          RETURN
        END IF
C==HYPOINVERSE SUMMARY
        ITYPE=1
        RETURN

C---------------------------------------
      ELSE IF (REC1(9:9).EQ.' ' .AND. REC1(14:14).EQ.' ') THEN
C==HYPO71-2000 SUMMARY
        ITYPE=4
        RETURN

      ELSE IF (LDIG17 .AND. REC1(12:12).EQ.' ') THEN 
C==HYPO71 SUMMARY
        ITYPE=3
        RETURN

      ELSE
c==UNKNOWN FORMAT, NOT SUMMARY OR PHASE
        ITYPE=0
        RETURN
      END IF
 
C--EMPTY FILE
200   ITYPE=-1
      RETURN
C--PREMATURE END OF FILE, OR A LINE WITH TOO MANY BLANKS OR LETTERS
202   ITYPE=0
      RETURN
C--AN END OF FILE HERE MEANS A HYPOINV-2000 SUMMARY FILE WITH 1 LINE
204   ITYPE=2
      RETURN
C--AN END OF FILE HERE MEANS AN OLD HYPOINVERSE SUMMARY FILE WITH 1 LINE
206   ITYPE=1
      RETURN

C	  WRITE (6,*) 'READING HYPOINVERSE-2000 FORMAT'
C	  WRITE (6,*) 'READING OLD HYPOINVERSE FORMAT'
C	  WRITE (6,*) 'READING HYPO71-2000 FORMAT'
C	  WRITE (6,*) 'READING OLD HYPO71 FORMAT'
C	  WRITE (6,*) 'UNRECOGNIZED SUMMARY FORMAT, SELECT QUITS'

      END

      SUBROUTINE HYFMC
C--CALLED FROM HYCMD TO INITIALLY READ FILE OF STATION DUR MAG CORRECTIONS AND
C  THEIR EXPIRATION DATES.
      INCLUDE 'common.inc'
      CHARACTER STN*5, SNET*2, SCOMP*3, SLOC*2
      DIMENSION FMC(6),IFEXP(6),ITEXP(6),IYEARI(6)
      KOUNT=0

      IF (JSTA.EQ.0) THEN
        WRITE (6,1001)
1001    FORMAT (' *** ERROR: YOU CANT READ FMAG CORRECTIONS BEFORE',
     2  ' READING THE STATION FILE')
        IRES=-37
        RETURN
      END IF

C--OPTIONALLY SET ALL WEIGHTS TO ZERO IF WE WANT TO USE ONLY STAS WITH
C  KNOWN CORRECTIONS
      IF (.NOT.LNOFMC) THEN
        DO J=1,JSTA
          JFWT(J)=0
        END DO
      END IF

C--OPEN THE STATION FMAG CORRECTION FILE
      CALL OPENR (13,FMCFIL,'F',IOS)
      IF (IOS.NE.0) GOTO 90

C--LOOP TO READ STATION FMAG CORRECTIONS
5     IF (L2000) THEN
        READ (13,1020,END=80) STN, SNET, SLOC, SCOMP,
     2  (FMC(I),IYEARI(I),ITEXP(I),I=1,6)
1020    FORMAT (A5,1X, A2,A2, A3,1X, 6(F5.2,1X,I4,I6,1X))

      ELSE
        READ (13,1000,END=80) STN, SNET, SCOMP,
     2  (FMC(I),IYEARI(I),ITEXP(I),I=1,6)
C--READ 2-DIGIT YEAR, MO, DA, HOUR, AND IGNORE MINUTES IF PRESENT
1000    FORMAT (A5,1X, A2,2X, A3,1X, 6(F5.2,1X,I2,I6,3X))
        SLOC='  '
      END IF

C--SEARCH STATION LIST IN MEMORY FOR A MATCH
      DO J=1,JSTA
        IF (STN(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2  SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3  (SLOC(1:NSLOC2) .EQ. JSLOC(J)(1:NSLOC2) .OR.
     3  SLOC(1:NSLOC2) .EQ. JSLOC2(J)(1:NSLOC2)) .AND.
     4  SCOMP(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN

C--GIVE STATION FULL WEIGHT IF WEIGHT IS CONTINGENT ON BEING IN FILE
          IF (.NOT.LNOFMC) JFWT(J)=10

C--MAKE SURE IYEARI IS THE FULL 4-DIGIT YEAR
C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE STATE
          DO I=1,6
            IF (IYEARI(I).LT.100 .AND. IYEARI(I).GT.0) 
     2      IYEARI(I)=IYEARI(I)+ICENT
            IF (IYEARI(I).GT.2146) THEN
              WRITE (6,1200) STN, SNET, SCOMP, IYEARI(I)
1200          FORMAT ('*** FMC EXPIRATION YEAR TOO LARGE,',
     2        ' RESET TO 2146:'/1X,A5,1X,A2,1X,A3,1X,I4)
              IYEARI(I)=2146
            END IF
            IFEXP(I)=IYEARI(I)*1000000 +ITEXP(I)
          END DO

C--IF THE TARGET DATE IS 0, JUST TAKE THE FIRST CORRECTION & EXPIRATION DATE
          IF (IFDATE.EQ.0) THEN
            I=1
          ELSE
C--SEARCH FOR THE FIRST EXPIRATION DATE AFTER THE TARGET DATE
            DO I=1,6
              IF (IFEXP(I).EQ.0 .OR. IFEXP(I).GT.IFDATE) GOTO 10
            END DO
            IFEXP(6)=0
          END IF

C--STORE THE CORRECTION & ITS EXPIRATION DATE
10        JFEXP(J)=IFEXP(I)

C--ADD 10 TO CORRECTION TO GIVE GAIN CORRECTION 0 WEIGHT
C--YOU CAN ADD BOTH 10 AND 5, BUT MUST DO THIS TEST FIRST
          IF (FMC(I).GT.7.45) THEN
            JFGWT(J)=0
            FMC(I)=FMC(I)-10.
          ELSE
            JFGWT(J)=1
          END IF

C--ADD 5 TO CORRECTION TO GIVE IT ZERO WEIGHT
          IF (FMC(I).GT.2.45) THEN
            JFWT(J)=0
            FMC(I)=FMC(I)-5.
          ELSE
            JFWT(J)=10
          END IF

          JFCOR(J)=NINT(FMC(I)*100.)
          KOUNT=KOUNT+1
C          GOTO 5  !COMMENT OUT TO STORE DATA FOR ALL CHANNELS THAT APPLY
        END IF
      END DO
      GOTO 5

C--END OF FILE
80    CLOSE (13)
      WRITE (6,1002) KOUNT
1002  FORMAT (I6,' STATION FMAG CORRECTIONS SET')
      RETURN

C--ERROR FOR NON-EXISTENT FILE
90    WRITE (6,1010)
1010  FORMAT (' *** ERROR: STATION FMAG CORRECTION FILE DOES NOT EXIST')
      IRES=-38
      RETURN
      END

      SUBROUTINE HYINIT
C--CALLED BY HYPOINV TO INITIALIZE SOME VALUES BEFORE EACH LOCATION RUN
      INCLUDE 'common.inc'

C--INITIALIZE THE SHADOW RECORDS
      LENSHA=0
      SHADO=' '
      DO I=1,MSHA
        LSHA1(I)=0
        SHAD1(I)=' '
      END DO
      DO K=1,MAXPHS
        KLSHA(K)=0
          KPAMP(K)=0
        KSHAD(K)=' '
      END DO

C--INITIALIZE SOME VALUES
      REMK=' '
      INUM=0
      LTBIG=.FALSE.
C--SET FLAG USED TO INDICATE END OF PHASE CARD FILE
      KEND=0

C--SET FLAGS FOR EACH STATION FOR MAGNITUDES TO BE COMPUTED
C--FMAG
      DO J=1,JSTA
        IF (NCPF1.LT.0) THEN
          JFM1(J)=.TRUE.
        ELSE
          JFM1(J)=.FALSE.
          DO I=1,NCPF1
            IF (COMPF1(I)(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
              JFM1(J)=.TRUE.
              GOTO 11
            END IF
          END DO
        END IF

C--FMAG2
11      IF (NCPF2.LT.0) THEN
          JFM2(J)=.TRUE.
        ELSE
          JFM2(J)=.FALSE.
          DO I=1,NCPF2
            IF (COMPF2(I)(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
              JFM2(J)=.TRUE.
              GOTO 12
            END IF
          END DO
        END IF

C--XMAG
12      IF (LXCH) THEN
C--CHOOSE XMAG BY COMPONENT
          IF (NCPX1.LT.0) THEN
            JXM1(J)=.TRUE.
          ELSE
            JXM1(J)=.FALSE.
            DO I=1,NCPX1
              IF (COMPX1(I)(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
                JXM1(J)=.TRUE.
                GOTO 13
              END IF
            END DO
          END IF

        ELSE
C--CHOOSE XMAG BY INSTRUMENT TYPE
          IF (NXTYP1.LT.0) THEN
            JXM1(J)=.TRUE.
          ELSE
            JXM1(J)=.FALSE.
            DO I=1,NXTYP1
              IF (IXTYP1(I) .EQ. JTYPE(J)) THEN
                JXM1(J)=.TRUE.
                GOTO 13
              END IF
            END DO
          END IF
        END IF

C--XMAG2
13      IF (LXCH) THEN
C--CHOOSE XMAG2 BY COMPONENT
          IF (NCPX2.LT.0) THEN
            JXM2(J)=.TRUE.
          ELSE
            JXM2(J)=.FALSE.
            DO I=1,NCPX2
              IF (COMPX2(I)(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
                JXM2(J)=.TRUE.
                GOTO 14
              END IF
            END DO
          END IF

        ELSE
C--CHOOSE XMAG2 BY INSTRUMENT TYPE
          IF (NXTYP2.LT.0) THEN
            JXM2(J)=.TRUE.
          ELSE
            JXM2(J)=.FALSE.
            DO I=1,NXTYP2
              IF (IXTYP2(I) .EQ. JTYPE(J)) THEN
                JXM2(J)=.TRUE.
                GOTO 14
              END IF
            END DO
          END IF
        END IF

C--PAMAG
14      IF (NCPP1.LT.0) THEN
          JPM1(J)=.TRUE.
        ELSE
          JPM1(J)=.FALSE.
          DO I=1,NCPP1
            IF (COMPP1(I)(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
              JPM1(J)=.TRUE.
              GOTO 15
            END IF
          END DO
        END IF

C--PAMAG2
15      IF (NCPP2.LT.0) THEN
          JPM2(J)=.TRUE.
        ELSE
          JPM2(J)=.FALSE.
          DO I=1,NCPP2
            IF (COMPP2(I)(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
              JPM2(J)=.TRUE.
              GOTO 16
            END IF
          END DO
        END IF

      END DO
16    RETURN
      END
      SUBROUTINE HYINP
C--CALLED BY HYPOINVERSE TO PROMPT FOR PHASE DATA & OUTPUT IT TO A FILE
C--IN CONDENSED FORMAT.
C--LASK IS A LOGICAL FUNCTION. THE g77 COMPILER COMPLAINS WITHOUT THESE LINES
      LOGICAL LASK
      EXTERNAL LASK
      LOGICAL LALL, LO
      CHARACTER STA*5,STA2*2,STA1*1,STA3*3
      CHARACTER STAS(100)*5,STAN(100)*2,STAC1(100)*1,STAC3(100)*3
      CHARACTER IFL*80,PRMK*4,SRMK*4,RMKP*4,RMKS*4
      CHARACTER SCHR(100)*1,ACHR(100)*1,CCHR(100)*1,NUMSTR*20
C--TELL HYPOINVERSE TO READ THE NEXT PHASE FILE IN CONDENSED FORMAT
C      JCP=2
C--INITIALIZE DATA
      PRMK=' P 0'
      SRMK=' S 2'
      RMKP=' P 0'
      RMKS=' S 2'
      IY=0
      IM=0
      ID=0
      IH=0
      IN=0

      WRITE (6,*)' INTERACTIVE PHASE DATA ENTRY.  READS A FILE OF'
      WRITE (6,*)' STATION NAMES FOR PROMPTING (DEFAULT IS stalist.dat)'
      WRITE (6,*)' PRESS RETURN FOR DEFAULT DATA OR FOR NO DATA.'
C--PROMPT FOR & OPEN OUTPUT FILE
      CALL ASKC ('PHASE DATA OUTPUT FILENAME',IFL)
      CALL OPENW (14,IFL,'F',IOS,'A')

C--LOOK FOR LIST OF STATIONS TO PROMPT FOR ON FILE 'stalist.'
C--IF STALIST IS NOT THERE, REQUEST ANOTHER FILENAME.
      CALL OPENR (12,'stalist.dat','F',IOS)
      IF (IOS.NE.0) THEN
10      CALL ASKC
     2 ('FILE NOT FOUND. FILE OF STATION NAMES TO PROMPT FOR',IFL)
        CALL OPENR (12,IFL,'F',IOS)
        IF (IOS.NE.0) GOTO 10
      END IF

C--READ IN LIST OF STATIONS TO PROMPT FOR
15    DO I=1,100
16      READ (12,1003,END=20) STAS(I),STAN(I),STAC1(I),STAC3(I),
     2 SCHR(I),ACHR(I),CCHR(I)
1003    FORMAT (A5,1X,A2,1X,A1,A3,1X,3A1)
        IF (STAS(I).EQ.'     ') GOTO 16
      END DO
20    NSTA=I-1
      CLOSE (12)

C--SET THE FLAG THAT PROMPTS FOR A P REMARK, FIRST MOTION & WEIGHT
      WRITE (6,1007)
1007  FORMAT (' DO YOU WANT TO ENTER REMARKS, FIRST MOTIONS & WEIGHTS')
      LALL= LASK ('FOR ALL STATIONS',LALL)

      IF (LALL) WRITE (6,1012)
1012  FORMAT (' REMARKS ARE 4 CHARACTERS LONG, AND CONSIST OF'/
     2 ' QUALITY, P OR S, FIRST MOTION, & WEIGHT,'/
     3 ' FOR EXAMPLE "IPU0" OR "ES 2". RETURN USES SIMPLY "P" OR "S".')

C******************* EVENT LOOP ******************************

C--PROMPT FOR DATE & TIME
25    WRITE (6,1004)
1004  FORMAT (1X,5('----'),/' FOR THE NEXT EVENT:')
      IY=JASK(' YEAR (2 DIGITS)',IY)
      IM=JASK('MONTH',IM)
      ID=JASK('  DAY',ID)
      IH=JASK(' HOUR',IH)
      IN=JASK('  MIN',IN)

C      WRITE (6,1006)
C1006  FORMAT (' ENTER P TIMES:')

C--LOOP OVER STATIONS IN THE PROMPTING LIST
C--ASSUME A P TIME IS TO BE ENTERED FOR MOST STATIONS
      DO 50 I=1,NSTA

C--INPUT P TIME IN FREE FORMAT, CR SKIPS THE STATION
30    WRITE (6,1010) STAS(I),STAN(I),STAC1(I),STAC3(I)
1010  FORMAT (' P-TIME FOR ',A5,A2,1X,A1,A3,': ',$)

C--READ P TIME
      READ (5,'(A)') NUMSTR
      IF (NUMSTR(1:4).NE.'    ') THEN
        READ (NUMSTR,*,ERR=30) P
        PRMK=' P 0'
      ELSE
        P=0.
        PRMK=' P 4'
      END IF

C--THE TIME IN 1/100 SECONDS AS AN INTEGER
      IP=NINT(P*100.)

C--OPTIONALLY INPUT S REMARK & WEIGHT
      IF (LALL .AND. IP.NE.0) THEN
        PRMK=' P 0'
        CALL ASKC ('P REMK & WEIGHT (A4)',PRMK)
        IF (PRMK.EQ.'    ') PRMK=' P 0'
      END IF

C--INPUT A DURATION IF THIS STATION WAS FLAGGED
      IC=0
      IF (CCHR(I).NE.' ') THEN
46      WRITE (6,1027) STAS(I)
1027    FORMAT (' CODA DURATION FOR ',A5,': ',$)
        READ (5,'(A)') NUMSTR
        IF (NUMSTR(1:4).NE.'    ') THEN
          READ (NUMSTR,*,ERR=46) C
        ELSE
          C=0.
        END IF
        IC=NINT(C)
      END IF

C--NOW INPUT AN S TIME IF THIS STATION WAS FLAGGED
      SRMK='    '
      IS=0
      IF (SCHR(I).NE.' ') THEN

C--INPUT S TIME IN FREE FORMAT, CR SKIPS THE STATION
40      WRITE (6,1024) STAS(I)
1024    FORMAT (' S TIME FOR ',A5,': ',$)
        READ (5,'(A)') NUMSTR
        IF (NUMSTR(1:4).NE.'    ') THEN
          READ (NUMSTR,*,ERR=40) S
          SRMK=' S  '
        ELSE
          S=0.
          SRMK='    '
        END IF

C--S TIME IN 1/100 SECONDS AS AN INTEGER
        IS=NINT(S*100.)

C--OPTIONALLY INPUT S REMARK & WEIGHT
        IF (LALL .AND. IS.NE.0) THEN
          SRMK=' S 2'
          CALL ASKC ('S REMK & WEIGHT (A4)',SRMK)
          IF (SRMK.EQ.'    ') SRMK=' S  '
        END IF
      END IF

C--INPUT AN AMPLITUDE IF THIS STATION WAS FLAGGED
      IA=0
      IF (ACHR(I).NE.' ') THEN
44      WRITE (6,1025) STAS(I)
1025    FORMAT (' AMPLITUDE FOR ',A5,': ',$)
        READ (5,'(A)') NUMSTR
        IF (NUMSTR(1:4).NE.'    ') THEN
          READ (NUMSTR,*,ERR=44) A
        ELSE
          A=0.
        END IF
        IA=NINT(A)
      END IF

C--WRITE STATION LINE
      IF (IP.GT.0 .OR. IC.GT.0 .OR. IS.GT.0 .OR. IA.GT.0)
     2 WRITE (14,1100) STAS(I)(1:4),PRMK,STAC1(I), IY,IM,ID,IH,IN,IP,
     3 IS,SRMK,IA, IC, STAS(I)(5:5),STAC3(I),STAN(I)
1100  FORMAT (A4,A4,A1, 5I2.2,I5,
     3 T32,I5,A4,4X,I3, T72,I4,2X, A1,A3,A2)

C--END OF STATION LOOP
50    CONTINUE

C------------------------------------------------------------
C--OPTIONALLY ENTER A TIME FOR A STATION NOT ON PROMPT LIST
60    LO=LASK('ENTER ANOTHER P, S OR CODA FOR THIS EVENT',.FALSE.)
      IF (.NOT.LO) GOTO 80

C--GET STATION NAME & REMARK
      CALL ASKC ('STATION SITE  CODE (A5)',STA)
      CALL ASKC ('STATION NET   CODE (A2)',STA2)
      CALL ASKC ('STATION COMP1 CODE (A1)',STA1)
      CALL ASKC ('STATION COMP3 CODE (A3)',STA3)

C--GET STATION P TIME
C  HIT RETURN (NO ENTRY) OR 0 FOR NO NUMERIC DATA
65    P=ASKR('P TIME (0 FOR NONE)',0.)
      IF (P.NE.0.) THEN
        RMKP=' P 0'
        IF (LALL) CALL ASKC ('P REMARK & WEIGHT (A4)',RMKP)
      ELSE
        RMKP=' P 4'
      END IF
      IP=NINT(P*100.)

C--GET STATION S TIME
C  HIT RETURN (NO ENTRY) OR 0 FOR NO NUMERIC DATA
66    S=ASKR('S TIME (0 FOR NONE)',0.)
      IF (S.NE.0.) THEN
        RMKS=' S 0'
        IF (LALL) CALL ASKC ('S REMARK & WEIGHT (A4)',RMKS)
      ELSE
C        RMKS='    '
        RMKS=' S 4'
      END IF
      IS=NINT(S*100.)

C--GET CODA
      C=ASKR('CODA DURATION (0 FOR NONE)',0.)
      IC=NINT(C)

C--GET STATION AMPLITUDE
      A=ASKR('AMPLITUDE (0 FOR NONE)',0.)
      IA=NINT(A)

C--WRITE STATION LINE
      WRITE (14,1100) STA(1:4),RMKP,STA1, IY,IM,ID,IH,IN,IP,
     3 IS,RMKS,IA, IC, STA(5:5),STA3,STA2
      GOTO 60

C--WRITE TERMINATOR LINE
80    WRITE (14,'(1X)')

C--DECIDE WHETHER TO ENTER ANOTHER EVENT
      LO=LASK('STOP ENTERING DATA & RETURN TO COMMAND LEVEL',.FALSE.)
      IF (.NOT.LO) GOTO 25

      CLOSE (14)
      RETURN
      END
      SUBROUTINE HYLIN
C--GIVEN DEPTH & DISTANCE, THIS ROUTINE CALCULATES TRAVEL TIME, ITS
C--DERIVATIVES AND EMERGENCE ANGLES AT THE SOURCE FOR ALL ARRIVALS.
C  USES THE LINV LINEAR GRADIENT (HALFSPACE) CALCULATOR FROM HYPOELLIPSE
      INCLUDE 'common.inc'
      LOGICAL ALTMOD, SALMOD

C--THE FOLLOWING ARE PASSED THRU THE ARRAY A:
C DTDR      !TT DERIV WRT DISTANCE
C DTDZ      !TT DERIV WRT DEPTH
C T      !TRAVEL TIME
C AIN      !ANGLE OF EMERGENCE AT SOURCE

      ALTMOD=MODALT(MOD).GT.0
      SALMOD=MODSAL(MOD).GT.0

C--LOOP OVER ALL ARRIVALS
      DO 280 I=1,M
C--FIND STATION INDEX AND REMOVE KPS AS AN S FLAG
      KI=IND(I)
      KPS=KI/10000
      KI=KI-10000*KPS
      J=KINDX(KI)

C--DETERMINE THE MODEL NO. TO ACTUALLY USE FOR THIS STATION
      MD=MOD
      IF (ALTMOD .AND. JLMOD(J)) MD=MODALT(MOD)
C--SWITCH TO S MODEL
      MDS=MD
      IF (SALMOD .AND. KPS.EQ.1) MD=MODSAL(MDS)

C--STATION DISTANCE
      DX=DIS(KI)
C--STZ IS THE STATION DEPTH IN KM BELOW THE REFERENCE ELEVATION
      STZ=ELEVMX(MD)
      IF (LELEV(MD)) STZ=STZ -0.001*JELEV(J)

C--CALCULATE TRAVEL TIME & DERIVATIVES
C--VST=VELOCITY AT STATION, VEQ=VEL AT EQ (NOT USED)
      CALL LINV(DX,Z1,VREF(MD),VGRAD(MD),T,AIN,DTDR,DTDZ,STZ,VST,VEQ)

C--END OF STATION LOOP
      A(I,1)=AIN
      A(I,2)=T
      A(I,3)=DTDR
280   A(I,4)=DTDZ

      RETURN
      END
      SUBROUTINE HYLINV
C--GIVEN DEPTH & DISTANCE, THIS ROUTINE CALCULATES TRAVEL TIME, ITS
C--DERIVATIVES AND EMERGENCE ANGLES AT THE SOURCE FOR ALL ARRIVALS.
C  USES THE LINVOL LINEAR GRADIENT OVER HALFSPACE CALCULATOR FROM HYPOELLIPSE
C--MODTYP IS 2
      INCLUDE 'common.inc'
      LOGICAL ALTMOD, SALMOD

C--THE FOLLOWING ARE PASSED THRU THE ARRAY A:
C DTDR      !TT DERIV WRT DISTANCE
C DTDZ      !TT DERIV WRT DEPTH
C T      !TRAVEL TIME
C AIN      !ANGLE OF EMERGENCE AT SOURCE

      ALTMOD=MODALT(MOD).GT.0
      SALMOD=MODSAL(MOD).GT.0

C--LOOP OVER ALL ARRIVALS
      DO 280 I=1,M
C--FIND STATION INDEX AND REMOVE KPS AS AN S FLAG
      KI=IND(I)
      KPS=KI/10000
      KI=KI-10000*KPS
      J=KINDX(KI)

C--DETERMINE THE MODEL NO. TO ACTUALLY USE FOR THIS STATION
      MD=MOD
      IF (ALTMOD .AND. JLMOD(J)) MD=MODALT(MOD)
C--SWITCH TO S MODEL
      MDS=MD
      IF (SALMOD .AND. KPS.EQ.1) MD=MODSAL(MDS)

C--STATION DISTANCE
      DX=DIS(KI)
C--STZSV IS THE STATION DEPTH IN KM BELOW SEA LEVEL
      STZSV=0.
      IF (LELEV(MD)) STZSV= -0.001*JELEV(J)

C--CALCULATE TRAVEL TIME & DERIVATIVES
C--VST=VELOCITY AT STATION, VEQ=VEL AT EQ (NOT USED)
      CALL LINVOL (DX,Z1,STZSV,VGRAD(MD),VSEA(MD),THICK(MD),VHALF(MD),
     2 T,AIN,DTDR,DTDZ)

C--END OF STATION LOOP
      A(I,1)=AIN
      A(I,2)=T
      A(I,3)=DTDR
280   A(I,4)=DTDZ

      RETURN
      END
      SUBROUTINE HYLOC
C--LOCATES ONE EARTHQUAKE FOR THE PROGRAM HYPOINVERSE
      LOGICAL CONERR,LZFIX,LPKTMP,LMESS,LFREEW,LSHAD
      INCLUDE 'common.inc'

C--THIS IS THE HYPOCENTER ADJUSTMENT VECTOR
      DIMENSION Y(4)

C--NRES IS THE NUMBER OF TIMES THAT RESIDUAL WEIGHTING IS APPLIED EACH ITER.
      SAVE NRES
      DATA NRES /2/

C--BLANK OUT FIELDS COMPUTED AFTER EQ IS LOCATED IN CASE RESULTS ARE PRINTED 
C  EACH ITERATION
      SOUCOD=' '
      FMSOU=' '
      XMSOU=' '
      LABPR=' '
      PMAG=0.

C--INITIALIZE VARIABLES
      LSHAD=JCP.EQ.4 .OR. JCP.EQ.5
      N=3
C--WHEN HYPO IS FIXED, SOLVE FOR EVERYTHING TO GET ERZ, ETC.
      IF (ITRLIM.EQ.0) N=4
      ITR=0
      LFREEW=.TRUE.
      DONE=.FALSE.
      RMSMIN=10000.
      OLDRMS=10000.
      RR=10000.
      LMESS=KPRINT.GT.1 .AND. LPRT

C--DEPFIX INDICATES WHETHER DEPTH IS FIXED FOR THIS EVENT, & LZFIX INDICATES
C  WHETHER IT IS FIXED ON THIS ITERATION.
      IF (Z1.EQ.0.) Z1=ZTR
      LZFIX=.TRUE.

C--ANNOUNCE WHETHER WE ARE FIXING THE HYPOCENTER
      IF (ALLFIX .AND. LPRT) THEN
        WRITE (15,*) ' FIX HYPOCENTER AND ORIGIN TIME FOR THIS EVENT'
      ELSE IF (HYPOFIX .AND. LPRT) THEN
        WRITE (15,*) ' FIX HYPOCENTER FOR THIS EVENT'
      ELSE IF (DEPFIX .AND. LPRT) THEN
        WRITE (15,*) ' FIX DEPTH FOR THIS EVENT'
      END IF

C--ZERO THE DATA NOT CALCULATED EACH ITERATION IF WE ARE PRINTING
C  A STATION LIST EACH ITERATION.
      IF (KPRINT.GT.5) THEN
        DO I=1,MMAX
          IMPORT(I)=0
        END DO
C        MXMAG=0
        NXMAG=0
        XMAG=0.
        XMMAD=0.
C        MFMAG=0
        NFMAG=0
        FMAG=0.
        FMMAD=0.
        REMK=' '
        DO K=1,KSTA
          KFMAG(K)=0
          KXMAG(K)=0
        END DO
      END IF

C******************* BEGIN ITERATION LOOP ********************************

30    M=0
      NWR=0
      D1=10000.
      D2=10000.
      ITR=ITR+1
      COSLAT=COS(CLAT/RDEG)

C--PRINT HEADING ON FIRST ITERATION
      IF (ITR.EQ.1 .AND. LMESS) WRITE (15,1010)

C--SIGNAL THE BEGINNING OF RESIDUAL & DISTANCE WEIGHTING
      IF ((ITR.EQ.ITRDI1) .AND. LMESS) WRITE (15,1081)
1081  FORMAT (' BEGIN FIRST DISTANCE WEIGHTING')
      IF ((HYPOFIX .OR. ITR.EQ.ITRDIS) .AND. LMESS) WRITE (15,1001)
1001  FORMAT (' BEGIN MAIN DISTANCE WEIGHTING')
      IF ((HYPOFIX .OR. ITR.EQ.ITRRES) .AND. LMESS) WRITE (15,1002)
1002  FORMAT (' BEGIN RESIDUAL WEIGHTING')

C++++++++++++++++++++++ CALC STATION DISTANCES AND AZIMUTHS +++++++++++++

35    DO 40 K=1,KSTA
      J=KINDX(K)

C--NEW DISTANCE CALCULATION USING UTM GRID CALCULATION
      DLATU=JLATD(J)+JLATM(J)/6000.
      DLONU=JLOND(J)+JLONM(J)/6000.
      CALL UTMCAL(CLAT,CLON,DLATU,DLONU,XSUTM,YSUTM,DELTKM)
      DIS(K)=DELTKM
C--CALCULATE AZIMUTH TO STATION IN DEG BETWEEN +/- 180
      KTEMP=0
      IF (XSUTM*YSUTM .NE. 0.) KTEMP=RDEG*ATAN2(-XSUTM,YSUTM)
      KAZEM(K)=180*KTEMP

C--SKIP UNWEIGHTED STATIONS IN FINDING THE 2ND CLOSEST STATION
C--DECODE P & S WEIGHTS
      LSWT=KWT(K)/10
      LPWT=KWT(K)-10*LSWT
      IF ((KPRK(K).EQ.'  '.OR.LPWT.GT.3) .AND.
     2 (KSRK(K).EQ.'  '.OR.LSWT.GT.3)) GOTO 40

C--DETERMINE THE INDEX OF THE 2ND CLOSEST STATION
      IF (DELTKM.EQ.D1 .OR. DELTKM.EQ.D2) THEN
        GOTO 40
      ELSE IF (DELTKM.LT.D1) THEN
        IF (D2 .NE. D1) THEN
          D2=D1
          K2=K1
        END IF
        D1=DELTKM
        K1=K
      ELSE IF (DELTKM.LT.D2) THEN
        D2=DELTKM
        K2=K
      END IF
40    CONTINUE

C--TEMP3 IS THE DISTANCE WEIGHTING SCALE FACTOR
      TEMP3=DIS(K2)
      IF (TEMP3.LT.DISCUT) TEMP3=DISCUT
      TEMP=TEMP3*DISW1
      TEMP2=TEMP3*DISW2

      TEMP4=DIS(K2)
      IF (TEMP4.LT.DISCU1) TEMP4=DISCU1
      TEMP5=TEMP4*DISW11
      TEMP6=TEMP4*DISW21

C--ABORT EVENT IF DISTANCE TO SECOND CLOSEST STATION EXCEEDS D2FAR KM
      IF (D2.GT.D2FAR) THEN
        J=KINDX(K2)
        WRITE (6,1003) KYEAR2,KMONTH,KDAY,KHOUR,KMIN,
     2  STANAM(J),JNET(J),JCOMP3(J),D2,D2FAR

        IF (LPRT) WRITE (15,1003) KYEAR2,KMONTH,KDAY,KHOUR,KMIN,
     2  STANAM(J),JNET(J),JCOMP3(J),D2,D2FAR

1003    FORMAT (' *** STOP ITERATING EVENT ',I4,4I3,
     2  ' BECAUSE DISTANCE TO SECOND CLOSEST'/
     3  ' *** STATION ',A5,'-',A2,'-',A3,' IS',
     4  F6.0,' & EXCEEDS',F6.0,' KM.')
        IRES=-53
        DONE=.TRUE.
      END IF

C++++++ LOOP OVER REPORTING STATIONS TO CALC DIST WTS & LOG IN TIMES ++++++

      DO 50 K=1,KSTA
      J=KINDX(K)

C-- APPLY DISTANCE AND STATION WEIGHTS
C--CHECK MAIN DISTANCE WEIGHTING FIRST (FOR EX. ITERATIONS 4-30),
C  THEN FIRST DISTANCE WEIGHTING SECOND (FOR EX. ITERATIONS 1-3)
      WFAC=.1*JPSWT(J)

      IF (DIS(K).GE.TEMP .AND. (ITR.GE.ITRDIS .OR. HYPOFIX) .AND.
     2 LFREEW) THEN
        IF (DIS(K).GT.TEMP2) THEN
          WFAC=0.
        ELSE
          WFAC=(.5*COS(PI*(DIS(K)-TEMP)/(TEMP2-TEMP))+.5)*WFAC
        END IF

      ELSE IF (DIS(K).GE.TEMP5 .AND. (ITR.GE.ITRDI1 .OR. HYPOFIX)
     2 .AND. LFREEW) THEN
        IF (DIS(K).GT.(TEMP4*DISW21)) THEN
          WFAC=0.
        ELSE
          WFAC=(.5*COS(PI*(DIS(K)-TEMP5)/(TEMP6-TEMP5))+.5)*WFAC
        END IF
      END IF

C--DECODE P & S WEIGHTS
      LSWT=KWT(K)/10
      LPWT=KWT(K)-10*LSWT
C--IF ONLY A MAGNITUDE IS TO BE COMPUTED (BUT THERE IS NO P OR S), OR IF THERE
C  IS A SHADOW CARD, RESERVE A PLACE FOR STATION BY PRETENDING TO LOG IN A P.
      LPKTMP=KPRK(K).NE.'  '
      IF (LPKTMP .OR. LSHAD .OR. ((AMPK(K).NE.0. .OR.
     2 FMPK(K).GT.0.) .AND. KSRK(K).EQ.'  ')) THEN

C--LOG IN P ARRIVAL TIMES AND WEIGHTS
        M=M+1
        IF (M.GT.MMAX) GOTO 52
        W(M)=0.

C--USE A FLEXIBLE WEIGHT SCHEME INSTEAD OF THE TRADITIONAL 0.25 WEIGHT STEPS
        IF (LPWT.LT.4 .AND. LPKTMP) W(M)= WTVALS(LPWT+1) *WFAC
        IF (W(M).GT.0.) NWR=NWR+1
        IND(M)=K
      END IF

      IF (KSRK(K).NE.'  ') THEN
C--LOG IN S ARRIVAL TIMES AND WEIGHTS
        M=M+1
        IF (M.GT.MMAX) GOTO 52
        W(M)=0.

C--USE A FLEXIBLE WEIGHT SCHEME INSTEAD OF THE TRADITIONAL 0.25 WEIGHT STEPS
        IF (LSWT.LT.4) W(M)= WTVALS(LSWT+1) *WFAC*SWT
        IF (W(M).GT.0.) NWR=NWR+1
C--USE IND BOTH TO INDEX ARRIVALS TO PHASE CARDS AND FLAG S ARRIVALS
        IND(M)=K+10000
      END IF

C--END OF STATION LOOP
50    CONTINUE
      GOTO 54

C--COME HERE IN CASE OF TOO MANY PHASES
52    M=MMAX
      K=IND(M)
      J=KINDX(K)
      IF (LPRT .AND. ITR.EQ.1)
     2 WRITE (15,1004) STANAM(J),JNET(J),JCOMP3(J)
1004  FORMAT (' TOO MANY PHASES. LAST STATION INCLUDED IS ',
     2 A5,'-',A2,'-',A3)

54    IF (M.LT.4) GO TO 500

C++++++++++++++ CALC ALL TRAVEL TIMES AND DERIVS ++++++++++++++++++++

C--PASS TRAVEL TIMES & DERIVATIVES IN COLS OF ARRAY A:
C--THIS USES ARRAY A TWICE TO SAVE SPACE
C  A(I,1)  AIN   ANGLE OF INCIDENCE
C  A(I,2)  T     TRAVEL TIME
C  A(I,3)  DTDR  TT DERIV WRT DISTANCE
C  A(I,4)  DTDZ  TT DERIV WRT DEPTH

C--GET ALL TRAVEL TIMES & DERIVATIVES, INCLUDING MULTIPLE MODELS
      CALL HYTRA

C--LOOP OVER ALL ARRIVAL TIMES TO CALC EMERGENCE ANGLES, RESIDUALS, ETC.
      DO 60 IM=1,M

C--FIND STATION INDEX AND REMOVE KPS AS AN S FLAG
      K=IND(IM)
      KPS=K/10000
      K=K-10000*KPS
      J=KINDX(K)

C--RECORD EMERGENCE ANGLE AND AZIMUTH
C--MAKE THEM THE SAME SIGN TO FIT BOTH IN A 16-BIT WORD
      KTEMP=KAZEM(K)/180
      AZM=KTEMP/RDEG
      TEMP=A(IM,1)
      IF (KTEMP.LT.0) TEMP=-TEMP
      KAZEM(K)=KTEMP*180+TEMP
C--CALCULATED TRAVEL TIME IN UNITS OF 0.01 SEC
      MTCAL(IM)=100.*A(IM,2)

C+++++++++++++++++ CALC DELAYS AND RESIDUALS ++++++++++++++++++

C--CALC DELAYS, OBS ARRIVAL TIME, AND VEL INDEPENDENTLY FOR P AND S
C--KP, JPD, KS, TEMP, TEMP2, DLY, PSB IN UNITS OF 0.01 SEC
C--PSFAC IS THE SLOPE OF THE P OVER S LINEAR VELOCITY RELATION FOR
C  USE WITH PARTIAL DERIVATIVES
      IF (KPS.NE.1) THEN
C--THIS IS A P WAVE
        PSFAC=1.
        PSB=0.
        TEMP2=KP(K)
        IF (LMULT) THEN
          DLY=0.
          DO I=1,NMOD
            IT=MODS(I)
            DLY=DLY+ WMOD(I)*JPD(IT,J)
          END DO
        ELSE
          DLY=JPD(MOD,J)
        END IF
      ELSE

C--THIS IS AN S WAVE
C--FOR AN S MODEL, POSM SHOULD BE 1, POSB SHOULD BE 0
        TEMP2=KS(K)
        IF (LMULT) THEN
          PSFAC=0.
          PSB=0.
          DLY=0.
          DO I=1,NMOD
            IT=MODS(I)
            PSFAC=PSFAC+ WMOD(I)*POSM(IT)
            PSB=PSB+ 100.*WMOD(I)*POSB(IT)
            DLY=DLY +(WMOD(I)*POSM(IT)*JPD(IT,J))
          END DO
        ELSE
          PSFAC=POSM(MOD)
          PSB=100.*POSB(MOD)
          DLY=POSM(MOD)*JPD(MOD,J)
        END IF
      END IF

C--CALC TRAVEL TIME RESIDUAL
C--MTCAL, TEMP2, PSB, DLY IN UNITS OF 0.01 SEC. 
C--PSFAC IS A CLOSE APPROX TO WEIGHTING DIFFERENT MODELS POS VALUES
      R(IM)=.01*(TEMP2 -(MTCAL(IM)*PSFAC+PSB) -DLY)-T1

C--SET PARTIAL DERIVATIVES
C--(1)=DTDT,(2)=DTDY,(3)=DTDX,(4)=DTDZ
      A(IM,1)=1.
      TEMP=PSFAC*A(IM,3)
C--SET LAT & LON PARTIAL DERIVATIVES
      A(IM,2)=-TEMP*COS(AZM)
      A(IM,3)= TEMP*SIN(AZM)
C--SET DT/DZ, WHICH MAY BE UNUSED IF DEPTH IS FIXED
      A(IM,4)=PSFAC*A(IM,4)

C--END OF PHASE LOOP
60    CONTINUE

C++++++++++++++++ RESIDUAL WEIGHTING ++++++++++++++++++++

C--LOOP TO APPLY RESIDUAL WEIGHTING NRES TIMES
C--NRES WILL APPROXIMATE THE NUMBER OF VERY LARGE RESIDUALS
C  TO BE DISCARDED BEFORE INVERTING FOR THE HYPOCENTER
C--IF NRES=1, ONLY 1 VERY LARGE RESIDUAL WILL BE DISCARDED,
C  LEAVING ERRORS IN THE REMAINING DATA TO CONTAMINATE THE SOLUTION

      DO 80 I=1,NRES
      RMSWT=0.
      WNORM2=0.
      NWR=0

C--ACCUMULATE RMSWT AND WEIGHTS
      DO IM=1,M
        WNORM2=WNORM2+W(IM)**2
        RMSWT=RMSWT+(W(IM)*R(IM))**2
      END DO
      IF (WNORM2.EQ.0.) GO TO 500
      RMSWT=SQRT(RMSWT/WNORM2)
C--DON'T SHRINK RESIDUAL WEIGHTING LIMITS IF RMSWT BECOMES TOO SMALL
      TEMP2=RMSWT
      IF (TEMP2.LT.RMSCUT) TEMP2=RMSCUT
      TEMP=(RMSW2-RMSW1)*TEMP2
      WNORM=0.

C--LOOP TO CALC AND APPLY RESIDUAL WEIGHTING FOR ALL ARRIVALS
      DO 70 IM=1,M
      IF ((ITR.GE.ITRRES .OR. HYPOFIX) .AND. LFREEW) THEN 
        IF (W(IM).EQ.0.) GO TO 70
        RES=(ABS(R(IM))-RMSW1*TEMP2)/TEMP
        IF (RES.GT.1.) THEN
          W(IM)=0.
          GOTO 70
        END IF
        IF (RES.GT.0.) W(IM)=W(IM)*(.5+.5*COS(PI*RES))
      END IF
      WNORM=WNORM+W(IM)
      NWR=NWR+1
70    CONTINUE
80    CONTINUE

      WFAC=NWR/WNORM
      WNORM2=0.
      RMS=0.
      NWS=0
      NWR=0

C--NOW NORMALIZE WEIGHTS AND APPLY THEM TO PARTIAL DERIVATIVES
      DO 95 IM=1,M

C--NORMALIZE WEIGHTS
        W(IM)=W(IM)*WFAC
        WNORM2=WNORM2+W(IM)**2
        RMS=RMS+(R(IM)*W(IM))**2
C--COUNT WEIGHTED ARRIVALS
        IF (W(IM).GT..1) THEN
          NWR=NWR+1
          K=IND(IM)
          KPS=K/10000
          IF (KPS.NE.0) NWS=NWS+1
        END IF

C--APPLY WEIGHTS TO PARTIAL DERIVS
        DO 90 I=1,N
90      A(IM,I)=A(IM,I)*W(IM)

C--LOAD THE DATA VECTOR R INTO THE N+1ST COL OF A FOR INVERSION IN SOLVE
95    A(IM,N+1)=R(IM)*W(IM)

      RMS=SQRT(RMS/WNORM2)

C--TEST TO SEE IF WE STILL HAVE ENOUGH DATA AFTER ALL WEIGHTING
      IF (NWR.LT.4 .AND. LFREEW) THEN
        LFREEW=.NOT.LJUNK
C--OPTIONALLY FORCE A SOLUTION WITHOUT DIST & RESIDUAL WEIGHTING
        IF (.NOT.LFREEW) THEN
          IF (LMESS) WRITE (15,1005)
1005      FORMAT (' DISTANCE & RESIDUAL WEIGHTING CANCELLED')
          IF (LREP) WRITE (6,1008) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1008      FORMAT (' *** DISTANCE & RESIDUAL WEIGHTING CANCELLED',
     2    ' FOR EVENT: ',I4,4I3)
        ELSE
          GOTO 500
        END IF
      END IF

C--SET DONE FLAG IF HYPOCENTER IS FIXED 
      IF (HYPOFIX) DONE=.TRUE. 

C--MAKE THIS THE LAST ITER IF 1) CHANGE IN RMS OR ADJ VECTOR IS SMALL
C  (ONLY IF THE DEPTH HAS BEEN FREED) OR 2) THE MAX NO. OF ITERATIONS 
C  IS REACHED (AND THE RMS DID NOT INCREASE LAST TIME)
C--BUT CONTINUE ITERATING IF DIS & RES WEIGHTS HAVENT BEEN APPLIED.
      IF (ITR.GT.ITRDIS .AND. ITR.GT.ITRRES .AND. .NOT.DONE)
     2 DONE=(((ABS(OLDRMS-RMS).LT.DRQT) .OR.
     3 RR.LT.DQUIT) .AND. (.NOT.LZFIX .OR. DEPFIX))
     4 .OR. (ITR.GT.ITRLIM .AND. RMS.LT.RMSMIN+RBACK)
     
C--GO BACK TOWARD OLD SOLUTION IF RMS INCREASED LAST TIME
      IF (RMS.GT.RMSMIN+RBACK .AND. .NOT.DONE) THEN
        JBAC=JBAC+1
        OLDRMS=RMS
        IF (RMS.LT.RMSMIN) RMSMIN=RMS
        IF (JBAC.EQ.1) THEN
C--BACKUP TOWARD OLD SOLUTION FOR FIRST TIME
          DO 105 I=1,4
105       Y(I)=-BACFAC*Y(I)
          RR=RR*BACFAC
        ELSE
C--BACKUP TOWARD OLD SOLUTION FOR SECOND OR LATER TIME
          DO 100 I=1,4
100       Y(I)=(1.-BACFAC)*Y(I)
          RR=RR*(1.-BACFAC)
        END IF
        IF (LMESS) WRITE (15,1006) BACFAC
1006    FORMAT (' RMS INCREASE - MOVE HYPO ',F4.2,' BACK')
        CONERR=.TRUE.
        GOTO 130
      END IF

C+++++++++++++++ INVERT FOR HYPO ADJUSTMENT ++++++++++++++++++++++++++

C--DO INVERSION FOR 1 ITER, FINDING OTHER USEFUL MATRICES IF REQUESTED
C--IF DEPTH HELD FIXED, N=3. N=4 OTHERWISE.
      CALL HYSOL (N,Y,NFREE,LZFIX)

C--SET CONVERGENCE ERROR FLAG (USED TO POST A '#' REMARK)
      CONERR=.FALSE.

C--ALLOW DEPTHS USING HYPOELLIPSE GRADIENT MODELS TO BECOME NEGATIVE, BUT
C  ONLY UP TO THE REFERENCE (MAX) ELEVATION
      IF (MODTYP(MOD).EQ.2 .OR. MODTYP(MOD).EQ.3
     2 .OR. MODTYP(MOD).EQ.4) THEN

C--PREVENT HYPO FROM ITERATING ABOVE REFERENCE ELEVATION
C        IF (Z1+Y(4) .LT. -ELEVMX(MOD)) THEN
        IF (Z1+Y(4) .LT. -ELEVMAX) THEN		!FWK 1.37

          IF (LMESS) WRITE (15,*)
     2    ' KEEP QUAKE BELOW REFERENCE ELEVATION'
          CONERR=.TRUE.
C          TEMP=-DZAIR*(ELEVMX(MOD)+Z1)/Y(4)
C          Y(4)=-DZAIR*(ELEVMX(MOD)+Z1)

          TEMP=-DZAIR*(ELEVMAX+Z1)/Y(4)	!FWK 1.37
          Y(4)=-DZAIR*(ELEVMAX+Z1)	!FWK 1.37
          DO I=1,3
            Y(I)=Y(I)*TEMP
          END DO
        END IF

      ELSE
C--HANDLE LAYER & GRADIENT MODELS AS BEFORE PREVENTING AIRQUAKES
C--PREVENT HYPO FROM ITERATING INTO THE AIR
C        IF (Z1+Y(4).LT.0.) THEN
        IF (Z1+Y(4) .LT. -ELEVMAX) THEN	!FWK 1.37

          IF (LMESS) WRITE (15,'(" AIRQUAKE PREVENTED")')
          CONERR=.TRUE.
C          TEMP=-DZAIR*Z1/Y(4)
C          Y(4)=-DZAIR*Z1

          TEMP=-DZAIR*(ELEVMAX+Z1)/Y(4)	!FWK 1.37
          Y(4)=-DZAIR*(ELEVMAX+Z1)	!FWK 1.37
          DO I=1,3
            Y(I)=Y(I)*TEMP
          END DO
        END IF
      END IF

C--DAMP DEPTH ADJUSTMENT IF TOO LARGE
      IF (ABS(Y(4)).GT.DZMAX) THEN
        IF (LMESS) WRITE (15,1220)
1220    FORMAT (' DEPTH ADJUSTMENT DAMPED')
        CONERR=.TRUE.
        Y(4)=Y(4)*DZMAX/(ABS(Y(4))+DZMAX)
      END IF

C--SAVE RMS AND COMPUTE ADJUSTMENT VECTOR LENGTH
      OLDRMS=RMS
      IF (RMS.LT.RMSMIN) RMSMIN=RMS
      JBAC=0
      RR=0.
      DO 120 I=2,4
120   RR=RR+Y(I)**2
      RR=SQRT(RR)

C--DAMP DISTANCE ADJUSTMENT
      IF (RR.GT.DXMAX) THEN
        CONERR=.TRUE.
        TEMP=DXMAX/RR
        IF (LMESS) WRITE (15,1233) TEMP
1233    FORMAT (' CURB DISTANCE STEP. ALL ADJUSTMENTS DAMPED BY',F6.3)
        DO I=1,4
          Y(I)=Y(I)*TEMP
        END DO

C--RE-COMPUTE ADJUSTMENT VECTOR LENGTH
        RR=0.
        DO I=2,4
          RR=RR+Y(I)**2
        END DO
        RR=SQRT(RR)
      END IF

C+++++++++++++++ PRINT INVERSION INFO +++++++++++++++++++++

C--GET COORDS IN DEG AND MIN, AND WRITE LOC FOR THIS ITERATION
C--LOCATION IS THAT PRIOR TO ADJUSTMENTS GIVEN
130   IS=' '
      IE=' '
C--LATITUDE
      IF (CLAT.LT.0.) IS='S'
      TEMP=ABS(CLAT)
      LAT=TEMP
      XLTM=60.*(TEMP-LAT)

C--LONGITUDE
C--BRING EQS WEST OF WEST HEMISPHERE INTO EAST HEMISPHERE V.1.38
      TEMP7=CLON
      IF (TEMP7.GT.180.) TEMP7=TEMP7-360.
      IE='W'
      IF (TEMP7.LT.0.) IE='E'
      TEMP=ABS(TEMP7)      
      LON=TEMP
      XLNM=60.*(TEMP-LON)

C--OUTPUT ADJUSTMENTS TO PRINT FILE
      IF (LMESS) THEN
C--PRINT HEADING
        IF (KPRINT.GT.4 .AND. ITR.NE.1) WRITE (15,1010)
1010    FORMAT (56X,'ADJUSTMENTS (KM)'/'  I ORIGIN   LAT N',5X,'LON W',
     2  5X,'Z   NWR  RMS    DT    DLAT   DLON    DZ    RR NF MOD')
C--PRINT ADJUSTMENT
        WRITE (15,1020) ITR,T1, LAT,IS,XLTM, LON,IE,XLNM,
     2  Z1,NWR,RMS, Y,RR, NFREE,CRODE(MOD)
1020    FORMAT (1X,I2,F6.2, I4,A1,F5.2, I5,A1,F5.2,
     2  F6.2,I4,F5.2, 4F7.3,F6.3, I2,1X,A3)
      END IF

C--IF HYPOCENTER IS FIXED 
      IF (ITRLIM.EQ.0 .OR. HYPOFIX) THEN 
        WNORM=0.
        TEMP=0.
C--FIND AVERAGE RESIDUAL
        DO IM=1,M
          WNORM=WNORM+W(IM)
          TEMP=TEMP+R(IM)*W(IM)
        END DO

C--ADJUST ORIGIN TIME IF OT IS NOT FIXED
        IF (.NOT.ALLFIX) THEN
          IF (LMESS) WRITE (15,1221)
1221      FORMAT (' AVERAGE RESIDUAL REMOVED; O.T. ADJUSTED')

          DT=TEMP/WNORM
          T1=T1+DT
C--ADJUST RESIDUALS BY SAME TIME SHIFT AND RECOMPUTE RMS.
C  RESIDUALS WILL BE RECALCULATED IN HYLST.
          RMS=0.
          WNORM2=0.
          DO IM=1,M
            R(IM)=R(IM)-DT
            WNORM2=WNORM2+W(IM)**2
            RMS=RMS+(R(IM)*W(IM))**2
          END DO
C--CORRECT VALUE OF RMS
          RMS=SQRT(RMS/WNORM2)
        END IF
      END IF

      IF (DONE) GOTO 510

C--OPTIONALLY LIST ALL STATIONS NOW
      IF (KPRINT.GT.5 .AND. LPRT) CALL HYLST

C+++++++++++++++++++++ ADJUST HYPOCENTER +++++++++++++++++++++

      T1=T1+Y(1)
      CLAT=CLAT+Y(2)/111.19
      CLON=CLON+Y(3)/(111.19*COS(CLAT/RDEG))
      Z1=Z1+Y(4)

C--FREE THE FOCAL DEPTH ON NEXT ITER IF ADJUSTMENT IS SMALL ENOUGH
C  AND THE DEPTH IS NOT PERMANENTLY FIXED
C      NLAST=N
      N=3
      IF (RR.LT.DXFIX .AND. .NOT.DEPFIX) THEN
        IF (LMESS .AND. LZFIX) WRITE (15,1230)
1230    FORMAT (' FREE DEPTH')
        LZFIX=.FALSE.
      END IF
C--SOLVE FOR DEPTH IF IT IS NOT FIXED
      IF (.NOT.LZFIX) N=N+1

      GOTO 30

C*************** END ITERATION LOOP ***************************

C--ABANDON SOLUTION WITH INSUFFICIENT DATA
C--OUTPUT STATIONS HERE, SINCE IT WILL NOT BE DONE FROM MAIN PROG
500   IF (LPRT) WRITE (15,1052) NWR,INUM,IDNO
      IF (LERR) WRITE (6,1052) NWR,INUM,IDNO
1052  FORMAT (' *** ',I1,' PHASES CANT SOLVE SEQUENCE NO.',
     2 I5,', ID NO.',I10)
      IRES=-51

C--FLAG THIS EVENT IF IT HAD CONVERGENCE PROBLEMS
510   IF (ITR.GT.ITRLIM .OR. CONERR .OR. .NOT.LFREEW) RMK2='#'
C--FLAG EVENT IF DEPTH HELD FIXED
      IF (NFREE.LT.4) RMK2='-'
C--FLAG EVENT IF HYPOCENTER HELD FIXED
      IF (HYPOFIX) RMK2='X' 
      IF (ALLFIX) RMK2='O' 
      RETURN
      END
      SUBROUTINE HYLST
C--DOES FINAL OUTPUT OF EVENT DATA BY STATION FOR HYPOINVERSE
      INCLUDE 'common.inc'

      LOGICAL LSHAD,LALT,LKILL,LMUSE,LSMOD
      DOUBLE PRECISION DTEMP
      CHARACTER XTEMP*5,FTEMP*5, CWT*1,C1*1,C3*3, CALCH*5,FCHAR*22
      CHARACTER XCHAR*17,XCHAR2*22,XCHAR7*7,XCHAR20*20,CA1*1,CWF*1
      CHARACTER CRES*6,STAR*1, XLABL(4)*3, STA*5, SLOC*2, MLABL(5)*3
      CHARACTER LINE*145,PRVSTA*5,LABF*1,LABX*1,LABPA*1
      CHARACTER COMP1*1,COMP3*3, PCOMP1*1,PCOMP3*3,PLOC*2
      CHARACTER SNET*2, PNET*2, CT1*1, COMPA*3, CFMP*4
      CHARACTER PTEMP*5,PCHAR*20, PACHAR*37, PACHR2*37
      CHARACTER FMNOT*1, XMNOT*1	!WEIGHTOUT CHARACTER FOR FMAG,XMAG
      CHARACTER XC3*3, FC3*3, XC2*2, FC2*2, CMAD*3, XC16*16, FC16*16
      SAVE XLABL,MLABL
      DATA XLABL /'OT ','LAT','LON','Z  '/
      DATA MLABL /'CRT','CRH','CRV','CRL','CRE'/

      PRVSTA=' '
      PCOMP1=' '
      PCOMP3=' '
      PLOC=' '
      LKILL=.FALSE.
      LALT=MODALT(MOD).GT.0
      LSMOD=MODSAL(MOD).GT.0
      LSHAD=JCA.EQ.3
      CMAD='RMS'
      IF (LMED) CMAD='MAD'

C--OUTPUT EIGENDATA AND ERROR ELLIPSE
      IF (KPRINT.GT.2 .AND. LPRT) THEN
C--OUTPUT HEADING & EIGENVALUES
        WRITE (15,1100) EIGVAL
1100    FORMAT (/14X,'EIGENVALUES'/ 5X,'(',F6.3,3F7.3,')' /6X,
     2  'EIGENVECTORS OF ADJUSTMENT', 16X,'COVARIANCE', 13X,'ERRORS')
C--COMPUTE STANDARD DEVIATIONS
        DO 150 I=1,4
          TEMP=SQRT(COVAR(I,I))

C--OUTPUT EIGENVECTORS, COVARIANCE, STD. DEV. & ERROR ELLIPSE
          WRITE (15,1101) XLABL(I),(V(I,J),J=1,4),(COVAR(I,J),J=1,4),
     2    TEMP
1101      FORMAT (1X,A3,' (',F6.3,3F7.3,') (',4F8.3,')',F8.3)
150     CONTINUE
      END IF

C--PRINT ERROR ELLIPSE AXES
      IF (KPRINT.GT.0 .AND. LPRT) WRITE (15,1102)
     2 (SERR(I),IAZ(I),IDIP(I),I=1,3)
1102  FORMAT (' ERROR ELLIPSE: ',
     2 3('-<',F7.2,I4,I3,'>'))

1001  FORMAT (F6.2)
1002  FORMAT (F4.2)
1003  FORMAT (F4.1)
1004  FORMAT (I4)
1009  FORMAT (F5.2)
1010  FORMAT (I1)

C--ADJUST ORIGIN IF EVENT HAS ITERATED INTO ANOTHER MINUTE.
C  DO NOT ADJUST TIME IF EVENT IS STILL BEING LOCATED.
C  NSHIF IS THE SHIFT IN .01 SEC TO SUBTRACT FROM P & S TIMES
      NSHIF=0
      IF (DONE) THEN
C--ROUND ORIGIN TIME TO NEAREST .01 SEC. THIS SHOULD PREVENT ROUND OFF ERROR
C  IN RESIDUAL CALCULATION.
        T1=.01*NINT(T1*100.)

C--AT FIRST, NT IS THE TIME SHIFT IN MINUTES, THEN IN HOURS.
        NT=(T1+600.)/60.
        NT=NT-10
        IF (ABS(NT).GT.4) THEN
          WRITE (6,1035) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
          IF (LPRT) WRITE (15,1035) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1035      FORMAT (' *** ORIGIN TIME SHIFT LIMITED TO 4 MIN. IN EVENT',
     2    I4,4I3)
          NT=ISIGN(4,NT)
        END IF

C--ADJUST ORIGIN MINUTES
        T1=T1-NT*60.
        KMIN=KMIN+NT
        NSHIF=NT*6000
C--ADJUST ORIGIN HOURS
        NT=(KMIN+60.)/60.
        NT=NT-1
        KMIN=KMIN-NT*60
        KHOUR=KHOUR+NT

C--ADJUST DATE IF EVENT HAS ITERATED INTO ANOTHER DAY
        IF (KHOUR.LT.0) THEN
          KHOUR=KHOUR+24
          DTEMP=DAYJL(KYEAR2,KMONTH,KDAY)-1.+.01
          CALL JDATE (DTEMP,KYEAR2,KMONTH,KDAY,JH,JN)
        END IF
        IF (KHOUR.GT.23) THEN
          KHOUR=KHOUR-24
          DTEMP=DAYJL(KYEAR2,KMONTH,KDAY)+1.+.01
          CALL JDATE (DTEMP,KYEAR2,KMONTH,KDAY,JH,JN)
        END IF
      END IF

C--COUNT NUMBER OF VALID READINGS WITH WEIGHT CODES <4
      NVR=0
C--TALLY FIRST MOTIONS WHEN THEY ARE NON-BLANK AND P TIMES ARE WEIGHTED
      NFRM=0
      DO K=1,KSTA
        LSWT=KWT(K)/10
        LPWT=KWT(K)-10*LSWT
          IF (LPWT.LT.4 .AND. KPRK(K).NE.'  ') THEN
            NVR=NVR+1
            IF (KPRK(K)(3:3).NE.' ') NFRM=NFRM+1
          END IF
          IF (LSWT.LT.4 .AND. KSRK(K).NE.'  ') NVR=NVR+1
      END DO

C--COMPUTE LARGEST GAP AS MAXGAP
      MAXGAP=0
C--CALC DISTANCE TO NEAREST STA & NUMBER OF FIRST MOTIONS
      DMIN=32700.

C--EXAMINE ALL POSSIBLE GAPS FOR THE LARGEST BETWEEN ADJACENT STATIONS
      DO 30 IM=1,M
C--DONT COUNT UNWEIGHTED STATIONS IN GAP OR MINDIS
      IF (W(IM).LT..1) GO TO 30
C--REMOVE S FLAG FROM STATION INDEX
      K=IND(IM)
      IF (K.GT.10000) K=K-10000
C--FIND LEAST STATION DISTANCE
      IF (DIS(K).LT.DMIN) DMIN=DIS(K)
      MINGAP=360
      LAZ1=KAZEM(K)/180

C--INNER STATION LOOP
      DO 20 I=1,M
        IF (I.EQ.IM .OR. W(I).LT..1) GOTO 20
        K2=IND(I)
        IF (K2.GT.10000) K2=K2-10000
        LAZ2=KAZEM(K2)/180
        JGAP=LAZ1-LAZ2
        IF (JGAP.LE.0) JGAP=JGAP+360
        IF (JGAP.LT.MINGAP) MINGAP=JGAP
20    CONTINUE

      IF (MINGAP.GT.MAXGAP) MAXGAP=MINGAP
30    CONTINUE

C--GET REAL MAGNITUDE WEIGHTS
C      FWT=MFMAG*.01
C      XWT=MXMAG*.01

C++++++++++++++ OUTPUT THE LOCATION +++++++++++++++++
C--OUTPUT TO ARCHIVE FILE, USING ARCHIVE FILE UNIT NUMBER
      IF (LARC .AND. NWR.GE.MINSTA .AND. DONE) THEN
        CALL HYSUM (7)
C--WRITE OPTIONAL SHADOWS TO SUMMARY HEADER
        IF (LSHAD) THEN
          IF (LSHA1(1).EQ.0) THEN
            SHAD1(1)='$'
            LSHA1(1)=1
          END IF

C          IF (LPMAG) THEN
C--ADD SOME PMAG DATA TO FIRST SUMMARY SHADOW CARD ONLY IF PMAGS ARE COMPUTED
C            KAZ=PNORMN*1000.+.5
C            KEM=PNRMN2*1000.+.5
C            WRITE (7,'(A,2I4)') SHAD1(1)(1:80),KAZ,KEM
C          ELSE
C--WRITE THE SUMMARY SHADOW RECORD
            WRITE (7,'(A)') SHAD1(1)(1:LSHA1(1))
C          END IF

          DO I=2,NSHA1
            IF (LSHA1(I).GT.0) THEN
              WRITE (7,1008) SHAD1(I)(1:LSHA1(I))
            ELSE
              WRITE (7,'(''$'')')
            END IF
          END DO
        END IF
      END IF

C--DO EVENT LEVEL OPERATIONS FOR OPTIONAL MAG DATA FILE
      IF (LMAG .AND. NWR.GE.MINSTA .AND. DONE) THEN
C--WRITE SUMMARY LINE TO MAG DATA FILE
        CALL HYSUM (16)
        KQ=NINT(T1*100.)

C--PREPARE EVENT FMAG INFO
        LFMAG=NINT(FMAG*100.)
        KFMMAD=NINT(FMMAD*100.)
        LFMAG2=NINT(FMAG2*100.)
        KFMMAD2=NINT(FMMAD2*100.)

C--PREPARE XMAG INFO
        LXMAG=NINT(XMAG*100.)
        KXMMAD=NINT(XMMAD*100.)
        LXMAG2=NINT(XMAG2*100.)
        KXMMAD2=NINT(XMMAD2*100.)

C--PREPARE PREFERRED MAG INFO
        LPRMAG=NINT(PMAG*100.)
        KPRMAD=NINT(PMMAD*100.)

C--PREPARE EXTERNAL MAG INFO
        LBMAG=NINT(BMAG*100.)
      END IF

C--OUTPUT TO PRINTER
      IF (LPRT) THEN

C--STORE & OUTPUT MAGNITUDES AS A STRING WHICH IS BLANK IF NONE PRESENT
        FTEMP=' '
        XTEMP=' '
        FC16=' '
        XC16=' '
        PTEMP=' '
        IF (NFMAG.GT.0) THEN
          WRITE (FTEMP,1009) FMAG
          WRITE (FC16,1019) NFMAG,FMMAD,LABF1
1019      FORMAT (I7,F6.2,1X,A1,1X)
        END IF
        IF (NXMAG.GT.0) THEN
          WRITE (XTEMP,1009) XMAG
          WRITE (XC16,1019) NXMAG,XMMAD,LABX1
        END IF
        IF (NPMAG.GT.0 .OR. PMAG.GT.VNOMAG) WRITE (PTEMP,1009) PMAG

C--FLAG THE MODEL CODE IF AN ALTERNATE OR S MODEL WAS USED FOR SOME STATIONS
        CTEMP=' '
        IF (LALT) CTEMP='*'
        IF (LSMOD) CTEMP='S'

C--OUTPUT LOCATION TO PRINT FILE
        WRITE (15,1027) CZFLAG
1027    FORMAT(1X,21('----')/' YEAR MO DA  --ORIGIN--  --',
     2 'LAT N-  --LON W--  DEPTH-',A1,' RMS   ERH   ERZ  XMAG1 FMAG1 ',
     3 'PMAG GEOID-DEP')

        WRITE (15,1028) KYEAR2,KMONTH,KDAY, KHOUR,KMIN,T1, LAT,IS,XLTM,
     2  LON,IE,XLNM,ZREP, RMS,ERH,ERZ, XTEMP,FTEMP,PTEMP, LABPR,ZGEOID
1028    FORMAT (1X,I4,2('-',I2.2), 2X,2I2.2,F6.2, I4,A1,F5.2,
     2  I5,A1,F5.2,F7.2, 3F6.2, 3(1X,A5), A1,F8.2)

        WRITE (15,1029) CMAD,CMAD
1029    FORMAT(90X,'SOURCE',/,' NSTA NPHS  DMIN MODEL GAP ITR NFM NWR ',
     2  'NWS NVR REMRKS-AVH  N.XMG-XM',A3,'-T   N.FMG-FM',A3,
     3  '-T  L F X')

        WRITE (15,1030) KSTA,M,DMIN,CRODE(MOD),CTEMP,
     2  MAXGAP,ITR,NFRM,NWR,NWS,NVR, REMK,RMK1,RMK2, CP1,CP2,CP3,
     3  XC16,FC16, SOUCOD,FMSOU,XMSOU

1030    FORMAT (1X,I4,I5,F6.1,2X,A3,A1,
     2  6I4,1X, A3,1X,2A1, 1X,3A1,
     3  2A16, 3(1X,A1))

C--WRITE SECOND & PREF MAG INFO, & DEPTH DATUM
C        IF (NFMAG2.GT.0 .OR. NXMAG2.GT.0 .OR. NPMAG.GT.0
C     2    .OR. PMAG.GT.VNOMAG) THEN
          XCHAR=' '
          XCHAR20=' '
          XCHAR2=' '
          FCHAR=' '
          PCHAR=' '
          WRITE (15,1040) CMAD,CMAD,CMAD
1040      FORMAT (/' XMAG2-N.XMG2-XM',A3,'-T-S  FMAG2-N.FMG2-FM',A3,
     2    '-T-S  PREF.MAG-N.PMAG-PR',A3,'-T DEPDAT NS ZT TYP')

C--WRITE SECOND AMP & DUR MAGS
          IF (NXMAG2.GT.0) THEN
            WRITE (XCHAR2,1041) XMAG2,NXMAG2,XMMAD2,LABX2,XMSOU2
1041        FORMAT (F5.2,I7,F6.2,2(1X,A1))
          END IF

          IF (NFMAG2.GT.0) THEN
            WRITE (FCHAR,1041) FMAG2,NFMAG2,FMMAD2,LABF2,FMSOU2
          END IF

C--WRITE THE PREFERRED MAGNITUDE
          IF (PMAG.GT.VNOMAG) THEN
            WRITE (PCHAR,'(F5.2,I7,F6.2,1X,A1)') PMAG,NPMAG,PMMAD,LABPR
          END IF

C--WRITE THE ENTIRE DATA LINE INCLUDING DEPTH DATUM
          WRITE (15,1042) XCHAR2,FCHAR,PCHAR, IDEPDAT,JDSTA,CZFLAG,
     2    MLABL(MODTYP(MODS(1))+1)
1042      FORMAT (1X,A22,2X,A22,5X,A20, I7,I3,2X,A1,1X, A3)
C        END IF

C--WRITE THE P AMPLITUDE MAGNITUDES IF EITHER IS PRESENT
C        IF ((PMUSED.GT.0. .OR. PMUSD2.GT.0.) .AND. LPMAG) THEN
C          PACHAR=' '
C          PACHR2=' '
C          WRITE (15,1045)
C1045      FORMAT (/' PAMAG-C-N.USED-N.CLIP-PMAD-NORM-T-S  ',
C     2    'PMAG2-C-N.USED-N.CLIP-PMAD-NORM-T-S')
C
C--WRITE PRIMARY P-AMPLITUDE MAGNITUDE
C          IF (PMUSED.GT.0.) THEN
C            WRITE (PACHAR,1048) PAMAG,PMUSED,PMCLIP,PAMAD,
C     2      PNORMN,LABP1,PSOUR
C1048        FORMAT (F5.2, 2X,F6.1,F7.1, F6.2, F5.2, 1X,A1,1X,A1,1X)
C          END IF
C
C--WRITE SECONDARY P-AMPLITUDE MAGNITUDE
C          IF (PMUSD2.GT.0.) THEN
C            WRITE (PACHR2,1048) PAMAG2,PMUSD2,PMCLP2,PAMAD2,
C     2      PNRMN2,LABP2,PSOUR2
C          END IF
C
C--FLAG THE PAMAGS WITH A + IF ANY OF THE 3 MIN NORM STATIONS ARE CLIPPED
C  (PAMAG IS A MIN. MAG)
C--THIS MINIMUM FLAG IS ALSO SET FROM THE RATIO OF PMCLIP TO PMUSED
C          IF (MINPM.EQ.1) PACHAR(7:7)='+'
C          IF (MINPM2.EQ.1) PACHR2(7:7)='+'
C
C--WRITE THE ENTIRE DATA LINE
C          WRITE (15,'(1X,2A37)') PACHAR,PACHR2
C        END IF
C
C--WRITE EXTERNAL (BERKELEY) MAGNITUDE
C          IF (BMAG.GT.0. .OR. MBMAG.GT.0) THEN
C          XWT=MBMAG*.01
C          WRITE (15,1043) BMAG,XWT,BMTYP
C1043      FORMAT (/' BERKELEY MAG=',F5.2,'  NUMBER READINGS=',F5.1,

        IF (BMAG.GT.VNOMAG .OR. NBMAG.GT.0) THEN
          WRITE (15,1043) BMAG,NBMAG,BMTYP
1043      FORMAT (/' EXTERNAL MAG=',F5.2,'  NUMBER READINGS=',I5,
     2    '  TYPE=',A1)
        END IF

C--WRITE EXTERNAL (AMP) X-MAGNITUDE
C--ASSUME FOR NOW THAT A ZERO OR BLANK EXTERNAL MAG MEANS NO MAG
C        IF (BMAGX.GT.VNOMAG .OR. NBMAGX.GT.0) THEN
        IF (BMAGX.GT.0. .OR. NBMAGX.GT.0) THEN
          WRITE (15,1044) BMAGX,NBMAGX,BMTYPX
1044      FORMAT (' EXTERNAL XMAG=',F5.2,'  NUMBER READINGS=',I5,
     2    '  TYPE=',A1)
        END IF

C--WRITE REGION NAME & MULTPLE CRUSTAL MODELS USED
        IF (LMULT) THEN
          WRITE(15,1014) FULNAM,
     2    (CRODE(MODS(I)), WMOD(I),I=1,NMOD)
1014      FORMAT (' REGION= ',A25,:
     2    '  MODELS USED:',3(2X,A3,'=',F4.2))
        ELSE
          WRITE (15,1014) FULNAM
        END IF
      END IF

C+++++++++++++++ PRINT OUT THE STATION LIST +++++++++++++++++++++++

      LINCUT=0
      MOUT=0
C--PRINT THE STATION HEADING
      IF (KPRINT.GT.0 .AND. LPRT) THEN
        WRITE (LINE,1031)
1031    FORMAT(' STA NET COM L CR DIST AZM  AN P/S WT   SEC (TOBS ',
     2  '-TCAL -DLY  =RES)  WT   SR  INFO  CAL  DUR-W-FMAG-T',
     3  ' -AMP-U-PER-W-XMAG-T DEV')
        WRITE (15,'(/,A)') LINE(1:124)
      END IF

C--LIST STATIONS IN DISTANCE ORDER
C--DISLST IS THE LEAST REMAINING DISTANCE AND WILL BE PRINTED ON THIS PASS
C--DISNXT IS THE NEXT TO LEAST REMAINING DISTANCE,
C--AND WILL BE PRINTED ON THE NEXT PASS
      DISNXT=-1

C--START OUTER STATION LOOP
40    DISLST=DISNXT
      DISNXT=32700
      KLSTA=-1

C--START INNER STATION LOOP
      DO 90 IM=1,M

C--DETERMINE STATION INDEX & WHETHER IT IS P OR S
      K=IND(IM)
      KPS=K/10000
      K=K-10000*KPS
      DK1=DIS(K)

      IF (DK1.NE.DISLST) THEN
        IF (DK1.GT.DISLST .AND. DK1.LT.DISNXT) DISNXT=DK1
        GOTO 90
      END IF
      MOUT=MOUT+1

C--DECODE CALCULATED TRAVEL TIME
      TCAL=.01*MTCAL(IM)

C--WRITE A LINE OF PHASE ARRIVAL DATA FOR THIS STATION
C--PREPARE STATION INFO
      IF (K.EQ.KLSTA) GOTO 60
      J=KINDX(K)

C--DECODE DISTANCE, AZIMUTH AND EMERGENCE ANGLE
      KAZ=KAZEM(K)/180
      KEM=ABS(KAZEM(K)-180*KAZ)
      IF (KAZ.LT.0) KAZ=KAZ+360

C--NOW STORE XMAG AND FMAG AND WEIGHTS AS ALPHAMERIC CODE
      CALCH=' '
      FCHAR=' '
      XCHAR=' '
      XCHAR20=' '
      LABF=' '
      LABX=' '

      IF (FMPK(K).GT.0. .OR. AMPK(K).GT.0.) THEN
C--USE KCAL INSTEAD OF JCAL IF KCAL IS PRESENT
        IF (KCAL(K).EQ.0) THEN
          TEMP=JCAL(J)*.001
        ELSE
          TEMP=KCAL(K)*.01
        END IF
        WRITE (CALCH,1009) TEMP
      END IF

      FMNOT=' '
      CFMP='    '
      IF (FMPK(K).GT.0.) THEN
C--FORMAT DURATION TO FIT IN 4 COLS
        IF (FMPK(K).LT.10.) THEN
          WRITE (CFMP,'(F4.2)') FMPK(K)
        ELSE IF (FMPK(K).LT.100.) THEN
          WRITE (CFMP,'(F4.1)') FMPK(K)
        ELSE
          KFMP=NINT(FMPK(K))
          WRITE (CFMP,'(I4)') KFMP
        END IF

        TEMP=.01*KFMAG(K)
C--CHOOSE THE CORRECT DUR MAG TYPE CODE (USE CODE2 IF COMPONENT USED FOR BOTH)
        IF (JFM1(J)) LABF=LABF1
        IF (JFM2(J)) LABF=LABF2

        WRITE (FCHAR,'(A4,I2,F5.2,1X,A1)') CFMP,KFWT(K),TEMP,LABF
        IF (KFWT(K).EQ.0) FCHAR(6:6)=' '

C--IDENTIFY STATIONS WITH NO WEIGHT
        IF (JFWT(J).LT.2 .OR. KFWT(K).GT.3 .OR. 
     2   (.NOT.JFM1(J) .AND. .NOT.JFM2(J))) FMNOT='X'
        FCHAR(12:12)=FMNOT
C--BLANK OUT NON-MAGNITUDES
        IF (TEMP.LE.VNOMAG) FCHAR(7:13)=' '
      END IF

C--LOAD AMP MAG DATA INTO OUTPUT STRING
C--PUT A ZERO IN AMP FIELD BECAUSE READING A NUM FIELD WITH ALL BLANKS IS BAD
      XMNOT=' '
      XCHAR7='      0'
      IF (AMPK(K).GT.0.) THEN
        TEMP=.01*KXMAG(K)
        TEMP3=AMPK(K)

C--USE PERIOD FROM PHASE CARD IF IT WAS GIVEN, OTHERWISE FROM STATION CARD
        IF (KPER(K).GT.0) THEN
          TEMP2=.01*KPER(K)
        ELSE
          TEMP2=.1*JPER(J)
        END IF
        IF (TEMP2.GT.9.9) TEMP2=9.9

C--CHOOSE THE CORRECT AMP MAG TYPE CODE (USE CODE2 IF COMPONENT USED FOR BOTH)
        LABX=' '
C        IF (KIMTYP(K).EQ.1) LABX='L'
C        IF (KIMTYP(K).EQ.2) LABX='X'
        IF (JXM1(J)) LABX=LABX1
        IF (JXM2(J)) LABX=LABX2

C--LABEL THE AMPLITUDE WITH UNITS
        CA1='M'
        IF (KAMPU(K).EQ.2) CA1='C'
        IF (KAMPU(K).EQ.3) CA1='D'
        IF (KAMPU(K).EQ.4) CA1='H'

C--CHOOSE THE AMP TYPE CODE LABEL
        CT1=' '
        IF (KAMPTYP(K).EQ.1) CT1='W'
        IF (KAMPTYP(K).EQ.2) CT1='V'
        IF (KAMPTYP(K).EQ.3) CT1='A'
        IF (KAMPTYP(K).EQ.4) CT1='X'
        IF (KAMPTYP(K).EQ.5) CT1='D'

C--SET THE WEIGHTOUT CODE TO X IF THE STATION AMP MAG WAS NOT USED (WEIGHTED)
C  IN THE EVENT MAGNITUDE.  LMUSE IS TRUE IF MAG WOULD BE USED IN ONE OF XMAG1
C  OR XMAG2 ACCORDING TO COMPONENT (OR INSTRUMENT) AND TYPE SELECTION.
        LMUSE=(JXM1(J) .AND. 
     2  (MAG1TYPX.EQ.0 .OR. KIMTYP(K).EQ.MAG1TYPX)) .OR.
     3  (JXM2(J) .AND. (MAG2TYPX.EQ.0 .OR. KIMTYP(K).EQ.MAG2TYPX))
     
        XMNOT='X'
        IF (LMUSE .AND. KXWT(K).LT.4 .AND. JXWT(J).GT.0) XMNOT=' '

C--XCHAR20 IS USED FOR PRINT FILE, XCHAR FOR OLD ARCHIVE FORMAT
        IF (AMPK(K).LT.0.996) THEN
          WRITE (XCHAR20,'(F6.3,A1,F4.2,A1,I1,F5.2,2A1)')
     2    TEMP3,CA1,TEMP2,CT1,KXWT(K),TEMP,XMNOT,LABX
          WRITE (XCHAR,'(F4.2)') TEMP3

        ELSE IF (AMPK(K).LT.9.9) THEN
          WRITE (XCHAR20,'(F6.3,A1,F4.2,A1,I1,F5.2,2A1)')
     2    TEMP3,CA1,TEMP2,CT1,KXWT(K),TEMP,XMNOT,LABX
          IF (TEMP3.GT.9.9) TEMP3=9.9
          WRITE (XCHAR,'(F4.1)') TEMP3

        ELSE
          ITMP=NINT(TEMP3)
          IF (ITMP.GT.999999) ITMP=999999
          WRITE (XCHAR20,'(I6,A1,F4.2,A1,I1,F5.2,2A1)')
     2    ITMP,CA1,TEMP2,CT1,KXWT(K),TEMP,XMNOT,LABX
          IF (ITMP.GT.9999) ITMP=9999
          WRITE (XCHAR,'(I4)') ITMP
        END IF

C--MAKE OUTPUT MORE READABLE
        IF (KXWT(K).EQ.0) XCHAR20(13:13)=' '
        IF (XCHAR20(8:8).EQ.'0') XCHAR20(8:8)=' '
        IF (TEMP.LE.VNOMAG) XCHAR20(14:19)='     '

C--XCHAR7 IS USED FOR YR 2000 ARCHIVE FORMAT. FIELD IS READ F7.2
C  PLACE DECIMAL POINT TO GET MAX DYNAMIC RANGE
        IF (TEMP3.LE.0.) THEN
          XCHAR7='      0'
        ELSE IF (TEMP3.LT.9.9999 .AND. TEMP3.GE.0.) THEN
          WRITE (XCHAR7,'(F7.5)') TEMP3
        ELSE IF (TEMP3.LT.99.999 .AND. TEMP3.GE.9.9999) THEN
          WRITE (XCHAR7,'(F7.4)') TEMP3
        ELSE IF (TEMP3.LT.999.99 .AND. TEMP3.GE.99.999) THEN
          WRITE (XCHAR7,'(F7.3)') TEMP3
        ELSE IF (TEMP3.LT.9999.9 .AND. TEMP3.GE.999.99) THEN
          WRITE (XCHAR7,'(F7.2)') TEMP3
        ELSE IF (TEMP3.LT.999999. .AND. TEMP3.GE.9999.9) THEN
          WRITE (XCHAR7,'(F7.0)') TEMP3
        ELSE IF (TEMP3.GE.999999.) THEN
          XCHAR7='999999.'
        END IF

      END IF

C--DECODE ASSIGNED WEIGHTS
      LSWT=KWT(K)/10
      LPWT=KWT(K)-LSWT*10
C--GIVE THESE A VALUE FOR ARCHIVE OUTPUT IN CASE AN ARRIVAL IS NOT PRESENT
      IMPORP=0
      IMPORS=0
      KPWT=0
      KSWT=0
      KPRES=0
      KSRES=0
      KPDLY=0
      KSDLY=0

C--SET STATION P DELAY

60    PSFAC=0.
C--DLY IS THE STATION DELAY IN SEC, PSFAC AND PSB TRANSLATE P-TT TO S-TT
C--PREPARE ARRIVAL TIME INFO, BUT FIRST DECIDE IF THIS IS P OR S
      IF (KPS.EQ.0) THEN

C--ASSUME A P ARRIVAL
        PSFAC=1.
        PSB=0.
        TEMP2=KP(K)
        IF (LMULT) THEN
          DLY=0.
          DO I=1,NMOD
            IT=MODS(I)
            DLY=DLY+ (0.01*WMOD(I)*JPD(IT,J))
          END DO
        ELSE
          DLY=0.01*JPD(MOD,J)
        END IF

        KPDLY=NINT(100.*DLY)
        C3=KPRK(K)
        C1=' '
        LWT=LPWT
C        KP(K)=KP(K)-NSHIF

C .. 8/15/95 AWW I2 INTEGER OVERFLOW PROBLEM
        ITMP = KP(K) - NSHIF
        IF (ITMP .LT. -32768) THEN
          ITMP = -32768
        ELSE IF (ITMP .GT. 32767) THEN 
          ITMP = 32767
        END IF      
        KP(K) = ITMP

        SEC=KP(K)*.01
        IMPORP=IMPORT(IM)
        KPWT=100.*W(IM)+.5
        IF (KPWT.GT.999) KPWT=999
      ELSE

C--ASSUME AN S ARRIVAL
C--MULTIPLE MODEL
        IF (LMULT) THEN
          PSFAC=0.
          PSB=0.
          DLY=0.
          DO I=1,NMOD
            IT=MODS(I)

C--IF A SEPERATE S MODEL IS DEFINED, USE THAT
            IF (MODSAL(IT).GT.0) THEN
              IT=MODSAL(IT)
              PSFAC=PSFAC+ WMOD(I)
              PSB=PSB
              DLY=DLY +(WMOD(I)*0.01*JPD(IT,J))
            ELSE
              IT=MODS(I)
              PSFAC=PSFAC+ WMOD(I)*POSM(IT)
              PSB=PSB+ WMOD(I)*POSB(IT)
              DLY=DLY +(WMOD(I)*0.01*POSM(IT)*JPD(IT,J))
            END IF
          END DO

C--SINGLE MODEL
        ELSE
C--IF A SEPERATE S MODEL IS DEFINED, USE THAT AND
C  TIMES AND DELAYS DO NOT HAVE TO MULTIPLIED BY POS
          IF (MODSAL(MOD).GT.0) THEN
            IT=MODSAL(MOD)
            PSFAC=1.
            PSB=0.
            DLY=0.01*JPD(IT,J)
          ELSE
            IT=MOD
            PSFAC=POSM(IT)
            PSB=POSB(IT)
            DLY=0.01*POSM(IT)*JPD(IT,J)
          END IF
        END IF

        KSDLY=NINT(100.*DLY)
        C3=KSRK(K)
        C1='S'
        LWT=LSWT
C        KS(K)=KS(K)-NSHIF

C .. 8/15/95 AWW I2 INTEGER OVERFLOW PROBLEM
        ITMP = KS(K) - NSHIF
        IF (ITMP .LT. -32768) THEN
          ITMP = -32768
        ELSE IF (ITMP .GT. 32767) THEN 
          ITMP = 32767
        END IF      
        KS(K) = ITMP

        SEC=KS(K)*.01
        TCAL=(TCAL*PSFAC) +PSB
        IMPORS=IMPORT(IM)
        KSWT=100.*W(IM)+.5
        IF (KSWT.GT.999) KSWT=999
      END IF

C--SET PARAMETERS COMMON TO BOTH P & S
      TOBS=SEC-T1
      XIMPOR=IMPORT(IM)*.001
C--OUTPUT WEIGHT AS A STRING
      CWT=' '
      IF (LWT.GT.0) WRITE (CWT,1010) LWT

C--FLAG STATIONS WHICH USED AN ALTERNATE MODEL
      CTEMP=' '
      IF (LALT .AND. JLMOD(J)) CTEMP='*'
      IF (LSMOD .AND. KPS.EQ.1) CTEMP='S'

C--OUTPUT RESIDUAL AS A STRING AND FLAG IT IF LARGE
      STAR=' '
      RES=TOBS-TCAL-DLY
C--LIMIT THIS NUMBER FOR PRINT OUTPUT ONLY
      IF (TOBS.GT.999.99) TOBS=999.99
      CRES=' '
      IF (C3.NE.'   ') THEN
        WRITE (CRES,1001) RES
C--FLAG READING WITH A * IF LARGE OR AN X IF READING NOT USED
        IF (ABS(RES).GT..5) STAR='*'
C        IF (LWT.GT.3 .OR. KPSWT(K).NE.' ') STAR='X'
        IF (LWT.GT.3) STAR='X'
      END IF

C--SET & THEN LIMIT P & S RESIDUALS AS INTEGERS FOR OUTPUT TO ARCHIVE FILE
      IF (KPS.EQ.0) THEN
C--P WAVE
        KPRES=NINT(100.*RES)
        IF (KPRES.GT.9999) KPRES=9999
        IF (KPRES.LT.-999) KPRES=-999
      ELSE
C--S WAVE
        KSRES=NINT(100.*RES)
        IF (KSRES.GT.9999) KSRES=9999
        IF (KSRES.LT.-999) KSRES=-999
      END IF

      STA=STANAM(J)
      SNET=JNET(J)
      COMP1=JCOMP1(J)
      COMP3=JCOMP3(J)
      COMPA=JCOMPA(J)
      SLOC=JSLOC(J)
C--USE LOCATION CODE AS INPUT, DO NOT ASSUME WHOLE EVENT IS THE SAME
C      IF (LLOC2) THEN
C        SLOC=JSLOC2(J)
C      ELSE
C        SLOC=JSLOC(J)
C      END IF

C--PRINT ARRIVAL TIME INFORMATION FOR ONE STATION
C--OPTIONALLY DONT PRINT STATION IF THERE IS NO DATA FOR IT. USE WEIGHTS
C  ASSIGNED BY THE USER TO DECIDE IF VALID DATA IS THERE.
      IF (KPRINT.GT.0 .AND. LPRT .AND. (LPRALL .OR. 
     1 (LWT.LT.4) .OR.
     2 (KFWT(K).LT.4 .AND. FMPK(K).GT.0.) .OR. 
     4 (KPAMP(K).GT.0 .AND. LPPRT) .OR.
     3 (KXWT(K).LT.4 .AND. AMPK(K).GT.0.))) THEN

C--DECIDE WHETHER TO PRINT STATION NAME ON DATA LINE. PRINT IT IF THIS STATION
C  IS DIFFERENT FROM PREVIOUS LINE OR IF THE STATION IS THE SAME BUT THE
C  PREVIOUS LINE WAS NOT PRINTED BECAUSE IT HAD NO DATA.
        IF (K.NE.KLSTA .OR. LKILL) THEN

C--WRITE ALL DATA FOR FIRST PHASE (WHICH IS A P UNLESS ONLY S WAS GIVEN)
          WRITE(LINE,1032)
     1    STA,SNET,CTEMP, COMP3,SLOC,COMP1,STRMK(J), DK1,KAZ,KEM,
     2    C3,CWT, SEC,TOBS,TCAL,
     3    DLY,CRES,STAR, W(IM),C1,KSOU(K),
     4    KRMK(K),XIMPOR, CALCH,FCHAR,XCHAR20, KRMK6(K)

1032      FORMAT (1X,A5,A2,A1, A3,1X,A2,2A1, F5.1,2I4,1X,
     2    A3,1X,A1,1X, 3F6.2,
     3    F5.2,A6,A1, F5.2,A1,1X,A1,
     4    A1,F6.3, A5,1X,A13,A20,1X, A6)

C--BLANK OUT REMARKS SINCE ONLY READING PHASE CARDS RESETS REMARK FIELD
          KRMK6(K)='    '      !

C--OMIT PRINTING STATION NAME IF SAME AS PREVIOUS ONE, EX FOR COL 9
          IF (STA.EQ.PRVSTA .AND. SNET.EQ.PNET .AND. COMP3.EQ.PCOMP3
     2     .AND. SLOC.EQ.PLOC) THEN
            LINE(1:8)=' '
            LINE(10:30)=' '
          END IF
C--BLANK OUT WEIGHT FIELDS OF UNWEIGHTED STATIONS
          IF (STAR.EQ.'X') THEN
            LINE(69:72)=' '
            LINE(78:82)=' '
          END IF

C--ADD THE DIGITIZER DEVICE CODE
          LINE(122:124)=KDEV(K)

C--WRITE THE STATION LINE
C--OPTIONALLY WRITE P AMPLITUDE MAG INFO. THIS OVERWRITES THE REMARK FIELD
C          IF (LPPRT .AND. KPAMP(K).GT.0) THEN
C
C--CHOOSE THE CORRECT P AMP MAG TYPE CODE (USE 2 IF COMPONENT USED FOR BOTH)
C            IF (JPM1(J)) THEN
C              LABPA=LABP1
C              ONORM=PNORM(K)
C            END IF
C            IF (JPM2(J)) THEN
C              LABPA=LABP2
C              ONORM=PNORM2(K)
C            END IF
C
C            TEMP=KPMAG(K)*.01
C            WRITE (LINE(119:145),1051) KPAMP(K), PARMK(K), KPAWT(K),
C     2      TEMP, PAWT(K), ONORM, LABPA
C1051        FORMAT (I5,1X,A1,I1, 2F5.2,F5.3,1X,A1)
C
C--PRINT BLANK INSTEAD OF 0 FOR FULLY WEIGHTED STATIONS
C            IF (LINE(126:126).EQ.'0') LINE(125:125)=' '
C--PRINT A + NEXT TO MINIMUM MAGS FROM CLIPPED STATIONS
C            IF (KPAWT(K).GT.1) LINE(128:128)='+'
C--PRINT AN X NEXT TO UNWEIGHTED MAGS
C            IF (PAWT(K).EQ.0.) LINE(128:128)='X'
C--BLANK OUT SOME LEADING ZEROS FOR BETTER READABILITY
C            IF (LINE(129:129).EQ.'0') LINE(129:129)=' '
C            IF (LINE(133:133).EQ.'0') LINE(133:133)=' '
C
C            WRITE (15,'(A)') LINE(1:145)
C

C--SHORTER OUTPUT LINE
C          ELSE
            WRITE (15,'(A)') LINE(1:125)
C          END IF

          PRVSTA=STA
          PNET=SNET
          PCOMP3=COMP3
          PLOC=SLOC

        ELSE

C--WRITE ONLY ARRIVAL TIME INFO FOR AN S FOLLOWING A P
          WRITE (LINE,1033) C3,CWT, SEC,TOBS,TCAL,DLY,
     2    CRES,STAR,W(IM), C1,KSOU(K),KRMK(K),XIMPOR

1033      FORMAT (31X,A3,1X,A1,1X, 3F6.2,F5.2,
     2    A6,A1,F5.2, A1,1X,2A1,F6.3)
C--ALSO LOAD S INTO OUTPUT LINE BECAUSE CTEMP WILL NOT BE WRITTEN ON S AFTER P
          IF (LSMOD .AND. KPS.EQ.1) LINE(9:9)='S'

C--BLANK OUT WEIGHT FIELDS OF UNWEIGHTED STATIONS
          IF (STAR.EQ.'X') THEN
            LINE(69:72)=' '
            LINE(78:82)=' '
          END IF
          WRITE (15,'(A)') LINE(1:82)
        END IF
        LKILL=.FALSE.

C--KEEP TRACK OF NUMBER OF STATIONS NOT PRINTED
      ELSE
        LINCUT=LINCUT+1
        LKILL=.TRUE.
      END IF
C---------------------------------------------------------------
C--WRITE A RECORD CONTAINING ALL STATION INFO TO AN ARCHIVE FILE
C--DON'T WRITE A LINE YET IF S ARRIVAL IS TO COME
      IF (IM.LT.M) THEN
        I=IND(IM+1)
        K1=I/10000
        K1=I-K1*10000
        IF (K.EQ.K1) GO TO 80
      END IF
      KTEMP=NINT(DIS(K)*10.)
      IF (KTEMP.GT.9999) KTEMP=9999

C--MANAGE MAGNITUDE STRINGS FOR BOTH ARC AND MAG FILES
      IF (KFMAG(K).LT.-99) THEN
        TEMP=ANINT(KFMAG(K)*.01)
        WRITE (FC3,'(F3.0)') TEMP
      ELSE
        WRITE (FC3,'(I3)') KFMAG(K)
      END IF
      IF (KXMAG(K).LT.-99) THEN
        TEMP=ANINT(KXMAG(K)*.01)
        WRITE (XC3,'(F3.0)') TEMP
      ELSE
        WRITE (XC3,'(I3)') KXMAG(K)
      END IF
          
      IF (LARC .AND. DONE .AND. NWR.GE.MINSTA) THEN

C--THIS PREVENTS ACCIDENTAL DATA OVERFLOW IN CASE OF VERY BAD TIMES
        IF (KP(K).LE.-10000) THEN
          KP(K)=-9999
          LPWT=9
        END IF
        IF (KS(K).LE.-10000) THEN
          KS(K)=-9999
          LSWT=9
        END IF

        IF (L2000) THEN
C--YEAR 2000 FORMAT
          WRITE (7,1005) STA,SNET,COMP1,COMP3, KPRK(K),LPWT,
     2    KYEAR2,KMONTH,KDAY,KHOUR,KMIN, KP(K),KPRES,KPWT,
     3    KS(K),KSRK(K),LSWT, KSRES,XCHAR7,KAMPU(K),KSWT,
     4    KPDLY,KSDLY,KTEMP,
     5    KEM,KXWT(K),KFWT(K),KPER(K), KRMK(K),CFMP,KAZ,
     6    FC3,XC3, IMPORP,IMPORS, KSOU(K),LABF,LABX,
     7    SLOC,KAMPTYP(K), COMPA,XMNOT,FMNOT

1005      FORMAT (A5,A2,1X,A1,A3, 1X,A3,I1,
     2    I4,4I2.2, I5,I4,I3,
     3    I5,A2,1X,I1, I4,A7,I2,I3,
     4    3I4,
     5    I3,2I1,I3, A1,A4,I3,
     6    2A3, 2I4, 3A1,
     7    A2,I2, A3,2A1)

        ELSE
C--OLD FULL FORMAT
          IXTMP=NINT(.1*KXMAG(K))
          IFTMP=NINT(.1*KFMAG(K))
          IF (IXTMP.LT.-9) IXTMP=-9
          IF (IFTMP.LT.-9) IFTMP=-9
C--PUT A ZERO IN AMP FIELD BECAUSE READING A NUM FIELD WITH ALL BLANKS IS BAD
          IF (XCHAR(2:4).EQ.'   ') XCHAR(2:4)='  0'

          WRITE (7,1034) STA(1:4),KPRK(K),LPWT,COMP1,
     2    KYEAR,KMONTH,KDAY,KHOUR,KMIN, KP(K),KPRES,KPWT,
     3    KS(K),KSRK(K),LSWT, KSRES,XCHAR(2:4),KSWT, KPDLY,KSDLY,KTEMP,
     4    KEM,KXWT(K),KFWT(K),KPER(K), KRMK(K),CFMP,KAZ,
     5    IFTMP,IXTMP, IMPORP,IMPORS, KSOU(K),LABF,LABX,
     6    STA(5:5),COMP3,SNET,SLOC

1034      FORMAT (A4,A3,I1,A1,
     2    5I2.2, I5,I4,I3,
     3    I5,A2,1X,I1, I4,A3,I3, 3I4,
     4    I3,2I1,I3, A1,A4,I3,
     5    2I2, 2I4, 1X,3A1,
     6    A1,A3,2A2)
        END IF

C--WRITE OPTIONAL SHADOW RECORD
        IF (LSHAD) THEN
          IF (KLSHA(K).EQ.0) THEN
            WRITE (7,'(''$'')') 
          ELSE

C--ADD P AMPLITUDE MAGNITUDE CALCULATIONS TO SHADOW CARD IF PMAG CALCULATED 
C            IF (LPMAG .AND. KPAMP(K).GT.0) THEN
C              IFTMP=0
C              IF (JPM1(J)) IFTMP= NINT(PNORM(K)*1000.)
C              IF (JPM2(J)) IFTMP= NINT(PNORM2(K)*1000.)
C              IXTMP= NINT(PAWT(K)*100.)
C
C--CHOOSE THE CORRECT P AMP MAG TYPE CODE (USE 2 IF COMPONENT USED FOR BOTH)
C              IF (JPM1(J)) LABPA=LABP1
C              IF (JPM2(J)) LABPA=LABP2

C              WRITE (KSHAD(K)(93:103),1059) KPMAG(K),IXTMP,IFTMP,LABPA
C1059          FORMAT (2I3,I4,A1)
C              KLSHA(K)=103
C            END IF

            WRITE (7,1008) KSHAD(K)(1:KLSHA(K))
1008        FORMAT (A)
          END IF
        END IF
      END IF

C------------ WRITE STATION TO MAGNITUDE DATA FILE --------------------
C--WRITE ENTIRE LINE, EVEN IF SOME MAGNITUDES ARE NOT PRESENT
      IF (LMAG .AND. DONE .AND. NWR.GE.MINSTA .AND.
     2 (AMPK(K).GT.0 .OR. FMPK(K).GT.0.)) THEN

C--PREPARE STATION MAG WEIGHTS AS CHARACTERS
        IF (JFWT(J).EQ.10) THEN
          CWF=' '
        ELSE
          CWF=CHAR(48+JFWT(J))
        END IF
        IF (JXWT(J).EQ.10) THEN
          CWT=' '
        ELSE
          CWT=CHAR(48+JXWT(J))
        END IF

C--DETERMINE DUR MAG COMPONENT CORRECTION
        ICOMF=0
        DO I=1,NFCM
          IF (JCOMP3(J)(1:NCOMP) .EQ. CFCM(I)(1:NCOMP))
     2    ICOMF=NINT(100.*AFCM(I))
        END DO

C--DETERMINE AMP MAG COMPONENT CORRECTION
        ICOMX=0
        DO I=1,NXCM
          IF (JCOMP3(J)(1:NCOMP) .EQ. CXCM(I)(1:NCOMP)) 
     2    ICOMX=NINT(100.*AXCM(I))
        END DO

C--WRITE STATION LINE
        WRITE (16,1036) STA,SNET,COMP3,SLOC,
     1  KYEAR2,KMONTH,KDAY,KHOUR,KMIN, KQ,KTEMP,
     2  KPRK(K),LPWT,MTCAL(IM),KPRES, REMK,KSOU(K),KRMK(K),
     3  JTYPE(J),JCAL(J), 
     4  CFMP,KFWT(K), CWF,JFCOR(J),ICOMF, KFMAG(K),LABF,
     5  AMPK(K),CA1,KPER(K),KXWT(K),CWT,JXCOR(J),ICOMX,KXMAG(K),LABX, 

     6  LFMAG,LABF1,FMSOU,KFMMAD,NFMAG,
     7  LFMAG2,LABF2,FMSOU2,KFMMAD2,NFMAG2,
     8  LXMAG,LABX1,XMSOU,KXMMAD,NXMAG,
     9  LXMAG2,LABX2,XMSOU2,KXMMAD2,NXMAG2,

     1  LPRMAG,LABPR,KPRMAD,NPMAG,
     2  LBMAG,BMTYP,NBMAG

1036    FORMAT (A5,A2,A3,A2,1X,
     1  I4,4I2.2, 2I4,
     2  A2,I1,2I4, A3,2A1,
     3  I1,I5,3X, 
     4  A4,I1, A1,2I3,I4,A1,2X,
     5  F6.2,A1,I3,I1, A1,2I3,I4,A1,2X,

     6  4(I4,2A1,I3,I4,1X),
     1  I4,A1,1X,I3,I4,1X,
     2  I4,A1,I3)

      END IF

C--UPDATE THE LAST STATION INDEX; END OF BOTH STATION LOOPS
80    KLSTA=K
90    CONTINUE
      IF (MOUT.LT.M) GOTO 40

C--WRITE NUMBER OF STATIONS NOT PRINTED
      IF (KPRINT.GT.0 .AND. LPRT .AND. LINCUT.GT.0) WRITE (15,
     2 '(I5,'' UNWEIGHTED STATIONS NOT PRINTED.'')') LINCUT

C--OUTPUT TERMINATOR LINE TO ARCHIVE FILE IF NO MORE PHASE CARDS REMAIN
      IF (DONE .AND. NWR.GE.MINSTA .AND. .NOT.LTBIG) THEN

C--FIRST WRITE UNKNOWN STATIONS SAVED BY HYPHS, IF ANY
        IF (LARC) THEN
          DO I=1,NUNK
            WRITE (7,1008) PUNK(I)
            IF (LSHAD) WRITE (7,1008) SUNK(I)(1:NSUNK(I))
          END DO
        END IF

C--WRITE TERMINATOR CARD COPIED FROM INPUT
        LTERM=LENG(TERM)
        IF (LARC) WRITE (7,'(A)') TERM(1:LTERM)
        IF (LMAG) WRITE (16,'(A)') TERM(1:LTERM)

C--WRITE OPTIONAL SHADOW RECORD
        IF (LARC .AND. LSHAD) THEN
          IF (LENSHA.GT.0) THEN
            WRITE (7,1008) SHADO(1:LENSHA)
          ELSE
            WRITE (7,'(''$'')')
          END IF
        END IF
      END IF

      RETURN
      END
      SUBROUTINE HYMAG
C--CALCULATE MAGNITUDES FOR ALL STATIONS FOR HYPOINVERSE
      INCLUDE 'common.inc'
      CHARACTER STN*5,SNET*2,SCOMP*3, SLOC*2
      DIMENSION IATN(7),IAEXP(7),RCAL(7), RSPA(26),FMCAR(6),XMCAR(6)
      DIMENSION IYEARI(7),S(7)
      SAVE RSPA

C--ARRAYS FOR GETTING WEIGHTED MEDIAN MAGNITUDES
C      INTEGER*2 IMAG(MAXPHS),IMWT(MAXPHS)
C      INTEGER*2 IMAG2(MAXPHS),IMWT2(MAXPHS)
      DIMENSION IMAG(MAXPHS),IMWT(MAXPHS)
      DIMENSION IMAG2(MAXPHS),IMWT2(MAXPHS)

C--MOTOR CONSTANTS FOR VARIOUS VELOCITY SEISMOMETERS IN V/CM/SEC.  
C  INDEX (SUBSCRIPT) IS THE SEISMOMETER TYPE CODE JTYPE(J)
      DATA S/ 	1.0,	!1 L4C, ATTENUATION HISTORY
     2 		1.0,	!2 UNUSED, ACTUALLY A SPRENGNETHER
     3		1.0,	!3 L4C, CAL FACTOR HISTORY
     4		0.448,	!4 HS1 (USED WITH NANOMETRICS)
     5		8.0,	!5 GURALP (USED WITH REFTEKS)
     6		24.0,	!6 STREKHEISEN STS-1 (USED WITH BDSN)
     7		15.0/	!7 STREKHEISEN STS-2 (USED WITH BDSN)

C--RESPONSE CURVE OF THE USGS STANDARD HIGH GAIN (L4C 1 SEC.) RELATIVE TO WA
C  WOOD ANDERSON HAS MAGNIFICATION 2080 & DAMPING 0.8
C     FREQUENCY  .16   .20   .25   .32   .40   .50   .63   .79   1.00
C     LOG FREQ   -.8   -.7   -.6   -.5   -.4   -.3   -.2   -.1   0.0
      DATA RSPA /.288, .432, .561, .680, .786, .891, .983, 1.066,1.138,

C FREQUENCY 1.26   1.59   2.00   2.51   3.16   3.98   5.01   6.31   7.94
C LOG FREQ   .1     .2     .3     .4     .5     .6     .7     .8     .9 
     2    1.205, 1.276, 1.355, 1.443, 1.535, 1.630, 1.726, 1.822, 1.916,

C FREQUENCY 10.0   12.6   15.9   20.0   25.1   31.6   39.8   50.1
C LOG FREQ  1.0    1.1    1.2    1.3    1.4    1.5    1.6    1.7
     3    2.007, 2.090, 2.145, 2.099, 1.878, 1.546, 1.172, .771/

C--INITIALIZE SUMS & VALUES
C      MFMAG=0
C      MXMAG=0
      NFMAG=0
      NXMAG=0
      FMMAD=0.
      XMMAD=0.
      XMAG=VNOMAG
      FMAG=VNOMAG
      NMED=0
C      MFMAG2=0
C      MXMAG2=0
      NFMAG2=0
      NXMAG2=0
      FMMAD2=0.
      XMMAD2=0.
      XMAG2=VNOMAG
      FMAG2=VNOMAG
      NMED2=0
      NDATE=KYEAR2*1000000 +KMONTH*10000 +KDAY*100 +KHOUR

C--OPTIONALLY SET FMAG2 FLAG FOR ALL STATIONS IF EPI IN LAT/LON BOX (MAR COMMAND)
      IF (USEMAR) THEN
        IF (((YLATMX-CLAT)*(CLAT-YLATMN)).GE.0. .AND.
     2  ((XLONMX-CLON)*(CLON-XLONMN)).GE.0.) THEN
          LINBOX=.TRUE.
          DO J=1,JSTA
            JFM2(J)=.TRUE.
          END DO
        ELSE
          LINBOX=.FALSE.
          DO J=1,JSTA
            JFM2(J)=.FALSE.
          END DO
        END IF
      END IF

C--LOOP OVER STATIONS TO UPDATE FMAG CORRECTIONS, CAL FACTORS & CALCULATE FMAGS 
      DO 50 K=1,KSTA
      KFMAG(K)=MINMAG		!IS THIS STATEMENT NECESSARY?
      J=KINDX(K)

C++++++++++++++++++++++++++++++++++++++++++++++++++++++
C--IF A FILE OF FMAG CORRECTIONS WITH EXPIRATION DATES WAS READ, CHECK TO SEE IF
C  THE ONE FOR THIS STATION HAS EXPIRED.
      IF (JFEXP(J).GT.0) THEN
        IF (NDATE.GT.JFEXP(J)) THEN

C--READ FILE TO GET A NEW EXPIRATION DATE & MAG CORRECTION. OPEN
C  CORRECTION FILE & SEARCH FOR THIS STATION. END OF FILE SHOULD NEVER OCCUR.
          CALL OPENR (13,FMCFIL,'F',IOS)

2         IF (L2000) THEN
            READ (13,1202) STN,SNET,SLOC,SCOMP, 
     2      (FMCAR(I),IYEARI(I),IAEXP(I),I=1,6)
1202        FORMAT (A5,1X,A2,A2,A3,1X, 6(F5.2,1X,I4,I6,1X))

          ELSE
            READ (13,1002) STN,SNET,SCOMP, 
     2      (FMCAR(I),IYEARI(I),IAEXP(I),I=1,6)
C--READ 2-DIGIT YEAR, MO, DA, HOUR, AND IGNORE MINUTES IF PRESENT
1002        FORMAT (A5,1X,A2,2X,A3,1X, 6(F5.2,1X,I2,I6,3X))
            SLOC='  '
          END IF

          IF (STN(1:NSTLET) .NE. STANAM(J)(1:NSTLET) .OR.
     2    SNET(1:NETLET) .NE. JNET(J)(1:NETLET) .OR.
     3    (SLOC(1:NSLOC2) .NE. JSLOC(J)(1:NSLOC2) .AND.
     3    SLOC(1:NSLOC2) .NE. JSLOC2(J)(1:NSLOC2)) .OR.
     4    SCOMP(1:NCOMP) .NE. JCOMP3(J)(1:NCOMP)) GOTO 2

C--SEARCH THE LIST OF EXPIRATION DATES FOR THE FIRST ONE AFTER THE CURRENT DATE,
C  OR AN EXPIRATION DATE OF 0 (FMAG COR GOOD THROUGH THE FUTURE).
          DO I=1,6
            IF (IYEARI(I).LT.100 .AND. IYEARI(I).GT.0) 
     2      IYEARI(I)=IYEARI(I)+ICENT
C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE DATE
            IF (IYEARI(I).GT.2146) IYEARI(I)=2146
            IAEXP(I)=IYEARI(I)*1000000 +IAEXP(I)

            IF (IAEXP(I).EQ.0 .OR. IAEXP(I).GT.NDATE) THEN

C--ADD 10 TO CORRECTION TO GIVE GAIN CORRECTION 0 WEIGHT
C--YOU CAN ADD BOTH 10 AND 5, BUT MUST DO THIS TEST FIRST
              IF (FMCAR(I).GT.7.45) THEN
                JFGWT(J)=0
                FMCAR(I)=FMCAR(I)-10.
              ELSE
                JFGWT(J)=1
              END IF

C--ADD 5 TO CORRECTION TO GIVE IT ZERO WEIGHT
              IF (FMCAR(I).GT.2.45) THEN
                JFWT(J)=0
                FMCAR(I)=FMCAR(I)-5.
              ELSE
                JFWT(J)=10
              END IF
              JFCOR(J)=NINT(100.*FMCAR(I))

C--WRITE MESSAGE THAT A NEW FMC WAS FOUND
              IF (LPRT .AND. KPRINT.GE.3) WRITE(15,1003) 
     2          FMCAR(I),STN,SNET,SCOMP,SLOC, JFEXP(J),IAEXP(I)
1003          FORMAT (' * NEW FMAG CORRECTION',F6.2,' ASSIGNED TO ',
     2        A5,'-',A2,'-',A3,'-',A2,'.'/
     3        ' NEW START DATE = ',I10,', EXPIRATION DATE = ',I10)
              JFEXP(J)=IAEXP(I)
              GOTO 3
            END IF
          END DO
3         CLOSE (13)
        END IF
      END IF

C++++++++++++++++++++++++++++++++++++++++++++++++++++++
C--IF A FILE OF XMAG CORRECTIONS WITH EXPIRATION DATES WAS READ, CHECK TO SEE IF
C  THE ONE FOR THIS STATION HAS EXPIRED.
      IF (JXEXP(J).GT.0) THEN
        IF (NDATE.GT.JXEXP(J)) THEN

C--READ FILE TO GET A NEW EXPIRATION DATE & MAG CORRECTION. OPEN
C  CORRECTION FILE & SEARCH FOR THIS STATION. END OF FILE SHOULD NEVER OCCUR.
C  IGNORE STATION TYPE BECAUSE WE GOT IT ON FIRST READING
          CALL OPENR (13,XMCFIL,'F',IOS)

12        IF (L2000) THEN
            READ (13,1212) STN,SNET,SLOC,SCOMP, 
     2      (XMCAR(I),IYEARI(I),IAEXP(I),I=1,6)
1212        FORMAT (A5,1X,A2,A2,A3, 3X, 6(F5.2,1X,I4,I6,1X))

          ELSE
            READ (13,1012) STN,SNET,SCOMP, 
     2      (XMCAR(I),IYEARI(I),IAEXP(I),I=1,6)
1012        FORMAT (A5,1X,A2,2X,A3, 3X, 6(F5.2,1X,I2,I6,3X))
            SLOC='  '
          END IF

          IF (STN(1:NSTLET) .NE. STANAM(J)(1:NSTLET) .OR.
     2    SNET(1:NETLET) .NE. JNET(J)(1:NETLET) .OR.
     3    (SLOC(1:NSLOC2) .NE. JSLOC(J)(1:NSLOC2) .AND.
     3    SLOC(1:NSLOC2) .NE. JSLOC2(J)(1:NSLOC2)) .OR.
     4    SCOMP(1:NCOMP) .NE. JCOMP3(J)(1:NCOMP)) GOTO 12

C--SEARCH THE LIST OF EXPIRATION DATES FOR THE FIRST ONE AFTER THE CURRENT DATE,
C  OR AN EXPIRATION DATE OF 0 (XMAG COR GOOD THROUGH THE FUTURE).
          DO I=1,6
            IF (IYEARI(I).LT.100 .AND. IYEARI(I).GT.0) 
     2      IYEARI(I)=IYEARI(I)+ICENT

C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE DATE
            IF (IYEARI(I).GT.2146) IYEARI(I)=2146
            IAEXP(I)=IYEARI(I)*1000000 +IAEXP(I)

            IF (IAEXP(I).EQ.0 .OR. IAEXP(I).GT.NDATE) THEN
C--ADJUST STATION WEIGHT DEPENDING ON RANGE OF CORRECTION
              IF (XMCAR(I).GT.2.45) THEN
                JXWT(J)=0
                XMCAR(I)=XMCAR(I)-5.
              ELSE
                JXWT(J)=10
              END IF
              JXCOR(J)=NINT(100.*XMCAR(I))

C--WRITE MESSAGE THAT A NEW XMC WAS FOUND
              IF (LPRT .AND. KPRINT.GE.3) WRITE(15,1013) 
     2          XMCAR(I),STN,SNET,SCOMP,SLOC, JXEXP(J),IAEXP(I)
1013          FORMAT (' * NEW XMAG CORRECTION',F6.2,' ASSIGNED TO ',
     2        A5,'-',A2,'-',A3,'-',A2,'.'/
     3        ' NEW START DATE = ',I10,', EXPIRATION DATE = ',I10)
              JXEXP(J)=IAEXP(I)
              GOTO 13
            END IF
          END DO
13        CLOSE (13)
        END IF
      END IF

C++++++++++++++++++++++++++++++++++++++++++++++++++++++
C--IF USING A FILE OF CAL FACTORS WITH EXPIRATION DATES, CHECK TO SEE IF
C  CAL FOR THIS STATION HAS EXPIRED.  IF NOT USING A HISTORY FILE,
C  THE EXPIRATION DATE SHOULD ALWAYS BE 0.
      IF (JCEXP(J).GT.0) THEN
        IF (NDATE.GT.JCEXP(J)) THEN

C--FOR INSTRUMENT TYPE 1, USE ATTENUATION HISTORY FILE
          IF (JTYPE(J).EQ.1) THEN

C--READ FILE TO GET A NEW EXPIRATION DATE & ATTENUATION. OPEN ATTENUATION FILE
C  & SEARCH FOR THIS STATION. END OF FILE SHOULD NEVER OCCUR.
            CALL OPENR (13,ATNFIL,'F',IOS)

5           IF (L2000) THEN
              READ (13,1200) STN,SNET,SLOC,SCOMP, 
     2        (IATN(I),IYEARI(I),IAEXP(I),I=1,7)
1200          FORMAT (A5,1X,A2,A2,A3,1X, 7(I2,1X,I4,I6,1X))

            ELSE
              READ (13,1000) STN,SNET,SCOMP, 
     2        (IATN(I),IYEARI(I),IAEXP(I),I=1,7)
1000          FORMAT (A5,1X,A2,2X,A3,1X, 7(I2,1X,I2,I6,3X))
              SLOC='  '
            END IF

            IF (STN(1:NSTLET) .NE. STANAM(J)(1:NSTLET) .OR.
     2      SNET(1:NETLET) .NE. JNET(J)(1:NETLET) .OR.
     3      (SLOC(1:NSLOC2) .NE. JSLOC(J)(1:NSLOC2) .AND.
     3      SLOC(1:NSLOC2) .NE. JSLOC2(J)(1:NSLOC2)) .OR.
     4      SCOMP(1:NCOMP) .NE. JCOMP3(J)(1:NCOMP)) GOTO 5

C--SEARCH THE LIST OF EXPIRATION DATES FOR THE FIRST ONE AFTER THE CURRENT DATE,
C  OR AN EXPIRATION DATE OF 0 (CAL GOOD THROUGH THE FUTURE).
            DO I=1,7
              IF (IYEARI(I).LT.100 .AND. IYEARI(I).GT.0) 
     2        IYEARI(I)=IYEARI(I)+ICENT

C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE DATE
              IF (IYEARI(I).GT.2146) IYEARI(I)=2146
              IAEXP(I)=IYEARI(I)*1000000 +IAEXP(I)

              IF (IAEXP(I).EQ.0 .OR. IAEXP(I).GT.NDATE) THEN
C--ATTEN MUST BE A MULTIPLE OF 6
                KTEMP=IATN(I)/6
                JCAL(J)=CALSV(KTEMP)*1000.

C--WRITE MESSAGE THAT A NEW ATTENUATION WAS FOUND
                IF (LPRT.AND.KPRINT.GE.3) WRITE (15,1001) CALSV(KTEMP),
     2          IATN(I), STN,SNET,SCOMP,SLOC, JCEXP(J), IAEXP(I)
1001            FORMAT (' * NEW CAL FACTOR',F6.3,' (ATTEN=',I2,
     2          ') ASSIGNED TO ',A5,'-',A2,'-',A3,'-',A2,'.'/
     4          ' NEW CAL FACTOR START DATE = ',
     3          I10,', EXPIRATION DATE = ',I10)
                JCEXP(J)=IAEXP(I)
                GOTO 6
              END IF
            END DO
6           CLOSE (13)
          END IF

C--FOR INSTRUMENT TYPES OTHER THAN 1, USE CAL FACTOR HISTORY FILE
          IF (JTYPE(J).NE.1) THEN

C--READ FILE TO GET A NEW EXPIRATION DATE & CAL FACTOR. OPEN ATTENUATION FILE
C  & SEARCH FOR THIS STATION. END OF FILE SHOULD NEVER OCCUR.
            CALL OPENR (13,CALFIL,'F',IOS)

7           IF (L2000) THEN
              READ (13,1207) STN,SNET,SLOC,SCOMP, 
     2        (RCAL(I),IYEARI(I),IAEXP(I),I=1,7)
1207          FORMAT (A5,1X,A2,A2,A3,1X, 7(F7.2,1X,I4,I6,1X))

            ELSE
              READ (13,1007) STN,SNET,SCOMP, 
     2        (RCAL(I),IYEARI(I),IAEXP(I),I=1,7)
1007          FORMAT (A5,1X,A2,2X,A3,1X, 7(F7.2,1X,I2,I6,1X))
              SLOC='  '
            END IF
            
            IF (STN(1:NSTLET) .NE. STANAM(J)(1:NSTLET) .OR.
     2      SNET(1:NETLET) .NE. JNET(J)(1:NETLET) .OR.
     3      (SLOC(1:NSLOC2) .NE. JSLOC(J)(1:NSLOC2) .AND.
     3      SLOC(1:NSLOC2) .NE. JSLOC2(J)(1:NSLOC2)) .OR.
     4      SCOMP(1:NCOMP) .NE. JCOMP3(J)(1:NCOMP)) GOTO 7

C--SEARCH THE LIST OF EXPIRATION DATES FOR THE FIRST ONE AFTER THE CURRENT DATE,
C  OR AN EXPIRATION DATE OF 0 (CAL GOOD THROUGH THE FUTURE).
            DO I=1,7
              IF (IYEARI(I).LT.100 .AND. IYEARI(I).GT.0) 
     2        IYEARI(I)=IYEARI(I)+ICENT

C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE DATE
              IF (IYEARI(I).GT.2146) IYEARI(I)=2146
              IAEXP(I)=IYEARI(I)*1000000 +IAEXP(I)

              IF (IAEXP(I).EQ.0 .OR. IAEXP(I).GT.NDATE) THEN
                JCAL(J)=RCAL(I)*1000.

C--WRITE MESSAGE THAT A NEW CAL FACTOR WAS FOUND
                IF (LPRT .AND. KPRINT.GE.3) WRITE (15,1008) RCAL(I),
     2          STN,SNET,SCOMP,SLOC, JCEXP(J), IAEXP(I)
1008            FORMAT (' * NEW CAL FACTOR',F6.3,
     2          ' ASSIGNED TO ',A5,'-',A2,'-',A3,'-',A2,'.'/
     4          ' NEW CAL FACTOR START DATE = ',
     3          I10,', EXPIRATION DATE = ',I10)
                JCEXP(J)=IAEXP(I)
                GOTO 8
              END IF
            END DO
8           CLOSE (13)
          END IF

        END IF
      END IF
C++++++++++++++++++++++++++++++++++++++++++++++++++++++

C------- CALCULATE CODA MAGNITUDES -------------------------------------
C--MAKE SURE THERE IS A DURATION FOR THIS STATION
      IF (FMPK(K).LE.0.) GOTO 50
      TEMP=FMPK(K)

C--GET CALIBRATION FACTOR
C--USE KCAL IN PREFERENCE TO JCAL IF KCAL IS PRESENT
      IF (KCAL(K).EQ.0) THEN
        CAL=.001*JCAL(J)
      ELSE
        CAL=.01*KCAL(K)
      END IF

C--CONVERT CAL FACTOR TO GAIN CORRECTION (NO CAL FACTOR MEANS NO CORRECTION)
      G=0.
C--3.95 IS THE GAIN OF A "TYPICAL" 15 DB STATION WITH A CORRECTION OF 0.0
C--DO NOT APPLY GAIN CORRECTION TO STATIONS INSTRUCTED NOT TO
      IF (CAL.NE.0.) G=-ALOG10 (CAL/3.95) *JFGWT(J)

C--GG IS THE ACTUAL GAIN CORRECTION USED
C  IT WILL BE 0 IF COMPONENT IS NOT ON LIST AND COMPONENT SELECTION IS DESIRED
      IF (IDUG.LT.0) THEN		!ALL COMPONENTS
        GG=G
      ELSE IF (IDUG.EQ.0) THEN		!NO COMPONENTS
        GG=0.
      ELSE IF (IDUG.GT.0) THEN		!SOME COMPONENTS
        GG=0.
        DO I=1,IDUG
          IF (JCOMP3(J)(1:NCOMP) .EQ. CDUG(I)(1:NCOMP)) GG=G
        END DO
      END IF

C--CALCULATE 3 MAGNITUDE TYPES (SMAGF, SMAGT, SMAGB)
C--USE A BI-LINEAR LOG (F-P) SCALE WITH DIST & DEPTH CORRECTIONS
      TLOG=ALOG10(TEMP)
      IF (TEMP.LT.FMBRK) THEN
        SMAGF=FMA1 +FMB1*TLOG +FMD1*DIS(K) +FMZ1*Z1 +.01*JFCOR(J)
     2  +FMF1*TEMP
      ELSE
        SMAGF=FMA2 +FMB2*TLOG +FMD2*DIS(K) +FMZ2*Z1 +.01*JFCOR(J)
     2  +FMF2*TEMP
      END IF
      SMAGF=SMAGF +FMGN*GG

C--SECOND CODA MAGNITUDE
      IF (TEMP.LT.FMBRKB) THEN
        SMAGB=FMA1B +FMB1B*TLOG +FMD1B*DIS(K) +FMZ1B*Z1 +.01*JFCOR(J)
     2  +FMF1B*TEMP
      ELSE
        SMAGB=FMA2B +FMB2B*TLOG +FMD2B*DIS(K) +FMZ2B*Z1 +.01*JFCOR(J)
     2  +FMF2B*TEMP
      END IF
      SMAGB=SMAGB +FMGNB*GG

C--USE MAGNITUDE BASED ON ELAPSED TIME TAU. USE CALC TRAVEL TIME, NOT OBSERVED
C--FIND STATION IN PHASE ARRAY
      DO IM=1,M
        IF (K.EQ.IND(IM)) THEN
          TAU=MTCAL(IM)*.01 +TEMP
          GOTO 22
        END IF
      END DO

C--GET MAGNITUDE FOR POSITIVE TAU
22    IF (TAU.GT..5) THEN
        TLOG=ALOG10 (TAU)
C--INCLUDE DEPTH, GAIN & STATION CORRECTION TERMS
        SMAGT=DMA0 +DMA1*TLOG +DMA2*TLOG**2 +DMLI*TAU
     2  +DMZ*Z1 +DMGN*G +.01*JFCOR(J)
      END IF

C--APPLY CORRECTIONS SPECIFIED FOR EACH COMPONENT
      DO I=1,NFCM
        IF (JCOMP3(J)(1:NCOMP) .EQ. CFCM(I)(1:NCOMP)) THEN
          SMAGT=SMAGT+AFCM(I)
          SMAGF=SMAGF+AFCM(I)
        END IF
      END DO

C--APPLY ADDITIONAL DISTANCE AND DEPTH CORRECTIONS
      IF (DIS(K).LT.DBRKM1) THEN
        SMAGT=SMAGT+DCOFM1*(DIS(K)-DBRKM1)
        SMAGF=SMAGF+DCOFM1*(DIS(K)-DBRKM1)
      END IF
      IF (DIS(K).GT.DBRKM2) THEN
        SMAGT=SMAGT+DCOFM2*(DIS(K)-DBRKM2)
        SMAGF=SMAGF+DCOFM2*(DIS(K)-DBRKM2)
      END IF
      IF (Z1.GT.ZBRKM) THEN
        SMAGT=SMAGT+ZCOFM*(Z1-ZBRKM)
        SMAGF=SMAGF+ZCOFM*(Z1-ZBRKM)
      END IF

C--DONT LET MAG BE LOWER THAN THE MINIMUM
      IF (SMAGF.LT.VNOMAG) SMAGF=VNOMAG
      IF (SMAGB.LT.VNOMAG) SMAGB=VNOMAG
      IF (SMAGT.LT.VNOMAG .OR. TAU.LE..5) SMAGT=VNOMAG

C--ASSIGN WEIGHT
      KFMWT=0
      IF (KFWT(K).LT.4) KFMWT=NINT(2.5*((4-KFWT(K))*JFWT(J)))

C--CHOOSE MAGNITUDE TYPE FOR FMAG1
C--NOTE THAT IF TWO FMAG TYPES ARE USED FOR THIS STATION, (I.E. ITS
C  COMPONET LETTER QUALIFIES IT FOR BOTH MAGNITUDES) EACH WILL FIGURE INTO
C  THE TWO EVENT MAGS BUT ONLY THE LAST WILL APPEAR IN THE STATION LIST.
      SMAG=VNOMAG
      KFMAG(K)=MINMAG
      IF (JFM1(J)) THEN
        IF (MAGSEL.EQ.1) THEN
          SMAG=SMAGF
        ELSE IF (MAGSEL.EQ.2) THEN
          SMAG=SMAGT
        ELSE IF (MAGSEL.EQ.3) THEN
          SMAG=SMAGB
        END IF
        KFMAG(K)=NINT(100.*SMAG)
        IF (SMAG.GT.VNOMAG .AND. KFMWT.GT.0 .AND. NMED.LT.MAXPHS) THEN
C          MFMAG=MFMAG+KFMWT
          NFMAG=NFMAG+1
          NMED=NMED+1
          IMAG(NMED)=KFMAG(K)
          IMWT(NMED)=KFMWT
        END IF
      END IF

C--CHOOSE MAGNITUDE TYPE FOR FMAG2
      IF (JFM2(J)) THEN
        IF (MAGSL2.EQ.1) THEN
          SMAG=SMAGF
        ELSE IF (MAGSL2.EQ.2) THEN
          SMAG=SMAGT
        ELSE IF (MAGSL2.EQ.3) THEN
          SMAG=SMAGB
        END IF
        KFMAG(K)=NINT(100.*SMAG)
        IF (SMAG.GT.VNOMAG .AND. KFMWT.GT.0 .AND. NMED2.LT.MAXPHS) THEN
C          MFMAG2=MFMAG2+KFMWT
          NFMAG2=NFMAG2+1
          NMED2=NMED2+1
          IMAG2(NMED2)=KFMAG(K)
          IMWT2(NMED2)=KFMWT
        END IF
      END IF

C--END OF STATION LOOP
50    CONTINUE

C-------- CALCULATE CODA MAGNITUDE FOR EVENT ---------------------------
C--CALCULATE WEIGHTED MEDIAN OF FMAG1 (OR MEAN)
      IF (NMED.GT.0) THEN
        CALL MEDWT (LMED,NMED,IMAG,IMWT,MEDIAN,MSD)
        FMAG=.01*MEDIAN
        IF (.NOT.LMED) FMMAD=.01*MSD
      END IF

C--CALC MEDIAN ABSOLUTE DIFFERENCE OF FMAG1
C  THE MAGS, WEIGHTS & MEDIAN ARE STILL IN THE ARRAYS
      IF (NMED.GT.1 .AND. LMED) THEN
        DO I=1,NMED
          IMAG(I)=ABS(IMAG(I)-MEDIAN)
        END DO
        CALL MEDWT (LMED,NMED,IMAG,IMWT,MEDIAN,MSD)
        FMMAD=.01*MEDIAN
      END IF
      NMED=0

C--CALCULATE WEIGHTED MEDIAN OF FMAG2
      IF (NMED2.GT.0) THEN
        CALL MEDWT (LMED,NMED2,IMAG2,IMWT2,MEDIAN,MSD)
        FMAG2=.01*MEDIAN
        IF (.NOT.LMED) FMMAD2=.01*MSD
      END IF

C--CALC MEDIAN ABSOLUTE DIFFERENCE OF FMAG2
C  THE MAGS, WEIGHTS & MEDIAN ARE STILL IN THE ARRAYS
      IF (NMED2.GT.1 .AND. LMED) THEN
        DO I=1,NMED2
          IMAG2(I)=ABS(IMAG2(I)-MEDIAN)
        END DO
        CALL MEDWT (LMED,NMED2,IMAG2,IMWT2,MEDIAN,MSD)
        FMMAD2=.01*MEDIAN
      END IF
      NMED2=0

C--CALCULATE AMPLITUDE MAGNITUDE --------------------------------------

C--COMPUTE XMAG AS A SUM OF 3 TERMS:
C--1: LOG(MAX PEAK-TO-PEAK AMP / 2*CAL FACTOR)
C--2: -LOG RESPONSE OF INST REL TO WOOD-ANDERSON.
C--3: -LOG(A(0)), THE LOCAL MAGNITUDE DISTANCE CORRECTION
C--ALFRQ = LOG(FREQUENCY OF SIGNAL AT MAX AMPLITUDE / 5HZ.)
C--SLDIS = HYPOCENTRAL DISTANCE IN KM
CC--ALDSQ = LOG((HYPOCENTRAL DISTANCE)**2)

C--LOOP OVER STATIONS
      DO 100 K=1,KSTA
C      KXMAG(K)=0
      KXMAG(K)=MINMAG
      J=KINDX(K)

C--DO NOT CALC A MAG IF THERE IS NO AMP OR IF AMP IS FROM THE WRONG INSTRUMENT
      KIMTYP(K)=0		!DEFAULT IS NO MAG FOR THIS STATION
      IF (AMPK(K).LE.0. .OR. KAMPTYP(K).GT.2) GOTO 100
     
C--DETERMINE MAGNITUDE TYPE
C--USE AMPLITUDE TYPE IF IT IS SPECIFIED FOR A WA OR VELOCITY
C--IF AMP TYPE IS UNSPECIFIED, USE INSTRUMENT TYPE
      IF (KAMPTYP(K).EQ.1) THEN
        KIMTYP(K)=1			!WOOD ANDERSON ML
      ELSE IF (KAMPTYP(K).EQ.2) THEN
        KIMTYP(K)=2			!VELOCITY MX
      ELSE IF (KAMPTYP(K).EQ.0) THEN
        IF (JTYPE(J).EQ.0 .OR. JTYPE(J).EQ.2) THEN
          KIMTYP(K)=1			!WOOD ANDERSON ML
        ELSE
          KIMTYP(K)=2			!VELOCITY MX
        END IF
      END IF

C--USE KCAL IN PREFERENCE TO JCAL IF KCAL IS PRESENT
      IF (KCAL(K).EQ.0) THEN
        CAL=.001*JCAL(J)
      ELSE
        CAL=.01*KCAL(K)
      END IF
      IF (CAL.EQ.0.) THEN
        KIMTYP(K)=0
        GO TO 100
      END IF

C--SET THE PERIOD AS STANDARD ONE FOR STATION IF NOT ON PHASE CARD
C  JPER(J) IS THE STATION PERIOD IN .1 SEC.
C  KPER(K) IS THE PHASE CARD PERIOD IN .01 SEC.
      IF (KPER(K).LE.0) THEN
        PER= .1*JPER(J)
      ELSE
        PER=.01*KPER(K)
      END IF
C--SKIP THE CALCULATIONS IF PERIOD IS OUT OF ALLOWED RANGE
      IF (PER.GT.6.3 .OR. PER.LT..02) THEN
        KIMTYP(K)=0
        GO TO 100
      END IF

C--USE AMPLITUDE IN PP MM FOR MAGNITUDE
C--THE COUNT-TO-MM CONVERSION IS USED FOR ALL DIGITAL SYSTEMS, CAL
C  IS USED TO ALLOW FOR DIFFERENCES FROM THE 12 BIT STANDARD SYSTEM.
C--USGS STANDARD SYSTEM IS 4096 COUNTS = 5.0 VOLT = 200 MM
      AMPMM=AMPK(K)			!KAMPU(K)=0
      IF (KAMPU(K).EQ.1) THEN		!HALF AMPLITUDE
        AMPMM=AMPK(K)*2.
      ELSE IF (KAMPU(K).EQ.2) THEN	!DIGITAL COUNTS FROM EARTHWORM OR MENLO
        AMPMM=AMPK(K)*0.04883
      ELSE IF (KAMPU(K).EQ.3) THEN	!DIGITAL COUNTS FROM HVO
        AMPMM=AMPK(K)*0.012207
      ELSE IF (KAMPU(K).EQ.4) THEN	!DIGITAL COUNTS IN HUNDREDS FROM MENLO
        AMPMM=AMPK(K)*4.883
      END IF

C--COMPUTE MAGNITUDE
      SLDIS=SQRT(Z1**2 +DIS(K)**2) +.01
C--AMPK IS PEAK-TO-PEAK AMPLITUDE IN MM (.5 IS TO USE HALF-AMP)
      SMAG=ALOG10(AMPMM*.5/CAL)

C--CORRECT TO WA RESPONSE IF A VELOCITY SEISMOMETER
C--ALSO CORRECT DIGITAL TELEMETRY STATIONS WITH SAME CURVE
C  (THIS IS THE OLD APPROXIMATION FOR DOMINANT FREQ)
C      IF (JTYPE(J).EQ.1 .OR. JTYPE(J).EQ.3) SMAG=SMAG-1.3-.95*ALFRQ 
C      IF (JTYPE(J).EQ.1 .OR. (JTYPE(J).GT.2 .AND. 
C     2 JTYPE(J).LE.7)) THEN

C--APPLY CORRECTION FOR VELOCITY SEISMOMETERS
C--DO NOT APPLY CORRECTION FOR WA (TYPE 0) OR SPRENGNETHER (TYPE 2)
      IF (KIMTYP(K).EQ.2) THEN
        FQ=10.*ALOG10(1./PER)+9.
        IFQ=FQ
C--USE RESPONSE CORRECTION INTERPOLATED FROM TABLE
        SMAG=SMAG -(RSPA(IFQ) +(FQ-IFQ) *(RSPA(IFQ+1)-RSPA(IFQ)))
C--APPLY MOTOR CONSTANT OF SEISMOMETER
        SMAG=SMAG -ALOG10 (S (JTYPE(J)))
      END IF

C--CORRECT AN HVO TYPE SPRENGNETHER
      IF (JTYPE(J).EQ.2) SMAG=SMAG+.41+.56*ALOG10(.2/PER)

C--APPLY CORRECTIONS SPECIFIED FOR EACH COMPONENT. 
      DO I=1,NXCM
        IF (JCOMP3(J)(1:NCOMP) .EQ. CXCM(I)(1:NCOMP)) SMAG=SMAG+AXCM(I)
      END DO

C--USE THE DEFAULT LOGA0 RELATION FOR MOST COMPONENTS
      LATYP=MLOGA0
C--TEST COMPONENTS TO USE A COMPONENT SPECIFIC LOGA0 RELATION
      DO I=1,NLA0
        IF (JCOMP3(J)(1:NCOMP) .EQ. CLA0(I)(1:NCOMP)) LATYP=MLA0(I)
      END DO

C--APPLY RICHTER'S LOGA0 DISTANCE CORRECTION TERM 
      CALL LOGA0 (LATYP,A0MAG,DIS(K),SLDIS)
      SMAG=SMAG+A0MAG
C--OUTPUT LOG(A0) TERM IN REMARK COLUMN OF PRINTOUT (DEBUG ONLY)
C      WRITE (KRMK6(K),'(F4.2,''-'',I1)') A0MAG,LATYP
      
C--APPLY MAG CORRECTION & ACCUMULATE SUMS
      SMAG=SMAG+.01*JXCOR(J)
C      IF (SMAG.LT.0.) SMAG=0.
      KXMAG(K)=NINT(100.*SMAG)
      KXMWT=0
      IF (KXWT(K).LT.4) KXMWT=NINT (2.5*((4-KXWT(K))*JXWT(J)))

C--USE XMAG IN FIRST AMP MAG
C--MXMAG IS 100X THE TOTAL OF STATION WEIGHTS (NO LONGER USED)
C--USE THIS MAG IN XMAG1 IF 
C  1) THE COMPONENT IS ON THE COMPONENT LIST (OR ALL COMPS ARE USED), AND
C  2) THE TYPE (MX OR ML) MATCHES THAT SELECTED FOR XMAG1 (OR ALL MAGS USED) 
      IF(JXM1(J) .AND. (MAG1TYPX.EQ.0 .OR. KIMTYP(K).EQ.MAG1TYPX)) THEN
C        IF (SMAG.GT.0. .AND. KXMWT.GT.0 .AND. NMED.LT.MAXPHS) THEN
        IF (KXMWT.GT.0 .AND. NMED.LT.MAXPHS) THEN
C          MXMAG=MXMAG+KXMWT
          NXMAG=NXMAG+1
          NMED=NMED+1
          IMAG(NMED)=KXMAG(K)
          IMWT(NMED)=KXMWT
        END IF
      END IF

C--USE XMAG IN SECOND AMP MAG
      IF(JXM2(J) .AND. (MAG2TYPX.EQ.0 .OR. KIMTYP(K).EQ.MAG2TYPX)) THEN
C        IF (SMAG.GT.0. .AND. KXMWT.GT.0 .AND. NMED2.LT.MAXPHS) THEN
        IF (KXMWT.GT.0 .AND. NMED2.LT.MAXPHS) THEN
C          MXMAG2=MXMAG2+KXMWT
          NXMAG2=NXMAG2+1
          NMED2=NMED2+1
          IMAG2(NMED2)=KXMAG(K)
          IMWT2(NMED2)=KXMWT
        END IF
      END IF

100   CONTINUE

C----------- CALCULATE AMPLITUDE MAGNITUDE FOR EVENT -------------------
C--CALCULATE WEIGHTED MEDIAN OF FIRST AMP MAG
      IF (NMED.GT.0) THEN
        CALL MEDWT (LMED,NMED,IMAG,IMWT,MEDIAN,MSD)
        XMAG=.01*MEDIAN
        IF (.NOT.LMED) XMMAD=.01*MSD
      END IF

C--CALC MEDIAN ABSOLUTE DIFFERENCE OF FIRST AMP MAG
C  THE MAGS, WEIGHTS & MEDIAN ARE STILL IN THE ARRAYS
      IF (NMED.GT.1 .AND. LMED) THEN
        DO I=1,NMED
          IMAG(I)=ABS(IMAG(I)-MEDIAN)
        END DO
        CALL MEDWT (LMED,NMED,IMAG,IMWT,MEDIAN,MSD)
        XMMAD=.01*MEDIAN
      END IF

C--CALCULATE WEIGHTED MEDIAN OF SECOND AMP MAG
      IF (NMED2.GT.0) THEN
        CALL MEDWT (LMED,NMED2,IMAG2,IMWT2,MEDIAN,MSD)
        XMAG2=.01*MEDIAN
        IF (.NOT.LMED) XMMAD2=.01*MSD
      END IF

C--CALC MEDIAN ABSOLUTE DIFFERENCE OF SECOND AMP MAG
C  THE MAGS, WEIGHTS & MEDIAN ARE STILL IN THE ARRAYS
      IF (NMED2.GT.1 .AND. LMED) THEN
        DO I=1,NMED2
          IMAG2(I)=ABS(IMAG2(I)-MEDIAN)
        END DO
        CALL MEDWT (LMED,NMED2,IMAG2,IMWT2,MEDIAN,MSD)
        XMMAD2=.01*MEDIAN
      END IF

      RETURN
      END

C-----------------------------------------------------------
C--APPLY THE LOGA0 TERM TO THE AMPLITUDE MAGNITUDE
      SUBROUTINE LOGA0 (LATYP,A0MAG,DIS,SLDIS)

      REAL*8 DPRDIST, CISN_mlAo
C-- -LOGA0 VALUES & THEIR MAX DISTANCES DIRECTLY FROM RICHTERS TABLE
      DIMENSION A0RICT(71)
      SAVE A0RICT
      DATA A0RICT /2*1.4,1.5, 1.6, 1.7, 1.9, 2.1, 2.3, 2.4, 2.5, 2.6, 
     2 2.7,3*2.8,2.85,2*2.9,3*3.0,2*3.1,2*3.2, 2*3.3,2*3.4,2*3.5,3.6,
     3 3.65, 2*3.7, 2*3.8, 2*3.9, 2*4.0, 2*4.1, 2*4.2, 3*4.3, 2*4.4, 
     4 3*4.5, 4*4.6, 4*4.7, 5*4.8, 5*4.9/

      A0MAG=0.
      IF (LATYP.LE.0 .OR. LATYP.GT.6) RETURN
C--USE THE APPROXIMATION OF EATON
      IF (LATYP.EQ.1) THEN
        IF (SLDIS.LT.185.3) THEN
          A0MAG=.821*ALOG10(SLDIS) +.00405*SLDIS +.955
        ELSE
          A0MAG=2.55*ALOG10(SLDIS) -2.21
        END IF

C--APPLY A SMALL SINUSOIDAL CORRECTION AT DISTANCES CLOSER THAN 70 KM
        IF (DIS.LT.70.) A0MAG=A0MAG -.09*SIN(.07*(DIS-25.))

C--ADD A (SIGNIFICANT) CORRECTION FOR P AMPLITUDE MAGNITUDES
C--CORRECTION CONSISTS OF 4 LINEAR SEGMENTS WITH DISTACE
C          IF (LATYP.EQ.5) THEN
C            IF (DIS.LT.52.) THEN
C              XX= -.08 +.00942*DIS
C            ELSE IF (DIS.GE.52. .AND. DIS.LT.115.) THEN
C              XX= +.41
C            ELSE IF (DIS.GE.115. .AND. DIS.LT.280.) THEN
C              XX= +.812 -.0035*DIS
C            ELSE IF (DIS.GE.280.) THEN
C              XX= -.168
C            END IF
C          A0MAG=A0MAG +XX
C          END IF

      ELSE IF (LATYP.EQ.2) THEN
C--USE THE APPROXIMATION OF BAKUN & JOYNER
        A0MAG= ALOG10(SLDIS) +.003*SLDIS +.7

      ELSE IF (LATYP.EQ.3) THEN
C--USE RICHTERS ORIGINAL APPROXIMATION
        ALDSQ=ALOG10(SLDIS**2)
        A0MAG=-.15+.8*ALDSQ
C        IF (ALDSQ.GT.4.6) A0MAG=-3.23+.7*ALDSQ
        IF (ALDSQ.GT.4.6) A0MAG= A0MAG -3.23+.7*ALDSQ

      ELSE IF (LATYP.EQ.4) THEN
C--APPLY BERKELEY'S CODE FOR THE NORDQUIST NOMOGRAM
        A0MAG=FLOGA0(DIS)

C--USE RICHTERS ORIGINAL TABLE
      ELSE IF (LATYP.EQ.5) THEN
        A0MAG=5.0
C--INDX IS THE INDEX OF THE NEAREST ENTRY IN RICHTERS TABLE
        IF (DIS.LT.100.) THEN
          INDX=NINT(DIS/5.)+1
        ELSE
          INDX=NINT(DIS/10.)+11
        END IF
        IF (INDX.GT.71) INDX=71
        A0MAG=A0RICT(INDX)

C--USE LOGA0 FUNCTION FROM CISN NETWORKS (USED IN TRIMAG & JIGGLE)
      ELSE IF (LATYP.EQ.6) THEN
        IF (SLDIS .LE. 0.1) RETURN
        DPRDIST=SLDIS
        A0MAG=CISN_mlAo (DPRDIST)
        RETURN
      END IF
      RETURN
      END

C---------------------------------------------------------------
      FUNCTION FLOGA0(DELTA)

C************************************************************************
C*   DEFINE LOG(AO) FUNCTION
C*   BASED ON LINEAR INTERPOLATION OF NORDQUIST NOMOGRAPH (BSSA, 1948)
C************************************************************************
C--THIS CODE FROM BERKELEY/BOB UHRHAMMER 5/95

      DIMENSION D(19),A(19)
      DATA A /1.4,1.4,1.5,1.7,2.3,2.7,2.85,
     1        3.0,3.65,4.2,4.6,5.0,5.3,5.7,
     2        6.0,6.2,6.3,6.4,6.5/
      DATA D /0.,5.,10.,20.,35.,55.,73.,96.,
     1        220.,334.,445.,600.,750.,1010.,
     2        1340.,1600.,1750.,1960.,2230./
      FLOGA0=0.
      IF ((DELTA.LT.0.).OR.(DELTA.GT.2224.)) RETURN
      J=0

      DO I=1,19
        J=J+1
        IF (DELTA.LT.D(I)) GOTO 2
      END DO
      RETURN
2     J0=J-1
      FLOGA0=A(J0)+(A(J)-A(J0))*(DELTA-D(J0))/(D(J)-D(J0))

      RETURN
      END

C------------------------------------------------------------------
	real*8 function CISN_mlAo( rdist )
c--Originally from Bob Uhrhammer from mid 2007 via Al Walter
c--Incorporated in hypoinverse in 2/2011
c--rdist is the slant (hypocentral) distance
c
c ...... calculate CISN -logAo ML attenuation function
c
	implicit none
	integer*4 j
c	real*8 rdist, TP(6), mlogAo, T, z, x, CISN_mlAo, b, logAo
	real*8 rdist, TP(6), mlogAo, T, z, x, b, logAo
c
	TP( 1 ) = +0.056d0
	TP( 2 ) = -0.031d0
	TP( 3 ) = -0.053d0
	TP( 4 ) = -0.080d0
	TP( 5 ) = -0.028d0
	TP( 6 ) = +0.015d0
c
	if( rdist .le. 0.1d0 ) then
c
c ...... invalid for rdist less that 0.1 km
c	 return with -9.d0
c
	  mlogAo = -9.d0
c
	elseif( rdist .le. 8.d0 ) then
c
c ...... linear extrapolation of average slope between 8 km and 60 km
c
	  b = ( 2.6182d0-1.5429d0)/(dlog10(60.d0)-dlog10(8.d0))
	  mlogAo = 1.5429d0 + b * ( dlog10( rdist ) - dlog10( 8.d0 ) )
c
	elseif( rdist .le. 500.d0 ) then
c
c ...... Chebychev polynomial expansion
c
	  x = z( rdist )
	  mlogAo = logAo( rdist ) + 0.0054d0
	  do j = 1 , 6
	    mlogAo = mlogAo + TP( j ) * T( j , x )
	  end do
c
	else
c
c ...... invalid for rdist greater than 500 km
c	 return with -9.d0
c
	  mlogAo = -9.d0
c
	endif
c
	CISN_mlAo = mlogAo
c
	return
	end

	real*8 function T( n , x )
c
c ...... Chebyshev Polynomial
c
	implicit none
	integer*4 n
c	real*8 T, x, theta
	real*8 x, theta
c
	theta = dacos( x )
	T = dcos( dble( n ) * theta )
c
	return
	end

	real*8 function z( r )
c
c ...... translate scale from r to z
c
	integer*4 ncall
	real*8 r, r0, r1, z0, z1, a , b, l_r0, l_r1
c
	data ncall /0/
	data r0,r1 /8.d0,500.d0/
	data z0,z1 /-1.d0,+1.d0/
c
	if( ncall .eq. 0 ) then
	  l_r0 = dlog10( r0 )
	  l_r1 = dlog10( r1 )
	  b = ( z1 - z0 ) / ( l_r1 - l_r0 )
	  a = z0 - b * l_r0
	  ncall = 1
	endif
c
	z = a + b * dlog10( r )
c
	return
	end

	real*8 function logAo( rdist )
c
c ...... -logAo attenuation function
c
	implicit none
c	real*8 rdist, logAo
	real*8 rdist
	
c
	logAo = 1.11d0 * dlog10( rdist ) + 
     1    0.00189d0 * rdist + 0.591d0
c
	return
	end

      SUBROUTINE HYMAGP
C--CALCULATE P AMP MAGNITUDES FOR ALL STATIONS FOR HYPOINVERSE
      INCLUDE 'common.inc'
      CHARACTER STN*5,SNET*2,SCOMP*3
      DIMENSION IATN(7),IAEXP(7),RCAL(7), RSPA(26),IYEARI(7)
      SAVE RSPA

C--ARRAYS FOR GETTING WEIGHTED MEDIAN MAGNITUDES
      DIMENSION IMAG(MAXPHS),IMWT(MAXPHS)

C--RESPONSE CURVE OF THE USGS STANDARD HIGH GAIN (L4C 1 SEC.) RELATIVE TO WA
C  WOOD ANDERSON HAS MAGNIFICATION 2080 & DAMPING 0.8
C     FREQUENCY  .16   .20   .25   .32   .40   .50   .63   .79   1.00
C     LOG FREQ   -.8   -.7   -.6   -.5   -.4   -.3   -.2   -.1   0.0
      DATA RSPA /.288, .432, .561, .680, .786, .891, .983, 1.066,1.138,

C FREQUENCY 1.26   1.59   2.00   2.51   3.16   3.98   5.01   6.31   7.94
C LOG FREQ   .1     .2     .3     .4     .5     .6     .7     .8     .9 
     2   1.205, 1.276, 1.355, 1.443, 1.535, 1.630, 1.726, 1.822, 1.916,

C  FREQUENCY 10.0   12.6   15.9   20.0   25.1   31.6   39.8   50.1
C  LOG FREQ  1.0    1.1    1.2    1.3    1.4    1.5    1.6    1.7
     3    2.007, 2.090, 2.145, 2.099, 1.878, 1.546, 1.172, .771/

C--INITIALIZE SUMS & VALUES
      PAMAD=0.
      PAMAG=0.
      MINPM=0
      PMUSED=0.
      PMCLIP=0.
      PAMAD2=0.
      PAMAG2=0.
      MINPM2=0
      PMUSD2=0.
      PMCLP2=0.

C--RETURN IF NO CALCULATIONS ARE DESIRED
      IF (.NOT.LPMAG) RETURN
      NDATE=KYEAR2*1000000 +KMONTH*10000 +KDAY*100 +KHOUR

C--LOOP OVER STATIONS ++++++++++++++++++++++++++++++++++++++++++++++++++++++
      DO 50 K=1,KSTA
      KPMAG(K)=0
      PNORM(K)=0.
      PAWT(K)=0.
C--SKIP THIS STATION IF NO DATA
      IF (KPAMP(K).EQ.0) GOTO 50
      J=KINDX(K)

C--IF USING A FILE OF CAL FACTORS WITH EXPIRATION DATES, CHECK TO SEE IF
C  CAL FOR THIS STATION HAS EXPIRED.  IF NOT USING A HISTORY FILE,
C  THE EXPIRATION DATE SHOULD ALWAYS BE 0.
      IF (JCEXP(J).GT.0) THEN
        IF (NDATE.GT.JCEXP(J)) THEN

C--FOR INSTRUMENT TYPE 1, USE ATTENUATION HISTORY FILE
          IF (JTYPE(J).EQ.1) THEN

C--READ FILE TO GET A NEW EXPIRATION DATE & ATTENUATION. OPEN ATTENUATION FILE
C  & SEARCH FOR THIS STATION. END OF FILE SHOULD NEVER OCCUR.
            CALL OPENR (13,ATNFIL,'F',IOS)
5           READ (13,1000) STN,SNET,SCOMP,
     2      (IATN(I),IYEARI(I),IAEXP(I),I=1,7)
1000        FORMAT (A5,1X,A2,2X,A3,1X, 7(I2,1X,I4,I6,1X))

            IF (STN(1:NSTLET) .NE. STANAM(J)(1:NSTLET) .OR.
     2      SNET(1:NETLET) .NE. JNET(J)(1:NETLET) .OR.
     3      SCOMP(1:NCOMP) .NE. JCOMP3(J)(1:NCOMP)) GOTO 5

C--SEARCH THE LIST OF EXPIRATION DATES FOR THE FIRST ONE AFTER THE CURRENT DATE,
C  OR AN EXPIRATION DATE OF 0 (CAL GOOD THROUGH THE FUTURE).
            DO I=1,7
C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE DATE
              IF (IYEARI(I).GT.2146) IYEARI(I)=2146
              IAEXP(I)=IYEARI(I)*1000000 +IAEXP(I)

              IF (IAEXP(I).EQ.0 .OR. IAEXP(I).GT.NDATE) THEN
C--ATTEN MUST BE A MULTIPLE OF 6
                KTEMP=IATN(I)/6
                JCAL(J)=CALSV(KTEMP)*1000.

C--WRITE MESSAGE THAT A NEW ATTENUATION WAS FOUND
                IF (LPRT.AND.KPRINT.GE.3) WRITE(15,1001) CALSV(KTEMP),
     2          IATN(I), STN,SNET,SCOMP, JCEXP(J), IAEXP(I)
1001            FORMAT (' * NEW CAL FACTOR',F6.3,' (ATTEN=',I2,
     2          ') ASSIGNED TO ',A5,'-',A2,'-',A3,'.'/
     4          ' NEW CAL FACTOR START DATE = ',
     3          I10,', EXPIRATION DATE = ',I10)
                JCEXP(J)=IAEXP(I)
                GOTO 6
              END IF
            END DO
6           CLOSE (13)
          END IF

C--FOR INSTRUMENT TYPE 3, USE CAL FACTOR HISTORY FILE
          IF (JTYPE(J).EQ.3) THEN

C--READ FILE TO GET A NEW EXPIRATION DATE & CAL FACTOR. OPEN ATTENUATION FILE
C  & SEARCH FOR THIS STATION. END OF FILE SHOULD NEVER OCCUR.
            CALL OPENR (13,CALFIL,'F',IOS)
7           READ (13,1007) STN,SNET,SCOMP,
     2      (RCAL(I),IYEARI(I),IAEXP(I),I=1,7)
1007        FORMAT (A5,1X,A2,2X,A3,1X, 7(F7.2,1X,I4,I6,1X))

            IF (STN(1:NSTLET) .NE. STANAM(J)(1:NSTLET) .OR.
     2      SNET(1:NETLET) .NE. JNET(J)(1:NETLET) .OR.
     3      SCOMP(1:NCOMP) .NE. JCOMP3(J)(1:NCOMP)) GOTO 7

C--SEARCH THE LIST OF EXPIRATION DATES FOR THE FIRST ONE AFTER THE CURRENT DATE,
C  OR AN EXPIRATION DATE OF 0 (CAL GOOD THROUGH THE FUTURE).
            DO I=1,7
C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE DATE
              IF (IYEARI(I).GT.2146) IYEARI(I)=2146
              IAEXP(I)=IYEARI(I)*1000000 +IAEXP(I)

              IF (IAEXP(I).EQ.0 .OR. IAEXP(I).GT.NDATE) THEN
                JCAL(J)=RCAL(I)*1000.

C--WRITE MESSAGE THAT A NEW CAL FACTOR WAS FOUND
                IF (LPRT .AND. KPRINT.GE.3) WRITE (15,1008) RCAL(I),
     2          STN,SNET,SCOMP, JCEXP(J), IAEXP(I)
1008            FORMAT (' * NEW CAL FACTOR',F6.3,
     2          ' ASSIGNED TO ',A5,'-',A2,'-',A3,'.'/
     4          ' NEW CAL FACTOR START DATE = ',
     3          I10,', EXPIRATION DATE = ',I10)
                JCEXP(J)=IAEXP(I)
                GOTO 8
              END IF
            END DO
8           CLOSE (13)
          END IF

        END IF
      END IF

C--CALCULATE P AMPLITUDE MAGNITUDE --------------------------------------

C--COMPUTE PAMAG AS A SUM OF 3 TERMS:
C--1: LOG(P PEAK-TO-PEAK AMP / 2*CAL FACTOR)
C--2: -LOG RESPONSE OF INST REL TO WOOD-ANDERSON AT 5 HZ.
C--3: -LOG(A(0)), THE LOCAL MAGNITUDE DISTANCE CORRECTION
C--FQ = LOG(FREQUENCY OF P WAVE / 5HZ.)
C--SLDIS = HYPOCENTRAL DISTANCE IN KM
CC--ALDSQ = LOG((HYPOCENTRAL DISTANCE)**2)

C--USE KCAL IN PREFERENCE TO JCAL IF KCAL IS PRESENT
      IF (KCAL(K).EQ.0) THEN
        CAL=.001*JCAL(J)
      ELSE
        CAL=.01*KCAL(K)
      END IF
      IF (CAL.EQ.0.) GO TO 50

C--THE PERIOD FOR P IS PRESENTLY UNSPECIFIED, THEREFORE USE .2 SEC
C  AND COMMENT OUT THE USE OF PERIOD AT THE MAXIMUM AMPLITUDE
      PER=.2

C--NOTE: PERIOD IS PRESENTLY UNSPECIFIED FOR P AMPLITUDES, SO SKIP THIS STUFF:
C--SET THE PERIOD AS STANDARD ONE FOR STATION IF NOT ON PHASE CARD
C  JPER(J) IS THE STATION PERIOD IN .1 SEC.
C  KPER(K) IS THE PHASE CARD PERIOD IN .01 SEC.
C      IF (KPER(K).LE.0) THEN
C        PER= .1*JPER(J)
C      ELSE
C        PER=.01*KPER(K)
C      END IF
C--SKIP THE CALCULATIONS IF PERIOD IS OUT OF ALLOWED RANGE
C      IF (PER.GT.6.3 .OR. PER.LT..02) GOTO 50

C--COMPUTE MAGNITUDE
      SLDIS=SQRT(Z1**2 +DIS(K)**2) +.01

C--KPAMP IS THE P AMPLITUDE AVERAGED FOR THE FIRST 3 PEAKS IN MILLIVOLTS
C--CONVERT AMPLITUDE TO PEAK-TO-PEAK MILLIMETERS ON DEVELOCORDER VIEWER
C  FOR COMPATIBILITY WITH OLDER XMAG FORMULATION.
C--FOR THE RTP,          CNT2MM=0.040:  2.5V = 2500 COUNTS = 100MM SOURCE=P,R,O
C--FOR EARTHWORM & CUSP, CNT2MM=.0488:  2.5V = 2048 COUNTS = 100MM SOURCE=W
C--FOR OTHERS, USE DEFAULT VALUE

      AMP=KPAMP(K)*CNT2MD
      DO I=1,NCNTMM
        IF (KSOU(K) .EQ. CCNTMM(I)) AMP=KPAMP(K)*CNT2MM(I)
      END DO

C--AMP IS PEAK-TO-PEAK AMPLITUDE IN MM (.5 IS TO USE HALF-AMP)
      SMAG= ALOG10(AMP*.5/CAL)

C--CONVERT OBSERVED P AMP TO S AMP. ACCORDING TO AKI & RICHARDS, 
C  As/Ap = (Vp/Vs)**3 = 1.73**3 = 5.178 = 10**0.7141
      SMAG=SMAG +.7141

C--CORRECT TO WA RESPONSE TO A STANDARD NETWORK STATION
C--ALSO CORRECT DIGITAL TELEMETRY STATIONS (TYPE 3) WITH SAME CURVE
C  (OLD APPROXIMATION FOR DOMINANT FREQ)
      IF (JTYPE(J).EQ.1 .OR. JTYPE(J).EQ.3) THEN
        FQ=10.*ALOG10(1./PER)+9.
        IFQ=FQ
C--USE RESPONSE CORRECTION INTERPOLATED FROM TABLE
        SMAG=SMAG -(RSPA(IFQ) +(FQ-IFQ) *(RSPA(IFQ+1)-RSPA(IFQ)))
      END IF

C--DONT APPLY XMAG CORRECTIONS SPECIFIED FOR EACH COMPONENT. 
C      DO I=1,NXCM
C        IF (JCOMP3(J)(1:NCOMP) .EQ. CXCM(I)(1:NCOMP)) SMAG=SMAG+AXCM(I)
C      END DO

C--CORRECT AN HVO TYPE SPRENGNETHER
      IF (JTYPE(J).EQ.2) SMAG=SMAG+.41+.56*ALOG10(.2/PER)

C--APPLY RICHTER'S LOGA0 DISTANCE CORRECTION TERM 
C--USE THE RELATION SPECIFIED FOR P AMP MAGS
      CALL LOGA0 (LATYPP,A0MAG,DIS(K),SLDIS)
      SMAG=SMAG+A0MAG

C--OUTPUT LOG(A0) TERM IN REMARK COLUMN OF PRINTOUT (DEBUG ONLY)
C      WRITE (KRMK6(K),'(F4.2,''-'',I1)') A0MAG,LATYP
C      WRITE (KRMK6(K),'(F4.2,''-'',I1)') xx,LATYPP
      
C--APPLY STATION'S INDIVIDUAL MAG CORRECTION
      SMAG=SMAG+.01*JXCOR(J)

C--CHOOSE CONSTANTS OF LINEAR TRANSFORM FOR PMAG 1 OR 2, DEPENDING ON COMPONENT.
C--IF COMPONENT QUALIFIES FOR BOTH, USE SECOND.
C--TRASFORMING MAG CAN ACCOMODATE FOR FAILURE TO APPLY PERIOD CORRECTION,
C  AND FOR UNMODELED SOURCE EFFECTS.
C--DO NOT MAKE BOTH CORRECTIONS IF COMPONENT IS USED FOR BOTH MAGS.

      IF (JPM2(J)) THEN
        SMAG= PMA2 +PMB2*SMAG
      ELSE IF (JPM1(J)) THEN
        SMAG= PMA1 +PMB1*SMAG
      END IF

C--STORE MAGNITUDE
      KPMAG(K)=NINT(100.*SMAG)

C--CODE SIMILAR TO THIS WILL BE USED IF WE EVER USE STATION WEIGHTS FOR PMAG
C$      KXMWT=0
C$      IF (KXWT(K).LT.4) KXMWT=NINT (2.5*((4-KXWT(K))*JXWT(J)))

C--DETERMINE THE WEIGHT FOR THIS P MAGNITUDE.
C--CLIPPING OF THE P WAVE COULD BE FREQUENT.  ITS WEIGHT CODE IS THE NUMBER
C  OF CLIPPED PEAKS IN THE FIRST 3 SWINGS. 
C  THIS CODE IS NOT USED TO DETERMINE THE ACTUAL WEIGHT, ONLY FOR CLIPPING.

C--THE WEIGHT IS THE PRODUCT OF 3 TERMS, AND NEED NOT BE NORMALIZED:
C  1) WEIGHTING FOR DIFFERENT COMPONENTS (IE LOWER GAIN CARRIES MORE WEIGHT)
C  2) P WAVE ARRIVAL TIME WEIGHT (UNCERTAIN & EMERGENT PHASES HAVE LOW WEIGHT)
C    NOTE: ALLOW FOR UPWEIGHTING OF VALID P'S WITH 5 ADDED TO WEIGHT CODE
C  3) THE SPECIFIC WEIGHT ASSIGNED TO AMP MAGS (ALSO XMAG) FROM THIS STATION

C--DECODE P & S WEIGHTS
      LSWT=KWT(K)/10
      L=KWT(K)-10*LSWT

C--DETERMINE P ARRIVAL TIME WEIGHT
      IF (L.EQ.0 .OR. L.EQ.5) THEN
        PAWT(K)=1.
      ELSE IF (L.EQ.1 .OR. L.EQ.6) THEN
        PAWT(K)=0.5
      ELSE IF (L.EQ.2 .OR. L.EQ.7) THEN
        PAWT(K)=0.25
      ELSE IF (L.EQ.3 .OR. L.EQ.8) THEN
        PAWT(K)=0.125
      ELSE
        PAWT(K)=0.
      END IF

C--APPLY STATION WEIGHT FACTOR: JXWT=0 FOR NO WEIGHT, JXWT=10 FOR FULL WEIGHT
      PAWT(K) =PAWT(K) *JXWT(J) *0.1

C--APPLY COMPONENT WEIGHT (PAC COMMAND) FOR THOSE THAT ARE NOT 1.0
      DO I=1,NPWM
        IF (JCOMP3(J)(1:NCOMP) .EQ. CPWM(I)(1:NCOMP))
     2  PAWT(K)=PAWT(K)*WPWM(I)
      END DO

50    CONTINUE

C----------- CALCULATE P AMPLITUDE MAGNITUDE FOR EVENT -------------------

C--DETERMINE THE NORM FOR EACH STATIONS PAMAG. THE MAGNITUDE OF THE STATION
C  WITH THE SMALLEST NORM IS THE L1 ESTIMATE OF THE EVENT P MAG.
C--THE NORM DEPENDS ON THE COMPARISON OF THE TEST MAGNITUDE OF THE STATION
C  FOR WHICH THE NORM IS COMPUTED (INDEX K) WITH ALL OTHER PAMAG'S (INDEX L).
C--NORM(K)= SUM-OVER-L (WEIGHT(L)*ABS[MAG(L) -MAG(K)]) /  SUM-OVER-L WEIGHT(L)
C--INITIALIZE THE REGISTER FOR FINDING MINIMUM NORM:
      PNORMN=9.
      PNRMN2=9.
      KMNNOR=0
      KMNNR2=0

C--LOOP OVER STATIONS TO COMPUTE THEIR NORMS
      DO 70 K=1,KSTA
        IF (KPAMP(K).EQ.0) GOTO 70
        J=KINDX(K)

C--INITIALIZE REGISTERS FOR CALCULATING NORM:
        TOTDEL=0.
        TOTWT=0.
        TOTDL2=0.
        TOTWT2=0.

C--LOOP OVER ALL STATIONS
        DO 60 L=1,KSTA
          IF (KPAMP(L).EQ.0) GOTO 60
          JL=KINDX(L)
          DELTM= .01*(KPMAG(L) -KPMAG(K))

C--CLIPPED STATIONS SHOULD ONLY CONTRIBUTE TO THE NORM IF THEIR MAGS ARE
C  LARGER THAN THE TEST MAG.  THE MAG FROM A CLIPPED STATION IS A MINIMUM EST.
C  THAT SHOULD DRIVE THE AVERAGE MAG UPWARD BUT NOT DOWNWARD.
          IF (DELTM.LT.0. .AND. KPAWT(L).GT.1) GOTO 60

C--ADD TERMS FOR THE NORM
C--PRIMARY PAMAG
          IF (JPM1(J) .AND. JPM1(JL)) THEN
            TOTDEL= TOTDEL +PAWT(L) *ABS(DELTM)
            TOTWT= TOTWT +PAWT(L)
          END IF

C--SECONDARY PAMAG
          IF (JPM2(J) .AND. JPM2(JL)) THEN
            TOTDL2= TOTDL2 +PAWT(L) *ABS(DELTM)
            TOTWT2= TOTWT2 +PAWT(L)
          END IF
60      CONTINUE

C--CALCULATE NORM AND STORE IF IT IS A MINIMUM.
C--NOTE THAT WE ARE COMPUTING NORMS FOR ALL STATIONS WITH A PMAG INCLUDING
C  THE STATIONS WITH NO WEIGHT THEMSELVES.  THE EVENT PMAG MAY THUS NOT BE
C  ONE OF THE SET OF WEIGHTED STATIONS.
C  DONT COMPUTE NORM IF NO DATA AT ALL WERE WEIGHTED
        IF (TOTWT.GT.0.) THEN
          PNORM(K)= TOTDEL/TOTWT
        ELSE
          PNORM(K)=9.
        END IF
        IF (TOTWT2.GT.0.) THEN
          PNORM2(K)= TOTDL2/TOTWT2
        ELSE
          PNORM2(K)=9.
        END IF

C--SAVE THE MINIMUM NORMS AND WHERE IT IS
        IF (PNORM(K) .LT. PNORMN) THEN
          PNORMN= PNORM(K)
          KMNNOR= K
        END IF
        IF (PNORM2(K) .LT. PNRMN2) THEN
          PNRMN2= PNORM2(K)
          KMNNR2= K
        END IF
70    CONTINUE

C--ALSO SAVE THE 2ND AND 3RD MINIMUM NORMS FOR PRIMARY PAMAG
      PNORMB=9.
      KMNB=0
      DO K=1,KSTA
        IF (KPAMP(K).GT.0) THEN
          IF (PNORM(K) .LT. PNORMB .AND. K.NE.KMNNOR) THEN
            PNORMB= PNORM(K)
            KMNB= K
          END IF
        END IF
      END DO

      PNORMC=9.
      KMNC=0
      DO K=1,KSTA
        IF (KPAMP(K).GT.0) THEN
          IF (PNORM(K) .LT. PNORMC .AND. K.NE.KMNNOR .AND.
     2    K.NE.KMNB) THEN
            PNORM3= PNORM(K)
            KMN3= K
          END IF
        END IF
      END DO

C--ALSO SAVE THE 2ND AND 3RD MINIMUM NORMS FOR SECONDARY PAMAG
      PNRMB2=9.
      KMNB2=0
      DO K=1,KSTA
        IF (KPAMP(K).GT.0) THEN
          IF (PNORM2(K) .LT. PNRMB2 .AND. K.NE.KMNNR2) THEN
            PNRMB2= PNORM2(K)
            KMNB2= K
          END IF
        END IF
      END DO

      PNRMC2=9.
      KMNC2=0
      DO K=1,KSTA
        IF (KPAMP(K).GT.0) THEN
          IF (PNORM2(K) .LT. PNRMC2 .AND. K.NE.KMNNR2 .AND.
     2    K.NE.KMNB2) THEN
            PNRMC2= PNORM2(K)
            KMNC2= K
          END IF
        END IF
      END DO

C--THE P AMP MAG FOR THE EVENT IS THAT OF THE STA WITH SMALLEST NORM
      IF (KMNNOR.GT.0) PAMAG= .01*KPMAG(KMNNOR)
      IF (KMNNR2.GT.0) PAMAG2= .01*KPMAG(KMNNR2)

C--ZERO PARAMETERS & COUNT WEIGHTS FOR NUMBER OF STATIONS
      PMUSED=0.
      PMCLIP=0.
      PMUSD2=0.
      PMCLP2=0.
      DO K=1,KSTA
        IF (KPAMP(K).GT.0) THEN
          J=KINDX(K)
          IF (JPM1(J)) THEN
            PMUSED= PMUSED +PAWT(K)
            IF (KPAWT(K).GT.1) PMCLIP= PMCLIP +PAWT(K)
          END IF
          IF (JPM2(J)) THEN
            PMUSD2= PMUSD2 +PAWT(K)
            IF (KPAWT(K).GT.1) PMCLP2= PMCLP2 +PAWT(K)
          END IF
        END IF
      END DO

C--FLAG THIS PAMAG AS A MINIMUM MAG IF:
C  1) 1 OF THE 3 MINIMUM NORM STATIONS ARE CLIPPED
C  2) MORE THAN CLPRAT (ABOUT 0.40) OF THE STATIONS ARE CLIPPED
C--PRIMARY P AMP MAGNITUDE
      MINPM=0
      L=0
      IF (KPAWT(KMNNOR).GT.1) L=L+1
      IF (KMNB.GT.0 .AND. KMNC.GT.0) THEN
        IF (KPAWT(KMNB).GT.1) L=L+1
        IF (KPAWT(KMNC).GT.1) L=L+1
      END IF
      IF (L.GT.0) MINPM=1
      IF (PMUSED.GT.0.) THEN
        IF (PMCLIP/PMUSED .GE. CLPRAT) MINPM=1
      END IF

C--SECONDARY P AMP MAGNITUDE
      MINPM2=0
      L=0
      IF (KPAWT(KMNNR2).GT.1) L=L+1
      IF (KMNB2.GT.0 .AND. KMNC2.GT.0) THEN
        IF (KPAWT(KMNB2).GT.1) L=L+1
        IF (KPAWT(KMNC2).GT.1) L=L+1
      END IF
      IF (L.GT.0) MINPM2=1
      IF (PMUSD2.GT.0.) THEN
        IF (PMCLP2/PMUSD2 .GE. CLPRAT) MINPM2=1
      END IF

C--CALC MEDIAN ABSOLUTE DIFFERENCE OF P AMP MAG & COUNT WEIGHTS
C--PASS THROUGH THE STATION LIST AND ACCUMULATE DIFFS IN A SEPARATE ARRAY
C--PRIMARY P AMP MAGNITUDE
      NMED=0
      DO K=1,KSTA
        J=KINDX(K)
        IF (KPAMP(K).GT.0 .AND. K.NE.KMNNOR .AND. JPM1(J)) THEN
          NMED=NMED+1
          IMAG(NMED)= ABS(KPMAG(K) -NINT(100.*PAMAG))
          IMWT(NMED)= 100.*PAWT(K)
        END IF
      END DO
      CALL MEDWT (NMED,IMAG,IMWT,MEDIAN)
      PAMAD=.01*MEDIAN

C--SECONDARY P AMP MAGNITUDE
      NMED=0
      DO K=1,KSTA
        J=KINDX(K)
        IF (KPAMP(K).GT.0 .AND. K.NE.KMNNR2 .AND. JPM2(J)) THEN
          NMED=NMED+1
          IMAG(NMED)= ABS(KPMAG(K) -NINT(100.*PAMAG))
          IMWT(NMED)= 100.*PAWT(K)
        END IF
      END DO
      CALL MEDWT (NMED,IMAG,IMWT,MEDIAN)
      PAMAD2=.01*MEDIAN

      RETURN
      END
      SUBROUTINE HYOPEN
C--CALLED BY HYPOINV TO OPEN FILES
      INCLUDE 'common.inc'
C--ISTAT2 IS USED BY HYOPEN TO TELL HYP WHETHER FILES EXIST.

      CHARACTER CHEAD*8,CHEADC*8
      DIMENSION CHEAD(5),CHEADC(5)
      DATA CHEAD/'DUR-MAG1','DUR-MAG2','AMP-MAG1','AMP-MAG2','EXT-MAG '/
      DATA CHEADC/'DUR,MAG1','DUR,MAG2','AMP,MAG1','AMP,MAG2',
     2 'EXT,MAG '/

C--OPEN PHASE FILE
      IF (JCP.LT.6) CALL OPENR (14,PHSFIL,'F',IOS)
      IF (IOS.NE.0) THEN
C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT PHASE FILES
        WRITE (6,1010)
1010    FORMAT (' *** ERROR - PHASE FILE DOES NOT EXIST ***')
        ISTAT2=0
        IRES=-61
        RETURN
      END IF

C--OPEN CUSP-ID FILE
C      IF (JCP.EQ.7) CALL OPENR (14,PHSFIL,'F',IOS)
C      IF (IOS.NE.0) THEN
CC--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT CUSP-ID FILE
C        WRITE (6,1011)
C1011    FORMAT (' *** ERROR - CUSP-ID FILE DOES NOT EXIST ***')
C        ISTAT2=0
C        IRES=-62
C        RETURN
C      END IF
      ISTAT2=1

C--OPEN OUTPUT FILES
      IF (LSUM .AND. LAPP(2)) CALL OPENW (12,SUMFIL,'F',IOS,'A')
      IF (LARC .AND. LAPP(3)) CALL OPENW (7,ARCFIL,'F',IOS,'A')
      IF (LPRT .AND. LAPP(1)) CALL OPENW (15,PRTFIL,'F',IOS,'A')

      IF (LSUM .AND. .NOT.LAPP(2)) THEN
        CALL OPENW (12,SUMFIL,'F',IOS,'S')

C--WRITE HEADER LINE IN READABLE SUMMARY FILES
        IF (IH71S.EQ.3) WRITE (12,1003) (CHEAD(MRDMAG(I)),I=1,NRDMAG)
1003    FORMAT ('   DATE     TIME  SEC     LAT      LON    ',
     2 ' DEPTH PREF-MAG NM NUM GAP  DMIN  RMS    ERH   ERZ QASR ',4X,
     3 'ID-NUM LOC',5(' ',A8))

        IF (IH71S.EQ.4) WRITE (12,1004) (CHEADC(MRDMAG(I)),I=1,NRDMAG)
1004    FORMAT ('   DATE     TIME, SEC ,   LAT  ,   LON   ,',
     2 ' DEPTH,PREF,MAG,NM,NUM,GAP, DMIN, RMS ,  ERH,  ERZ,QASR,',4X,
     3 'ID-NUM,LOC',5(',',A8))
      END IF

      IF (LARC .AND. .NOT.LAPP(3)) CALL OPENW (7,ARCFIL,'F',IOS,'S')
      IF (LPRT .AND. .NOT.LAPP(1)) CALL OPENW (15,PRTFIL,'F',IOS,'S')

      IF (LMAG) CALL OPENW (16,MAGFIL,'F',IOS,'S')
      RETURN

      END
      SUBROUTINE HYPHS
C--READS IN PHASE DATA FOR 1 HYPOINVERSE EARTHQUAKE
C--ALSO CHECK FOR TRIAL HYPOCENTER & MANY ERRORS IN DATA
      INCLUDE 'common.inc'
      LOGICAL LPHFMT,LSHAD
C--USE STRI FOR PHASE LINE INPUT & OUTPUT, STR AS A SCRATCH STRING
C  FOR REFORMATTING, AND STR2 FOR AN EXPECTED SUMMARY (HEADER) LINE
      CHARACTER CSTA*4,CCWT*1, LASTA*5,STA*5, RTPFL*2, STR*188, STRI*188
      CHARACTER STR2*188, COMP1*1,COMP3*3, SNET*2, SHASTR*104, CSTIM*5
      CHARACTER SLOC*2
      DOUBLE PRECISION DT
      SAVE RMKS, RMKA, NLET

C--ARRAYS FOR INPUT (EXTERNAL) MAGNITUDES TO PASS THRU
      CHARACTER BMTYPI*1
      DIMENSION BMTYPI(2),BMAGI(2),TEMPI(2)

C--RMKS IS THE ARRAY OF EVENT REMARKS WHICH ARE RECOGNIZED, ABBREVIATED
C  TO 1 LETTER & OUTPUT AS A SUPPLEMENTARY REMARK.
      PARAMETER (NRMK=9)      !THE NUMBER OF INPUT REMARKS RECOGNIZED
      DIMENSION NLET(NRMK)      !NUMBER OF LETTERS REQUIRED TO RECOGNIZE
      CHARACTER RMKS(NRMK)*3      !INPUT REMARKS RECOGNIZED
      CHARACTER RMKA(NRMK)*1      !TRANSLATED 1-LETTER OUTPUT REMARK CODES
C-- FLT OR F: FELT
C-- TRM OR T: TREMOR ASSOCIATED
C-- LP_ (LPC OR LPD): LONG PERIOD
C-- BLS, Q__ OR *__: QUARRY BLAST
      DATA RMKS/'FLT','F  ','TRM','T  ','LP ','BLS','Q  ','*  ','NTS'/
      DATA RMKA/'F',  'F',  'T',  'T',  'L',  'B',  'Q',  'Q',  'N'  /
      DATA NLET/ 3,    3,    3,    3,    2,    2,    1,    1,    3   /

C--JCP IS THE INPUT FORMAT CONTROL:
C  1= FULL PHASE
C  2= CONDENSED PHASE
C  3= ARCHIVE
C  4= FULL PHASE WITH HEADER & SHADOW RECORDS
C  5= ARCHIVE WITH SHADOW RECORDS

1001  FORMAT (A)

C--DEFINE LOGICAL SHORT-CUTS
      LPHFMT=JCP.EQ.1 .OR. JCP.EQ.4
      LSHAD =JCP.EQ.4 .OR. JCP.EQ.5

C---------------------- PROCESS THE LAST PART OF A LARGE EVENT ---------------
      IF (LTBIG) THEN
C--MORE PHASE CARDS REMAIN FROM EVENT, SO COPY THEM TO OUTPUT
        LTBIG=.FALSE.
C--SEND MESSAGES TO THE PRINT FILE & TERMINAL
        IF (LERR) WRITE (6,1020)
        IF (LPRT) WRITE (15,1020)
1020    FORMAT (' *** ADDITIONAL PHASE DATA FOR ABOVE EVENT',
     2 ' WAS NOT USED BUT WAS COPIED TO OUTPUT.')

C--LOOP TO READ AND COPY ADDITIONAL PHASE DATA
5       CALL READQ (14,STRI,NSTR,IOS)
        IF (IOS.GT.0) GOTO 80
        IF (STRI(1:4).EQ.'    ') THEN

C--THIS IS A TERMINATOR SO COPY IT AS IS
          IF (LARC) WRITE (7,1001) STRI(1:NSTR)
          IF (LSHAD) THEN
            CALL READQ (14,SHADO,LENSHA,IOS)
            IF (IOS.GT.0) GOTO 80
            IF (LARC) WRITE (7,1001) SHADO(1:LENSHA)
          END IF
          GOTO 8
        END IF

C--THIS IS NOT A TERMINATOR, SO PROCESS ACCORDING TO ITS FORMAT
C  COPY FIELDS FROM INPUT TO OUTPUT STRING
        STR=' '
        IF (LPHFMT) THEN
C--FULL FORMAT PHASE CARD. MOVE DATA TO ARCHIVE POSITION.
C--THIS TRANSLATION CODE IS ALSO THE BASIS FOR A TRANSLATION PROGRAM
          IF (L2000) THEN
C--Y2000 ARCHIVE FORMAT
            STR(1:4)=STRI(1:4)		!SITE CODE
            STR(5:5)=STRI(78:78)	!SITE CODE
            STR(6:7)=STRI(82:83)	!NET CODE
            STR(10:12)=STRI(79:81)	!COMP CODE
            STR(14:17)=STRI(5:8)	!P RMK
            STR(18:19)='19'		!CENTURY
            STR(20:34)=STRI(10:24)	!DATE, P TIME
            STR(42:50)=STRI(32:40)	!S TIME, S RMK
            STR(57:59)=STRI(45:47)	!AMP
            STR(60:63)='00 0'		!AMP & UNITS CODE
            STR(82:82)=STRI(51:51)	!AMP MAG WEIGHT CODE
            STR(83:83)=STRI(76:76)	!DUR MAG WEIGHT CODE
            STR(84:86)=STRI(48:50)	!PERIOD OF MAX AMP
            STR(87:91)=STRI(71:75)	!STA RMK, CODA DUR
            STR(109:109)=STRI(41:41)	!DATA SOURCE CODE
            STR(112:113)=STRI(84:85)	!LOCATION CODE
            NSTR=113

          ELSE
C--PHASE INPUT TO OLD ARCHIVE FORMAT OUTPUT
            STR(1:9)=STRI(1:9)		!SITE CODE, P RMK
            STR(10:24)=STRI(10:24)	!DATE, P TIME
            STR(32:40)=STRI(32:40)	!S TIME, S RMK
            STR(45:47)=STRI(45:47)	!AMP
            STR(71:75)=STRI(71:75)	!STA RMK, CODA DUR
            STR(95:100)=STRI(78:83)	!NET & COMP CODES
            STR(91:91)=STRI(25:25)	!P/S WEIGHT OUT CODE
            STR(92:92)=STRI(41:41)	!DATA SOURCE CODE
            STR(68:70)=STRI(48:50)	!PERIOD OF MAX AMP
            STR(67:67)=STRI(76:76)	!DUR MAG WEIGHT CODE
            STR(66:66)=STRI(77:77)	!AMP MAG WEIGHT CODE
            NSTR=100
          END IF
          
        ELSE
          IF (L2000) THEN
C--BLANK OUT FIELDS RESERVED FOR DERIVED DATA
C--ARCHIVE 2000 INPUT & OUTPUT
            STR=STRI
            STR(35:41)=' '		!P RESIDUAL & WT
            STR(51:54)=' '		!S RESIDUAL
            STR(64:81)=' '		!S WEIGHT, 2 DELAYS, DIST, EM.ANGLE
            STR(92:108)=' '		!AZIM, MAGS, IMPORTANCE
            STR(110:111)=' '		!MAG CODES
            NSTR=113
          ELSE
          
C--BLANK OUT FIELDS RESERVED FOR DERIVED DATA
C--OLD ARCHIVE INPUT & OUTPUT
            STR=STRI
            STR(25:31)=' '		!P RESIDUAL & WT
            STR(41:44)=' '		!S RESIDUAL
            STR(48:65)=' '		!S WEIGHT, 2 DELAYS, DIST, EM.ANGLE
            STR(76:90)=' '		!AZIM, MAGS, IMPORTANCE
            NSTR=100
          END IF
        END IF

C--LOAD REFORMATTED DATA BACK INTO STRI
        STRI=STR

C--WRITE DATA TO APPROPRIATE FILES
        IF (LARC) WRITE (7,1001) STRI(1:NSTR)
        IF (LPRT) WRITE (15,1049) STRI(1:NSTR)
1049        FORMAT (1X,A)

C--COPY THE SHADOW IF ITS THERE
        IF (LSHAD) THEN
C          READ (14,1014,END=80) LENSHA,SHADO
          CALL READQ (14,SHADO,LENSHA,IOS)
          IF (IOS.GT.0) GOTO 80
          IF (LARC) WRITE (7,1001) SHADO(1:LENSHA)
        END IF
        GOTO 5
      END IF		!END OF BIG EVENT PROCESSING

C-------------------- START REGULAR INPUT -----------------------------
C--INITIALIZATION BEFORE EACH EQ. (IN CASE IT IS NOT GIVEN A VALUE)
8     IL=0
      IDNO=0
      NUNK=0
      CCOR=0.
      RMK1=' '
      RMK2=' '
      CP1=' '
      CP2=' '
      CP3=' '
      LASTA=' '
      BMTYP=' '
C      MBMAG=0
      NBMAG=0
C      BMAG=0.
      BMAG=VNOMAG
      BMTYPX=' '
C      MBMAGX=0
      NBMAGX=0
C      BMAGX=0.
      BMAGX=VNOMAG
      TEPER=0.
      K=0

C--READ THE EVENT REFERENCE TIME IF PHASE FILE IS CONDENSED
C--ALSO DEFINE THE AUXILIARY REMARKS FROM THE HEADER LINE IF THIS IS
C--A CONDENSED FORMAT ARCHIVE FILE.
C      IF (JCP.EQ.2) THEN
C        READ (14,1008,ERR=9,END=80) KYEAR,KMONTH,
C     2 KDAY,KHOUR,KMIN,SEC,RMK1,RMK2
C        KYEAR2=KYEAR+ICENT
C1008    FORMAT (5I2,F4.2,62X,2A1)
C        IF (RMK2.EQ.'#' .OR. RMK2.EQ.'-') RMK2=' '
C        IF (RMK1.EQ.'#' .OR. RMK1.EQ.'-') RMK1=' '
C      END IF

C--READ THE EVENT REMARKS IF THIS IS A FULL-FORMAT ARCHIVE FILE
C--USE THE ID NUMBER, BUT REPLACE IT WITH THAT ON THE TERMINATOR CARD
C  (UNLESS THE EVENT IS TOO BIG AND FILLS ARRAYS BEFORE READING THE END)
      IF (JCP.EQ.3 .OR. JCP.EQ.5) THEN
        READ (14,1001,END=80) STR2
        
        IF (L2000) THEN
          READ (STR2,1212) KYEAR2,KMONTH,KDAY,KHOUR,KMIN, RMK1,RMK2,
     2    CP1, (BMTYPI(I),BMAGI(I),TEMPI(I), I=1,2), IDNO, CP2,CP3

1212      FORMAT (I4,4I2, T81,2A1,
     2    T114,A1, T123,2(A1,F3.2,F3.1), I10, T163,2A1)
          ICNT=KYEAR2/100
          KYEAR=KYEAR2-ICNT*100		!GET 2 DIGIT YEAR IF NEEDED

        ELSE
          READ (STR2,1012) KYEAR,KMONTH,KDAY,KHOUR,KMIN, RMK1,RMK2,
     2    CP1, (BMTYPI(I),BMAGI(I),TEMPI(I), I=1,2), IDNO, CP2,CP3

1012      FORMAT (5I2, T77,2A1,
     2    T106,A1, T115,2(A1,F3.2,F3.1), I10, T153,2A1)
          KYEAR2=KYEAR+ICENT
        END IF

        IF (RMK2.EQ.'#' .OR. RMK2.EQ.'*' .OR. RMK2.EQ.'-') RMK2=' '
C--RMK1 SHOULD NOT BE - OR * OR #
        IF (RMK1.EQ.'#' .OR. RMK1.EQ.'*' .OR. RMK1.EQ.'-') RMK1=' '
C--IF THE 2ND REMARK WAS MADE Q BY HAND, THIS PUTS IT WHERE IT BELONGS
        IF (RMK2.EQ.'Q') THEN
          RMK1='Q'
          RMK2=' '
        END IF

C--EITHER PASS THROUGH THE VERSION REMARK, OR RESET IT FROM LAB COMMAND
        IF (.NOT.LP153) CP2=RUNLAB

C--CHECK FOR & SAVE EXTERNAL MAGNITUDES, TO PASS THRU LOCATION RUN.
C  A IS USED FOR OLDER XMAGS, OUTPUT THROUGH XMAG2
C  L IS BERKELEY NETWORK MAGNITUDE, FORMERLY B, OUTPUT THROUGH BMAG
C  C IS CURRENTLY UNUSED

C--PASS THROUGH AN EXTERNAL MAGNITUDE LABELED 'L', BUT ONLY IN THE EXTERNAL
C  POSITION. AN 'L' MAGNITUDE IN THE XMAG2 POSITION IS RECALCULATED.
C--NOTE: NOW PASS THROUGH ALL EXTERNAL MAGNITUDES. NORMALLY THEY ARE:
C  L  LOCAL MAGNITUDE FROM BERKELEY (NCSN)
C  S  SURFACE WAVE MAGNITUDE MS (HVO, NCSN)
C  B  OLD BERKELEY MAG, SOMEDAY BODY WAVE MAG MB

        IF (BMTYPI(1).NE.' ') THEN
          BMTYP=BMTYPI(1)
          BMAG=BMAGI(1)
          NBMAG=NINT(TEMPI(1))
        END IF

        DO I=1,2
          IF (BMTYPI(I).EQ.'B') THEN
C--CONVERT THE CONFUSING B CODE TO L. THIS WILL ALWAYS BE OUTPUT AS EXTERNAL
C  MAG, NEVER AS THE CALCULATED SECONDARY AMPLITUDE MAG
            BMTYP='L'
            BMAG=BMAGI(I)
            NBMAG=NINT(TEMPI(I))
          END IF
          IF (BMTYPI(I).EQ.'A') THEN
            BMTYPX=BMTYPI(I)
            BMAGX=BMAGI(I)
C            MBMAGX=100.*TEMPI(I)+.5
            NBMAGX=NINT(TEMPI(I))
          END IF
        END DO

C--OPTIONALLY GET TRIAL HYPO FROM HEADER
        IF (IH71T.EQ.3) THEN
          IF (L2000) THEN
            READ (STR2,1124) T1,LAT,IS,XLTM,LON,IE,XLNM,Z1
1124        FORMAT (12X,F4.2,I2,A1,F4.2,I3,A1,F4.2,F5.2)
          ELSE
            READ (STR2,1024) T1,LAT,IS,XLTM,LON,IE,XLNM,Z1
1024        FORMAT (10X,F4.2,I2,A1,F4.2,I3,A1,F4.2,F5.2)
	  END IF
          CLAT=LAT+XLTM/60.
          CLON=LON+XLNM/60.
          IF (IS.EQ.'S') CLAT = -CLAT
          IF (IE.EQ.'E') CLON = -CLON

C--IF USING TRIAL LOCATION & OT FROM THE HEADER, COMPARE ALL PHASES, INCLUDING
C  THE FIRST, TO TRIAL FOR CLOSE TIME AGREEMENT
          DAYFIRST=DAYJL(KYEAR2,KMONTH,KDAY)
        END IF

C--SAVE THE FIRST SHADOW RECORD
        IF (LSHAD) THEN
          CALL READQ (14,SHASTR,LENIN,IOS)
          IF (IOS.GT.0) GOTO 80
          SHAD1(1)=SHASTR
          LSHA1(1)=LENIN
          NSHA1=1
          IF (LSHA1(1) .GT. 100) THEN
            WRITE (6,1019) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
            IF (LPRT) WRITE (15,1019) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1019        FORMAT (' *** SHADOW RECORD FOLLOWING ',I4,4I3,
     2     ' HEADER IS TOO LONG')
            IRES=-101
            STOP
          END IF
        END IF
      END IF

C--READ THE HEADER IF THIS IS A PHASE FILE WITH SHADOW CARDS
      IF (JCP.EQ.4) THEN
        IF (IH71T.EQ.3) THEN
C--READ TRIAL HYPO IN PRE-2000 HYPO71 FORMAT
          READ (14,1026,END=80) KYEAR,KMONTH,KDAY,KHOUR,KMIN,
     2    T1, LAT,IS,XLTM, LON,IE,XLNM,Z1
1026      FORMAT (3I2,1X,2I2,F6.2,1X, I2,A1,F5.2,1X, I3,A1,F5.2,F7.2)
          KYEAR2=KYEAR+ICENT
          CLAT=LAT+XLTM/60.
          CLON=LON+XLNM/60.
          IF (IS.EQ.'S') CLAT = -CLAT
          IF (IE.EQ.'E') CLON = -CLON

C--IF USING TRIAL LOCATION & OT FROM THE HEADER, COMPARE ALL PHASES, INCLUDING
C  THE FIRST, TO TRIAL FOR CLOSE TIME AGREEMENT
          DAYFIRST=DAYJL(KYEAR2,KMONTH,KDAY)
        ELSE

C--SKIP HEADER (& HOPE THAT DATE ISN'T NEEDED FOR SHADOW ERROR MESSAGE)
          READ (14,*,END=80)
        END IF

C--SAVE THE FIRST SHADOW RECORD
C        READ (14,1014,END=80) LSHA1(1),SHAD1(1)
        CALL READQ (14,SHASTR,LENIN,IOS)
        IF (IOS.GT.0) GOTO 80
        SHAD1(1)=SHASTR
        LSHA1(1)=LENIN
        NSHA1=1
        IF (LSHA1(1) .GT. 100) THEN
          WRITE (6,1019) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
          IF (LPRT) WRITE (15,1019) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
          STOP
        END IF
      END IF
C      GOTO 10

C--LOOP TO READ PHASE CARDS **************************************************
10    DO 50 K=1,MAXPHS
      GOTO 15

C--PRINT AN ERROR MESSAGE & SKIP A BAD PHASE CARD
12    IF (LPRT) WRITE (15,1000) STRI(1:NSTR)
      IF (LERR) WRITE (6,1000) STRI(1:NSTR)
1000  FORMAT (' *** SKIP BAD PHASE CARD:'/1X,A)
      GOTO 14

C--PRINT AN ERROR MESSAGE & SKIP A BAD ARCHIVE CARD
13    IF (LPRT) WRITE (15,1300) STRI(1:NSTR)
      IF (LERR) WRITE (6,1300) STRI(1:NSTR)
1300  FORMAT (' *** SKIP BAD INPUT ARCHIVE CARD:'/1X,A)

C--REMAINING ERROR PROCESSING
14    IF (LSHAD) THEN
        CALL READQ (14,STRI,NSTR,IOS)
        IF (IOS.GT.0) GOTO 80
        IF (LPRT) WRITE (15,1200) STRI(1:NSTR)
        IF (LERR) WRITE (6,1200) STRI(1:NSTR)
1200    FORMAT (' *** ALSO SKIP NEXT CARD, ASSUMED TO BE A SHADOW CARD'/
     2  1X,A)
      END IF
      IRES=-14
      GOTO 15

C      WRITE (6,*) 'STA= ',STA
C      WRITE (6,*) 'NET= ',SNET
C      WRITE (6,*) 'COMP1= ',COMP1
C      WRITE (6,*) 'COMP3= ',COMP3
C      WRITE (6,*) 'PRK= ',KPRK(K)
C      WRITE (6,*) 'PWT= ',LPWT
C      WRITE (6,*) 'DATE= ',LYEAR2,LMONTH,LDAY,LHOUR,LMIN
C      WRITE (6,*) 'P= ',P
C      WRITE (6,*) 'S= ',S
C      WRITE (6,*) 'SRK= ',KSRK(K)
C      WRITE (6,*) 'SWT= ',LSWT
C      WRITE (6,*) 'AMP= ',AMPK(K)
C      WRITE (6,*) 'AMPU= ',KAMPU(K)
C      WRITE (6,*) 'XWT= ',KXWT(K)
C      WRITE (6,*) 'FWT= ',CCWT
C      WRITE (6,*) 'PER= ',TEPER
C      WRITE (6,*) 'SRMK= ',KRMK(K)
C      WRITE (6,*) 'DUR= ',FMP
C      WRITE (6,*) 'SOU= ',KSOU(K)

C--READ A PHASE CARD
15    CALL READQ (14,STRI,NSTR,IOS)
      IF (IOS.GT.0) GOTO 80

C--ALLOW FOR ADDITIONAL SHADOWS TO THE HEADER IF READING ARCHIVE SHADOW FORMAT
      IF (JCP.EQ.5 .AND. K.EQ.1) THEN
        IF (STRI(1:1).EQ.'$') THEN
          NSHA1=NSHA1+1
          IF (NSHA1.GT.MSHA) THEN
            WRITE (6,1021) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1021        FORMAT (' *** TOO MANY HEADER SHADOW RECORDS IN EVENT, '/
     2      ' OR TOO MANY BAD PASE CARDS AT START OF EVENT.',I4,4I3)
            IRES=-102
            STOP
          END IF
          LSHA1(NSHA1)=NSTR
          SHAD1(NSHA1)=STRI
          GOTO 15
        END IF
      END IF

C--INTERPRET A CARD WITH A BLANK STATION NAME AS A TERMINATOR CARD
      CSTA=STRI(1:4)
      IF (CSTA.EQ.'    ') GOTO 60

C      IF (JCP.EQ.2) THEN
C---------------------- CONDENSED PHASE CARD FORMAT --------------------
C--INITIALIZE DATA IN CASE IT IS NOT GIVEN A VALUE READING CONDENSED FORMAT
C        KP(K)=0
C        KSOU(K)=' '
C        KPRK(K)='  '
C        KWT(K)=0
C        KS(K)=0
C        KFMP(K)=0
C        AMPK(K)=0.
C        KSRK(K)='  '
C        KRMK(K)=' '

C--IF THIS LINE INCLUDES DATA FROM THE STATION ON PREVIOUS LINE,
C  DONT INCREMENT THE STATION INDEX
C        READ (STRI,1010,ERR=12) STA(1:4),CM,I,TEMP,FMP
C1010    FORMAT (A4,A3,I1,F5.2,F4.0)
C        STA(5:5)=' '
C        IK=K
C        IF (STA.EQ.LASTA) IK=K-1
C        CTEMP=CM(2:2)
C        IF (FMP.NE.0.) KFMP(IK)=FMP+.5

C--THIS IS A P TIME 
C        IF (CTEMP.EQ.'P') THEN
C          KPRK(IK)=CM
C          KWT(IK)=KWT(IK)+I
C          KP(IK)=NINT(100.*(TEMP+SEC))
C        END IF

C--THIS IS AN S TIME
C        IF (CTEMP.EQ.'S') THEN
C          KSRK(IK)=CM
C          KWT(IK)=KWT(IK)+10*I
C          KS(IK)=NINT(100.*(TEMP+SEC))
C        END IF

C--THIS IS AN AMPLITUDE
C        IF (CTEMP.EQ.'A') AMPK(IK)=TEMP
C        IF (IK.EQ.K) GOTO 18
C        GOTO 15
C      END IF

C------------------- READ FULL FORMATS -----------------------------
      IF (LPHFMT) THEN
        KRMK6(K)=' '
C--ASSUME A FULL PHASE CARD
        READ (STRI,1002,ERR=12) STA(1:4),KPRK(K),LPWT,COMP1,LYEAR,
     2  LMONTH,LDAY,LHOUR,LMIN,P, S,KSRK(K),LSWT,KSOU(K),
     3  AMPK(K),TEPER,KXWT(K),IL, TECAL,KRMK6(K),CCOR, KRMK(K),FMP,
     4  CCWT,STA(5:5),COMP3,SNET,SLOC

1002    FORMAT (BZ,A4,A3,I1,A1,
     2  5I2,F5.2,1X,6X, F5.2,A2,1X,I1,A1,3X,
     3  F3.0,F3.2,I1,3X,I4, F4.1,A3,F5.2, A1,F4.0,
     4  A1,1X,A1,A3,2A2)
        LYEAR2=LYEAR+ICENT
        IF (AMPK(K).GT.0.) KAMPU(K)=IAMPU
        KAMPTYP(K)=0
      ELSE

C--ASSUME AN ARCHIVE CARD
        TECAL=0.
        IF (L2000) THEN
          READ (STRI,1213,ERR=13) STA,SNET,COMP1,COMP3, KPRK(K),LPWT,
     2    LYEAR2,LMONTH,LDAY,LHOUR,LMIN,P, S,KSRK(K),LSWT,AMPK(K),
     3    KAMPU(K),KXWT(K), CCWT,TEPER,KRMK(K), FMP,KSOU(K),SLOC,
     4    KAMPTYP(K)
 
1213      FORMAT (BZ,A5,A2,1X,A1,A3,1X, A3,I1,
     2    I4,4I2,F5.2,7X, F5.2,A2,1X,I1,4X,F7.2,
     3    I2,18X,I1, A1,F3.2,A1, F4.0,17X,A1,2X,A2,
     4    I2)

          CSTIM=STRI(42:46)
          ICNT=LYEAR2/100
          LYEAR=LYEAR2-ICNT*100		!GET 2 DIGIT YEAR IF NEEDED
        ELSE

C--OLD 20TH CENT FORMAT
          READ (STRI,1013,ERR=13) STA(1:4),KPRK(K),LPWT,COMP1,LYEAR,
     2    LMONTH,LDAY,LHOUR,LMIN,P, S,KSRK(K),LSWT,AMPK(K),
     3    KXWT(K),CCWT,TEPER,KRMK(K), FMP,KSOU(K),
     4    STA(5:5),COMP3,SNET,SLOC

1013      FORMAT (BZ,A4,A3,I1,A1,
     2    5I2,F5.2,7X, F5.2,A2,1X,I1,4X,F3.0,
     3    18X,I1,A1,F3.2,A1, F4.0,15X,1X,A1,
     4    2X,A1,A3,2A2)
     
          LYEAR2=LYEAR+ICENT
          IF (AMPK(K).GT.0.) KAMPU(K)=IAMPU
          CSTIM=STRI(32:36)
          KAMPTYP(K)=0
        END IF
      END IF

C--USE THE 1-LETTER COMPONENT FOR MATCHING IF THE FLAG IS SET
C      IF (LCOMP1) COMP3=COMP1

C--GET THE CODA WEIGHT CODE, BUT DONT LET ALPHA DATA CAUSE A FATAL ERROR
C  KEEP THE INTEGER VALUE, OR SET TO 9 IF WEIGHT CODE IS NOT AN INTEGER.
      IF (LCOWT) THEN
        KFWT(K)=ICHAR(CCWT)-48
C--TREAT A BLANK AS FULL WEIGHT (CODE 0)
        IF (KFWT(K).EQ.-16) KFWT(K)=0
        IF (KFWT(K).LT.0 .OR. KFWT(K).GT.9) KFWT(K)=9
      ELSE
        KFWT(K)=0
        IF (CCWT.EQ.'N' .OR. CCWT.EQ.'X') KFWT(K)=4
      END IF

C---------------------- LOAD THE DATA INTO ARRAYS -----------------------
      FMPK(K)=FMP
      KPER(K)=TEPER*100.
      KCAL(K)=100.*TECAL

C--IF THE S TIME IS BLANK, MAKE SURE NO S IS USED BY BLANKING THE S REMARK
      IF (CSTIM .EQ. '     ') KSRK(K)='  '
C--IF THE S TIME IS NOT ZERO, BE SURE S HAS A REMARK (PHASE FORMAT ONLY)
      IF (S.NE.0. .AND. KSRK(K).EQ.'  ' .AND. LPHFMT) KSRK(K)=' S'

C--KEEP THE FIRST NON-ZERO ID NUMBER ON A PHASE CARD, BUT REPLACE IT WITH
C  THE ID NO. ON THE TERMINATOR CARD IF PRESENT
      IF (IDNO.EQ.0) IDNO=IL

C--TEST ALL PHASE CARDS FOR CLOSE TIME AGREEMENT TO:
C  1) THE TIME ON THE HEADER CARD IF IT'S USED FOR THE TRIAL, OR
C  2) THE TIME ON THE FIRST PHASE CARD IF IT'S USED FOR THE TRIAL.

C  DONT RESET A REFERENCE DATE & TIME IF WE GOT IT AS A TRIAL FROM HEADER
      IF (K.EQ.1 .AND. IH71T.NE.3) THEN
        KYEAR=LYEAR
        KYEAR2=LYEAR2
        KMONTH=LMONTH
        KDAY=LDAY
        KHOUR=LHOUR
        KMIN=LMIN
        DAYFIRST=DAYJL(KYEAR2,KMONTH,KDAY)
        DT=0.
      END IF

C--SIMPLE TEST NOT ALLOWING EVENT TO SPAN A MONTH BOUNDARY
C        IF (LYEAR2-KYEAR2 +LMONTH-KMONTH .NE. 0 .OR.
C     2  ABS(((LDAY-KDAY)*24 +LHOUR-KHOUR)*60+LMIN-KMIN).GT.6) THEN

C--COMPLEX TEST ALLOWING EVENT TO SPAN A CENTURY BOUNDARY
C  DT IS THE NUMBER OF MINUTES THE PRESENT PHASE IS BEHIND THE TRIAL OT
      DT=((DAYJL(LYEAR2,LMONTH,LDAY) -DAYFIRST)*24. 
     2 +LHOUR-KHOUR)*60.+LMIN-KMIN

      IF (DABS(DT).GT. 6.D0) THEN
        IF (LPRT) WRITE (15,1003) STRI(1:NSTR)
        IF (LERR) WRITE (6,1003) STRI(1:NSTR)
1003    FORMAT (' *** SKIP OVER PHASE CARD WITH WRONG TIME:'/1X,A)
        IRES=-13
C--SKIP EXPECTED SHADOW CARD
        IF (LSHAD) READ (14,*,END=80)
        GOTO 15
      END IF

C--OPTIONALLY SAVE THE NEXT LINE AS SHADOW PHASE DATA
      IF (LSHAD) THEN
        CALL READQ (14,SHASTR,LENIN,IOS)
        IF (IOS.GT.0) GOTO 80
        KSHAD(K)=SHASTR
        KDEV(K)=SHASTR(93:95)
        KLSHA(K)=LENIN
      ELSE
        KDEV(K)='   '
      END IF

      IF (KLSHA(K).GT.104) THEN
        WRITE (6,1015) STRI(1:NSTR)
        IF (LPRT) WRITE (15,1015) STRI(1:NSTR)
1015    FORMAT(' *** THE SHADOW RECORD FOLLOWING THIS PHASE CARD',
     2  ' IS TOO LONG:'/1X,A)
        IRES=-101
        STOP
      END IF

C--READ THE P AMPLITUDE INFO FROM THE SHADOW CARD
C      IF (LSHAD .AND. LPMAG) THEN
C        KPAMP(K)=0 
C        READ (KSHAD(K),1055,END=80,ERR=17) RTPFL
C1055    FORMAT (41X,A2)
C
C--ONLY READ AND USE THE P AMPLITUDE IF THIS IS AN RTP STATION
C        IF (RTPFL .NE. 'PH') GOTO 18 
C        READ (KSHAD(K),1056,END=80,ERR=17) PARMK(K),KPAWT(K),KPAMP(K)
C1056    FORMAT (43X,A1,I1,I5)
C--THE WEIGHT CODE KPAWT IS THE NUMBER OF CLIPPED PEAKS IN THE FIRST 3: 0-3
C      END IF

      GOTO 18
C--ERROR ON READ OF SHADOW CARD
17    WRITE (6,1057) KLSHA(K)
      IF (LPRT) WRITE (15,1057) KLSHA(K)
1057  FORMAT (' *** BAD FORMAT SHADOW CARD:'/1X,A)
      IRES=-19

C--DERIVE THE AUXILIARY REMARKS FROM CERTAIN EVENT REMARKS
18    IF (LPHFMT) THEN
        DO I=1,NRMK
          IF (KRMK6(K)(1:NLET(I)) .EQ. RMKS(I)(1:NLET(I))) THEN
            IF (RMK1.EQ.' ') THEN
              RMK1=RMKA(I)
            END IF
            GOTO 24
          END IF
        END DO
      END IF

C--KEEP TRACK OF THE CURRENT STATION FOR NEXT PASS THRU LOOP
24    LASTA=STA

C--TEST TO SEE IF THE STATION IS ON THE LOOK-UP LIST. GOTO 35 IF MATCH IS
C  COMPLETE.
      DO J=1,JSTA
        IF (SLOC.EQ.'  ' .OR. SLOC.EQ.'--') THEN
          LLOC2= SLOC .EQ. JSLOC2(J)
        END IF
        IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2  SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3  COMP3(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP) .AND.
     4  (SLOC(1:NSLOC) .EQ. JSLOC(J)(1:NSLOC) .OR.
     5  SLOC(1:NSLOC) .EQ. JSLOC2(J)(1:NSLOC)) ) GOTO 35
      END DO

C--PRINT AN ERROR MESSAGE IF STATION NOT ON EXPECTED UNKNOWN LIST
      DO I=1,NLUNK
        IF (LUNK(I)(1:NSTLET) .EQ. STA(1:NSTLET)) GOTO 32
      END DO
      IF (LPRT) WRITE (15,1004) STRI(1:NSTR)
      IF (LERR) WRITE (6,1004) STRI(1:NSTR)
1004  FORMAT (' *** SKIP PHASE CARD WITH UNKNOWN STATION:'/1X,A)
      IRES=-15

C--FOR THE PHASE & ARCHIVE FORMATS, SAVE THE UNKNOWN STATION FOR OUTPUT TO
C  THE ARCHIVE FILE.
32    IF (JCP.EQ.2 .OR. .NOT.LARC .OR. .NOT.LKEEP) GOTO 15

C--IGNORE ANY UNKNOWN STAS BEYOND THE MAXIMUM, BUT COMPLAIN
      IF (NUNK.GE.MAXUNK) THEN
        WRITE (6,1023) MAXUNK,STRI(1:NSTR)
        IF (LPRT) WRITE (15,1023) MAXUNK,STRI(1:NSTR)
1023    FORMAT (' *** MORE THAN',I3,' UNKNOWN STATIONS IN THIS EVENT. ',
     2  'SKIP THIS ONE:'/1X,A)
        IRES=-16
        GOTO 15
      END IF

C--MOVE FIELDS TO THE RIGHT PLACE & BLANK OTHERS IF THIS IS A PHASE CARD
      IF (LPHFMT) THEN
C--FULL FORMAT PHASE CARD. MOVE DATA TO ARCHIVE POSITION.
C--THIS TRANSLATION CODE IS ALSO THE BASIS FOR A TRANSLATION PROGRAM
          IF (L2000) THEN
C--PHASE INPUT TO Y2000 ARCHIVE FORMAT
            STR=' '
            STR(1:4)=STRI(1:4)		!SITE CODE
            STR(5:5)=STRI(78:78)	!SITE CODE
            STR(6:7)=STRI(82:83)	!NET CODE
            STR(10:12)=STRI(79:81)	!COMP CODE
            STR(14:17)=STRI(5:8)	!P RMK
            STR(18:19)='19'		!CENTURY
            STR(20:34)=STRI(10:24)	!DATE, P TIME
            STR(42:50)=STRI(32:40)	!S TIME, S RMK
            STR(57:59)=STRI(45:47)	!AMP
            STR(60:63)='00 0'		!AMP & UNITS CODE
            STR(82:82)=STRI(51:51)	!AMP MAG WEIGHT CODE
            STR(83:83)=STRI(76:76)	!DUR MAG WEIGHT CODE
            STR(84:86)=STRI(48:50)	!PERIOD OF MAX AMP
            STR(87:91)=STRI(71:75)	!STA RMK, CODA DUR
            STR(109:109)=STRI(41:41)	!DATA SOURCE CODE
            STR(112:113)=STRI(84:85)	!STATION LOCATION CODE
            NSTR=113

          ELSE
C--PHASE INPUT TO OLD ARCHIVE FORMAT OUTPUT
            STR(1:9)=STRI(1:9)		!SITE CODE, P RMK
            STR(10:24)=STRI(10:24)	!DATE, P TIME
            STR(32:40)=STRI(32:40)	!S TIME, S RMK
            STR(45:47)=STRI(45:47)	!AMP
            STR(71:75)=STRI(71:75)	!STA RMK, CODA DUR
            STR(95:100)=STRI(78:83)	!NET & COMP CODES
            STR(91:91)=STRI(25:25)	!P/S WEIGHT OUT CODE
            STR(92:92)=STRI(41:41)	!DATA SOURCE CODE
            STR(68:70)=STRI(48:50)	!PERIOD OF MAX AMP
            STR(67:67)=STRI(76:76)	!DUR MAG WEIGHT CODE
            STR(66:66)=STRI(77:77)	!AMP MAG WEIGHT CODE
            STR(101:102)=STRI(84:85)	!STATION LOCATION CODE
            NSTR=102
          END IF
C--LOAD REFORMATTED DATA BACK INTO STRI
          STRI=STR
      END IF

C--SAVE THE PHASE & SHADOW RECORDS
      NUNK=NUNK+1
      PUNK(NUNK)=STRI
      IF (LSHAD) THEN
        SUNK(NUNK)=KSHAD(K)
        NSUNK(NUNK)=KLSHA(K)
      END IF
      GOTO 15

C--SET REFERENCE INDEX FOR THIS STATION & ENCODE DATA
35    KINDX(K)=J
      IF (JCP.EQ.2) GOTO 50

C--CORRECT ARRIVAL TIMES TO SAME MINUTE
      LSHIF=NINT(DT*60.)
C--STORE TIMES IN .01 SEC, ROUNDED TO NEAREST INTEGER
      KP(K)=NINT(100.*(P+LSHIF+CCOR))
      KS(K)=NINT(100.*(S+LSHIF+CCOR))

C--STORE P & S WEIGHTS
      KWT(K)=10*LSWT+LPWT
50    CONTINUE

C-------------- TERMINATOR CARD PROCESSING ------------------------
C--TREATMENT OF EXCESS PHASE CARDS IN EVENT
      KSTA=MAXPHS
      IF (LPRT) WRITE (15,1005) STRI(1:NSTR)
      IF (LERR) WRITE (6,1005) STRI(1:NSTR)
1005  FORMAT (' *** TOO MANY STATIONS. COPY REST TO OUTPUT FILES.',
     2 ' LAST STATION FOR THIS EVENT IS:'/1X,A)
      IRES=-17
C--ZERO THE TRIAL COORDINATES AS IF A BLANK CARD WAS READ
      T1=0.
      Z1=0.
      CLON=0.
      CLAT=0.
      IDNO=0
      IL=0
C--SET FLAG SO REST CAN BE COPIED WHEN WE RETURN TO HYPHS. NOTE THAT COPYING
C  OF TERMINATOR TO ARCHIVE PRESEVES TRIAL HYPO & ID NO., BUT DOES NOT USE IT
C  IN CURRENT LOCATION RUN.
      LTBIG=.TRUE.
      RETURN

C--OPTIONALLY STORE THE SHADOW RECORD AFTER THE TERMINATOR
60    IF (LSHAD) THEN
        CALL READQ (14,SHADO,LENSHA,IOS)
        IF (IOS.GT.0) GOTO 80
        IF (LENSHA .GT. 100) THEN
          WRITE (6,1016) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
          IF (LPRT) WRITE (15,1016) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1016      FORMAT (' *** SHADOW RECORD FOLLOWING ',I4,4I3,
     2    ' TERMINATOR IS TOO LONG')
          IRES=-101
          STOP
        END IF
      END IF

C--COME HERE FOR NORMAL EVENT TERMINATION WITH AN INSTRUCTION (TERMINATOR) CARD
      KSTA=K-1
C--SKIP AN EVENT WITH FEWER THAN 3 PHASE CARDS
      IF (KSTA.LT.3) THEN
        IF (LPRT) WRITE (15,1006) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
        IF (LERR) WRITE (6,1006) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1006    FORMAT (' *** SKIP EVENT WITH LESS THAN 3 PHASE CARDS:',I4,4I3)
        IRES=-52
        GOTO 8
      END IF

C--GET TRIAL DATA (IF ANY) FROM TERMINATOR CARD
      IF (IH71T.EQ.2) THEN
        FIXCHR=' '
C--CHOOSE HYPO71 INSTRUCTION (TERMINATOR) FORMAT
        READ (STRI,1011,ERR=84) NSTR,Z1, IL
1011    FORMAT (18X,I1,F5.2, T63,I10)
        IF (NSTR.EQ.1) THEN
          DEPFIX=.TRUE.
          FIXCHR='-'
        END IF
        CLAT=0.
        CLON=0.
        T1=0.
      ELSE IF (IH71T.EQ.1) THEN

C--CHOOSE HYPOINVERSE TERMINATOR FORMAT
C--THE FIRST PART OF THE LINE IS IN OLD HI SUMMARY FORMAT, EXCEPT
C  THE DATE IS IGNORED AND THE ID NO IS I10 STARTING IN COL 63.

        READ (STRI,1007,ERR=84) MHOUR,MINIT,T, LAT,IS,
     2  XLTM,LON,IE,XLNM, Z1,FIXCHR,IL
1007    FORMAT (6X,2I2,F4.2, I2,A1,
     2  F4.2,I3,A1,F4.2, F5.2,A1,T63,I10)

C--LOAD LAT & LON
        CLAT=LAT+XLTM/60.
        CLON=LON+XLNM/60.
        IF (IS.EQ.'S') CLAT=-CLAT
        IF (IE.EQ.'E') CLON=-CLON

C--ANNOUNCE THAT A TRIAL HYPOCENTER WAS GIVEN
        IF (CLAT.NE.0. .AND. CLON.NE.0. .AND. LPRT) 
     2  WRITE (15,1076) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1076    FORMAT (' USE SUPPLIED TRIAL HYPOCENTER FOR EVENT: ',I4,4I3)

C--OPTIONALLY FIX THE HYPOCENTER FOR THIS EVENT
        DEPFIX=FIXCHR.EQ.'-' .OR. FIXCHR.EQ.'X' .OR. FIXCHR.EQ.'O'
     2   .OR. DEPFIXA
        HYPOFIX=FIXCHR.EQ.'X' .OR. FIXCHR.EQ.'O'
        ALLFIX=FIXCHR.EQ.'O'

C--DONT FIX HYPOCENTER IF WE WERNT GIVEN A LOCATION 
        IF (HYPOFIX .AND. (CLAT.EQ.0. .OR. CLON.EQ.0.)) THEN
          IF (LPRT) WRITE (15,1078) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
          IF (LERR) WRITE (6,1078) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1078      FORMAT (' *** CANT FIX HYPOCENTER BECAUSE WE WERNT GIVEN',
     2'   A LOCATION: ',I4,4I3)
          IRES=-12
          HYPOFIX=.FALSE.
        END IF

C--DONT FIX ORIGIN IF WE WERNT GIVEN AN ORIGIN TIME 
        IF (ALLFIX .AND. (MHOUR.EQ.0 .AND. MINIT.EQ.0 .AND. 
     2  T.EQ.0.)) THEN
          IF (LPRT) WRITE (15,1079) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
          IF (LERR) WRITE (6,1079) KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1079      FORMAT (' *** CANT FIX ORIGIN BECAUSE WE WERNT GIVEN',
     2'   AN ORIGIN TIME: ',I4,4I3)
          IRES=-12
          HYPOFIX=.FALSE.
          ALLFIX=.FALSE.
        END IF

C--ALLOW FOR FIXING DEPTH OR O.T. TO ZERO, 
C  ZERO (OR BLANK) IS NORMALLY TREATED AS "NOT SUPPLIED"
	IF ((HYPOFIX .OR. ALLFIX) .AND. Z1.EQ.0.) Z1=0.001
	IF (ALLFIX .AND. T.EQ.0.) T=0.001

C--DONT INTERPRET AN OLD STYLE INSTRUCTION PARAMETER IN COLS 18-19
C  AS A TRIAL LATITUDE.
        IF (ABS(CLAT).LT..4 .AND. CLON.EQ.0.) CLAT=0.
        TEMP=MHOUR+MINIT+T
        IF (TEMP.EQ.0.) THEN
          T1=0.
        ELSE
          T1=T+((MHOUR-KHOUR)*60+MINIT-KMIN)*60
        END IF

C-- IF IH71T.EQ.3, WE GOT A TRIAL HYPO & ID FROM THE HEADER
      END IF

C--SAVE THE TERMINATOR CARD TO OUTPUT IT INTACT
      TERM=STRI

C--USE EVENT ID NUMBER IF ON TERMINATOR CARD
      IF (IL.NE.0) IDNO=IL
74    RETURN

C--COME HERE IF AN END OF FILE WAS JUST READ
80    KSTA=K-1
      KEND=1
      IF (KSTA.LT.2) KEND=-1
      RETURN

C--COME HERE FOR AN ERROR READING THE TERMINATOR CARD
84    IF (LERR) WRITE (6,1017) STRI(1:NSTR)
      IF (LPRT) WRITE (15,1017) STRI(1:NSTR)
1017  FORMAT (' *** BAD TERMINATOR LINE:'/1X,A)
      IRES=-18
      CLAT=0.
      CLON=0.
      T1=0.
      Z1=0.
      IL=0
      HYPOFIX=.FALSE.
      RETURN
      END
      SUBROUTINE HYPREF
C--SELECTS THE PREFERRED MAGNITUDE AMONG THOSE CALCULATED
      INCLUDE 'common.inc'

C--ZERO NUMBERS IN CASE NO MAG IS SELECTED, SET PMAG TO DEFAULT VALUE
      PMAG=VNOMAG
      NPMAG=0
      LABPR=' '
      PMMAD=0.

C--GO THROUGH PREFERENCE ORDER UNTIL ONE IS FOUND
      DO I=1,NMAGS

        IF (MPREF(I).EQ.1) THEN
C--CHECK FMAG
          IF (FMAG.GT.VNOMAG .AND. NFMAG.GE.MNPREF(I) .AND.
     2    FMAG.GE.AMPREF(I) .AND. FMAG.LE.AXPREF(I)) THEN
            PMAG=FMAG
            NPMAG=NFMAG
            LABPR=LABF1
            PMMAD=FMMAD
            RETURN
          END IF

        ELSE IF (MPREF(I).EQ.2) THEN
C--CHECK XMAG
          IF (XMAG.GT.VNOMAG .AND. NXMAG.GE.MNPREF(I) .AND.
     2    XMAG.GE.AMPREF(I) .AND. XMAG.LE.AXPREF(I)) THEN
            PMAG=XMAG
            NPMAG=NXMAG
            LABPR=LABX1
            PMMAD=XMMAD
            RETURN
          END IF

        ELSE IF (MPREF(I).EQ.3) THEN
C--CHECK EXTERNAL BMAG
          IF (BMAG.GT.VNOMAG .AND. NBMAG.GE.MNPREF(I) .AND.
     2    BMAG.GE.AMPREF(I) .AND. BMAG.LE.AXPREF(I)) THEN
            PMAG=BMAG
            NPMAG=NBMAG
            LABPR=BMTYP
            PMMAD=0.
            RETURN
          END IF

        ELSE IF (MPREF(I).EQ.4) THEN
C--CHECK XMAG2
          IF (XMAG2.GT.VNOMAG .AND. NXMAG2.GE.MNPREF(I) .AND.
     2    XMAG2.GE.AMPREF(I) .AND. XMAG2.LE.AXPREF(I)) THEN
            PMAG=XMAG2
            NPMAG=NXMAG2
            LABPR=LABX2
            PMMAD=XMMAD2
            RETURN
          END IF

        ELSE IF (MPREF(I).EQ.5) THEN
C--CHECK FMAG
          IF (FMAG2.GT.VNOMAG .AND. NFMAG2.GE.MNPREF(I) .AND.
     2    FMAG2.GE.AMPREF(I) .AND. FMAG2.LE.AXPREF(I)) THEN
            PMAG=FMAG2
            NPMAG=NFMAG2
            LABPR=LABF2
            PMMAD=FMMAD2
            RETURN
          END IF

C        ELSE IF (MPREF(I).EQ.6) THEN
C--CHECK PRIMARY P AMP MAG
C          IF (PAMAG.GT.0. .AND. NINT(PMUSED).GE.MNPREF(I) .AND.
C     2    PAMAG.GE.AMPREF(I) .AND. PAMAG.LE.AXPREF(I)) THEN
C            PMAG=PAMAG
C            NPMAG=PMUSED
C            LABPR=LABP1
C            PMMAD=PAMAD
C            RETURN
C          END IF

C        ELSE IF (MPREF(I).EQ.7) THEN
C--CHECK SECONDARY P AMP MAG
C          IF (PAMAG2.GT.0. .AND. NINT(PMUSD2).GE.MNPREF(I) .AND.
C     2    PAMAG2.GE.AMPREF(I) .AND. PAMAG2.LE.AXPREF(I)) THEN
C            PMAG=PAMAG2
C            NPMAG=PMUSD2
C            LABPR=LABP2
C            PMMAD=PAMAD2
C            RETURN
C          END IF

        END IF
      END DO
      RETURN
      END
      SUBROUTINE HYPRO
C--INTERACTIVELY PROCESS EVENTS IN INDIVIDUAL FILES.
      LOGICAL LR,KILLS, LTEMP, LKILL
      CHARACTER BASE*20,C13*15,CP*1,CC*1,CS*1,SCD*1,TRY(20)*103
      CHARACTER STA*5, SNET*2, SCOMP*3, SLOC*2
      CHARACTER PRVSTA*5, PRVNET*2, PRVCMP*3, PRVLOC*2
      INCLUDE 'common.inc'
      LOGICAL FOUNDIT
C--LASK IS A LOGICAL FUNCTION. THE OS2 COMPILER COMPLAINS WITHOUT THESE LINES
c      LOGICAL LASK
c      EXTERNAL LASK

      BASE=' '
      ISEQ=0

C--BLANK OUT STATION CODES
      STA=' '
      SNET=' '
      SCOMP=' '
      SLOC=' '
      PRVSTA=' '
      PRVNET=' '
      PRVCMP=' '
      PRVLOC=' '

C--IF ALL SUBSEQUENT STATIONS ARE WEIGHTED OUT USING !, KLAST REMEMBERS LAST
C  STATION KEPT
      KLAST=0

C--OPEN THE EVENT ID FILE WHICH LISTS BASE FILENAMES TO BE PROCESSED.
      CALL OPENR (17,LSTFIL,'F',IOS)
      IF (IOS.NE.0) GOTO 32

C****************** BEGIN EVENT LOOP **********************************
C--READ THE BASE ID STRING FROM THE EVENT LIST FILE
2     READ (17,LSTFOR,ERR=31,END=70) BASE(1:NCBASE)
C--IGNORE BLANK LINES OR ONES COMMENTED OUT WITH * IN COL 1
      IF (BASE.EQ.'                    ' .OR. BASE(1:1).EQ.'*') GOTO 2
C--TURN ANY BLANKS IN THE FILENAME TO ZEROS
      DO I=1,NCBASE
        IF (BASE(I:I).EQ.' ') BASE(I:I)='0'
      END DO

C--FORM THE I/O FILENAMES FROM THE BASE STRING
      PHSFIL=' '
      ARCFIL=' '
      SUMFIL=' '
      PRTFIL=' '
      PHSFIL=(BASE(1:NCBASE)//EXTPHS)
      ARCFIL=(BASE(1:NCBASE)//EXTARC)
      SUMFIL=(BASE(1:NCBASE)//EXTSUM)
      PRTFIL=(BASE(1:NCBASE)//EXTPRT)

C--INITIALIZE SOME VARIABLES. DONT CALL HYOPEN OR HYSTL.
      ISEQ=ISEQ+1
      CALL HYINIT
      GOTO 38

C--ERROR READING EVENT ID
31    WRITE (6,*)' *** ERROR - BAD EVENT ID OR FORMAT NEAR: '
      WRITE (6,*) BASE(1:NCBASE)
      GOTO 2

C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT EVENT LIST FILES
32    WRITE (6,*)' *** ERROR - EVENT LIST FILE DOES NOT EXIST ***'
      RETURN

C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT PHASE FILES
33    WRITE (6,1010) PHSFIL
1010      FORMAT (' *** ERROR - PHASE FILE DOES NOT EXIST:'/1X,A)
      GOTO 2

C--ERROR MESSAGE FOR NON-EXISTENT PRINT FILES
34    WRITE (6,1003) PRTFIL
1003      FORMAT (' *** ERROR - PRINT FILE DOES NOT EXIST:'/1X,A)
      GOTO 42

C********************** BEGIN EVENT PROCESSING LOOP *******************
C--OPEN PHASE FILE & READ IT
38    KEND=0
      IF (JCP.LT.6) THEN
        CALL OPENR (14,PHSFIL,'F',IOS)
        IF (IOS.NE.0) GOTO 33
      ELSE
        WRITE (6,'('' *** CANNOT PROCESS CUSP EVENTS INTERACTIVELY'')')
        RETURN
      END IF

C--GO READ THE EVENT
      CALL HYPHS
C--CLOSE FILE UNLESS IT IS A LARGE EVENT AND MORE PHASES REMAIN
      IF (.NOT.LTBIG) CLOSE (14)

C--INITIALIZE SOME VALUES
      INUM=0

C--KEND IS SET BY HYPHS DEPENDING ON END-OF-FILE STATUS
C  =-1  END OF FILE, STOP RIGHT AWAY
C  = 0  LOCATE THIS EVENT, THEN READ ANOTHER
C  = 1  END OF FILE, LOCATE THIS EVENT THEN STOP
      IF (KEND.LT.0) THEN
        WRITE (6,1004) BASE(1:NCBASE)
1004    FORMAT (' *** CANNOT FIND DATA FOR ',A)
        GOTO 2
      END IF

C--SET THE TRIAL HYPOCENTER
C--RETURN HERE IF ONLY THE WEIGHTS WERE CHANGED IN THE PRINT FILE
42    CALL HYTRL

C--OPEN OUTPUT FILES
      IF (LSUM) CALL OPENW (12,SUMFIL,'F',IOS,'S')
      IF (LARC) CALL OPENW (7,ARCFIL,'F',IOS,'S')
      IF (LPRT) CALL OPENW (15,PRTFIL,'F',IOS,'S')

C--WRITE HEADER
      IF (LPRT) WRITE (15,1005) ISEQ,INUM,IDNO
1005  FORMAT (I6,'=SEQUENCE',I4,'=TRY',I10,'=ID')
C--LOCATE THE EVENT
      CALL HYLOC

C--ASSIGN A 3-LETTER CODE AND NAME BASED ON LOCATION
C  I IS THE REGION NUMBER, PRESENTLY UNUSED
      IF (NET.GT.0) I=KLAS (NET,CLAT,-CLON,Z1,REMK,FULNAM)

C--CALCULATE THE EARTHQUAKE'S MAGNITUDE
      CALL HYMAG

C--CALCULATE THE EARTHQUAKE'S P AMPLITUDE MAGNITUDE
      CALL HYMAGP

C--SELECT PREFERRED MAGNITUDE
      CALL HYPREF

C--TABULATE DATA SOURCE CODES
      CALL HYSOU

C--WRITE PAST LOCATION TRIES, IF ANY
      IF (INUM.GT.1 .AND. LPRT) THEN
        WRITE (15,1000)
        DO I=1,INUM-1
          WRITE (15,'(A)') TRY(I)
        END DO
      END IF

C--GENERATE PRINTED AND ARCHIVE OUTPUT
      CALL HYLST

C--ABORT THE LOOP IF THERE ARE NOT ENOUGH READINGS
      IF (NWR.LT.MINSTA) THEN
        WRITE (6,1002) NWR,KYEAR2,KMONTH,KDAY,KHOUR,KMIN
        IF (LPRT) WRITE (15,1002) NWR,KYEAR2,KMONTH,KDAY,KHOUR,KMIN
1002    FORMAT (' *** ABANDON EVENT WITH ONLY',I2,' READINGS:',I4,4I3)
        GOTO 2
      END IF

C--OUTPUT SUMMARY DATA USING UNIT NUMBER FOR SUMMARY FILE
      IF (LSUM) CALL HYSUM (12)

C--COPY THE REST OF A LARGE EVENT TO OUTPUT FILES
      IF (LTBIG) THEN
        CALL HYPHS
        CLOSE (14)
      END IF

C--RECORD THIS LOCATION TRY
      IT=NINT(XLTM)
      IN=NINT(XLNM)
      IDMIN=NINT(DMIN)
      WRITE (TRY(INUM),1011) ISEQ,INUM,KYEAR2,KMONTH,KDAY,
     2 KHOUR,KMIN,REMK, RMK1,RMK2, LAT,IT,LON,IN,
     3 Z1,RMS,PMAG,LABPR,NWR, ERH,ERZ,IDMIN,IDNO

1011  FORMAT (1X,I4,I3,I5,'/',I2,'/',I2,
     2 I3,':',I2.2, 1X,A3, 2A1, 1X,2I3,I5,I3, 
     3 F7.2,F5.2,F5.1,A1,I3, 2F5.1,I5,I10)

C--OUTPUT A MESSAGE ON THE CONSOLE FOR EACH EVENT SO FAR
      IF (LREP) THEN
        WRITE (6,1000)
1000    FORMAT ('  SEQ TRY ---DATE--  TIME REMARK -LAT-  --LON-  ',
     2 'DEPTH  RMS PMAG NUM  ERH  ERZ DMIN')
        DO I=1,INUM
          WRITE (6,'(A)') TRY(I)
        END DO
      END IF

C--CLOSE FILES
      CLOSE (12)
      CLOSE (7)
      CLOSE (15)

C--NOW GO EDIT THE PRINT FILE TO LOOK AT THE EVENT
      IF (LPRT) THEN
C--IF THE EDITOR AUTOMATICALLY ERASES THE SCREEN, IT MAY BE GOOD TO HAVE A
C  DELAY OR PAUSE HERE, LIKE THIS:
C        WRITE (6,*)' PRESS RETURN TO CONTINUE'
C        READ (5,*)
        CALL HYEDIT (IEDFLG,PRTFIL)
      END IF

C--DECIDE WHETHER TO RELOCATE, ISSUE A COMMAND OR CONTINUE TO NEXT EVENT
48    INST=' '
      KILLS=.FALSE.
      WRITE(6,*)' T=RELOCATE, RETURN=CONTINUE, KS=KILL S & RELOCATE,'
      CALL ASKC(
     2 'KA=KILL P&S & CONTINUE, ZXZ=DELETE, ELSE SYSTEM COMMAND',INST)
      IF (INST.EQ.' ') GOTO 2

C--DELETE ENTIRE EVENT
      IF (INST.EQ.'ZXZ ' .OR. INST.EQ.'zxz ') THEN
        LX=LENG(EXTPHS)
        CALL HYDELT (BASE,NCBASE, EXTPHS,LX)
        LX=LENG(EXTARC)
        CALL HYDELT (BASE,NCBASE, EXTARC,LX)
        LX=LENG(EXTPRT)
        CALL HYDELT (BASE,NCBASE, EXTPRT,LX)
        LX=LENG(EXTSUM)
        CALL HYDELT (BASE,NCBASE, EXTSUM,LX)
        GOTO 48
      END IF

C--KILL (UPWEIGHT) ALL P & S
      IF (INST.EQ.'KA  ' .OR. INST.EQ.'ka  ') THEN
C--UPWEIGHT P&S WEIGHTS. DATA SHOULD STILL BE IN MEMORY
        DO K=1,KSTA
          KWT(K)=99
        END DO

C--OPEN ARC FILE, BUT OMIT PRINT FILE
        IF (LARC) CALL OPENW (7,ARCFIL,'F',IOS,'S')
        LTEMP=LPRT
        LPRT=.FALSE.
        CALL HYLST
        LPRT=LTEMP
C--CLOSE FILE & GO TO NEXT EVENT
        CLOSE (7)
        GOTO 2
      END IF

C--ISSUE A COMMAND
      IF (INST.NE.'T    ' .AND. INST.NE.'t    ' .AND.
     2  INST.NE.'KS  ' .AND. INST.NE.'ks  ') THEN
        CALL SPAWN (INST)
        GOTO 48
      END IF

C--SET FLAG TO KILL S WEIGHTS AFTER REREADING EVENT
      KILLS= INST.EQ.'KS  ' .OR. INST.EQ.'ks  '

C--RELOCATE THE EVENT
C--DECIDE WHETHER TO EDIT PHASE FILE TO MAKE MORE CHANGES THAN JUST WEIGHTING
      LR=LASK('EDIT THE INPUT PHASE FILE',.FALSE.)
      IF (LR)  CALL HYEDIT (IEDFLG,PHSFIL)

C--READ THE PHASE FILE EVEN IF IT WAS NOT CHANGED TO RESET TRIAL HYPO, ETC.
      KEND=0
      CALL OPENR (14,PHSFIL,'F',IOS)
      CALL HYPHS
      CLOSE (14)
      IF (KEND.LT.0) THEN
        WRITE (6,1004) BASE(1:NCBASE)
        GOTO 2
      END IF

C--UPWEIGHT (KILL) ALL S READINGS
      IF (KILLS) THEN
        DO K=1,KSTA
          IF (KSRK(K).NE.'  ') THEN
            LSWT=KWT(K)/10
            LPWT=KWT(K)-10*LSWT
            IF (LSWT.LT.5) LSWT=LSWT+5
            KWT(K)=LPWT+10*LSWT
          END IF
        END DO
      END IF

C--READ THE PRINT FILE TO SEE IF ANY WEIGHTS WERE CHANGED. THESE CHANGES WILL
C  OVERRIDE ANY MADE IN THE PHASE FILE. USE THE PHASE UNIT NUMBER.
      IF (LPRT) THEN
        CALL OPENR (14,PRTFIL,'F',IOS)
        IF (IOS.NE.0) GOTO 34

C--SEARCH THE PRINT FILE FOR THE BEGINNING OF THE STATION LIST
51      READ (14,'(A15)',END=59) C13
        IF (C13.NE.' STA NET COM L ') GOTO 51

C--SEARCH FOR STATIONS WITH NEW WEIGHTS IN COLS 1 & 6. NEW WEIGHT CODES:
C  BLANK: NO CHANGE
C  0-9  : NEW WEIGHT CODE
C  "-"  : ADD 5 TO WEIGHT CODE (WEIGHT OUT)
C  "+"  : SUBTRACT 5 FROM WEIGHT CODE (RESTORE)
C  "!"  : WEIGHT OUT THIS AND ALL FOLLOWING P & S READINGS
C
C  COL  1: P WEIGHT CODE
C  COL  9: CODA WEIGHT CODE
C  COL 13: S WEIGHT CODE

C--LKILL SIGNALS WHETHER ALL SUBSEQUENT STATIONS ARE TO BE WEIGHTED OUT
        LKILL=.FALSE.

C--READ AND MATCH THE SOURCE CODE FROM PRINT COL 75 (FWK CHANGE V. 1.38)
53      READ (14,'(A15,T75,A1)',END=59) C13,SCD
        CP=C13(1:1)
        CC=C13(9:9)
        CS=C13(13:13)
        STA=C13(2:6)
        SNET=C13(7:8)
        SCOMP=C13(10:12)
        SLOC=C13(14:15)

C--IF STATION CODE WAS LEFT OUT, GET IT FROM PREVIOUS LINE (PRVSTA
C  SHOULD NEVER BE BLANK WHEN STA IS BLANK)
        IF (STA.EQ.'     ') THEN
          STA=PRVSTA
          SNET=PRVNET
          SCOMP=PRVCMP
          SLOC=PRVLOC
        END IF
        PRVSTA=STA
        PRVNET=SNET
        PRVCMP=SCOMP
        PRVLOC=SLOC
        FOUNDIT=.FALSE.

C--WEIGHT OUT THIS AND ALL SUBSEQUENT STATIONS
        IF (CP.EQ.'!') LKILL=.TRUE.

        IF (CP.EQ.' ' .AND. CC.EQ.' ' .AND.
     2  (CS.LT.'+' .OR. CS.GT.'9') .AND. .NOT.LKILL) GOTO 53

C--FIND STATION CODE IN STATION TABLE, THEN IN PHASE TABLE
        DO J=1,JSTA
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3    (SLOC(1:NSLOC2) .EQ. JSLOC(J)(1:NSLOC2) .OR.
     3    SLOC(1:NSLOC2) .EQ. JSLOC2(J)(1:NSLOC2)) .AND.
     4    SCOMP(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
            DO K=1,KSTA
C--CONTINUE SEARCHING UNTIL DATA SOURCE CODES ALSO MATCH (IN CASE OF DUP. DATA)
              IF (KINDX(K).EQ.J .AND. SCD.EQ.KSOU(K)) THEN
                KLAST=K

C--GET PREVIOUS WEIGHT CODES
                LSWT=KWT(K)/10
                LPWT=KWT(K)-10*LSWT

C--WEIGHT OUT P & S WITHOUT CHECKING WHATS MARKED FOR THIS STATION
                IF (LKILL) THEN
                  IF (LPWT.LT.5) LPWT=LPWT+5
                  IF (KSRK(K).NE.'  ' .AND. LSWT.LT.5) LSWT=LSWT+5
                  GOTO 55
                END IF

C--DECODE NEW P WEIGHT CODE
                IF (CP.GE.'0' .AND. CP.LE.'9') THEN
                  READ (CP,'(I1)') LPWT
                ELSE IF (CP.EQ.'-') THEN
                  IF (LPWT.LT.5) LPWT=LPWT+5
                ELSE IF (CP.EQ.'+') THEN
                  LPWT=LPWT-5
                  IF (LPWT.LT.0) LPWT=0
                END IF

C--DECODE NEW S WEIGHT CODE
                IF (CS.GE.'0' .AND. CS.LE.'9') THEN
                  READ (CS,'(I1)') LSWT
                ELSE IF (CS.EQ.'-') THEN
                  IF (LSWT.LT.5) LSWT=LSWT+5
                ELSE IF (CS.EQ.'+') THEN
                  LSWT=LSWT-5
                  IF (LSWT.LT.0) LSWT=0
                END IF

C--DECODE NEW CODA WEIGHT CODE
55              IF (CC.GE.'0' .AND. CC.LE.'9') THEN
                  READ (CC,'(I1)') KFWT(K)
                ELSE IF (CC.EQ.'-') THEN
                  IF (KFWT(K).LT.5) KFWT(K)=KFWT(K)+5
                ELSE IF (CC.EQ.'+') THEN
                  KFWT(K)=KFWT(K)-5
                  IF (KFWT(K).LT.0) KFWT(K)=0
                END IF

C--RELOAD NEW P & S WEIGHTS
                KWT(K)=LPWT+10*LSWT
                FOUNDIT=.TRUE.
C--THIS STATION IN THE PHASE LIST IS DONE
C--CONTINUE SEARCHING THE PHASE LIST FOR MORE OCCURRENCES OF THE SAME STATION
C                GOTO 53 !STATEMENT COMMENTED OUT TO CONTINUE SEARCHING PHASES
              END IF
            END DO
            IF (.NOT.FOUNDIT) WRITE (6,1059) STA,SCD
1059        FORMAT (' *** CANNOT CHANGE STATION ',A5,1X,A1,
     2      '. NOT USED IN THIS EVENT') 
            GOTO 53
          END IF
        END DO
        WRITE (6,1060) STA
1060    FORMAT (' *** CANNOT CHANGE STATION ',A5,
     2  ' WAS NEVER IN STATION FILE')
        GOTO 53

59      CLOSE (14)
      END IF

C--NOW GO RELOCATE THE EVENT USING THE DATA IN MEMORY
      GOTO 42

C--END OF EVENT LIST TO BE PROCESSED
70    CLOSE (17)
      RETURN
      END
      SUBROUTINE HYREP
C--CALLED BY HYPOINVERSE TO REPORT THE CURRENT EVENT ON THE CONSOLE
      INCLUDE 'common.inc'

C--PRINT A HEADING EVERY 15TH LINE
      IT=INUM/15
      IT=INUM-15*IT
      IF (IT.EQ.1) WRITE (6,1000)
1000  FORMAT ('  SEQ ---DATE--- TIME REMARK -LAT-  --LON-  DEPTH  RMS',
     2 ' PMAG  NUM  ERH  ERZ  ID')

      IT=NINT(XLTM)
      IN=NINT(XLNM)
      WRITE (6,1011) INUM,KYEAR2,KMONTH,KDAY, KHOUR,KMIN,REMK,
     2 RMK1,RMK2, LAT,IT,LON,IN, Z1,RMS,PMAG,LABPR,NWR, ERH,ERZ,IDNO
1011  FORMAT (I5,I5,'-',I2,'-',I2, I3,':',I2.2, 1X,A3,
     2 2A1, 2I3,I5,I3, F7.2,F5.2,F5.1,A1,I4, 2F5.1,I10)
      RETURN
      END
      SUBROUTINE HYSOL (N,Y,NFREE,LZFIX)
C--USES SVD TO INVERT THE PARTIAL DERIV MATRIX A FOR THE HYPO ADJUSTMENT
C--VECTOR Y. ALSO CALCULATES EIGENVALUES, EIGENVECTORS, COVARIANCE,
C--IMPORTANCE, AND ERROR ELLIPSE.
      LOGICAL WITHU,LZFIX
      INCLUDE 'common.inc'
      DIMENSION Y(4),V3(3,3),TSVD(MMAX)
      WITHU=DONE .AND. (LPRT.OR.LARC)
      DO 2 I=1,4
2     EIGVAL(I)=0.

C--OBTAIN THE SVD OF MATRIX A.
C--THE DATA VECTOR OF TT RESIDUALS R IS INPUT IN THE N+1ST COL OF A.
C--A IS REPLACED BY U AND R IS REPLACED BY UT*R IN SVD.
      CALL HYSVD (A,EIGVAL,V,MMAX,4,M,N,1,WITHU,.TRUE.,TSVD)

C--NFREE IS THE ACTUAL DEGREES OF FREEDOM USED
C--(THE NO. OF EIGENVALUES > EIGTOL)
      NFREE=0
      DO 5 I=1,N
      IF (EIGVAL(I).GT.EIGTOL) NFREE=NFREE+1
5     CONTINUE

C--CALCULATE ADJUSTMENT VECTOR Y AS V*S**-1*(UT*R)
C--MOVE THE HYPOCENTER ONLY IN DIRECTIONS WITH LARGER EIGENVALUE CONTROL
C--DAMP THE MOVES WITH A FACTOR WHOSE INFLUENCE INCREASES FOR SMALL EIGENVALUES
      DO 10 I=1,4
        Y(I)=0.
        IF (I.GT.N) GO TO 10
        DO 8 J=1,NFREE
8       Y(I)=Y(I)+V(I,J)*A(J,N+1)/ (EIGVAL(J)+0.006)
10    CONTINUE

C--DAMP THE ADJUSTMENT VECTOR
C--USE EXTRA DAMPING IF THE SOLUTION IS NOT CONVERGING QUICKLY
      I=ITRLIM*.6
      TEMP=DAMP
      IF (ITR.GT.I) TEMP=.5*DAMP
      DO 11 I=1,4
11    Y(I)=Y(I)*TEMP

C--CALCULATE IMPORTANCE VECTOR AS TRACE OF INFORMATION MATRIX U*UT
      IF (WITHU) THEN
        DO 15 I=1,M
          TEMP=0.
          DO 12 J=1,N
12        TEMP=TEMP+A(I,J)**2
15      IMPORT(I)=TEMP*1000.
      END IF

C--FIND LENGTH OF HYPO ADJ VECTOR IN KM
      RR=0.
      DO 25 I=2,N
25    RR=RR+Y(I)**2
      RR=SQRT(RR)

C--SKIP THE REMAINING CALCS IF THEY ARE NOT NEEDED FOR FINAL OUTPUT
      IF (.NOT.DONE .AND. KPRINT.LT.5) GO TO 110
C--CALCULATE COVARIANCE MATRIX AS SIGMA**2 * V * EIGVAL**-2 * VT
C--ESTIMATED ARRIVAL TIME ERROR
      SIGSQ=RDERR**2+ERCOF*RMS**2
      TEMP=EIGTOL**2
      DO 52 I=1,4
      DO 50 J=1,I
        COVAR(I,J)=0.
        IF (I.GT.N .OR. J.GT.N) THEN
          IF (I.EQ.J) COVAR(I,J)=999.
          GO TO 50
        END IF
        DO 45 L=1,N
45      COVAR(I,J)=COVAR(I,J)+V(I,L)*V(J,L)/(EIGVAL(L)**2+TEMP)
        COVAR(I,J)=SIGSQ*COVAR(I,J)
50    COVAR(J,I)=COVAR(I,J)
52    CONTINUE

C--EVALUATE THE HYPOCENTER ERROR ELLIPSE BY DIAGONALIZING
C--THE SPATIAL PART OF THE COVARIANCE MATRIX
C--USE A AS TEMPORARY STORAGE
      DO 57 I=1,3
        DO 55 J=1,3
55      A(I,J)=COVAR(I+1,J+1)
57    CONTINUE
      CALL HYSVD (A,SERR,V3,MMAX,3,3,3,0,.FALSE.,.TRUE.,TSVD)
      DO 60 I=1,3
        SERR(I)=SQRT(SERR(I))
        IF (SERR(I).GT.99.) SERR(I)=99.
60    CONTINUE

C--COMPUTE ERH AND ERZ AS THE LARGEST OF THE HORIZ AND VERTICAL
C--PROJECTIONS OF THE PRINCIPAL STANDARD ERRORS
      ERH=0.
      ERZ=0.
      DO 65 I=1,3
        TEMP=SERR(I)*SQRT(V3(1,I)**2+V3(2,I)**2)
        IF (TEMP.GT.ERH) ERH=TEMP
        TEMP=SERR(I)*ABS(V3(3,I))
        IF (TEMP.GT.ERZ) ERZ=TEMP
65    CONTINUE
      IF (ERZ.GT.99.) ERZ=99.
      IF (ERH.GT.99.) ERH=99.

C--NOW CALC THE ORIENTATIONS OF THE PRINCIPAL STD ERRORS
      DO 90 J=1,3
        IAZ(J)=0
        IDIP(J)=90
        TEMP=SQRT(V3(1,J)**2+V3(2,J)**2)
        IF (TEMP.EQ.0.) GO TO 90
        IAZ(J)=RDEG*ATAN2(-V3(2,J),V3(1,J))
        IDIP(J)=RDEG*ATAN2(V3(3,J),TEMP)
        IF (IDIP(J).LT.0) THEN
          IDIP(J)=-IDIP(J)
          IAZ(J)=IAZ(J)+180
        END IF
        IF (IAZ(J).LT.0) IAZ(J)=IAZ(J)+360
90    CONTINUE
110   RETURN
      END
      SUBROUTINE HYSOU
C--TABULATES THE MOST COMMON DATA SOURCE CODES FOR HYPOINVERSE PRIOR TO OUTPUT
C--THIS CODE USED TO BE IN HYLST
      INCLUDE 'common.inc'
      DIMENSION NSOU(5),NSOUF(5),NSOUX(5),NSOUF2(5),NSOUX2(5)
      DIMENSION NSOUP(5),NSOUP2(5)
      CHARACTER CH(5)*1,CHF(5)*1,CHX(5)*1,CHF2(5)*1,CHX2(5)*1
      CHARACTER CHP(5)*1,CHP2(5)*1

C--GET THE PRIMARY DATA SOURCES FOR WEIGHTED PHASES, FMAGS, XMAGS
      DO I=1,5
        NSOU(I)=0
        NSOUF(I)=0
        NSOUX(I)=0
        NSOUF2(I)=0
        NSOUX2(I)=0
        NSOUP(I)=0
        NSOUP2(I)=0
      END DO
      XMSOU=' '
      FMSOU=' '
      XMSOU2=' '
      FMSOU2=' '
      PSOUR=' '
      PSOUR2=' '
      SOUCOD=' '

C--CHECK ALL PHASES FOR PRIMARY DATA SOURCE
C--KEEP COUNTS OF 7 DIFFERENT SOURCE CODES
C--P OR S ARRIVAL TIME
      DO 11 IM=1,M
        IF (W(IM).LT..1) GOTO 11
C--DETERMINE STATION INDEX & REMOVE S FLAG
        K=IND(IM)
        KPS=K/10000
        K=K-10000*KPS
        DO I=1,5
          IF (NSOU(I).EQ.0) THEN
            NSOU(I)=1
            CH(I)=KSOU(K)
            GOTO 11
          END IF
          IF (KSOU(K).EQ.CH(I)) THEN
            NSOU(I)=NSOU(I)+1
            GOTO 11
          END IF
        END DO
11    CONTINUE

C--COUNT FMAG AND XMAG SOURCE CODES FROM WEIGHTED READINGS FOR ALL STATIONS
      DO 15 K=1,KSTA
        J=KINDX(K)
C--COUNT FIRST FMAG SOURCE CODES
        IF (KFWT(K).GT.3 .OR. KFMAG(K).EQ.0 .OR. .NOT.JFM1(J)) GOTO 12
        DO I=1,5
          IF (NSOUF(I).EQ.0) THEN
            NSOUF(I)=1
            CHF(I)=KSOU(K)
            GOTO 12
          END IF
          IF (KSOU(K).EQ.CHF(I)) THEN
            NSOUF(I)=NSOUF(I)+1
            GOTO 12
          END IF
        END DO

C--COUNT FIRST XMAG SOURCE CODES 
12      IF (KXWT(K).GT.3 .OR. KXMAG(K).EQ.0 .OR. .NOT.JXM1(J)) GOTO 13
        DO I=1,5
          IF (NSOUX(I).EQ.0) THEN
            NSOUX(I)=1
            CHX(I)=KSOU(K)
            GOTO 13
          END IF
          IF (KSOU(K).EQ.CHX(I)) THEN
            NSOUX(I)=NSOUX(I)+1
            GOTO 13
          END IF
        END DO

C--COUNT SECOND FMAG SOURCE CODES
13      IF (KFWT(K).GT.3 .OR. KFMAG(K).EQ.0 .OR. .NOT.JFM2(J)) GOTO 14
        DO I=1,5
          IF (NSOUF2(I).EQ.0) THEN
            NSOUF2(I)=1
            CHF2(I)=KSOU(K)
            GOTO 14
          END IF
          IF (KSOU(K).EQ.CHF2(I)) THEN
            NSOUF2(I)=NSOUF2(I)+1
            GOTO 14
          END IF
        END DO

C--COUNT SECOND XMAG SOURCE CODES 
14      IF (KXWT(K).GT.3 .OR. KXMAG(K).EQ.0 .OR. .NOT.JXM2(J)) GOTO 15
        DO I=1,5
          IF (NSOUX2(I).EQ.0) THEN
            NSOUX2(I)=1
            CHX2(I)=KSOU(K)
            GOTO 15
          END IF
          IF (KSOU(K).EQ.CHX2(I)) THEN
            NSOUX2(I)=NSOUX2(I)+1
            GOTO 15
          END IF
        END DO
15    CONTINUE

C--COUNT PAMAG SOURCE CODES FROM WEIGHTED READINGS FOR ALL STATIONS
      IF (LPMAG) THEN
      DO 17 K=1,KSTA
        J=KINDX(K)
C--COUNT PRIMARY P AMP MAG SOURCE CODES 
        IF (PAWT(K).LT..1 .OR. KPAMP(K).EQ.0 .OR. .NOT.JPM1(J)) GOTO 16
        DO I=1,5
          IF (NSOUP(I).EQ.0) THEN
            NSOUP(I)=1
            CHP(I)=KSOU(K)
            GOTO 16
          END IF
          IF (KSOU(K).EQ.CHP(I)) THEN
            NSOUP(I)=NSOUP(I)+1
            GOTO 16
          END IF
        END DO

C--COUNT SECONDARY P AMP MAG SOURCE CODES 
16      IF (PAWT(K).LT..1 .OR. KPAMP(K).EQ.0 .OR. .NOT.JPM2(J)) GOTO 17
        DO I=1,5
          IF (NSOUP2(I).EQ.0) THEN
            NSOUP2(I)=1
            CHP2(I)=KSOU(K)
            GOTO 17
          END IF
          IF (KSOU(K).EQ.CHP2(I)) THEN
            NSOUP2(I)=NSOUP2(I)+1
            GOTO 17
          END IF
        END DO

17    CONTINUE
      END IF

C--REPORT THE MOST FREQUENT DATA SOURCE CODES
      K1=0
      K2=0
      KF2=0
      KX2=0
      KP1=0
      KP2=0
      IM=0
      DO I=1,5
        IF (NSOU(I).GT.IM) THEN
          IM=NSOU(I)
          SOUCOD=CH(I)
        END IF

        IF (NSOUF(I).GT.K1) THEN
          K1=NSOUF(I)
          FMSOU=CHF(I)
        END IF

        IF (NSOUX(I).GT.K2) THEN
          K2=NSOUX(I)
          XMSOU=CHX(I)
        END IF

        IF (NSOUF2(I).GT.KF2) THEN
          KF2=NSOUF2(I)
          FMSOU2=CHF2(I)
        END IF

        IF (NSOUX2(I).GT.KX2) THEN
          KX2=NSOUX2(I)
          XMSOU2=CHX2(I)
        END IF

        IF (NSOUP(I).GT.KP1) THEN
          KP1=NSOUP(I)
          PSOUR=CHP(I)
        END IF

        IF (NSOUP2(I).GT.KP2) THEN
          KP2=NSOUP2(I)
          PSOUR2=CHP2(I)
        END IF
      END DO

      RETURN
      END
      SUBROUTINE HYSTA
C--READ IN STATION LIST & COORDINATES FOR HYPOINVERSE
      CHARACTER CXWT*1,CFWT*1,CALT*1,LINE*132,C1*1
      INCLUDE 'common.inc'
      DOUBLE PRECISION TEMPD

C--GIVE THESE A VALUE IN CASE HYPO71 FORMAT IS USED
      PD1=0.
      PD2=0.
      CXWT=' '
      CFWT=' '

C--ZERO THE DELAYS IN CASE WE HAVE OLD VALUES IN MEMORY
      DO 5 I=1,LM
      DO 5 J=1,MAXSTA
5     JPD(I,J)=0

C--LOOP TO READ STATIONS INTO LOOK-UP TABLE
      DO 20 J=1,MAXSTA
      JSTA=J-1

      READ (14,'(A)',END=30,ERR=40) LINE

C--INITIALIZE NAME CODES THAT MAY NOT BE READ
      STANAM(J)='     '
      JNET(J)='   '
      JCOMP3(J)='   '
      JCOMP1(J)=' '
      JCOMPA(J)='   '
      JSLOC(J)='  '
      JSLOC2(J)='  '
cxx
c      write(6,*) istfmt
c      istfmt=1
      IF (ISTFMT.EQ.1) THEN
C--OLD HYPOINVERSE FORMAT
        READ (LINE,1000,ERR=40) STANAM(J)(1:4),CTEMP,JLATD(J),
     2  ALAT,IS, JLOND(J),ALON,IE, JELEV(J),PER,JCOMP1(J),CALT,STRMK(J),
     3  PD1,PD2, XMC,CXWT,FMC,CFWT, JTYPE(J),CAL, JNET(J),JCOMP3(J),
     4  JSLOC(J)

1000   FORMAT (A4,A1,I2,1X,
     2  F5.2,A1, I3,1X,F5.2,A1,I4, F3.1,A1,1X,2A1,
     3  2(F5.2,1X), 2(F5.2,A1), I1,F6.2,A2,1X,A3,
     4  A2)

        JLMOD(J)=CALT.EQ.'2' .OR. CALT.EQ.'A'
      ELSE IF (ISTFMT.EQ.2) THEN

C--HYPO71 FORMAT
        READ (LINE,1001,ERR=40) JCOMP1(J),CTEMP,STANAM(J)(1:4),
     2  JLATD(J),ALAT,IS, JLOND(J),ALON,IE, JELEV(J),
     3  PD1,STRMK(J), FMC,XMC, JTYPE(J),PER,CAL
1001    FORMAT (2A1,A4,
     2  I2,F5.2,A1, I3,F5.2,A1,I5,
     3  F5.2,1X,A1,2X, F5.2,2X,F5.2,1X, I1,1X,F4.2,1X,F6.2)

      ELSE
C--NEW HYPOINVERSE FORMAT
        READ (LINE,1012,ERR=40) STANAM(J),JNET(J),
     4  JCOMP1(J),JCOMP3(J), CTEMP,JLATD(J),
     2  ALAT,IS, JLOND(J),ALON,IE,JELEV(J), PER,CALT,STRMK(J),
     3  PD1,PD2, XMC,CXWT,FMC,CFWT, JTYPE(J),CAL,JSLOC(J),JCOMPA(J),
     4  C1

1012    FORMAT (A5,1X,A2,1X,
     4  A1,A3,1X, A1,I2,1X,
     2  F7.4,A1, I3,1X,F7.4,A1,I4, F3.1,2X,2A1,
     3  2(F5.2,1X), 2(F5.2,A1), I1,F6.2,A2,A3,
     4  A1)

        JLMOD(J)=CALT.EQ.'2' .OR. CALT.EQ.'A'
C--MINUS SIGN MAKES STATION DEPTH NEGATIVE (ALLOWS VALUES <-999) V 1.36
        IF (C1.EQ.'-') JELEV(J)=-IABS(JELEV(J))

      END IF

C--IF WE WILL MATCH ON THE 1-LETTER COMPONENTS, TRANSFER THEM TO THE 3-LETTER
C  ARRAY WHERE TESTING IS DONE
C      IF (LCOMP1) JCOMP3(J)=JCOMP1(J)

C--ASSIGN EQUIVALENT LOCATION CODE: '  ' AND '--' WILL BOTH MATCH
      IF (JSLOC(J).EQ.'  ') THEN
        JSLOC2(J)='--'
      ELSE IF (JSLOC(J).EQ.'--') THEN
        JSLOC2(J)='  '
      ELSE
        JSLOC2(J)=JSLOC(J)
      END IF

C--OPTIONALLY CONVERT ATTENUATIONS TO CAL FACTORS
      IF (LATEN) THEN
        KTEMP2=NINT(CAL)
        KTEMP=KTEMP2/6
C--ATTENUATIONS MUST BE A VALID MULTIPLE OF 6 DB
        IF (KTEMP2-6*KTEMP .EQ. 0 .AND. KTEMP.GT.0 .AND. KTEMP.LT.11)
     2  CAL=CALSV(KTEMP)
      END IF

C--CORRECT VALUES WHICH ARE OUT OF RANGE
      IF (PER.LT..1) PER=.2
      IF (CAL.LT.0.) CAL=0.

C--STORED LAT & LON ARE POSITIVE N & W
C--USE NEG LAT FOR SOUTH, NEG LON FOR EAST
      IF (IS.EQ.'S' .OR. IS.EQ.'s') THEN
        JLATD(J)=-JLATD(J)
        ALAT=-ALAT
      END IF
      IF (IE.EQ.'E' .OR. IE.EQ.'e') THEN
        JLOND(J)=-JLOND(J)
        ALON=-ALON
      END IF

C--BRING WEST END OF ALEUTIANS INTO WESTERN HEMISPHERE V.1.38
C--THIS MAKES A TEAR BETWEEN AUSTRALIA AND NEW ZEALAND
      IF (JLOND(J).LE.-165) THEN
        TEMPD=JLOND(J) +ALON/60.
        TEMPD=TEMPD+360.
        JLOND(J)=INT(TEMPD)
        ALON=60.*(TEMPD-JLOND(J))
      END IF

C--STORE STATION INFO IN CONDENSED INTEGER FORMAT
C--LAT & LON IN .01 MINUTE, KEPT AS NEAREST INTEGER
      JLATM(J)=NINT(100.*ALAT)
      JLONM(J)=NINT(100.*ALON)

C--STORE STATION WEIGHTS IN UNITS OF 0.1 FROM 0.0 TO 1.0
C--P & S TIME WEIGHTS
      JPSWT(J)=IWT(CTEMP)

C--AMP MAG WEIGHT
      JXWT(J)=IWT(CXWT)
C--ALLOW FOR 0 WEIGHT ASSIGNED BY ADDING 5.0 TO MAG CORRECTION
      IF (XMC.GT.2.45) THEN
        XMC=XMC-5.
        JXWT(J)=0
      END IF

C--DURATION MAGNIUTDE WEIGHT
      JFWT(J)=IWT(CFWT)

C--ADD 10 TO CORRECTION TO GIVE GAIN CORRECTION 0 WEIGHT
C--YOU CAN ADD BOTH 10 AND 5, BUT MUST DO THIS TEST FIRST
      IF (FMC.GT.7.45) THEN
        JFGWT(J)=0
        FMC=FMC-10.
      ELSE
        JFGWT(J)=1
      END IF

C--ALLOW FOR 0 WEIGHT ASSIGNED BY ADDING 5.0 TO MAG CORRECTION
      IF (FMC.GT.2.45) THEN
        FMC=FMC-5.
        JFWT(J)=0
      END IF

C--STORE MAGNITUDE CORRECTIONS
      JXCOR(J)=NINT(XMC*100.)
      JFCOR(J)=NINT(FMC*100.)

C--STORE P DELAYS
      JPD(1,J)=NINT(PD1*100.)
      JPD(2,J)=NINT(PD2*100.)

C--STORE STATION TYPE, CAL FACTOR & PERIOD
      JPER(J)=NINT(PER*10.)
      JCAL(J)=NINT(CAL*1000.)
20    CONTINUE

C--COME HERE IF TOO MANY STATIONS ARE IN FILE
      JSTA=MAXSTA
      WRITE (6,1003) JSTA
1003  FORMAT (' *** TOO MANY STATIONS. THE FIRST',I4,' ARE USED.')
      IRES=-34

C--WRITE NUMBER OF STATIONS READ
30    WRITE (6,'(I6,'' STATIONS READ IN.'')') JSTA
      RETURN

C--COME HERE FOR READ ERROR
40      WRITE (6,1002) LINE(1:79)
1002      FORMAT (' *** ERROR READING STATION FILE AT LINE:'/1X,A)
      IRES=-94
      STOP
      END

      FUNCTION IWT (CHA)
C--USED BY HYSTA TO CONVERT A 1-CHARACTER WEIGHT CODE INTO AN
C  INTEGER THAT REPRESENTS THE NUMERICAL WEIGHT IN TENTHS.
C--TREAT INTEGER WEIGHT CODES AS WEIGHT IN TENTHS (0-9).
C--0 OR * GIVES NO WEIGHT (0).
C--BLANK OR ANY OTHER CHARACTER GIVES FULL WEIGHT (10).

      CHARACTER CHA*1
      L=ICHAR(CHA)
      IF (L.GT.47 .AND. L.LT.58) THEN
        IWT=L-48
      ELSE IF (CHA.EQ.'*') THEN
        IWT=0
      ELSE
        IWT=10
      END IF
      RETURN
      END
      SUBROUTINE HYSTL
C--CALLED BY HYPOINV TO LIST STATIONS & CRUST MODEL ON PRINT FILE.
      CHARACTER COMSTR*10,CURTIM*28, TYPSTR*3
      INCLUDE 'common.inc'
      DIMENSION PD(20)
      SAVE PD
      DATA PD /20*0./

C--CONTINUE ONLY IF STATIONS & OTHER DATA ARE TO BE PRINTED
      IF (.NOT.LPRT .OR. JST.EQ.0) RETURN

C--PRINT CURRENT DATE & TIME FIRST
      CALL HYTIME (CURTIM)
      WRITE (15,1000) GREETING, CURTIM,RUNLAB, CDOMAN,CPVERS
1000  FORMAT (' HYPOINVERSE 2000'/1X,A/' RUN ON ',A28,
     2 '  RUN LABEL=',A1/' PROCESSING DOMAIN=',A2,
     3 '  PROCESSING VERSION=',A2/)
      IF (JST.LT.2) GOTO 18

      IF (JST2.LT.1) GOTO 210
C--LIST THE BASIC STATION DATA
      M=MAXMOD
      IF (M.GT.2) M=2
      WRITE (15,1025) (CRODE(I),I=1,M)
1025  FORMAT (' STATIONS:',41X,A3,66X,A3)
      WRITE (15,1009)
1009  FORMAT (6X,'NAME NT COM LC CR  --LAT---  ---LON--- ELEV',
     3 ' PDLY1 A  FCOR FWT FMC.EXPIRE  XCOR XWT PSWT  CAL ',
     2 ' CAL.EXPIRE PER TYP PDLY2')

C--LOOP TO DECODE PARAMETERS AND WRITE STATIONS
      DO 5 J=1,JSTA
        XLTM=ABS(JLATM(J)*.01)
        XLNM=ABS(JLONM(J)*.01)
        XMC=JXCOR(J)*.01
        FMC=JFCOR(J)*.01
        DO I=1,M
          PD(I)=.01*JPD(I,J)
        END DO
        IF (JLMOD(J)) THEN
          CTEMP='A'
        ELSE
          CTEMP=' '
        END IF
        PWT=.1*JPSWT(J)
        XWT=JXWT(J)*.1
        CWT=JFWT(J)*.1
        PER=JPER(J)*.1
        CAL=JCAL(J)*.001
        KTEMP=ABS(JLATD(J))
        KTEMP2=ABS(JLOND(J))
        IE=' '
        IS=' '
        IF (KTEMP.LT.0 .OR. XLTM.LT.0.) IS='S'
        IF (KTEMP2.LT.0 .OR. XLNM.LT.0.) IE='E'

C--OUTPUT ONE LINE FOR THIS STATION
C--CHOOSE MAIN OR EQUIVALENT LOCATION CODE
        WRITE (15,1001) 
     2  J,STANAM(J),JNET(J), JCOMP3(J),JSLOC(J),JCOMP1(J),
     2  STRMK(J),KTEMP,IS,XLTM, KTEMP2,IE,XLNM,JELEV(J), 
     3  PD(1),CTEMP,FMC, CWT,JFEXP(J),XMC,XWT,PWT,  
     4  CAL,JCEXP(J), PER,JTYPE(J),(PD(I),I=2,M)
     
1001    FORMAT (1X,I4,1X,A5,A2,1X, A3,1X,A2,1X,A1,
     2  A1,I4,A1,F5.2, I5,A1,F5.2,I5, 
     3  F6.2,1X,A1,F6.2, F4.1,I11,F6.2,F4.1,F5.2, 
     4  F6.2,I11, F4.1,I3,1X,5F6.2)

5     CONTINUE

      IF (JST2.LT.2) GOTO 210
C--PRINT THE DELAYS FOR ALL MODELS IF THERE IS MORE THAN 1
      IF (MAXMOD.GT.1) THEN
        M=MAXMOD
        IF (M.GT.20) M=20
        WRITE (15,1026) (CRODE(I),I=1,M)
1026    FORMAT (/21X,20(3X,A3))
        WRITE (15,1017) (I,I=1,M)
1017    FORMAT(6X,'NAME NT COM C LC', 9(:,'  DLY',I1), 11(:,' DLY',I2))
        DO J=1,JSTA
          DO I=1,M
            PD(I)=.01*JPD(I,J)
          END DO
          WRITE (15,1018) J,STANAM(J),JNET(J),
     2    JCOMP3(J),JCOMP1(J),JSLOC(J), (PD(I),I=1,M)
1018      FORMAT (1X,I4,1X,A5,A2,1X, A3,1X,A1,1X,A2, 20F6.2)
        END DO
      END IF

      IF (MAXMOD.GT.20) THEN
        M=MAXMOD
        IF (M.GT.40) M=40
        WRITE (15,1026) (CRODE(I),I=21,M)
        WRITE (15,1027) (I,I=21,M)
1027    FORMAT (6X,'NAME NT COM C LC', 20(:,' DLY',I2))
        DO J=1,JSTA
          DO I=1,M-20
            PD(I)=.01*JPD(I+20,J)
          END DO
          WRITE (15,1018) J,STANAM(J),JNET(J),
     2    JCOMP3(J),JCOMP1(J),JSLOC(J), (PD(I),I=1,M-20)
        END DO
      END IF

210   IF (JST3.LT.1) GOTO 18
C--PRINT THE CRUSTAL MODELS, ONE AT A TIME
      DO 15 I=1,MAXMOD
      IF (MODTYP(I).EQ.-1) GOTO 15
      WRITE (15,1002) I,MODNAM(I)
1002  FORMAT (/' CRUST MODEL',I3,': ',A/)

C--LIST THE APPLICABLE REGIONS (NODES) IF MULTIPLE MODELS ARE IN USE
      IF (LMULT) THEN
        IF (I.EQ.MODDEF) THEN
          WRITE (15,1012)
1012      FORMAT (' THIS IS THE DEFAULT MODEL FOR UNASSIGNED REGIONS')
        ELSE

          WRITE (15,1024)
1024      FORMAT (' THE CIRCULAR REGIONS (NODES) DEFINED FOR THIS ',
     2    'MODEL ARE:'/' NODE  CENTER-LAT  CENTER-LON  MOD  ',
     3    'INNER-RADIUS  RING-WIDTH  OUTER-RADIUS')
          DO IZ=1,NNODE
            IF (I.EQ.MODH(IZ)) WRITE (15,1019) IZ,HLAT(IZ),HLON(IZ),
     2      MODH(IZ),RAD1(IZ),DRAD(IZ),RAD2(IZ)
1019        FORMAT (I4,F11.4,F13.4,I5,F11.2,2F13.2)
          END DO
        END IF

        WRITE (15,1013)
1013    FORMAT (1X)
      END IF

C--SIGNAL IF THIS MODEL HAS AN ALTERNATE MODEL
      IF (MODALT(I).GT.0) WRITE (15,1016) MODALT(I),CRODE(MODALT(I))
1016  FORMAT (' ALTERNATE: SOME STATIONS USE MODEL',I3,' (',A3,
     2 ') INSTEAD OF THIS ONE.')

C--SIGNAL IF THIS MODEL HAS AN S-WAVE MODEL
      IF (MODSAL(I).GT.0) WRITE (15,1144) MODSAL(I),CRODE(MODSAL(I))
1144  FORMAT (' S-MODEL: S-ARRIVALS USE MODEL',I3,' (',A3,
     2 ') INSTEAD OF THIS ONE.')

C--PRINT THE LAYER PARAMETERS FOR THE MODEL
C--LINEAR GRADIENT MODEL
      IF (MODTYP(I).EQ.0) THEN
        WRITE (15,1003)
1003    FORMAT (' LINEAR GRADIENT MODEL WITH VELOCITIES SPECIFIED AT',
     2  ' THE FOLLOWING DEPTHS:')
        WRITE (15,1005)
1005    FORMAT (4X,'VELOCITY  DEPTH') 
        DO J=1,LAY(I)
          WRITE (15,1006) J,VEL(J,I),D(J,I)
        END DO
1006    FORMAT (I3,2F8.3)

C--HOMOGENEOUS LAYER MODEL
      ELSE IF (MODTYP(I).EQ.1) THEN
        WRITE (15,1004)
1004    FORMAT (' HOMOGENEOUS LAYER MODEL WITH THE FOLLOWING',
     2  ' VELOCITIES AND LAYER TOPS:')
        WRITE (15,1005)
        DO J=1,LAY(I)
          WRITE (15,1006) J,VEL(J,I),D(J,I)
        END DO
     
C--LINEAR GRADIENT OVER HALFSPACE MODEL
      ELSE IF (MODTYP(I).EQ.2) THEN
        WRITE (15,1061) VSEA(I),VGRAD(I),THICK(I),VHALF(I),ELEVMX(I),
     2  LELEV(I)
1061    FORMAT (' -LINEAR GRADIENT OVER HALFSPACE MODEL (CRV):'/
     2  ' VELOCITY AT SEA LEVEL ELEV (KM/S) ',F7.3/
     3  ' VELOCITY GRADIENT OF LAYER ',F7.3/
     4  ' THICKNESS OF GRADIENT LAYER (KM) ',F7.3/
     5  ' VELOCITY OF HALFSPACE ',F7.3/
     6  ' REFERENCE (MAX) ELEV ABOVE S.L. IN KM ',F7.3/
     7  ' USE STATION ELEVATIONS? ',L1)

C--LINEAR GRADIENT HALFSPACE
      ELSE IF (MODTYP(I).EQ.3) THEN
        WRITE (15,1062) ELEVMX(I),VREF(I),VGRAD(I),LELEV(I)
1062    FORMAT (' -LINEAR GRADIENT HALFSPACE MODEL (CRL):'/
     2  ' REFERENCE (MAX) ELEV ABOVE S.L. IN KM ',F7.3/
     3  ' VELOCITY AT REFERENCE ELEV',F7.3/
     4  ' VELOCITY GRADIENT OF ENTIRE MODEL',F7.3/
     5  ' USE STATION ELEVATIONS? ',L1)

C--HYPOELLIPSE LAYER MODEL
      ELSE IF (MODTYP(I).EQ.4) THEN
        WRITE (15,1010)
1010    FORMAT (' HYPOELLIPSE LAYER MODEL WITH THE FOLLOWING',
     2  ' VELOCITIES AND LAYER TOPS:')
        WRITE (15,1005)
        DO J=1,LAY(I)
          WRITE (15,1006) J,VEL(J,I),D(J,I)
        END DO

        WRITE (15,1063) ELEVMX(I),LELEV(I)
1063    FORMAT (' REFERENCE (MAX) ELEV ABOVE S.L. IN KM ',F7.3/
     2  ' USE STATION ELEVATIONS? ',L1)
      END IF
15    CONTINUE

C--PRINT THE COMPUTATIONAL PARAMETERS FOR THIS RUN
18    WRITE (15,1007)
1007  FORMAT (/' TEST PARAMETERS:'/'   -ITERATION AND CONVERGENCE-',
     2 5X,'-WEIGHTING AND ERRORS-     -MISCELLANEOUS-')

      WRITE (15,1008) ITRLIM,DAMP,DISCUT,RMSCUT,MINSTA,
     2 DQUIT,DRQT,DISW1,RMSW1,NET,
     3 DXFIX,EIGTOL,DISW2,RMSW2,
     4 DZMAX,RBACK,ITRDIS,ITRRES,ZTR,
     5 DZAIR,BACFAC,SWT,RDERR,
     6 ERCOF
1008  FORMAT (
     1  I9,'=ITRLIM',F8.3,'=DAMP  ',F8.3,'=DISCUT',F8.3,'=RMSCUT',
     1  I8,'=MINSTA'/
     2 F9.3,'=DQUIT ',F8.3,'=DRQT  ',F8.3,'=DISW1 ',F8.3,'=RMSW1 ',
     2  I8,'=NET'/
     3 F9.3,'=DXFIX ',F8.3,'=EIGTOL',F8.3,'=DISW2 ',F8.3,'=RMSW2 '/
     4 F9.3,'=DZMAX ',F8.3,'=RBACK ',  I8,'=ITRDIS',  I8,'=ITRRES',
     4 F8.3,'=ZTR'/
     5 F9.3,'=DZAIR ',F8.3,'=BACFAC',F8.3,'=SWT   ',F8.3,'=RDERR '/
     6 46X,                                        F8.3,'=ERCOF')

      WRITE (15,1014)
1014  FORMAT (/6X,'------DURATION MAG CONSTANTS------',7X
     2 ,'-DELAYS & MISC-    -STATIONS-')

      WRITE (15,1015) FMA1,FMA2, DMA0,LMULT,LATEN,
     2 FMB1,  FMB2,  DMA1,  LCOWT,  NSTLET,
     3 FMZ1,  FMZ2,  DMA2,  LJUNK,  NETLET,
     4 FMD1,  FMD2,  DMZ,            NCOMP,
     5 FMF1,  FMF2,  DMGN,
     6 FMGN,  FMBRK, DMLI,
     7 DCOFM1,DBRKM1,MLOGA0,
     7 DCOFM2,DBRKM2,
     8 ZCOFM, ZBRKM
1015  FORMAT (
     1 F9.3,'=FMA1  ',F8.3,'=FMA2  ',F8.4,'=DMA0  ',  L8,'=LMULT ',
     1   L8,'=ATTEN'/
     2 F9.3,'=FMB1  ',F8.3,'=FMB2  ',F8.4,'=DMA1  ',  L8,'=CODAWT',
     2   I8,'=SITE-LET'/
     3 F9.3,'=FMZ1  ',F8.3,'=FMZ2  ',F8.4,'=DMA2  ',  L8,'=LJUNK ',
     3   I8,'=NET-LET'/
     4 F9.3,'=FMD1  ',F8.3,'=FMD2  ',F8.4,'=DMZ   ',  15X,
     4   I8,'=COMP-LET'/
     5 F9.3,'=FMF1  ',F8.3,'=FMF2  ',F8.4,'=DMGN  '/
     6 F9.3,'=FMGN  ',F8.3,'=FMBRK ',F8.4,'=DMLIN '/
     7 F9.4,'=DCOF1 ',F8.3,'=DBRK1 ',  I8,'=LOGA0 '/
     7 F9.4,'=DCOF2 ',F8.3,'=DBRK2 '/
     8 F9.4,'=ZCOF  ',F8.3,'=ZBRK  ')

C--WRITE FMAG & XMAG COMPONENT CORRECTIONS
      IF (NFCM.GT.0) WRITE (15,1077) (CFCM(I),AFCM(I),I=1,NFCM)
1077  FORMAT(/'    DUR MAG COMPONENT CORRECTIONS:',10(2X,A3,'=',F4.2))
      IF (NXCM.GT.0) WRITE (15,1078) (CXCM(I),AXCM(I),I=1,NXCM)
1078  FORMAT ('    AMP MAG COMPONENT CORRECTIONS:',10(2X,A3,'=',F4.2))

C--WRITE MAGNITUDE LABELS AND COMPONENTS
C--FIRST FMAG
      IF (NCPF1.EQ.0) THEN
        COMSTR=' NO'
      ELSE IF (NCPF1.LT.0) THEN
        COMSTR='ALL'
      ELSE
        COMSTR='   '
      END IF
      WRITE (15,1040) LABF1,COMSTR, (COMPF1(I),I=1,NCPF1)
1040  FORMAT (/'    --- MAGNITUDE LABELS & COMPONENTS ---'/
     2 '    FMAG1: LABEL=',A1,2X,A3,' COMPS=',20(1X,A3))

C--SECOND FMAG
      IF (NCPF2.EQ.0) THEN
        COMSTR=' NO'
      ELSE IF (NCPF2.LT.0) THEN
        COMSTR='ALL'
      ELSE
        COMSTR='   '
      END IF
      WRITE (15,1041) LABF2,COMSTR, (COMPF2(I),I=1,NCPF2)
1041  FORMAT ('    FMAG2: LABEL=',A1,2X,A3,' COMPS=',20(1X,A3))

C--FIRST XMAG
C--CHOOSE BY COMPONENT
      IF (LXCH) THEN
        IF (NCPX1.EQ.0) THEN
          COMSTR=' NO'
        ELSE IF (NCPX1.LT.0) THEN
          COMSTR='ALL'
        ELSE
          COMSTR='   '
        END IF

C--MAG TYPE
        TYPSTR='ALL'
        IF (MAG1TYPX.EQ.1) TYPSTR='ML '
        IF (MAG1TYPX.EQ.2) TYPSTR='MX '

        WRITE (15,1042) LABX1,COMSTR,TYPSTR, (COMPX1(I),I=1,NCPX1)
1042    FORMAT ('    XMAG1: LABEL=',A1,2X,A3, '  TYPE=',A3,
     2  '  COMPS=',20(1X,A3))

C--CHOOSE BY INST TYPE
      ELSE
        IF (NXTYP1.EQ.0) THEN
          COMSTR=' NO'
        ELSE IF (NXTYP1.LT.0) THEN
          COMSTR='ALL'
        ELSE
          COMSTR='   '
        END IF
        WRITE (15,1142) LABX1,COMSTR, (IXTYP1(I),I=1,NXTYP1)
1142    FORMAT ('    XMAG1: LABEL=',A1,2X,A3,' INST TYPES=',3(1X,I1))
      END IF

C--SECOND XMAG
C--CHOOSE BY COMPONENT
      IF (LXCH) THEN
        IF (NCPX2.EQ.0) THEN
          COMSTR=' NO'
        ELSE IF (NCPX2.LT.0) THEN
          COMSTR='ALL'
        ELSE
          COMSTR='   '
        END IF

C--MAG TYPE
        TYPSTR='ALL'
        IF (MAG2TYPX.EQ.1) TYPSTR='ML '
        IF (MAG2TYPX.EQ.2) TYPSTR='MX '

        WRITE (15,1043) LABX2,COMSTR,TYPSTR, (COMPX2(I),I=1,NCPX2)
1043    FORMAT ('    XMAG2: LABEL=',A1,2X,A3, '  TYPE=',A3,
     2  '  COMPS=',20(1X,A3))

C--CHOOSE BY INST TYPE
      ELSE
        IF (NXTYP2.EQ.0) THEN
          COMSTR=' NO'
        ELSE IF (NXTYP2.LT.0) THEN
          COMSTR='ALL'
        ELSE
          COMSTR='   '
        END IF
        WRITE (15,1143) LABX2,COMSTR, (IXTYP2(I),I=1,NXTYP2)
1143    FORMAT ('    XMAG2: LABEL=',A1,2X,A3,' INST TYPES=',3(1X,I1))
      END IF

      WRITE (15,1141) MAGSEL,MAGSL2
1141  FORMAT ('    FMAG1 MAGSEL=',I1,'  FMAG2 MAGSEL=',I1)

C--WRITE INPUT FILENAMES
      WRITE (15,1020) INFILE(1),INFILE(2)
1020  FORMAT (/' INPUT FILES:'/' COMMANDS:    ',A/14X,A)
      IF (LBSTA) THEN
        WRITE (15,'('' BINARY STATION SNAPSHOT FILE: '',A)') BSTAFL
      ELSE
        WRITE (15,'('' STATIONS:    '',A,''STATION FORMAT CODE='',I2)')
     2  STAFIL,ISTFMT
      END IF

      WRITE (15,1021)DELFIL,ATNFIL,CALFIL,FMCFIL,XMCFIL,
     2 PHSFIL,JCP,IH71T
1021  FORMAT (
     3 ' DELAYS:       ',A/
     4 ' ATTENUATIONS: ',A/
     5 ' CAL FACTORS:  ',A/
     5 ' FMAG CORRECT: ',A/
     6 ' XMAG CORRECT: ',A//
     7 ' PHASES:       ',A/
     8 8X,'PHASE FORMAT CODE=',I2,', TERMINATOR FORMAT CODE=',I1)

      IF (LBCRU) THEN
        WRITE (15,'('' BINARY CRUST SNAPSHOT FILE: '',A)') BCRUFL
      ELSE
        DO I=1,MAXMOD
          IF (MODTYP(I).EQ.0) WRITE (15,1022) I,CRUFIL(I)
1022      FORMAT (' LINEAR  GRADIENT  CRUST',I2,':  ',A)
          IF (MODTYP(I).EQ.1) WRITE (15,1023) I,CRUFIL(I)
1023      FORMAT (' HOMOGENEOUS LAYER CRUST',I2,':  ',A)
        END DO
      END IF

C--WRITE OUTPUT FILENAMES
      WRITE (15,1030) LAPP(1),PRTFIL
1030  FORMAT (/' OUTPUT FILES: (T IF APPENDED TO)'/
     2 ' (',L1,') PRINTOUT:    ',A)
      IF (LSUM) WRITE (15,1031) LAPP(2),SUMFIL,IH71S
1031  FORMAT (' (',L1,') SUMMARY:     ',A,'FORMAT CODE=',I1)
      IF (LARC) WRITE (15,1032) LAPP(3),ARCFIL,JCA
1032  FORMAT (' (',L1,') ARCHIVE:     ',A,'ARCHIVE FORMAT CODE=',I2)
      IF (LMAG) WRITE (15,1036) MAGFIL
1036  FORMAT (' MAGNITUDE DATA:  ',A)

      WRITE (15,*)
      RETURN
      END
      SUBROUTINE HYSUM (IUNIT)
C--CALLED BY HYPOINVERSE TO OUTPUT SUMMARY DATA
C--IUNIT IS THE UNIT NUMBER FOR OUTPUT, 7 FOR ARCHIVE, 12 FOR SUMMARY FILE
      INCLUDE 'common.inc'
      CHARACTER LINE*188,CT1*1, CQ*1, Q*1
      CHARACTER*3 CFMAG2,CXMAG2,CPMAG,CF2MAG,CX2MAG,CBMAG
      CHARACTER CM5*5, CM2*2, CR5*5, CR2*2,CR2A*2, CMODT*1
      DIMENSION KSIG(3), CM5(5), CM2(5), CMODT(5)
      SAVE CMODT
      DATA CMODT /'T','H','V','L','E'/
      
C      CHARACTER*5 ,CF5,CX5,CE5
C      CHARACTER*2 ,CF2,CX2,CE2

C--CONVERT SOME DATA TO INTEGER FOR OUTPUT TO HYPOINVERSE FORMAT
      KLTM=NINT(XLTM*100.)
      KLNM=NINT(XLNM*100.)
      KQ=NINT(T1*100.)
      KZ=NINT(ZREP*100.)
      KZG=NINT(ZGEOID*100.)
      KDMIN=NINT(DMIN)
      IF (KDMIN.GT.999) KDMIN=999
      KRMS=NINT(RMS*100.)
      IF (KRMS.GT.9999) KRMS=9999
      KERH=NINT(ERH*100.)
      KERZ=NINT(ERZ*100.)

      KFMMAD=NINT(100.*FMMAD)
      IF (KFMMAD.GT.999) KFMMAD=999
      KXMMAD=NINT(100.*XMMAD)
      IF (KXMMAD.GT.999) KXMMAD=999
      DO 10 I=1,3
10    KSIG(I)=NINT(SERR(I)*100.)

      NFM2=NFRM			!NEW FORMAT
      IF (NFM2.GT.999) NFM2=999
      NWSR2=NWS
      IF (NWSR2.GT.999) NWSR2=999

C--CONVERT SOME DATA TO INTEGER FOR OUTPUT IN OLD FORMAT
      NFM=NFRM
      IF (NFM.GT.99) NFM=99
      NWSR=NWS
      IF (NWSR.GT.99) NWSR=99

C--CONVERT MAG DATA TO INTEGER FOR OUTPUT, CAN BE NEGATIVE
C--M*MAG* IS THE TOTAL OF STATION WEIGHTS *100 (NO LONGER USED)

C--DUR MAG
      CALL MAG2C3 (FMAG,CFMAG2)
      IF (NFMAG.GT.999) NFMAG=999	

      LFMAG=NINT(FMAG*10.)		!DUR MAG, OLD FORMAT
      IF (LFMAG.LT.-9) LFMAG=-9
      NFMA=NFMAG
      IF (NFMA.GT.99) NFMA=99

C--AMP MAG
      CALL MAG2C3 (XMAG,CXMAG2)
      IF (NXMAG.GT.999) NXMAG=999

      LXMAG=NINT(XMAG*10.)		!AMP MAG, OLD FORMAT
      IF (LXMAG.LT.-9) LXMAG=-9
      NXMA=NXMAG
      IF (NXMA.GT.99) NXMA=99

C--PREFERRED MAG
      CALL MAG2C3 (PMAG,CPMAG)
      IF (NPMAG.GT.999) NPMAG=999	!NEW FORMAT

      NPMAGSH=NPMAG			!PREFERRED MAG, OLD FORMAT
      IF (NPMAGSH.GT.99) NPMAGSH=99

C--ALTERNATE DUR MAG
      CALL MAG2C3 (FMAG2,CF2MAG)
      IF (NFMAG2.GT.999) NFMAG2=999	!NEW FORMAT

      NFMAG2SH=NFMAG2			!ALTERNATE DUR MAG, OLD FORMAT
      IF (NFMAG2SH.GT.99) NFMAG2SH=99

C--XMAG2 THE ALTERNATE AMP MAG
C--OVERWRITE XMAG2 WITH EXTERNAL XMAG (LABEL CODE A) IF IT WAS READ IN
      IF (BMAGX.GT.0. .OR. NBMAGX.GT.0) THEN
        XMAG2=BMAGX
        NXMAG2=NBMAGX
        CT1=BMTYPX
      ELSE
        CT1=LABX2
      END IF

C--ALTERNATE AMP MAG
      CALL MAG2C3 (XMAG2,CX2MAG)
      IF (NXMAG2.GT.99) NXMAG2=99
 
C--ADDITIONAL MAGNITUDES (BOTH FORMATS)
C--EXTERNAL (BERKELEY) MAG
      CALL MAG2C3 (BMAG,CBMAG)
      IF (NBMAG.GT.99) NBMAG=99

C--WRITE A SUMMARY RECORD
C--HYPO71 FORMAT--------------------------------------------------
      IF (IH71S.EQ.2 .AND. IUNIT.EQ.12) THEN
        CALL QUALITY (CQ,RMS,MAXGAP,ERH,ERZ,NWR,ZREP,DMIN)
        
C--YEAR 2000 HYPO71 FORMAT
        IF (L2000) THEN
          WRITE (12,1202) KYEAR2,KMONTH,KDAY,KHOUR,KMIN,T1,LAT,IS,
     2    XLTM,LON,IE,XLNM,ZREP, LABPR,PMAG,
     3    NWR,MAXGAP,DMIN,RMS,ERH,ERZ, RMK1,CQ,SOUCOD,RMK2,
     4    IDNO,CP2,REMK

1202      FORMAT (I4,2I2.2,1X,2I2.2,F6.2,I3,A1,
     2    F5.2,I4,A1,F5.2,F7.2,1X, A1,F5.2,
     3    I3,I4,F5.1,F5.2,2F5.1, 4A1,
     4    I10,1X,A1,A3)

C--OLD HYPO71 FORMAT ENHANCED
        ELSE
          WRITE (12,1002) KYEAR,KMONTH,KDAY,KHOUR,KMIN,T1,LAT,IS,
     2    XLTM,LON,IE,XLNM,ZREP, LABPR,PMAG,
     3    NWR,MAXGAP,DMIN,RMS,ERH,ERZ, RMK1,CQ,SOUCOD,RMK2,
     4    IDNO,CP2

1002      FORMAT (3I2.2,1X,2I2.2,F6.2,I3,A1,
     2    F5.2,I4,A1,F5.2,F7.2,1X, A1,F5.2,
     3    I3,I4,F5.1,F5.2,2F5.1, 4A1,
     4    I10,A1)
        END IF

C--READABLE AND COMMA-DELIM FORMATS----------------------------------
      ELSE IF ((IH71S.EQ.3 .OR. IH71S.EQ.4) .AND. IUNIT.EQ.12) THEN
        CALL QUALITY (CQ,RMS,MAXGAP,ERH,ERZ,NWR,ZREP,DMIN)
        Q=' '
        IF (IH71S.EQ.4) Q=','

C--PREPARE MAGNITUDE STRINGS
C  PREFERRED MAG
        CR5='     '
        CR2='  '
        CR2A='  '
        IF (PMAG.GT.VNOMAG) THEN
          WRITE (CR5,'(F5.2)') PMAG
          CR2=('M'//LABPR)
          CR2A='99'
          IF (NPMAG.LT.100) WRITE (CR2A,'(I2)') NPMAG
        ELSE IF (.NOT.LBLANKMAG) THEN
          WRITE (CR5,'(F5.2)') VNOMAG
          CR2=('M'//LABPR)
          CR2A=' 0'
        END IF

C--0-5 INDIVIDUAL MAGS AT END OF LINE (NOT RUN IF NRDMAG IS 0)
C--OPTIONALLY SWITCH FMAGS 1 & 2 IF EQ IN LAT/LON BOX
        DO I=1,NRDMAG
          IF (MRDMAG(I).EQ.1) THEN
            WMAG=FMAG
            CM2(I)=('M'//LABF1)
            IF (USEMAR .AND. LINBOX .AND. SWITCH12) THEN
              WMAG=FMAG2
              CM2(I)=('M'//LABF2)
            END IF
          ELSE IF (MRDMAG(I).EQ.2) THEN
            WMAG=FMAG2
            CM2(I)=('M'//LABF2)
            IF (USEMAR .AND. LINBOX .AND. SWITCH12) THEN
              WMAG=FMAG
              CM2(I)=('M'//LABF1)
            END IF
          ELSE IF (MRDMAG(I).EQ.3) THEN
            WMAG=XMAG
            CM2(I)=('M'//LABX1)
          ELSE IF (MRDMAG(I).EQ.4) THEN
            WMAG=XMAG2
            CM2(I)=('M'//LABX2)
          ELSE IF (MRDMAG(I).EQ.5) THEN
            WMAG=BMAG
            CM2(I)=('M'//BMTYP)
          END IF
          
          IF (WMAG.GT.VNOMAG) THEN
            WRITE (CM5(I),'(F5.2)') WMAG
          ELSE IF (.NOT.LBLANKMAG) THEN
            WRITE (CM5(I),'(F5.2)') VNOMAG
          ELSE IF (LBLANKMAG) THEN
            CM5(I)='     '
            CM2(I)='  '
          END IF
        END DO

C--WRITE READABLE SUMMARY LINE
        WRITE (12,1203) KYEAR2,KMONTH,KDAY,KHOUR,KMIN,Q, T1,Q,CLAT,Q,
     2  -CLON,Q,ZREP,Q, CR5,Q,CR2,Q,CR2A,Q, 
C     3  NWR,Q,MAXGAP,Q,DMIN,Q,RMS,Q, ERH,Q,ERZ,Q, RMK1,CQ,SOUCOD,RMK2,
     3  NWR,Q,MAXGAP,Q,DMIN,Q,RMS,Q, ERH,Q,ERZ,Q, CQ,RMK2,SOUCOD,RMK1,
     4  Q,IDNO,Q,REMK, (Q,CM5(I),Q,CM2(I),I=1,NRDMAG)

1203    FORMAT (I4,2('/',I2.2),1X,I2.2,':',I2.2,A1, F5.2,A1,F8.4,A1,
     2  F9.4,A1,F6.2,A1, A5,A1,A2,A1,A2,A1,
     3  I3,A1,I3,A1,F5.1,A1,F5.2,A1, 2(F5.1,A1), 4A1,
     4  A1,I10,A1,A3, 5(A1,A5,A1,A2))

      ELSE
C--YEAR 2000 HYPOINVERSE FORMAT-------------------------------------
        IF (L2000) THEN
          WRITE (LINE,1201) KYEAR2,KMONTH,KDAY,KHOUR,KMIN, KQ,LAT,IS,
     2    KLTM,LON,IE,KLNM,KZ, CXMAG2,NWR,MAXGAP, KDMIN,KRMS,
     3    (IAZ(I),IDIP(I),KSIG(I),I=1,2), CFMAG2,REMK,KSIG(3),
     4    RMK1,RMK2,NWSR2, KERH,KERZ,NFM2, NXMAG,NFMAG,KXMMAD,KFMMAD,
     5    CRODE(MOD),CP1, SOUCOD,FMSOU,XMSOU,LABF1, NVR,LABX1,
     6    BMTYP,CBMAG,NBMAG, CT1,CX2MAG,NXMAG2, IDNO,
     7    LABPR,CPMAG,NPMAG, LABF2,CF2MAG,NFMAG2, CP2,CP3,
     8    CDOMAN,CPVERS, CZFLAG,CMODT(MODTYP(MODS(1))+1),IDEPDAT,KZG
     
1201      FORMAT (I4,4I2.2, I4.4,I2,A1,
     2    I4,I3,A1,I4,I5, A3,3I3,I4,
     3    2(I3,I2,I4), 2A3,I4,
     4    2A1,I3, 2I4,I3, 2(I3,'0'),2I3,
     5    A3,A1, 4A1, I3,A1,
     6    2(A1,A3,I2,'0'), I10,
     7    2(A1,A3,I3,'0'), 2A1,
     8    2A2, 2A1,I4,I5)
     
          LENLIN=179

        ELSE
C--OLD HYPOINVERSE FORMAT
          WRITE (LINE,1001) KYEAR,KMONTH,KDAY,KHOUR,KMIN, KQ,LAT,IS,
     2    KLTM,LON,IE,KLNM,KZ, LXMAG,NWR,MAXGAP, KDMIN,KRMS,
     3    (IAZ(I),IDIP(I),KSIG(I),I=1,2), LFMAG,REMK,KSIG(3),
     4    RMK1,RMK2,NWSR, KERH,KERZ,NFM, NXMA,NFMA,KXMMAD,KFMMAD,
     5    CRODE(MOD),CP1, SOUCOD,FMSOU,XMSOU,LABF1, NVR,LABX1,
     6    BMTYP,CBMAG,NBMAG, CT1,CX2MAG,NXMAG2, IDNO,
     7    LABPR,CPMAG,NPMAGSH, LABF2,CF2MAG,NFMAG2SH, CP2,CP3

1001      FORMAT (5I2.2, I4.4,I2,A1,
     2    I4,I3,A1,I4,I5, I2,3I3,I4,
     3    2(I3,I2,I4), I2,A3,I4,
     4    2A1,I2, 2I4,I2, 2(I2,'0'),2I3,
     5    A3,A1, 4A1, I3,A1,
     6    2(A1,A3,I2,'0'), I10,
     7    2(A1,A3,I2,'0'), 2A1)

          LENLIN=154
        END IF

C--WRITE HYPOINVERSE FORMAT LINE
C--WE COULD TRIM LENGTH IF LATER FIELDS WERE UNUSED, BUT FOR NOW SPIT IT ALL
        WRITE (IUNIT,'(A)') LINE(1:LENLIN)
      END IF
      RETURN
      END

      SUBROUTINE QUALITY (CQ,RMS,MAXGAP,ERH,ERZ,NWR,Z1,DMIN)

C--COMPUTE QUALITY LABEL (HYPO71 ONLY) AS AVERAGE OF ERROR AND GEOMETRICAL
C  QUALITIES.
      CHARACTER CQ*1

      IF (RMS.LT.0.15 .AND. ERH.LE.1.0 .AND. ERZ.LE.2.0) THEN
        IQS = 1
      ELSE IF (RMS.LT.0.30 .AND. ERH.LE.2.5 .AND. ERZ.LE.5.0) THEN
        IQS = 2
      ELSE IF (RMS.LT.0.50 .AND. ERH.LE.5.0) THEN
        IQS = 3
      ELSE
        IQS = 4
      ENDIF

      IF (NWR.GE.6 .AND. MAXGAP.LE.90 .AND. 
     1 (DMIN.LE.Z1 .OR. DMIN.LE.5.0)) THEN
        IQD = 1
      ELSE IF (NWR.GE.6 .AND. MAXGAP.LE.135 .AND. 
     1 (DMIN.LE.2.*Z1 .OR. DMIN.LE.10.0)) THEN
	IQD = 2
      ELSE IF (NWR.GE.6 .AND. MAXGAP.LE.180 .AND. DMIN.LE.50.) THEN
        IQD = 3
      ELSE
        IQD = 4
      ENDIF

C--MAKE A LETTER QUALITY 1=A, 2=B, 3=C, 4=D
      IQ = NINT((IQS + IQD)/2.)
      CQ=CHAR(IQ+64)
      RETURN
      END

      SUBROUTINE MAG2C3 (AMAG,CM3)
C--CONVERT A REAL MAG TO 3-CHARACTER STRING
      CHARACTER CM3*3
      I=NINT(AMAG*100.)			!DUR MAG, NEW FORMAT
      IF (I.LT.-99) THEN
        WRITE (CM3,'(F3.0)') AMAG
      ELSE
        WRITE (CM3,'(I3)') I
      END IF
      RETURN
      END
      SUBROUTINE  HYSVD  (A, S, V, MMAX, NMAX, M, N, P, WITHU, WITHV,T)

C--NOTE THAT FOR USE IN HYPOINVERSE:
C-(1) THE TEMPORARY T IS DIMENSIONED T(MMAX) IN THE CALLING ROUTINE.
C-(2) THE NUMBER OF COLUMNS OF A IS NPMAX = NMAX + PMAX. SINCE PMAX
C-IS 1 AND NMAX IS 4, NPMAX = 5.
      PARAMETER (NPMAX=5)

      INTEGER    MMAX, NMAX, M, N, P
      REAL       R, W, CS, SN, TOL, F, X, EPS, G, T, Y
      REAL       ETA, H, Q, Z
      INTEGER    I, J, K, L, L1, N1, NP
      LOGICAL    WITHU, WITHV
      DIMENSION       S(NMAX), V(NMAX,NMAX), T(MMAX)
      DIMENSION A(MMAX,NPMAX)

C     ------------------------------------------------------------------

C     THIS IS A TRANSLATION OF A CDC 6600 FORTRAN PROGRAM TO IBM 360
C     FORTRAN IV.  THIS SUBROUTINE USES SHORT PRECISION ARITHMETIC.
C     A LONG PRECISION VERSION IS AVAILABLE UNDER THE NAME 'DSVD'.

C     THIS SUBROUTINE REPLACES EARLIER SUBROUTINES WITH THE SAME NAME,
C    689   6       &   &0&  S OF A COMPLEX AR&THMETIC PROGRAM, PUBLISHED
C     AS ALGORITHM 358.  THIS CURRENT PROGRAM IS FASTER, MORE ACCURATE
C     AND LESS OBSCURE IN DESCRIBING ITS CAPABILITIES.

C     ORIGINAL PROGRAMMER=  R. C. SINGLETON
C     360 VERSION BY=       J. G. LEWIS
C     LAST REVISION OF THIS SUBROUTINE=  4 DECEMBER 1973

C     ------------------------------------------------------------------

C     ADDITIONAL SUBROUTINE NEEDED=  ROTATE
C--THE HYROT SUBROUTINE WAS ELIMINATED TO PERMIT USE OF VIRTUAL ARRAYS

C     ------------------------------------------------------------------


C     THIS SUBROUTINE COMPUTES THE SINGULAR VALUE DECOMPOSITION
C     OF A REAL M*N MATRIX A, I.E. IT COMPUTES MATRICES U, S, AND V
C     SUCH THAT
C
C                  A = U * S * VT ,
C     WHERE
C              U IS AN M*N MATRIX AND UT*U = I, (UT=TRANSPOSE
C                                                    OF U),
C              V IS AN N*N MATRIX AND VT*V = I, (VT=TRANSPOSE
C                                                    OF V),
C        AND   S IS AN N*N DIAGONAL MATRIX.
C
C     DESCRIPTION OF PARAMETERS=
C
C     A = REAL ARRAY. A CONTAINS THE MATRIX TO BE DECOMPOSED.
C         THE ORIGINAL DATA ARE LOST.  IF WITHV=.TRUE., THEN
C         THE MATRIX U IS COMPUTED AND STORED IN THE ARRAY A.
C
C     MMAX = INTEGER VARIABLE.  THE NUMBER OF ROWS IN THE
C            ARRAY A.
C
C     NMAX = INTEGER VARIABLE.  THE NUMBER OF ROWS IN THE
C            ARRAY V.
C
C     M,N = INTEGER VARIABLES.  THE NUMBER OF ROWS AND COLUMNS
C           IN THE MATRIX STORED IN A.  (N<=M<=100.  IF IT IS
C           NECESSARY TO SOLVE A LARGER PROBLEM, THEN THE
C           AMOUNT OF STORAGE ALLOCATED TO THE ARRAY T MUST
C           BE INCREASED ACCORDINGLY.)  IF M0, THEN COLUMNS N+1, . . . ,
C         N+P OF A ARE ASSUMED TO CONTAIN THE COLUMNS OF AN M*P
C         MATRIX B.  THIS MATRIX IS MULTIPLIED BY UT, AND UPON
C         EXIT, A CONTAINS IN THESE SAME COLUMNS THE N*P MATRIX
C         UT*B. (P>=0)
C
C     WITHU, WITHV = LOGICAL VARIABLES.  IF WITHU=.TRUE., THEN
C         THE MATRIX U IS COMPUTED AND STORED IN THE ARRAY A.
C         IF WITHV=.TRUE., THEN THE MATRIX V IS COMPUTED AND
C         STORED IN THE ARRAY V.
C
C     S = REAL ARRAY.  S(1), . . . , S(N) CONTAIN THE DIAGONAL
C         ELEMENTS OF THE MATRIX S ORDERED SO THAN S(I)>=S(I+1),
C         I=1, . . . , N-1.
C
C     V = REAL ARRAY.  V CONTAINS THE MATRIX V.  IF WITHU
C         AND WITHV ARE NOT BOTH =.TRUE., THEN THE ACTUAL
C         PARAMETER CORRESPONDING TO A AND V MAY BE THE SAME.
C
C     THIS SUBROUTINE IS A REAL VERSION OF A FORTRAN SUBROUTINE
C     BY BUSINGER AND GOLUB, ALGORITHM 358=  SINGULAR VALUE
C     DECOMPOSITION OF A COMPLEX MATRIX, COMM. ACM, V. 12,
C     NO. 10, PP. 564-565 (OCT. 1969).
C     WITH REVISIONS BY RC SINGLETON, MAY 1972.
C     ------------------------------------------------------------------


C    ECLIPSE CONSTANTS
      SAVE ETA,TOL
      DATA ETA,TOL/1.9E-7,1.1E-30/

C     DATA ETA,TOL /1.5E-15,1.E-250/


C     ETA (16**-6) AND TOL (16**-59) ARE MACHINE DEPENDENT CONSTANTS
C     FOR IBM 360/370 COMPUTERS (SHORT FORM ARITHMETIC).
C     ETA IS THE MACHINE EPSILON (RELATIVE ACCURACY)!
C     TOL IS THE SMALLEST REPRESENTABLE REAL DIVIDED BY ETA.

      NP = N + P
      N1 = N + 1

C     HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM
      G = 0.0
      EPS = 0.0
      L = 1
   10 T(L) = G
      K = L
      L = L + 1

C     ELIMINATION OF A(I,K), I=K+1, . . . , M
      S(K) = 0.0
      Z = 0.0
      DO 20 I = K,M
   20   Z = Z + A(I,K)**2
      IF (Z.LT.TOL) GOTO 50
      G = SQRT(Z)
      F = A(K,K)
      IF (F.GE.0.0) G = - G
      S(K) = G
      H = G * (F - G)
      A(K,K) = F - G
      IF (K.EQ.NP) GOTO 50
      DO 40 J = L,NP
         F = 0
         DO 30 I = K,M
   30       F = F + A(I,K)*A(I,J)
         F = F/H
         DO 40 I = K,M
   40       A(I,J) = A(I,J) + F*A(I,K)

C     ELIMINATION OF A(K,J), J=K+2, . . . , N
   50 EPS = AMAX1(EPS,ABS(S(K)) + ABS(T(K)))
      IF (K.EQ.N) GOTO 100
      G = 0.0
      Z = 0.0
      DO 60 J = L,N
   60    Z = Z + A(K,J)**2
      IF (Z.LT.TOL) GOTO 10
      G = SQRT(Z)
      F = A(K,L)
      IF (F.GE.0.0) G = - G
      H = G * (F - G)
      A(K,L) = F - G
      DO 70 J = L,N
   70    T(J) = A(K,J)/H
      DO 90 I = L,M
         F = 0
         DO 80 J = L,N
   80       F = F + A(K,J)*A(I,J)
         DO 90 J = L,N
   90       A(I,J) = A(I,J) + F*T(J)

      GOTO 10

C     TOLERANCE FOR NEGLIGIBLE ELEMENTS
  100 EPS = EPS*ETA

C     ACCUMULATION OF TRANSFORMATIONS
      IF (.NOT.WITHV) GOTO 160
      K = N
      GOTO 140
  110    IF (T(L).EQ.0.0) GOTO 140
         H = A(K,L)*T(L)
         DO 130 J = L,N
            Q = 0
            DO 120 I = L,N
  120          Q = Q + A(K,I)*V(I,J)
            Q = Q/H
            DO 130 I = L,N
  130          V(I,J) = V(I,J) + Q*A(K,I)
  140    DO 150 J = 1,N
  150       V(K,J) = 0
         V(K,K) = 1.0
         L = K
         K = K - 1
         IF (K.NE.0) GOTO 110

  160  K = N
       IF (.NOT.WITHU) GOTO 230
       G = S(N)
       IF (G.NE.0.0) G = 1.0/G
       GO TO 210
  170    DO 180 J = L,N
  180       A(K,J) = 0
         G = S(K)
         IF (G.EQ.0.0) GOTO 210
         H = A(K,K)*G
         DO 200 J = L,N
            Q = 0
            DO 190 I = L,M
  190          Q = Q + A(I,K)*A(I,J)
            Q = Q/H
            DO 200 I = K,M
  200          A(I,J) = A(I,J) + Q*A(I,K)
         G = 1.0/G
  210    DO 220 J = K,M
  220       A(J,K) = A(J,K)*G
         A(K,K) = A(K,K) + 1.0
         L = K
         K = K - 1
         IF (K.NE.0) GOTO 170

C     QR DIAGONALIZATION
      K = N

C     TEST FOR SPLIT
  230    L = K
  240       IF (ABS(T(L)).LE.EPS) GOTO 290
            L = L - 1
            IF (ABS(S(L)).GT.EPS) GOTO 240

C     CANCELLATION
         CS = 0.0
         SN = 1.0
         L1 = L
         L = L + 1
         DO 280 I = L,K
            F = SN*T(I)
            T(I) = CS*T(I)
            IF (ABS(F).LE.EPS) GOTO 290
            H = S(I)
            W = SQRT(ABS(F*F + H*H))
            S(I) = W
            CS = H/W
            SN = - F/W
C           IF (WITHU) CALL HYROT(A(1,L1), A(1,I), CS, SN, M)
            IF (WITHU) THEN
              DO 260 JJ=1,M
                XX=A(JJ,L1)
                YY=A(JJ,I)
                A(JJ,L1)=XX*CS + YY*SN
260             A(JJ,I)= YY*CS - XX*SN
            END IF
            IF (NP.EQ.N) GOTO 280
            DO 270 J = N1,NP
               Q = A(L1,J)
               R = A(I,J)
               A(L1,J) = Q*CS + R*SN
 270           A(I,J) = R*CS - Q*SN
  280     CONTINUE

C     TEST FOR CONVERGENCE
  290    W = S(K)
         IF (L.EQ.K) GOTO 360

C     ORIGIN SHIFT
         X = S(L)
         Y = S(K-1)
         G = T(K-1)
         H = T(K)
         F = ((Y - W)*(Y + W) + (G - H)*(G + H))/(2.0*H*Y)
         G = SQRT(F*F + 1.0)
         IF (F.LT.0.0) G = - G
         F = ((X - W)*(X + W) + (Y/(F + G) - H)*H)/X

C     QR STEP
         CS = 1.0
         SN = 1.0
         L1 = L + 1
         DO 350 I = L1,K
            G = T(I)
            Y = S(I)
            H = SN*G
            G = CS*G
            W = SQRT(H*H + F*F)
            T(I-1) = W
            CS = DIV (F,W,TOL)
            SN = DIV (H,W,TOL)
            F = X*CS + G*SN
            G = G*CS - X*SN
            H = Y*SN
            Y = Y*CS
C           IF (WITHV) CALL HYROT(V(1,I-1), V(1,I), CS, SN, N)
          IF (WITHV) THEN
            DO 320 JJ=1,N
            XX=V(JJ,I-1)
            YY=V(JJ,I)
            V(JJ,I-1)=XX*CS + YY*SN
320            V(JJ,I)=  YY*CS - XX*SN
          END IF
            W = SQRT(ABS(H*H + F*F))
            S(I-1) = W
            CS = DIV (F,W,TOL)
            SN = DIV (H,W,TOL)
            F = CS*G + SN*Y
            X = CS*Y - SN*G
C           IF (WITHU) CALL HYROT(A(1,I-1), A(1,I), CS, SN, M)
          IF (WITHU) THEN
            DO 330 JJ=1,M
            XX=A(JJ,I-1)
            YY=A(JJ,I)
            A(JJ,I-1)=XX*CS + YY*SN
330            A(JJ,I)=  YY*CS - XX*SN
          END IF
            IF (N.EQ.NP) GOTO 350
            DO 340 J = N1,NP
               Q = A(I-1,J)
               R = A(I,J)
               A(I-1,J) = Q*CS + R*SN
 340  A(I,J) = R*CS - Q*SN
  350       CONTINUE

         T(L) = 0.0
         T(K) = F
         S(K) = X
         GOTO 230

C     CONVERGENCE
  360    IF (W.GE.0.0) GOTO 380
         S(K) = - W
         IF (.NOT.WITHV) GOTO 380
         DO 370 J = 1,N
  370       V(J,K) = - V(J,K)
  380    K = K - 1
         IF (K.NE.0) GO TO 230

C     SORT SINGULAR VALUES
      DO 450 K = 1,N
         G = -1.0
         DO 390 I = K,N
            IF (S(I).LT.G) GOTO 390
            G = S(I)
            J = I
  390       CONTINUE
      IF (J .EQ. K) GO TO 450
      S(J) = S(K)
         S(K) = G
         IF (.NOT.WITHV) GOTO 410
         DO 400 I = 1,N
            Q = V(I,J)
            V(I,J) = V(I,K)
  400       V(I,K) = Q
  410    IF (.NOT.WITHU) GOTO 430
         DO 420 I = 1,M
            Q = A(I,J)
            A(I,J) = A(I,K)
  420       A(I,K) = Q
  430    IF (N.EQ.NP) GOTO 450
         DO 440 I = N1,NP
            Q = A(J,I)
            A(J,I) = A(K,I)
  440       A(K,I) = Q
  450    CONTINUE

      RETURN
      END
C      SUBROUTINE   HYROT  (X, Y, CS, SN, N)
C      INTEGER N
C      REAL    X(N), Y(N), CS, SN
C      REAL    XX
C      INTEGER J
C      DO 10 J = 1, N
C         XX = X(J)
C         X(J) = XX*CS + Y(J)*SN
C   10    Y(J) = Y(J)*CS - XX*SN
C      RETURN
C      END

      FUNCTION DIV (A,B,TOL)
C--AVOID DIVION BY 0, AND UNDEFINED 0/0 DIVIOSN
C--DIV RETURNS 0 FOR 0/0 INPUT
      IF (A.EQ.0.) THEN
        DIV=0.
        RETURN
      END IF
      IF (B.EQ.0.) THEN
        DIV=SIGN(TOL,A)
        RETURN
      END IF
      DIV=A/B
      RETURN
      END
      SUBROUTINE HYTIME (CURTIM)
C--RETURNS THE CURRENT TIME AND DATE AS A 28 CHARACTER STRING
      CHARACTER CURTIM*28

C--SUN/UNIX
      CALL FDATE (CURTIM)

C--VAX
C      CHARACTER DAT*14,TIM*8
C      CALL DATE (DAT)
C      CALL TIME (TIM)
C      CURTIM=(DAT//' , '//TIM//'    ')

C--OS2
C      INCLUDE 'FSUBLIB.FI'
C      INTEGER*2 YEAR, MONTH, DAY, HRS, MINS, SECS, HSECS
C      CALL GETDAT( YEAR, MONTH, DAY )
C      CALL GETTIM( HRS, MINS, SECS, HSECS )
C      WRITE ( CURTIM, 10 ) YEAR, MONTH, DAY, HRS, MINS, SECS, HSECS
C10    FORMAT( I4,'-',I2.2,'-',I2.2,' ',I2.2,':',I2.2,':',I2.2,'.',I2.2,'  ' )

      RETURN
      END
      SUBROUTINE HYTRA
C--MANAGE MULTIPLE CRUSTAL MODELS & CALC ALL TRAVEL TIMES & DERIVATIVES
      INCLUDE 'common.inc'
C--AA ACCUMULATES INDIVIDUAL TRAVEL TIMES & DERIVS FOR THE MODELS USED
      DIMENSION AA (MMAX,4)
C--NODE HOLDS THE CURRENT NODE NUMBER & IS TESTED FIRST FOR PROGRAM SPEED
      SAVE NODE
      DATA NODE /0/
      LOGICAL LMESS
      LMESS=KPRINT.GT.1 .AND. LPRT

C---------------- SEE IF ONLY 1 MODEL IS NEEDED -----------------------
C--USE MODEL 1 EXCLUSIVELY IF MULTIPLE MODELS ARE NOT IN USE
      IF (.NOT.LMULT) THEN
        MOD=1
        GOTO 90
      END IF
      COSLAT=COS(CLAT/RDEG)

C--IF THIS IS NOT THE FIRST ITERATION, TRY THE SAME NODE AS LAST TIME.
C  MOD SHOULD BE SET TO THE SAME MODEL AS LAST TIME. LEAVE NODE UNCHANGED.
      IF (ITR.GT.1 .AND. NODE.GT.0) THEN
        DIST=111.195* SQRT((CLAT-HLAT(NODE))**2
     2  +(COSLAT*(CLON-HLON(NODE)))**2)
        IF (DIST.LE.RAD1(NODE)) GOTO 90
      END IF

C--FOR EACH NODE IN TURN, CALC EPICENTRAL DIST & TEST IF EPI IS IN INNER CIRCLE
      DO NODE=1,NNODE
        HDIS(NODE)=111.195* SQRT((CLAT-HLAT(NODE))**2
     2  +(COSLAT* (CLON-HLON(NODE)))**2)
        IF (HDIS(NODE) .LE. RAD1(NODE)) THEN
          MOD=MODH(NODE)
          GOTO 90
        END IF
      END DO

C----------------------- TEST FOR A MIXTURE OF MODELS --------------------
C--WE NOW HAVE A MIXTURE OF MODELS OR THE DEFAULT MODEL. RECORD THIS FOR
C  THE NEXT ENTRY INTO HYTRA
      NODE=0
C--ZERO THE NODE WEIGHTS & SET THE NODE COUNTER
      MNODE=0
      DO I=1,3
        WMOD(I)=0.
      END DO

C--TEST ALL NODES TO SEE IF EPICENTER IS IN OUTER CIRCLE.
C  IF SO, RECORD IT BUT STOP AT 3 NODES
      WNORM=0.
      DO NO=1,NNODE
        IF (HDIS(NO) .LT. RAD2(NO)) THEN
          MNODE=MNODE+1
C--RECORD THE CRUST MODEL NUMBER FOR THIS NODE
          MODS(MNODE)=MODH(NO)
C--SET THE WEIGHT OF THIS MODEL FOR AVERAGING USING A COSINE TAPER
          DIST=(HDIS(NO)-RAD1(NO))/DRAD(NO)
          WMOD(MNODE)=.5+.5*COS(PI*DIST)
          WNORM=WNORM+WMOD(MNODE)

C--SKIP REMAINING NODES IF THIS MAKES 3
          IF (MNODE.EQ.3) GOTO 10
        END IF
      END DO

C--WE NOW HAVE MNODE MODELS. USE A WEIGHTED AVERAGE. THE LOGIC DEPENDS ON MNODE:
C  MNODE=0  USE 100% OF THE DEFAULT MODEL
C  MNODE=1  USE "WMOD" WEIGHT OF MODEL "MODS", 1-WMOD OF THE DEFAULT
C  MNODE=2  & WNORM>=1  USE ONLY THE 2 MODELS BUT RENORMALIZE
C    "      & WNORM <1  USE THE 2 MODELS PLUS THE DEFAULT MODEL
C  MNODE=3  USE THE 3 MODELS BUT RENORMALIZE

C--IF WE WERE OUTSIDE ALL OUTER CIRCLES, USE ONLY THE DEFAULT MODEL
10    IF (MNODE.EQ.0) THEN
        MOD=MODDEF
        GOTO 90

C--IF IN ONLY 1 OUTER CIRCLE, MIX IN SOME OF THE DEFAULT
      ELSE IF (MNODE.EQ.1) THEN
        NMOD=2
        MODS(2)=MODDEF
        WMOD(2)=1.-WMOD(1)

C--IF IN 2 CIRCLES, MIX IN SOME DEFAULT IF WE ARE NOT FULLY WEIGHTED
      ELSE IF (MNODE.EQ.2) THEN
        IF (WNORM.LT.1.) THEN
C--MIX IN SOME DEFAULT AS THE 3RD MODEL
          NMOD=3
          MODS(3)=MODDEF
          WMOD(3)=1.-WNORM
        ELSE
C--USE ONLY THE 2 MODELS, BUT RENORMALIZE THE WEIGHTS
          NMOD=2
          WMOD(1)=WMOD(1)/WNORM
          WMOD(2)=WMOD(2)/WNORM
        END IF

C--IF IN 3 CIRCLES, KEEP THEM ALL BUT RENORMALIZE WEIGHTS
      ELSE IF (MNODE.EQ.3) THEN
        NMOD=3
        DO I=1,3
          WMOD(I)=WMOD(I)/WNORM
        END DO

C------------------- CHECK THE MODELS FOR REDUNDANCY --------------------
C--CHECK THE 2ND & 3RD MODELS FOR REDUNDANCY NOW WHILE WE KNOW THERE ARE 3
        IF (MODS(2).EQ.MODS(3)) THEN
          NMOD=2
          WMOD(2)=WMOD(2)+WMOD(3)
        END IF
      END IF

C--CHECK THE 1ST & 2ND MODELS FOR REDUNDANCY. THERE MAY BE 2 OR 3 DEFINED
      IF (MODS(1).EQ.MODS(2)) THEN
        NMOD=NMOD-1
        WMOD(1)=WMOD(1)+WMOD(2)
        MODS(2)=MODS(3)
        WMOD(2)=WMOD(3)
      END IF

C--IF WE ARE LEFT WITH ONE MODEL, GO USE SINGLE MODEL LOGIC
      IF (NMOD.EQ.1) THEN
        MOD=MODS(1)
        GOTO 90
      END IF

C------------------- SORT THE MODELS BY WEIGHT -------------------------
C--MAKE SURE THE 3RD MODEL HAS THE SMALLEST WEIGHT
      IF (NMOD.EQ.3) THEN
        I=2
        IF (WMOD(1).LT.WMOD(2)) I=1      !I HAS THE LEAST WEIGHT
C--COMPARE WEIGHTS I & 3
        IF (WMOD(3).GT.WMOD(I)) THEN
          TEMP=WMOD(3)
          WMOD(3)=WMOD(I)
          WMOD(I)=TEMP
          IT=MODS(3)
          MODS(3)=MODS(I)
          MODS(I)=IT
        END IF
      END IF

C--COMPARE WEIGHTS 1 & 2 & INTERCHANGE IF NECESSARY
      IF (WMOD(2).GT.WMOD(1)) THEN
        TEMP=WMOD(2)
        WMOD(2)=WMOD(1)
        WMOD(1)=TEMP
        IT=MODS(2)
        MODS(2)=MODS(1)
        MODS(1)=IT
      END IF

C---------------- GET WEIGHTED AVERAGE OF 2 OR 3 MODELS -------------------
C--USE THE ARRAY AA TO ACCUMULATE THE TRAVEL TIME DATA
      DO 40 I=1,M
      DO 40 IT=1,4
40    AA(I,IT)=0.

C--SET THE LIMIT ON NEGATIVE EQ DEPTH TO THE MIN OF MIN ELEVS OF ALL 3 MODELS
C  FWK 1.37
      ELEVMAX=ELEVMX(MODS(1))
      DO NO=1,NMOD
        IF (ELEVMX(MODS(NO)) .LT. ELEVMAX) ELEVMAX=ELEVMX(MODS(NO))
      END DO

C--LIMIT DEPTH TO BE BELOW THE MAXIMUM ELEVATION TO AVOID PROGRAM CRASH
C  FWK 1.37
      IF (Z1.LT.ELEVMAX) THEN
        Z1=ELEVMAX
        IF (LMESS) WRITE (15,*)
     2  ' LIMIT QUAKE BELOW MINIMUM REFERENCE ELEVATION OF MODELS USED'
      END IF

C--LOOP OVER THE 2 OR 3 MODELS
      DO 50 NO=1,NMOD
        WNORM=WMOD(NO)
        MOD=MODS(NO)

C--CALC TRAVEL TIMES & DERIVS FOR ALL STATIONS. HYTRT, HYTRH, HYLINV USE ONLY
C  MOD TO DECIDE WHAT MODEL TO USE, AND KNOW NOTHING OF MULTIPLE MODELS.
        IF (MODTYP(MOD).EQ.0) THEN
          CALL HYTRT (.FALSE.)	!CALL ONCE FOR P MODEL, AGAIN FOR S IF NEEDED
          IF (MODSAL(MOD).GT.0) CALL HYTRT (.TRUE.)
        ELSE IF (MODTYP(MOD).EQ.1) THEN
          CALL HYTRH
        ELSE IF (MODTYP(MOD).EQ.2) THEN
          CALL HYLINV
        ELSE IF (MODTYP(MOD).EQ.3) THEN
          CALL HYLIN
        ELSE IF (MODTYP(MOD).EQ.4) THEN
          CALL HYTRE
        END IF

C--WEIGHT THE RESULTS & ACCUMULATE IN AA
        DO 45 I=1,M
        DO 45 IT=1,4
45      AA(I,IT)=AA(I,IT)+A(I,IT)*WNORM
50    CONTINUE

C--TRANSFER THE TRAVEL TIME DATA BACK TO A, WHICH HYLOC USES
      DO 55 I=1,M
      DO 55 IT=1,4
55    A(I,IT)=AA(I,IT)
C--BE SURE TO LEAVE MOD SET TO THE DOMINANT MODEL
      MOD=MODS(1)
      RETURN

C------------------- USE ONLY ONE MODEL -----------------------
90    NMOD=1
      MODS(1)=MOD
      WMOD(1)=1.
      ELEVMAX=ELEVMX(MOD)	!FWK 1.37
      IF (MODTYP(MOD).EQ.0) THEN
          CALL HYTRT (.FALSE.)	!CALL ONCE FOR P MODEL, AGAIN FOR S IF NEEDED
          IF (MODSAL(MOD).GT.0) CALL HYTRT (.TRUE.)
      ELSE IF (MODTYP(MOD).EQ.1) THEN
        CALL HYTRH
      ELSE IF (MODTYP(MOD).EQ.2) THEN
        CALL HYLINV
      ELSE IF (MODTYP(MOD).EQ.3) THEN
        CALL HYLIN
      ELSE IF (MODTYP(MOD).EQ.4) THEN
        CALL HYTRE
      END IF
      RETURN
      END
      SUBROUTINE HYTRE
C--GIVEN DEPTH & DISTANCE, THIS ROUTINE CALCULATES TRAVEL TIME, ITS
C--DERIVATIVES AND EMERGENCE ANGLES AT THE SOURCE FOR ALL ARRIVALS.
C  USES THE TRVCON LAYER MODEL CALCULATOR FROM HYPOELLIPSE
      INCLUDE 'common.inc'
      LOGICAL ALTMOD, SALMOD
      DIMENSION VNOW(NLYR),THKNOW(NLYR),V2NOW(NLYR)	!CURRENT MODEL
      DIMENSION VINOW(NLYR)
      CHARACTER MSTA*5				!?

C--ARRAYS FOR TRVCON ARGUMENTS (USED BY HYPOELLIPSE)
      DIMENSION TIDNOW (NLYR,NLYR), DIDNOW (NLYR,NLYR)
      DIMENSION VSQDNOW (NLYR,NLYR), FNOW (NLYR,NLYR)

C--JREF LABELS LAYERS WHICH CAN BE REFRACTORS (=1) AND TOP LAYER WHICH CANT(=0)
      DIMENSION JREF(NLYR)	!LABELS REFRACTING LAYERS
      JREF(1)=0
      DO I=2,NLYR
        JREF(I)=1
      END DO

C--THE FOLLOWING ARE PASSED THRU THE ARRAY A:
C DTDR      !TT DERIV WRT DISTANCE
C DTDZ      !TT DERIV WRT DEPTH
C T      !TRAVEL TIME
C AIN      !ANGLE OF EMERGENCE AT SOURCE

C--STILL NEED MODEL RENUMBERING CODE
      ALTMOD=MODALT(MOD).GT.0
      SALMOD=MODSAL(MOD).GT.0

C--LOOP OVER ALL ARRIVALS
      DO 280 I=1,M
C--FIND STATION INDEX AND REMOVE KPS AS AN S FLAG
      KI=IND(I)
      KPS=KI/10000
      KI=KI-10000*KPS
      J=KINDX(KI)

C--DETERMINE THE MODEL NO. TO ACTUALLY USE FOR THIS STATION
      MD=MOD
      IF (ALTMOD .AND. JLMOD(J)) MD=MODALT(MOD)
C--SWITCH TO S MODEL
      MDS=MD
      IF (SALMOD .AND. KPS.EQ.1) MD=MODSAL(MDS)

C--ZTM IS THE EQ DEPTH IN KM BELOW THE MODEL TOP (REFERENCE ELEVATION)
C  Z1 IS RELATIVE TO SEA LEVEL
      ZTM=Z1 +ELEVMX(MD)

C--PREPARE VELOCITY MODEL INFO IN 1D & 2D ARRAYS FROM COMMON AREA
      LAYNOW=LAY(MD)
      DO IL=1,LAYNOW
        VNOW(IL)=VEL(IL,MD)
        V2NOW(IL)=VSQ(IL,MD)
        THKNOW(IL)=THK(IL,MD)
        VINOW(IL)=VELI(IL,MD)
C--THESE 3D ARRAYS WERE DEFINED IN HYCRE AS MODEL WAS READ IN
        DO L=1,LAYNOW
          TIDNOW(IL,L)=TIDE(IL,L,MD)
          DIDNOW(IL,L)=DIDE(IL,L,MD)
          VSQDNOW(IL,L)=VSQDE(IL,L,MD)
          FNOW(IL,L)=FREF(IL,L,MD)
        END DO
      END DO

C--STATION DISTANCE
      DX=DIS(KI)
C--STZ IS THE STATION DEPTH IN KM BELOW THE REFERENCE ELEVATION
      STZ=ELEVMX(MD)
      IF (LELEV(MD)) STZ=ELEVMX(MD) -0.001*JELEV(J)
C--STATION CODE
      MSTA=STANAM(J)
      
C--ASSUME THE TOP OF THE MODEL SURFACE IS AT ELEVMX
C  (THE REFERENCE ELEVATION)

C--CALCULATE TRAVEL TIME & DERIVATIVES
C--VST=VELOCITY AT STATION, VEQ=VEL AT EQ (NOT USED)
C      CALL LINV(DX,Z1,VREF(MD),VGRAD(MD),T,AIN,DTDR,DTDZ,STZ,VST,VEQ)

C--THIS IS THE CALLING LIST FROM TRVDRV IN HYPOELLIPSE
C        call trvcon( delta(i), z, t(i), ain(i), dtdd, dtdh,
C     *            lbeg(imod), lend(imod), lbeg(imod)-1, nlayers,
C     *            ivlr, ivl, thk, nlay(i), ldx(i), wt(i), wtk,
C     *            tid, did, jref, vsq, vsqd, v, vi, f,
C     *            vs, vt, msta(i), stz)

C--THIS IS THE ARGUMENT LIST FROM TRVCON IN HYPOELLIPSE & HYPOINVERSE
C      subroutine trvcon(delta, zsv, t, ain, dtdd, dtdh,
C     *  lbeg, lend, lbegm1, nlayers,
C     *  ivlr, ivl, thk, nlay, ldx, wti, wtk,
C     *  tid, did, jref, vsq, vsqd, v, vi, f, vs, vt, msta, stzsv)

      CALL TRVCON (DX,	!EPICENTRAL DISTANCE IN KM
     * ZTM,		!DEPTH OF EQ BELOW MODEL TOP (REFERENCE ELEV)
     * T,		!CALCULATED TRAVEL TIME (RETURN FROM TRVCON)
     * AIN,		!CALCULATED ANGLE OF EMERGENCE AT SOURCE
     * DTDR,		!CALCULATED TT DERIV WRT DISTANCE
     * DTDZ,		!CALCULATED TT DERIV WRT DEPTH

     * 1,		!INDEX OF FIRST LAYER (LBEG)
     * LAYNOW,		!INDEX OF LAST LAYER (LEND)
     * 0,		!(LBEGM1) (LBEG-1)
     * LAYNOW,		!NUMBER OF LAYERS (NLAYERS)

     * 0,		!NO LAYER WITH VARIABLE THICKNESS (IVLR)
     * 0,		!NO LAYER WITH VARIABLE THICKNESS (IVL)
     * THKNOW,		!THICKNESS OF EACH LAYER OF CURRENT MODEL
     * 0,		!NO LAYER WITH A FORCED REFRACTION (NLAY) 
C-- (NLAY IS INPUT FROM HYPOE PHASE CARDS & INDICATES FORCED REFRACTION LAYER)
     * 0,		!NO HYPOELLIPSE LAYERED S MODELS (LDX)
C--THE FOLLOWING 2 VARIABLES ARE SET IN TRVCON BUT NEVER USED
     * WTI,		!WEIGHT (SET TO 0) FOR IMPOSSIBLE RAYS (NOT IMPLEMENTED)
     * WTK,		!WEIGHT (SET TO 0) FOR IMPOSSIBLE RAYS (NOT IMPLEMENTED)

     * TIDNOW,		!PREDEFINED ARRAYS RELATED TO REFRACTION
     * DIDNOW,		!PREDEFINED ARRAYS RELATED TO REFRACTION
     * JREF,		!RELATED TO REFRACTING LAYERS
     * V2NOW,		!VELOCITIES SQUARED OF LAYERS OF CURRENT MODEL
     * VSQDNOW,		!PREDEFINED ARRAYS RELATED TO REFRACTION

     * VNOW,		!VELOCITIES OF LAYERS OF CURRENT MODEL
     * VINOW,		!PREDEFINED ARRAYS RELATED TO REFRACTION (1/V)
     * FNOW,		!PREDEFINED ARRAYS RELATED TO REFRACTION
     * VSHYPO,		!CALCULATED VELOCITY AT HYPOCENTER
     * VSSTA,		!CALCULATED VELOCITY AT STATION
     * MSTA,		!STATION CODE FOR ERROR MESSAGE
     * STZ)		!STATION DEPTH (KM) BELOW TOP OF MODEL

C--END OF STATION LOOP
C--ASSIGN CALCULATIONS INTO ARRAY FOR INVERSION
      A(I,1)=AIN
      A(I,2)=T
      A(I,3)=DTDR
280   A(I,4)=DTDZ

      RETURN
      END
      SUBROUTINE HYTRH
C--GIVEN DEPTH & DISTANCE, THIS ROUTINE CALCULATES TRAVEL TIME, ITS
C--DERIVATIVES AND EMERGENCE ANGLES AT THE SOURCE FOR ALL ARRIVALS.
C  USES HOMOGENEOUS LAYER VELOCITY MODELS & ALGORITHMS OF HYPOLAYR/HYPO71
      INCLUDE 'common.inc'
      DIMENSION TINJ(NLYR+1),DIDJ(NLYR+1),TR(NLYR)
      LOGICAL ALTMOD, SALMOD

C--THE FOLLOWING ARE PASSED THRU THE ARRAY A:
C DTDR      !TT DERIV WRT DISTANCE
C DTDZ      !TT DERIV WRT DEPTH
C T      !TRAVEL TIME
C AIN      !ANGLE OF EMERGENCE AT SOURCE

      ZSQ=Z1*Z1
      ALTMOD=MODALT(MOD).GT.0
      SALMOD=MODSAL(MOD).GT.0

C--LOOP OVER ALL ARRIVALS
      DO 280 I=1,M
C--FIND STATION INDEX AND REMOVE KPS AS AN S FLAG
      KI=IND(I)
      KPS=KI/10000
      KI=KI-10000*KPS
      J=KINDX(KI)

C--DETERMINE THE MODEL NO. TO ACTUALLY USE FOR THIS STATION
      MD=MOD
      IF (ALTMOD .AND. JLMOD(J)) MD=MODALT(MOD)
C--SWITCH TO S MODEL
      MDS=MD
      IF (SALMOD .AND. KPS.EQ.1) MD=MODSAL(MDS)

C--STATION DISTANCE
      DX=DIS(KI)

C--JL IS THE LAYER IN WHICH THE HYPOCENTER LIES
      NL=LAY(MD)
      DO 10 L=1,NL
        IF (D(L,MD).GT.Z1) THEN
          JJ=L
          JL=L-1
          GOTO 30
        END IF
10    CONTINUE
      JL=NL

C--CALC SOME BASIC PARAMETERS FOR THIS MODEL
30    TKJ=Z1-D(JL,MD)
      TKJSQ=TKJ**2+0.000001
C--IF HYPO IS IN HALFSPACE (BOT LAYER), THEN ALL RAYS GO UP
      IF (JL.EQ.NL) GOTO 100
      TMIN=999.99

C--DETERMINE DIST OF CLOSEST CRITICALLY REFRACTED RAY XOVMAX
      DO 40 L=JJ,NL
        SQT=SQRT(VSQ(L,MD)-VSQ(JL,MD))
        TINJ(L)=HYTID(JL,L,MD)-TKJ*SQT/(VEL(L,MD)*VEL(JL,MD))
40    DIDJ(L)=HYDID(JL,L,MD)-TKJ*VEL(JL,MD)/SQT
      XOVMAX=VEL(JJ,MD)*VEL(JL,MD)*(TINJ(JJ)-HYTID(JL,JL,MD))/
     2 (VEL(JJ,MD)-VEL(JL,MD))

      DO 70 L=JJ,NL
        TR(L)=TINJ(L)+DX/VEL(L,MD)
        IF (TR(L).GT.TMIN .OR. DIDJ(L).GT.DX) GOTO 70
        K=L
        TMIN=TR(L)
70    CONTINUE
      IF (DX .LT. XOVMAX) GO TO 90

C--TRAVEL TIME & DERIVATIVES FOR REFRACTED WAVE
80    T=TR(K)
      DTDR=1.0/VEL(K,MD)
      DTDZ=-SQRT(VSQ(K,MD)-VSQ(JL,MD))/(VEL(K,MD)*VEL(JL,MD))
      ANIN=-VEL(JL,MD)/VEL(K,MD)
      GO TO 260

C--DIRECT WAVE WITH EARTHQ IN TOP LAYER
90    IF (JL.NE.1) GOTO 100
      SQT=SQRT(ZSQ+DX**2)
      TDJ1=SQT/VEL(1,MD)
      IF (TDJ1 .GE. TMIN) GO TO 80

C--TRAVEL TIME & DERIVATIVES FOR DIRECT WAVE IN FIRST LAYER
      T=TDJ1
      DTDR=DX/(VEL(1,MD)*SQT)
      DTDZ=Z1/(VEL(1,MD)*SQT)
      ANIN=DX/SQT
      GO TO 260

C--FIND A DIRECT WAVE THAT WILL EMERGE AT THE STATION
100   XBIG=DX
      XLIT=DX*TKJ/Z1
      UB=XBIG/SQRT(XBIG**2+TKJSQ)
      UL=XLIT/SQRT(XLIT**2+TKJSQ)
      UBSQ=UB**2
      ULSQ=UL**2
      DELBIG=TKJ*UB/SQRT(1.000001-UBSQ)
      DELLIT=TKJ*UL/SQRT(1.000001-ULSQ)
      J1=JL-1
      DO 110 L=1,J1
        DELBIG=DELBIG+(THK(L,MD)*UB)/SQRT(VSQ(JL,MD)/VSQ(L,MD)-UBSQ)
110   DELLIT=DELLIT+(THK(L,MD)*UL)/SQRT(VSQ(JL,MD)/VSQ(L,MD)-ULSQ)

C--SHOOT UP TO 25 RAYS TO ITERATIVELY FIND THE STATION BY TRAPPING
C--IT BETWEEN TWO RAYS
      DO 170 LL=1,25
        XTEST=DELBIG-DELLIT
        IF (XTEST.LT..02) GOTO 180
        XTR=XLIT+(DX-DELLIT)*(XBIG-XLIT)/XTEST
        U=XTR/SQRT(XTR**2+TKJSQ)
        USQ=U**2
        DELXTR=TKJ*U/SQRT(1.000001-USQ)
        DO 120 L=1,J1
120     DELXTR=DELXTR+(THK(L,MD)*U)/SQRT(VSQ(JL,MD)/VSQ(L,MD)-USQ)
        XTEST=DX-DELXTR
C--STATION IS FOUND WHEN RAY IS WITHIN .02 KM
        IF (ABS(XTEST) .LE. 0.02) GOTO 190
        IF (XTEST.LT.0.) THEN
          XBIG=XTR
          DELBIG=DELXTR
        ELSE
          XLIT=XTR
          DELLIT=DELXTR
        END IF
        IF (LL.GT.10 .AND. U.GT..9999) GOTO 190
170   CONTINUE

180   XTR=0.5*(XBIG+XLIT)
      U=XTR/SQRT(XTR**2+TKJSQ)
      USQ=U**2

C--IF U IS TOO NEAR 1, COMPUTE TDIR AS WAVE ALONG THE TOP OF LAYER JL
190   IF (U.GT..9999) THEN
        TDC=HYTID(JL,JL,MD)+DX/VEL(JL,MD)
        IF (JL.NE.NL .AND. TDC.GE.TMIN) GO TO 80
        T=TDC
        DTDR=1./VEL(JL,MD)
        DTDZ=0.
        ANIN=0.99999
        GOTO 260
      END IF

C--TRAVEL TIME & DERIVATIVES FOR DIRECT WAVE BELOW FIRST LAYER
      TDIR=TKJ/(VEL(JL,MD)*SQRT(1.-USQ))
      DO 240 L=1,J1
240   TDIR=TDIR+(THK(L,MD)*VEL(JL,MD))/(VSQ(L,MD)*SQRT(VSQ(JL,MD)/
     2 VSQ(L,MD)-USQ))
      IF(JL.NE.NL .AND. TDIR.GE.TMIN) GOTO 80
      T=TDIR
      SRR=SQRT(1.-USQ)
      SRT=SRR**3
      ALFA=TKJ/SRT
      BETA=TKJ*U/(VEL(JL,MD)*SRT)
      DO 250 L=1,J1
        STK=(SQRT(VSQ(JL,MD)/VSQ(L,MD)-USQ))**3
        VTK=THK(L,MD)/(VSQ(L,MD)*STK)
        ALFA=ALFA+VTK*VSQ(JL,MD)
250   BETA=BETA+VTK*VEL(JL,MD)*U
      DTDR=BETA/ALFA
      DTDZ=(1.-VEL(JL,MD)*U*DTDR)/(VEL(JL,MD)*SRR)
      ANIN=U
260   AIN=RDEG*ASIN(ANIN)
      IF (AIN.LT.0.) AIN=AIN+180.
      AIN=180.-AIN

C--END OF STATION LOOP
270   A(I,1)=AIN
      A(I,2)=T
      A(I,3)=DTDR
280   A(I,4)=DTDZ

      RETURN
      END

C**************************************************
      FUNCTION HYDID (J,ML,MD)
C--CALLED BY HYTRH IN PROGRAM HYPOINVERSE
      INCLUDE 'common.inc'
      HYDID=0.
      IF (ML.EQ.1) GOTO 110
      DO 20 L=1,ML-1
        SQT=SQRT(VSQ(ML,MD)-VSQ(L,MD))
        DM=THK(L,MD)*VEL(L,MD)/SQT
        FLJ=1.
        IF (L.GE.J) FLJ=2.
        HYDID=HYDID+FLJ*DM
20    CONTINUE
110   RETURN
      END

C*********************************************************
      FUNCTION HYTID (J,ML,MD)
C--CALLED BY HYTRH IN PROGRAM HYPOINVERSE
      INCLUDE 'common.inc'
      HYTID=0.
      IF (ML.EQ.1) GOTO 110
      DO 20 L=1,ML-1
        SQT=SQRT(VSQ(ML,MD)-VSQ(L,MD))
        TIM=THK(L,MD)*SQT/(VEL(L,MD)*VEL(ML,MD))
        FLJ=1.
        IF (L.GE.J) FLJ=2.
        HYTID=HYTID+FLJ*TIM
20    CONTINUE
110   RETURN
      END
      SUBROUTINE HYTRL
C--SETS THE TRIAL HYPOCENTER FOR HYPOINVERSE
      INCLUDE 'common.inc'
      KTEMP=30000

C--INCREMENT THE SEQUENCE NUMBER
      INUM=INUM+1

C--DETERMINE EARLIEST ARRIVING STATION AND USE ITS COORDS AS TRIAL LOC
      DO 20 K=1,KSTA
        LSWT=KWT(K)/10
        LPWT=KWT(K)-LSWT*10
        IF (LPWT.GT.3 .OR. KP(K).GT.KTEMP .OR. KPRK(K).EQ.' ')
     2  GO TO 20
        J=KINDX(K)
        KTEMP=KP(K)
20    CONTINUE

C--SET A TRIAL COORDINATE ONLY IF IT WASN'T GIVEN ON INST CARD
      IF (CLAT.EQ.0.) CLAT=JLATD(J)+JLATM(J)/6000.+.005
      IF (CLON.EQ.0.) CLON=JLOND(J)+JLONM(J)/6000.+.005
      IF (T1.EQ.0.) T1=KTEMP/100.-2.
      
C--ZERO-OUT GEOID PARAMETERS IN CASE STATION LIST GENERATED EVERY ITERATION
      ZGEOID=0.
      JDSTA=0
      CZFLAG=' '
      DEPDAT=0.
      
      RETURN
      END
      SUBROUTINE HYTRT (SPASS)
C--GIVEN DEPTH AND DISTANCE, THIS ROUTINE CALCULATES TRAVEL TIME AND ITS
C--DERIVATIVES, AND EMERGENCE ANGLE AT THE SOURCE FOR ALL ARRIVALS.
C--HYTRT USES A CONDENSED AND REDUCED TRAVEL TIME TABLE GENERATED 
C--BY THE PROGRAM TTGEN.
C--IND AND KINDX ARE INDEXING ARRAYS NECESSARY TO REFERENCE THE CORRECT
C--ELEMENTS OF THE STATION ARRAYS.

      INCLUDE 'common.inc'
C--ALTMOD CONTROLS THE BEHAVIOR OF HYTRT. IF F, HYTRT CALCS TT DATA FOR ALL
C  STATIONS USING MODEL MOD. IF T, HYTRT CALCS TT'S ONLY FOR STATIONS WITH
C  A DESIGNATED ALTERNATE MODEL MODALT(MOD) (IF JLMOD(J)=T)
      LOGICAL ALTMOD, SPASS

C--THESE VALUES ARE PASSED BY THE ARRAY A.
C DTDR      !TT DERIVATIVE WRT DISTANCE
C DTDZ      !TT DERIVATIVE WRT DEPTH
C T      !TRAVEL TIME
C AIN      !ANGLE OF EMERGENCE AT THE SOURCE, MEASURED IN DEGREES FROM NADIR.

C--WE DO NOT NEED THESE FOR SEVERAL MODELS AT ONCE, SINCE THE SAME
C  MODEL IS USED FOR ALL STATIONS.
C      DIMENSION VH(LN)      !VELOCITY AT HYPOCENTER
C      DIMENSION DHRZ(LN)      !DIST AT WHICH HORIZ RAY EMERGES
C      DIMENSION TZ(LN,42)      !TT AT EACH DISTANCE POINT
C      DIMENSION DTZ(LN,42)      !TT DEPTH DERIV AT EACH DISTANCE POINT

      DIMENSION TZ(42)      !TT AT EACH DISTANCE POINT
      DIMENSION DTZ(42)      !TT DEPTH DERIV AT EACH DISTANCE POINT
      SAVE SCFAC
      DATA SCFAC/2000./

C--ALLOW 2 PASSES OVER THE CALCULATIONS FOR MAIN & OPTIONAL ALTERNATE MODEL
      ALTMOD=.FALSE.
      MD=MOD
      DO 70 IPASS=1,2
      IF (IPASS.EQ.2) THEN
        MD=MODALT(MOD)
        IF (MD.EQ.0) THEN
          RETURN
        ELSE
          ALTMOD=.TRUE.
        END IF
      END IF

C--IF THIS IS THE 2ND PASS FOR THE ASSOCIATED S MODEL, RESET MODEL NUMBER
      IF (SPASS .AND. (MODSAL(MD).GT.0)) MD=MODSAL(MD)

C--PERFORM SOME PRELIMINARY CALCS AND INTERPOLATIONS WHICH DEPEND ONLY ON
C  DEPTH. DO THIS FOR EACH LINEAR GRAD MODEL ONCE.
      NZM=NZ(MD)
      NZ1M=NZ1(MD)
      NZ2M=NZ2(MD)
      DZ1M=DZ1(MD)
      DZ2M=DZ2(MD)
      LAYM=LAY(MD)
      ND1M=ND1(MD)

C--PERFORM DEPTH INTERPOLATION FIRST
C--FIND DEPTH INDEX = INDEX OF TABLE ENTRY NEAREST HYPOCENTER
C--ALSO DEPTH SPACING H AND FRACTION OF INTERVAL X
C--USE I (NEAREST POINT) FOR 3-POINT INTERPOLATION
C--USE I1 (POINT ABOVE) FOR 2-POINT INTERPOLATION
      TEMP=NZ1M*DZ1M
      IF ((.NOT.GZ1(MD) .OR. Z1.GT.TEMP) .AND. GD2(MD)) THEN

C--HYPO IN LOWER PART OF TABLE
        TMP2=(Z1-TEMP)/DZ2M
        I=NZ1M+TMP2+1.5001
        IF (I.GE.NZM) I=NZM-1
        IF (I.LT.NZ1M+2) I=NZ1M+2
        H=DZ2M
        X=TMP2-(I-NZ1M-1)
        I1=NZ1M+TMP2+1
        IF (I1.GE.NZM) I1=NZM-1
        Y=TMP2-(I1-NZ1M-1)
      ELSE

C--HYPO IN UPPER PART OF TABLE
        TMP2=Z1/DZ1M
        I=TMP2+1.5
        IF (I.GT.NZ1M) I=NZ1M
        IF (I.LT.2) I=2
        H=DZ1M
        X=TMP2-(I-1)
        I1=TMP2+1
        Y=TMP2-(I1-1)
      END IF

C--FIND EXACT VELOCITY AT HYPOCENTER. HYPO IS IN LAYER L.
      DO 20 K=1,LAYM
        IF (D(K,MD).LT.Z1) L=K
20    CONTINUE
      VH=VEL(LAYM,MD)
      IF (L.LT.LAYM) VH=VEL(L,MD)+(VEL(L+1,MD)-VEL(L,MD))
     2 *(Z1-D(L,MD))/(D(L+1,MD)-D(L,MD))

C--INTERPOLATE DIST AT WHICH A HORIZONTAL RAY EMERGES
C      DHRZ=(KDHR(MD,I)+X*(KDHR(MD,I+1)-KDHR(MD,I)))*.1
      DHRZ=(KDHR(MD,I1)+Y*(KDHR(MD,I1+1)-KDHR(MD,I1)))*.1

C--DEPTH INTERPOLATION
      IF (Z1.LE.TEMP+DZ2M*NZ2M) THEN
C--USE 3 POINT INTERPOLATION
        CA=X*.5*(X-1.)
        CB=1.-X**2
        CC=X*.5*(X+1.)
        DA=(X-.5)/H
        DB=-2.*X/H
        DC=(X+.5)/H
      ELSE
C--USE LINEAR EXTRAPOLATION
        CA=0.
        CB=1.-X
        CC=X
        DA=0.
        DC=1./H
        DB=-DC
        DHRZ=1000.
      END IF

C--INTERPOLATE TT AND ITS DEPTH DERIVATIVE FOR ALL DISTANCE GRID POINTS
      TEMP=ND1M*DD1(MD)
      DO 30 J=1,ND(MD)
        DX=(J-1)*DD1(MD)
        IF (J.GT.ND1M+1) DX=TEMP+(J-ND1M-1)*DD2(MD)
        TZ(J)=(CA*KT(MD,I-1,J)+CB*KT(MD,I,J)
     2  +CC*KT(MD,I+1,J)+32000.)/SCFAC+DX*REDV(MD)
30    DTZ(J)=(DA*KT(MD,I-1,J)+DB*KT(MD,I,J)+DC*KT(MD,I+1,J))/SCFAC

C--NOW FIND TRAVEL TIME, DTDR, DTDZ, AND ANGLE OF EMERGENCE FOR EACH ARRIVAL
C--LOOP OVER ALL ARRIVALS
      DO 60 I=1,M

C--FIND STATION INDEX 
      KI=IND(I)
      KPS=KI/10000
      KI=KI-10000*KPS
      J=KINDX(KI)

C--IF MODEL ALSO HAS AN ASSOCIATED S MODEL, CALL HYTRT TWICE, ONCE WITH SPASS=T
C  ONLY PROCESS (AND REDEFINE) S PICKS ON THE S PASS & SKIP P PICKS
      IF (SPASS .AND. KPS.EQ.0) GOTO 60

C--DECIDE WHETHER TO USE AN ALTERNATE MODEL FOR THIS STATION
C  (SKIP STATION IF WE NEED BUT DONT HAVE AN ALTERNATE CALCULATION)
      IF (ALTMOD .AND. .NOT.JLMOD(J)) GOTO 60

C--START DISTANCE INTERPOLATION
      NDM=ND(MD)
      ND1M=ND1(MD)
      ND2M=ND2(MD)
      DD1M=DD1(MD)
      DD2M=DD2(MD)
      TEMP=ND1M*DD1M

C--STATION DISTANCE
      DX=DIS(KI)

C--FIND DISTANCE INDEX = INDEX OF TABLE ENTRY NEAREST THE STATION DIST
C--ALSO DISTANCE SPACING H AND FRACTION OF INTERVAL X
      IF ((.NOT.GD1(MD) .OR. DX.GT.TEMP) .AND. GD2(MD)) THEN
C--HYPO IN FAR PART OF TABLE
        J=ND1M+(DX-TEMP)/DD2M+1.5001
        IF (J.GE.NDM) J=NDM-1
        IF (J.LT.ND1M+2) J=ND1M+2
        H=DD2M
        X=(DX-TEMP)/DD2M-(J-ND1M-1)
      ELSE
C--HYPO IN NEAR PART OF TABLE
        J=DX/DD1M+1.5
        IF (J.GT.ND1M) J=ND1M
        IF (J.LT.2) J=2
        H=DD1M
        X=DX/DD1M-(J-1)
      END IF

C--DISTANCE INTERPOLATION
      IF (DX.LE.TEMP+DD2M*ND2M) THEN
C--USE 3 POINT INTERPOLATION
        CA=X*.5*(X-1.)
        CB=1.-X**2
        CC=X*.5*(X+1.)
        DA=X-.5
        DB=-2.*X
        DC=X+.5
      ELSE
C--USE LINEAR EXTRAPOLATION
        CA=0.
        CB=1.-X
        CC=X
        DA=0.
        DC=1.
        DB=-1.
      END IF

C--INTERPOLATE TT AND ITS 2 DERIVATIVES
      A(I,2)=CA*TZ(J-1)+CB*TZ(J)+CC*TZ(J+1)
      A(I,4)=CA*DTZ(J-1)+CB*DTZ(J)+CC*DTZ(J+1)
      DTDR=(DA*TZ(J-1)+DB*TZ(J)+DC*TZ(J+1))/H
      IF (DTDR.LT.0.) DTDR=0.
      A(I,3)=DTDR

C--CALC EMERGENCE ANGLE
      CA=VH*DTDR
      IF (CA.GT..99999) CA=.99999
      AIN=RDEG*ASIN(CA)
      IF (DX.LT.DHRZ) AIN=180.-AIN
      A(I,1)=AIN

C--END OF LOOP OVER ARRIVALS
60    CONTINUE
70    CONTINUE
      RETURN
      END
      SUBROUTINE HYXMC
C--CALLED FROM HYCMD TO INITIALLY READ FILE OF STATION DUR MAG CORRECTIONS AND
C  THEIR EXPIRATION DATES.
      INCLUDE 'common.inc'
      CHARACTER STN*5,SNET*2,SCOMP*3, SLOC*2, CTYPE*1
      DIMENSION XMC(6),IXEXP(6),ITEXP(6),IYEARI(6)
      KOUNT=0

      IF (JSTA.EQ.0) THEN
        WRITE (6,1001)
1001    FORMAT (' *** ERROR: YOU CANT READ XMAG CORRECTIONS BEFORE',
     2  ' READING THE STATION FILE')
        IRES=-39
        RETURN
      END IF

C--OPTIONALLY SET ALL WEIGHTS TO ZERO IF WE WANT ONLY STAS W/ KNOWN CORRECTIONS
      IF (.NOT.LNOXMC) THEN
        DO J=1,JSTA
          JXWT(J)=0
        END DO
      END IF

C--OPEN THE STATION XMAG CORRECTION FILE
      CALL OPENR (13,XMCFIL,'F',IOS)
      IF (IOS.NE.0) THEN
C--ERROR FOR NON-EXISTENT FILE
        WRITE (6,1010)
1010    FORMAT 
     2  (' *** ERROR: STATION XMAG CORRECTION FILE DOES NOT EXIST')
        IRES=-40
        RETURN
      END IF

C--LOOP TO READ STATION XMAG CORRECTIONS
5     IF (L2000) THEN
        READ (13,1020,END=80) STN, SNET, SLOC, SCOMP, CTYPE, 
     2  (XMC(I),IYEARI(I),ITEXP(I),I=1,6)
1020    FORMAT (A5,1X, A2,A2, A3,1X, A1,1X, 6(F5.2,1X,I4,I6,1X))

      ELSE
        READ (13,1000,END=80) STN, SNET, SCOMP, CTYPE,
     2  (XMC(I),IYEARI(I),ITEXP(I),I=1,6)
1000    FORMAT (A5,1X, A2,2X, A3,1X, A1,1X, 6(F5.2,1X,I2,I6,3X))
        SLOC='  '
      END IF

C--SEARCH STATION LIST IN MEMORY FOR A MATCH (ALL LETTERS MUST MATCH,
C  UNLIKE STATION DELAYS)
      DO J=1,JSTA
        IF (STN(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2  SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3  (SLOC(1:NSLOC2) .EQ. JSLOC(J)(1:NSLOC2) .OR.
     3  SLOC(1:NSLOC2) .EQ. JSLOC2(J)(1:NSLOC2)) .AND.
     4  SCOMP(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN

C--GIVE STATION FULL WEIGHT IF WEIGHT IS CONTINGENT ON BEING IN FILE
          IF (.NOT.LNOXMC) JXWT(J)=10

C--MAKE SURE IYEARI IS THE FULL 4-DIGIT YEAR
C--TRUNCATE YEAR TO 2146, THE LARGEST STORABLE IN I*4, STORE WHOLE STATE
          DO I=1,6
            IF (IYEARI(I).LT.100 .AND. IYEARI(I).GT.0) 
     2      IYEARI(I)=IYEARI(I)+ICENT
            IF (IYEARI(I).GT.2146) THEN
              WRITE (6,1200) STN, SNET, SCOMP, IYEARI(I)
1200          FORMAT ('*** XMC EXPIRATION YEAR TOO LARGE,',
     2        ' RESET TO 2146:'/1X,A5,1X,A2,1X,A3,1X,I4)
              IYEARI(I)=2146
            END IF
            IXEXP(I)=IYEARI(I)*1000000 +ITEXP(I)
          END DO

C--IF THE TARGET DATE IS 0, JUST TAKE THE FIRST CORRECTION & EXPIRATION DATE
          IF (IXDATE.EQ.0) THEN
            I=1
          ELSE
C--SEARCH FOR THE FIRST EXPIRATION DATE AFTER THE TARGET DATE
            DO I=1,6
              IF (IXEXP(I).EQ.0 .OR. IXEXP(I).GT.IXDATE) GOTO 10
            END DO
            IXEXP(6)=0
          END IF
C--STORE THE CORRECTION & ITS EXPIRATION DATE
10        JXEXP(J)=IXEXP(I)
C  ADD 5 TO CORRECTION TO GIVE IT ZERO WEIGHT
          IF (XMC(I).GT.2.45) THEN
            JXWT(J)=0
            XMC(I)=XMC(I)-5.
          ELSE
            JXWT(J)=10
          END IF
          JXCOR(J)=NINT(XMC(I)*100.)

C--GET TYPE IF FIELD IS NON-BLANK
          IF (CTYPE.NE.' ') THEN
            READ (CTYPE,'(I1)',ERR=75) ITYPE
            JTYPE(J)=ITYPE
            GOTO 77
75          WRITE (6,1075) STN, SNET, SCOMP, CTYPE
1075        FORMAT ('*** BAD INST TYPE IN XMC FILE: ',
     2      A5,1X,A2,1X,A3,1X, A1)
          END IF
77        KOUNT=KOUNT+1
C          GOTO 5  !COMMENT OUT TO STORE DATA FOR ALL CHANNELS THAT APPLY $
        END IF
      END DO
      GOTO 5

C--END OF FILE
80    CLOSE (13)
      WRITE (6,1002) KOUNT
1002  FORMAT (I6,' STATION XMAG CORRECTIONS SET')
      RETURN

      END
c linv.for    []
c test driver for subroutine linv
c      data elevmx/3.0/, ielest/2000/, x/10./, zeq/3.0/
c      data v/3.0/, ak/1.0/
c      print *, 'welcome to linv!  this program tests subroutine'
c      print *, 'linv, which computes travel times in a half space'
c      print *, 'with linearly increasing velocity.'
c
c20    elevmx = raskk(
c     *'maximum topographic elevation (reference elevation in km)',
c     *          elevmx)
c      ielest = iaskk(
c     *'station elevation above sea level', ielest)
c      stz = elevmx - ielest*.001
c      v = raskk('velocity at reference elevation (km/s)', v)
c      ak = raskk('velocity gradient (km/s per km)', ak)
c30    x = raskk('epicentral distance (km)', x)
c      zeq = raskk('depth of eq beneath reference elevation (km)', zeq)
c
c      call linv(x, zeq, v, ak, t, ain, dtdd, dtdh, stz)
c      vsta = v + ak*(elevmx - ielest/1000.)
c      zeff = zeq - (elevmx - ielest/1000.)
c      call linvjl(x, zeff, vsta, ak, t, ain, dtdd, dtdh, stz,
c    *  vst, veq)
c
c      print *, 'linvjl results to test linv when eq is deeper',
c     * ' than station:'
c      print *, 'travel time (s) = ', t
c      ain =  asin(c      if(ain .lt. 0.) ain = 180. + ain
c      ain = 180. - ain
c      print *, 'ain in degrees = ', ain
c      print *, 'partial of tt wrt dist and depth = ', dtdd, dtdh
c
c      if(x .gt. 0.) goto 20
c      stop
c      end
      subroutine linv(x, zeq, v, ak, t, ain, dtdd, dtdh, stz,
     *  vst, veq)
c compute travel time and partial derivatives for a linear increasing
c velocity model in a region of significant topography.
      real x
c          x      epicentral distance in km
      real zeq
c          zeq    depth in km of earthquake beneath reference elevation
      real v
c          v      velocity at reference elevation in km/sec
      real ak
c          ak     velocity gradient km/sec per km
      real t
c          t      computed travel time in sec
      real ain
c          ain    angle-of-incidence
      real dtdd
c          dtdd   partial derivative of tt wrt distance
      real dtdh
c          dtdh   partial derivative of tt wrt depth
      real stz
c          stz    depth in km of station beneath reference elevation
      real vst
c          vst    velocity at station
      real veq
c          veq    velocity at earthquake
      real dz
c          dz     depth of eq beneath station
      real dc
c          dc     distance in km from eq or station, whichever is
c                 at higher elevation, to center of raypath circle
      parameter (pi = 3.14159265)
      parameter (rad = pi/180.)
      parameter (deg = 1.0/rad)
c      print *, 'station elevation (m)    = ', ielest
c      print *, 'eq depth (km)            = ', zeq
c      print *, 'epicentral distance      = ', x
c      print *, 'velocity at ref elev and grad = ', v, ak
      vst = v + ak*stz
      veq = v + ak*zeq
      dz = (zeq - stz)
      dist = sqrt(dz*dz + x*x)
      if (dist .lt. .0001) then
c       distance less than 10 cm
        t = 0.0
        dtdd = 1./veq
        dtdh = 1./veq
        anin = 1.
        ain = 90.
        return
      endif
      p = ak*ak*(x*x + dz*dz)/(2.*vst*veq) + 1.
      t = coshi(p)/ak
      if (dz .lt. 0) then
c earthqauke is above station (ray is down-going)
c        print *, 'eq is above station, dz = ', dz
        if (x .eq. 0) then
          anin = 0.0
          ain = 0.0
        else
          dc = (x*x + 2.*abs(dz)*veq/ak + dz*dz)/(2.*x)
          anin = (veq/ak) / sqrt(dc*dc + (veq/ak)**2)
          ain = deg*asin(anin)
c          print *, 'anin = ', anin
        endif
      else
c station is above earthquake (ray may be up- or down-going)
c        print *, 'station is above eq, dz = ', dz
        alam = vst*(cosh(ak*t) - 1.)/ak
        if(ak .le. .0001) alam = 0.0
        dif = dz - alam
        anin = x/sqrt(dif*dif + x*x)
      endif
      dtdd = x*ak/( vst*(vst + ak*dz)*sqrt(p*p - 1.) )
      dtdh = (dz*ak/(vst*(vst+ak*dz)) -
     *         ak*ak*(x*x + dz*dz)/(2.*vst*((vst + ak*dz)**2.)))/
     *         ((p*p - 1.)**0.5)
      if(dtdh .gt. 0.0) then
c       upgoing
        ain = 180. - deg*asin(anin)
      else
c       downgoing
        ain = deg*asin(anin)
      endif
      return
      end
c end linv
c coshi.for    []
      function coshi(x)
      p = x + sqrt(x*x - 1.)
      coshi = alog(p)
      return
      end
c end coshi
c linvol.for    []
      subroutine linvol(delta, depthsv, stzsv, ak, voa, aha, vi, t,
     *  ain, dtdd, dtdh)
c model:  linearly increasing velocity over a halfspace
c bill gawthrop  (modified by j.c. lahr  3/6/91)
c     delta  epicentral distance (km)
c     depthsv eq depth (km)
c     stzsv   station depth (km)
c     ak     velocity gradient
c     voa    v at surface
c     aha    thickness of linear layer (depth to half space)
c     vi     velocity of half space
c     t      travel time
c     ain    angle of incidence
c     dtdd   partial derivative of tt wrt distance
c     dtdh   partial derivative of tt wrt depth
      integer punt
      common /punt/ punt 
      parameter (pi = 3.14159265)
      parameter (rad = pi/180.)
      parameter (deg = 1.0/rad)
      logical flip
      dist = sqrt(delta**2 + (depthsv - stzsv)**2)
      if (dist .lt. .0001) then
c       distance less than 10 cm
        t = 0.0
        dtdd = 1./(voa + ak*depthsv)
        dtdh = 1./(voa + ak*depthsv)
        ain = 90.
        return
      endif
      if((stzsv .ge. aha - .0001) .and.
     *  (depthsv .ge. aha - .0001)) then
c both eq and station are within (or within 10 cm) of the
c constant velocity halfspace
c       write(punt, *) 'eq and station both in halfspace'
        t = dist/vi
        dtdd = delta/(dist*vi)
        dtdh = (depthsv - stzsv)/(dist*vi)
        if (stzsv .eq. depthsv) then
          ain = 90.0
        else
          if(stzsv .lt. depthsv) then
c           upward
            ain = 180 + deg*atan(delta/(stzsv - depthsv))
          else
c           downward
            ain = deg*atan(delta/(stzsv - depthsv))
          endif
        endif
        return
      endif
      if(depthsv .ge. stzsv) then
        flip = .false.
        deptha = depthsv
        stza = stzsv
      else
        flip = .true.
        deptha = stzsv
        stza = depthsv
      endif
c if near boundary, then move to boundary
      if(abs(deptha - aha) .le. .0001) deptha = aha
      if(abs(stza - aha) .le. .0001) stza = aha
c set vsource
      if(flip) then
        if(stza .le. aha) then
          vsource = voa + stza*ak
        else
          vsource = vi
        endif
      else
        if(deptha .le. aha) then
	  vsource = voa + deptha*ak
	else
	  vsource = vi
	endif
      endif
c create modified model with station at surface
      ah = aha - stza
      vo = voa + ak*stza
      depth = deptha - stza
      stz = 0.0
      if (depth .le. ah) then
c source: within the layer
c       write(punt, *) ' source: within the layer'
        vz = vo + depth*ak
c       compute time of direct wave
        call tatime(delta,depth,vo,ak,ah,tat,aina)
c       compute time of refracted wave
        call tbtime(delta,depth,vo,ak,ah,vi,tbt,ainb)
        if (tbt .lt. tat) then
c         refracted wave is faster
          t = tbt
          if(flip) then
c           downward ray
            anin = vsource*sin(ainb)/vz
            ain = asin(anin)
          else
c           downward ray
            anin = sin(ainb)
            ain = ainb
          endif
        else if (tat .eq. 900000.) then
c         neither direct nor refracted wave could be computed!
          print *,
     *      'neither direct nor refracted wave could be computed!'
          print *, 'so stop'
          stop '1: abort from linvol'
        else
c         direct wave is faster
          t = tat
          if(flip) then
c           downward ray
            anin = vsource*sin(aina)/vz
            ain = asin(anin)
          else
c           upward or downward ray
            anin = sin(aina)
            ain = aina
          endif
        endif
      else
c source: within the halfspace
c       write(punt, *) ' source: within the halfspace'
c	write(punt, *) 'delta,depth,vo,ak,ah,vi'
c	write(punt, *)  delta,depth,vo,ak,ah,vi 
        call tdtime(delta,depth,vo,ak,ah,vi,td,aina)
        if (td.eq.900000.) then
c         direct wave could not be computed!
          print *,
     *      'direct wave could not be computed, so stop!'
          stop '2: abort from linvol'
        else
c         direct wave from halfspace
          t = td
          if(flip) then
c           downward ray
            anin = vsource*sin(aina)/vi
            ain = asin(anin)
          else
c           upward ray
            anin = sin(aina)
            ain = aina
          endif
        endif
      endif
      dtdd = anin/vsource
      dtdh = -cos(ain)/vsource
      ain = deg*ain
      return
      end
c end linvol
c----------------------------
c tatime.for    []
      subroutine tatime (delta,depth,vo,ak,ah,tat,toa1)
c model:  linearly increasing velocity over a halfspace
c source: within the layer
c path:   direct wave
c   bill gawthrop  (modified by j.c. lahr  3/6/91)
c     vo   v at surface
c     ak   velocity gradient
c     ah   thickness of linear layer (depth to half space)
      if (delta.ge. 0.1) then
        a = (vo/ak)**2
        b = (vo/ak + depth)**2
        xc = (delta*delta + a - b)/(2.*delta)
        r = sqrt(xc*xc + b)
        toa1 = acos(xc/r)
        if ((r - vo/ak).gt.ah.and.toa1.le.1.57) then
          tat = 900000.
          return
        endif
        c = r*r + delta*xc - xc*xc
        tat = alog((c + r*delta)/(c - r*delta))/(2.*ak)
      else
        tat = alog((vo + depth*ak)/(vo))/ak
        toa1 = 3.1415926
      endif
      return
      end
c end tatime
c-------------------
c tbtime.for    []
      subroutine tbtime (delta,depth,vo,ak,ah,vi,tbt,toa2)
c model:  linearly increasing velocity over a halfspace
c source: within the layer
c path:   refracted wave
c   bill gawthrop  (modified by j.c. lahr  3/6/91)
c     vo   v at surface
c     ak   velocity gradient
c     ah   thickness of linear layer (depth to half space)
c     vi   velocity of half space
      character*55 mess(3)
      integer punt
      common /punt/ punt
      common /logfil/ logfil
      a = (depth + vo/ak)**2
      b = (ah + vo/ak)**2
      c = (vo/ak)**2
      r = vi/ak
      r2 = r*r
      if(b .le. r2) then
        xc1 = sqrt(r2 - a)
        xi = xc1 - sqrt(r2 - b)
        xc2 = sqrt(r2 - c)
        x2 = xc2 - xc1 + xi
        if ((delta - xi - x2) .gt. 0.0) then
          d = r2 + xi*xc1 - xc1*xc1
          e = r2 + x2*xc2 - xc2*xc2
          tbt = alog(
     *     (d + r*xi)*(e + r*x2)/((d - r*xi)*(e - r*x2))
     *          )/(2.*ak) + (delta - xi - x2)/vi
          toa2 = acos(xc1/r)
        else
          tbt = 900000.
        endif
      else
        mess(1) =  ' for a linear increase over halfspace model the'
        mess(2) =  ' velocity at the base of the linear model is '
        mess(3) =  ' greater than the half space velocity, so stop.'
        write(punt, '(a, /, a, /, a)') mess
        write(logfil, '(a, /, a, /, a)') mess
        stop 'abort from tbtime'
      endif
      return
      end
c end tbtime
c--------------------
c tdtime.for    []
      subroutine tdtime (delta, depth, vo, ak, ah, vi, tdt, toa1)
c
c model:  linearly increasing velocity over a halfspace
c source: within the halfspace
c path:   direct wave
c bill gawthrop  (modified by j.c. lahr  3/6/91)
c
c   this sub determines the traveltime of a ray from an origin
c   below the moho in constant velocity material passing thru a crust
c   with velocity increasing linearly with depth
c   bill gawthrop
c     xo   delta
c     yo   depth
c     vo   v at surface
c     ak   velocity gradient
c     ah   thickness of linear layer (depth to half space)
c     vi   velocity of half space
c     tdt
c     toa1
      double precision xp, xp2, xp3, a, b, c, d, xt1, xt2, el
      double precision xpold, xt, xr, chx, denom, xpa, xpb
      double precision r2, r
      integer punt
      common /punt/ punt
c     write(punt, *) 'in tdtime: delta, depth, vo, ak, ah, vi'
c     write(punt, *)  delta, depth, vo, ak, ah, vi 
      if ((delta .lt. .001) .or. (delta/depth .lt. .001)) then
        tdt = (depth - ah)/vi + alog((vo + ak*ah)/(vo))/ak
        toa1 = 3.1415926
c	write(punt, *) 'tdt, toa1 ', tdt, toa1
        return
      endif
      a = (vi/ak)**2
      b = a - (vo/ak)**2
      c = a - (ah + vo/ak)**2
      d = a*(depth - ah)**2
ctest
      iwrt = 0
      chx = 0.d0
    6 continue
ctest
      xp = .8d0*delta
      do 15 i = 1, 25
        xpold = xp
        xp2 = xp*xp
        xp3 = xp2*xp
        xt1 = dsqrt(d/xp2 + b)
        xt2 = dsqrt(d/xp2 + c)
        xt = xp + xt1 - xt2
        xr = xt - delta
ctest
        if (iwrt .eq. 1) write(punt, 100)
     *    i, delta, depth, xr, xpold, chx,
     *    xp, xt1, xt2, xp3
100     format(i5, 8f13.7, f13.2)
ctest
        if (dabs(xr).lt..0001d0) then
          xc = delta - xt1
          r2 = a + d/xp2
          r = dsqrt(r2)
          ta = r2 - delta*xp + delta*xc + xp*xc - xc*xc
          tb = r*delta - r*xp
          el = dsqrt((xp2 + (depth - ah)**2)*1.d0)
c	  write(punt, *) 'xc, r2, r, ta, tb, el ', xc, r2, r, ta, tb, el
          tdt = alog((ta + tb)/(ta - tb))/(2.*ak) + el/vi
          toa1 = 1.5707963 + acos(xp/el)
c	  write(punt, *) 'tdt toa1 ', tdt, toa1
c
          return
        endif
        denom = xp3*xt1
        if (denom .eq. 0.d0) then
          xp = -1.d0
        else
          xpa = d/(xp3*xt1)
          xpb = d/(xp3*xt2)
          denom = 1.d0 - xpa + xpb
          if (denom .eq. 0.) then
            xp = -1.d0
          else
            chx = xr/(1.d0 - xpa + xpb)
            xp = xp - chx
          endif
        endif
   10   continue
        if (xp .lt. 0.000001) xp = xpold/4.
   15 continue
ctest
      tdt = 900000.
      if(iwrt .eq. 1) return
      write(punt, 200) delta, depth, vo, ak, ah, vi, tdt, toa1,
     * xr, xpold, chx, xp, xt1, xt2, xp3
  200 format(' sub. tdtime convergence problem', /,
     * '         delta           z          vo           ak
     *             ah            vi         tdt         toa1', /,
     * 5x, 8f13.7, /,
     *  '    xr          xpold          chx          ',
     *  ' xp          xt1          xt2          xp3', /, 5x, 7f13.7)
      iwrt = 1
      goto 6
ctest
      end
c end tdtime
      SUBROUTINE MEDWT (LMED, N, K, KW, MED, MSD)
C--COMPUTES THE WEIGHTED MEDIAN OF N VALUES (MAGNITUDES). THE VALUES ARE IN K
C  AND THE WEIGHTS IN KW. THE MEDIAN IS RETURNED IN MED.
C--EACH WEIGHT KW MUST BE LARGER THAN 0, BUT NEED NOT BE NORMALIZED.
C--K AND KW ARE REARRANGED IN THIS PROCESS.
      LOGICAL        LMED	!T FOR WEIGHTED MEDIAN, F FOR MEAN
C      INTEGER*4      N      !THE NUMBER OF VALUES DEFINED IN K & KW.
C      INTEGER*2      K(N)      !ARRAY OF VALUES.
C      INTEGER*2      KW(N)      !WEIGHTS OF THE VALUES OF K.
C      INTEGER*4      MED      !THE RESULTING MEDIAN OF N VALUES OF K.
C      INTEGER*4      MSD	!THE RMS (STANDARD DEV) OF MED FOR MEAN ONLY
      DIMENSION K(N), KW(N)

      MSD=0
C--HANDLE THE TRIVIAL CASE OF N=1
      IF (N.LT.2) THEN
        MED=K(1)
        RETURN
      END IF

C--WEIGHTED MEDIAN
      IF (LMED) THEN
C--FIRST SORT THE VALUES OF K IN ASCENDING ORDER
        CALL SORT2 (N,K,KW)

C--GET THE TOTAL WEIGHT THEN DIVIDE BY 2
        KX=KW(1)
        DO I=2,N
          KX=KX+KW(I)
        END DO
        X=KX*.5

C--FIND THE INDEX I OF THE WEIGHT AT OR BELOW THE HALFWAY POINT
        KX=KW(1)
        DO I=2,N
          IF (KX+.5*KW(I) .GT. X) GOTO 30
          KX=KX+KW(I)
        END DO

30      I=I-1
C--HALF THE TOTAL WEIGHT X IS NOW AT I OR BETWEEN I & I+1
C  THE CUMULATIVE WEIGHT AT I   IS NOW KX-.5*KW(I)
C  THE CUMULATIVE WEIGHT AT I+1 IS NOW KX+.5*KW(I+1)
C--NOW USE LINEAR INTERPOLATION BETWEEN I AND I+1
        MED= NINT( K(I) + (K(I+1)-K(I)) * (2.*(X-KX) + KW(I)) /
     2 (KW(I+1)+KW(I)) )
      
      ELSE
C--MEAN AND SD (ACTUALLY RMS OF MAGNITUDES)
        KD=KW(1)*K(1)
        KX=KW(1)
        DO I=2,N
          KD=KD+KW(I)*K(I)
          KX=KX+KW(I)
        END DO
        IF (KX.EQ.0) WRITE (6,*) ' *** EVENT MAGNITUDE HAS 0 WEIGHT'
        S=KD
        MED=NINT(S/KX)

        S=(KW(1)*(K(1)-MED))**2
        T=KW(1)**2
        DO I=2,N
          S=S+(KW(I)*(K(I)-MED))**2
          T=T+KW(I)**2
        END DO
        MSD=NINT(SQRT(S/T))
      END IF
      RETURN
      END
C---------------------------------------------------------------------
      SUBROUTINE SORT2 (N,KA,KB)
C--THIS IS AN INTEGER VERSION OF THE HEAPSORT SUBROUTINE FROM THE NUMERICAL
C  RECIPES BOOK. KA IS REARRANGED IN ASCENDING ORDER & KB IS PUT IN THE SAME
C  ORDER AS KA.
C      INTEGER*4      N      !THE NUMBER OF VALUES OF KA TO BE SORTED
C      INTEGER*2      KA(N)      !SORT THIS ARRAY IN ASCENDING ORDER
C      INTEGER*2      KB(N)      !PASSIVELY REARRANGE THIS ARRAY TOO
C      INTEGER*2      KKA,KKB
      DIMENSION KA(N), KB(N)

      L=N/2+1
      IR=N
10    IF (L.GT.1) THEN
        L=L-1
        KKA=KA(L)
        KKB=KB(L)
      ELSE
        KKA=KA(IR)
        KKB=KB(IR)
        KA(IR)=KA(1)
        KB(IR)=KB(1)
        IR=IR-1
        IF (IR.EQ.1) THEN
          KA(1)=KKA
          KB(1)=KKB
          RETURN
        END IF
      END IF
      I=L
      J=L+L
20    IF (J.LE.IR) THEN
        IF (J.LT.IR) THEN
          IF (KA(J) .LT. KA(J+1)) J=J+1
        END IF
        IF (KKA .LT. KA(J)) THEN
          KA(I)=KA(J)
          KB(I)=KB(J)
          I=J
          J=J+J
        ELSE
          J=IR+1
        END IF
        GOTO 20
      END IF
      KA(I)=KKA
      KB(I)=KKB
      GOTO 10
      END
c trvcon.for    []
      subroutine trvcon(delta, zsv, t, ain, dtdd, dtdh,
     *  lbeg, lend, lbegm1, nlayers,
     *  ivlr, ivl, thk, nlay, ldx, wti, wtk,
     *  tid, did, jref, vsq, vsqd, v, vi, f, vs, vt, msta, stzsv)
c compute travel time and derivatives for model with constant
c    velocity layers
c indecies for this crustal structure, model number imod.  (lbegm1 = lbeg-1)
c
c    interface    index            velocity       thickness
c
c----surface------(lbeg)--------------------------------------(lstm1)---
c                                  v(lbeg)        thk(lbeg)
c
c-----------------(lbeg+1)------------------------------------(lst)-----
c                                    station is in this layer
c                                  v(lbeg+1)=vt   thk(lbeg+1)
c
c-----------------(lbeg+2) = (leqm1)--------------------------(lstp1)---
c                                  v(leqmq)       thk(leqm1)
c
c-----------------(lbeg+3) = (leq)--------------------------------------
c
c    epicenter is in this layer    v(leq)=vs       thk(leq)
c
c-----------------(lbeg+4) = (leqp1)------------------------------------
c                                  v(jj)          thk(jj)
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c-----------------(lend-1) = -------------------------------------------
c
c-top of half space-(lend)----------------------------------------------
c                                  v(lend)        infinite thickness
c
c
C FWK UNNEEDED PARAMETERS COMMENTED OUT 1/29/2011
C OTHERWISE CALCULATION CODE UNCHANGED
C      include 'params.inc'
c     HYPOELLIPSE params.inc for the SUN version
c
c     (npa - 1) is the maximum number of phases (P plus S plus S-P) for
c               a single earthquake.
C FWK      parameter (npa = 1501)

c     nsn is the maximum number of stations that can be included in the
c               station list.
c     parameter (nsn = 1024)
C FWK      parameter (nsn = 2048)

c     lmax is the maximum number of VELOCITY records allowed to define
c               the velocity models.
c     parameter (lmax = 96)
c      parameter (lmax = 128)
C FWK       parameter (lmax = 160)
      PARAMETER (LMAX=20)	!SHOULD BE THE MAX # LAYERS PER MODEL NLYR=20

c     mmax is the maximum number of velocity models that can be specified.
c     remember that a model with variable vp/vs ratio counts as two.
C FWK      parameter (mmax = 25)
C FWK      parameter (mmaxp3 = mmax+3)

c     lmmax is the maximum number of records that can be used to define
c     a single velocity model.  A model defined by N records will have
c     N-1 layers over a half space.
      parameter (lmmax = 20) 

c     lmax2 and narray are other array dimensions computed from lmax
C FWK      parameter (lmax2 = lmax + 2)
C FWK      parameter (narray = 2*lmmax*lmax)


      parameter (pi = 3.14159265)
      parameter (rad = pi/180.)
      parameter (deg = 1.0/rad)
      dimension jref(lmax)
      character*5 msta
      double precision umax, utemp, div, u1, u2, tkj, tkjsq, det, c1,
     *  c2, a, b, ac4, dmb, u0, vsqu, xtest, dlimit, d0, d1, d2, 
     *  ssqu
c     double precision top, bot
      dimension vsq(lmax), vsqu(lmax), vsqd(lmmax, lmax), v(lmax+2)
      dimension vi(lmax), thk(lmax+1)
      dimension tid(lmax, lmmax), did(lmax, lmmax), f(lmax, lmmax)
      dimension didj(lmmax), tidj(lmmax), tr(lmmax), div(lmax)
      integer punt
      DATA PUNT /6/
C FWK      common /punt/ punt
      logical flip
      idrt = 0
      tmin = 99999.
      z = zsv
      stz = stzsv
      if(abs(z - stz) .lt. 0.001) then
        stz = z
      endif
c
c decide which is deeper, station or eq
c and if station is deeper, then reverse roles for now so that
c "eq" is always deeper
      if (z .ge. stz) then
        flip = .false.
      else
        flip = .true.
        temp = z
        z = stz
        stz = temp
      endif
cd    print *, 'z = ', z, ', stz = ', stz
c determine which layer contains the hypocenter.
      sum = 0.0
      do 19 leq = lbeg, lend - 1
        sum = sum + thk(leq)
        if (z .le. sum) then
c         the hypocenter is not in the halfspace
c         leq is the layer containing the hypocenter, leqp1 is the one below,
c         and leqm1 is the one above.
          leqp1 = leq + 1
          leqm1 = leq - 1
          leqr = leq - lbegm1
c         tkj is the distance to the boundary above the eq
          tkj = z - sum + thk(leq)
          tkjsq = tkj**2
cd        print *, 'eq is in layer # ', leq, ', ', tkj, ' km below top'
          goto 23
        endif
19    continue
c the hypocenter is in the halfspace
      leq = lend
cd    print *, 'eq is in halfspace, layer ', leq
      leqm1 = leq - 1
      leqr = leq - lbegm1
      tkj = z - sum
      tkjsq = tkj**2
c set weight if this ray was supposed to be refracted
      if (nlay .ne. 0) wti = 0.0
      idrt = 1
c determine which layer contains the station
23    sum = 0.0
      do 24 lst = lbeg, lend - 1
        sum = sum + thk(lst)
        if (stz .le. sum) then
c         the station is not in the halfspace
c         lst is the layer containing the station, lstp1 is the one below,
c         and lstm1 is the one above.
          lstp1 = lst + 1
          lstm1 = lst - 1
          lstr = lst - lbegm1
c         tkjst is the distance to the boundary above the station
          tkjst = stz - sum + thk(lst)
          tkjstsq = tkj**2
cd        print *,
cd   *      'sta is in layer # ', lst, ', ', tkjst, ' km below top'
          goto 25
        endif
24    continue
c the station is in the halfspace
      lst = lend
cd    print *, 'station is in halfspace, layer ', lst
      lstm1 = lst - 1
      lstr = lst - lbegm1
      tkjst = stz - sum
      tkjstsq = tkj**2
      idrt = 1
      if (leq .eq. lst) then
c eq and station in halfspace
        vs = v(leq)
        vt = vs
        goto 43
      endif
c set the velocity at the source to vs and receiver to vt
25    if(flip) then
        vs = v(lst)
        vt = v(leq)
      else
        vs = v(leq)
        vt = v(lst)
      endif
      tjljll = tid(leq, leqr)
      djljll = did(leq, leqr)
c     correct for variable layers
      if ((ivlr .gt. 0) .and. (leq .gt. ivl) .and.
     *    (jref(leq) .ne. 0)) then
        tjljll = tjljll + thk(ivl)*vsqd(leqr, ivl)*vi(leq)
        djljll = djljll + thk(ivl)/vsqd(leqr, ivl)
        if (leq .gt. ivl + 1) then
          tjljll = tjljll + thk(ivl+1)*vsqd(leqr, ivl+1)*vi(leq)
          djljll = djljll + thk(ivl+1)/vsqd(leqr, ivl+1)
        endif
      endif
c     correct for portion of layer above station
      if ((leq .gt. lst) .and. (vsqd(leqr, lst) .ne. 0.0)) then
        tjljll = tjljll - tkjst*vsqd(leqr, lst)*vi(leq)
cd      print *, 'vsqd(leqr, lst), leqr, lst ', vsqd(leqr, lst), leqr,
cd   *    lst
        djljll = djljll - tkjst/vsqd(leqr, lst)
      endif
c     correct for full layers above station
      if(lst .gt. lbeg) then
        do 30 layer = lbeg, lst - 1
          if (vsqd(leqr, layer) .eq. 0.0) goto 30
          tjljll = tjljll - thk(layer)*vsqd(leqr, layer)*vi(leq)
          djljll = djljll - thk(layer)/vsqd(leqr, layer)
30      continue
      endif
      if ((idrt .eq. 1) .or. (delta .lt. .0001)) goto 43
c***************************************************************************
c calculations for refracted waves.
c***************************************************************************
c if this arrival is to be refracted along a certain boundary
c   calculate travel time or set weight = 0 if this refracted wave
c   can not exist.
      if (nlay .ne. 0) then
        k = nlay + 1
c       k at non-refraction boundary
        if (jref(lbeg + nlay) .eq. 0) goto 31
c       k below(?) halfspace or k above hypocenter layer
        if ((k .gt. nlayers) .or. (k .lt. leqr)) goto 31
c       refraction in layer of hypocenter (compute for direct wave)
        if (k .eq. leqr) then
          idrt = 1
          goto 43
        endif
        didj(k) = did(leq, k)-tkj/vsqd(k, leq)
        if (ivlr .gt. 0) then
          if (k .gt. ivlr) didj(k) = didj(k) +
     *      f(ivl, leqr)*thk(ivl)/vsqd(k, ivl)
          if (k .gt. ivlr+1)
     *      didj(k) = didj(k) + f(ivl+1, leqr)*thk(ivl+1)/
     *      vsqd(k, ivl+1)
        endif
        if (didj(k) .gt. delta) goto 31
        kk = nlay + lbegm1 + 1
        tmin = tid(leq, k )-tkj*vsqd(k, leq)*vi(kk) + delta*vi(kk)
        if (ivlr .le. 0) goto 42
        if (k .gt. ivlr)
     *    tmin = tmin+f(ivl, leqr)*thk(ivl)*vsqd(k, ivl)*vi(k+lbegm1)
        if (k .gt. ivlr+1) tmin = tmin + f(ivl+1, leqr)*thk(ivl+1)*
     *    vsqd(k, ivl+1)*vi(k+lbegm1)
        goto 42
c       if not possible, set p & s weights to zero.
31      wti = 0.0
        if (ldx .ne. 0) wtk = 0.0
      endif
c calculate intercept times and critical distances for all possible
c refracted waves.
      do 34 m = leqp1, lend
        mm = m - lbegm1
        tidj(mm) = 0.
        didj(mm) = 0.
        if (jref(m) .eq. 0) goto 34
        tidj(mm) = tid(leq, mm) - tkj*vsqd(mm, leq)*vi(m)
        didj(mm) = did(leq, mm) - tkj/vsqd(mm, leq)
c       correct for portion of layer above station
        tidj(mm) = tidj(mm) - tkjst*vsqd(mm, lst)*vi(m)
        didj(mm) = didj(mm) - tkjst/vsqd(mm, lst)
c       correct for full layers above station
        if(lst .gt. lbeg) then
          do 32 layer = lbeg, lst - 1
            tidj(mm) = tidj(mm) - thk(layer)*vsqd(mm, layer)*vi(m)
            didj(mm) = didj(mm) - thk(layer)/vsqd(mm, layer)
32        continue
        endif
        if ((ivlr .le. 0) .or. (m .le. ivl)) goto 34
        xtemp = f(ivl, leqr)*thk(ivl)
        tidj(mm) = tidj(mm)+xtemp*vsqd(mm, ivl)*vi(m)
        didj(mm) = didj(mm)+xtemp/vsqd(mm, ivl)
        if (m .le. ivl+1) goto 34
        xtemp = f(ivl+1, leqr)*thk(ivl+1)
        tidj(mm) = tidj(mm) + xtemp*vsqd(mm, ivl+1)*vi(m)
        didj(mm) = didj(mm) + xtemp/vsqd(mm, ivl+1)
34    continue
c xovmax is the maximum cross over distance.  at this or greater
c distance, refracted wave must be first.
      xovmax = (tidj(leqr + 1)-tjljll)/(vi(leq)-vi(leqp1))
cd    print *, 'xovmax = ', xovmax
      if (jref(leqp1) .eq. 0 .or. jref(leq) .eq. 0) xovmax = 9999.
c calculate all possible refracted wave travel-times and find least
      do 40 m = leqr + 1, nlayers
        if (delta .lt. didj(m)) goto 40
        if (jref(m+lbegm1) .eq. 0) goto 40
        tr(m) = tidj(m)+delta*vi(m+lbegm1)
        if (tr(m) .ge. tmin) goto 40
        k = m
        kk = k + lbegm1
        tmin = tr(m)
40    continue
cd    print *, 'min refracted tt and layer = ', tmin, k
c     if (delta .ge. xovmax) then
      if (delta .lt. xovmax) goto 43
c refracted wave is fastest
c relabel travel-time and find derivatives
42      t = tmin
cd      print *, 'refracted wave is fastest'
        dtdd = vi(kk)
        if(flip) then
          dtdh = -vsqd(k, lst)*dtdd
          anin = v(lst)*vi(kk)
        else
          dtdh = -vsqd(k, leq)*dtdd
          anin = v(leq)*vi(kk)
        endif
        ain = deg*asin(anin)
        return
c     endif
c*************************************************************************
c calculations for the direct waves
c*************************************************************************
43    if (leq .eq. lst) then
c for hypocenter and station in same layer
cd      print *, 'hypocenter & station in same layer'
        sqt = sqrt((stz - z)**2 + delta**2)
        tdj1 = sqt/v(leq)
        if (tdj1 .ge. tmin) goto 42
        t = tdj1
        if (sqt .lt. .0001) then
c         hypocentral distance (sqt) less than 0.1 meters
          dtdd = vi(leq)
          dtdh = vi(leq)
          ain = 90.
        else
          dtdd = delta*vi(leq)/sqt
          anin = delta/(sqt)
          if(flip) then
c           downgoing
            dtdh = -(z - stz)*vi(leq)/sqt
            ain = deg*asin(anin)
cd          print *, 'downgoing ain = ', ain
          else
c           upgoing
            dtdh = (z - stz)*vi(leq)/sqt
            ain = 180. - deg*asin(anin)
cd          print *, 'upgoing ain = ', ain
          endif
        endif
        return
      endif
c find parameters of direct wave from hypocenter not in station layer.
c invert the funct. delta(u) (where u is the sine of the angle
c    of incidence) by iterating to find u.
c    use the interpolating funct.:
c       d(u) = c/(umax - u) + a*(u - umax) + b
c    to find better values of u0 which satisfy
c    delta(u0) = given distance within some error, say .03 km.
c use a linear interpolating finction for large epicenteral
c    distances to save computing time.
c----
c find umax for this layer and velocity structure.
c (umax is less than 1 for a hypocenter in a low velocity layer)
      if (delta .lt. 0.0001) then
c vertical ray path
cd      print *, 'vertical ray path'
        u0 = 0.0
        ssqu = 1.d0
        umax = 1.0
        vsqu(lst) = (thk(lst)-tkjst)/(v(leq)/v(lst))
        if(lst+1 .le. leqm1) then
          do 52 l = lst + 1, leqm1
            vsqu(l) = thk(l)/(v(leq)/v(l))
52        continue
        endif
        goto 220
      endif
c non-vertical ray path
cd    print *, 'non-vertical ray path'
      umax = v(leq)/v(lst)
      do 54 l = lst, leqm1
        utemp = v(leq)/v(l)
        div(l) = utemp**2
        if (utemp .lt. umax) umax = utemp
54    continue
cd    print *, 'non-vertical ray.  umax = ', umax
      if (umax .gt. 1.d0) umax = 1.d0
c choose 2 initail points (u1, d1) and (u2, d2) for interpolation,
c    depending on epicentral distance.
      u1 = .75d0*umax
      u2 = delta/sqrt((z-stz)**2+delta**2)
      if (u2 .gt. umax-1.d-4) u2 = umax-1.d-4
      if (u2 .gt. u1) goto 56
      utemp = u1
      u1 = u2
      u2 = utemp
56    continue
c first take care of eq layer and station layer:
      d1 = tkj*u1/dsqrt(1.d0-u1**2) +
     *     (thk(lst) - tkjst)*u1/dsqrt(  vsq(leq)/vsq(lst) - u1**2 )
c    *     (thk(lst) - tkjst)*u1/dsqrt( (v(leq)/v(lst))**2 - u1**2 )
      d2 = tkj*u2/dsqrt(1.-u2**2) +
     *     (thk(lst) - tkjst)*u2/dsqrt(  vsq(leq)/vsq(lst) - u2**2 )
c    *     (thk(lst) - tkjst)*u2/dsqrt( (v(leq)/v(lst))**2 - u2**2 )
c then add terms for layers in between:
      if(lst+1 .le. leqm1) then
        do 58 l = lst+1, leqm1
          d1 = d1 + u1*thk(l)/dsqrt(  vsq(leq)/vsq(l) - u1**2 )
c         d1 = d1 + u1*thk(l)/dsqrt( (v(leq)/v(l))**2 - u1**2 )
          d2 = d2 + u2*thk(l)/dsqrt(  vsq(leq)/vsq(l) - u2**2 )
c         d2 = d2 + u2*thk(l)/dsqrt( (v(leq)/v(l))**2 - u2**2 )
58      continue
      endif
c begin the iteration loop.
      do 150 ll = 1, 25
cd      print *, 'u1, d1, u2, d2 ', u1, d1, u2, d2
c now find the constants a, b, c of d(u) subject to the conditions
c       d(u1) = d1, d(u2) = d2, and d(0) = 0
        det = u1*u2*(u2-u1)
        c1 = d1*u2*(umax-u1)
        c2 = d2*u1*(umax-u2)
        a = (c1-c2)/det
        b = (c1*(2.d0*umax-u2)-c2*(2.d0*umax-u1))/det
        ac4 = 4.d0*a*(a*umax**2-b*umax)
        dmb = delta - b
c invert d(u0) for u0 and find d0 = delta(u0)
        u0 = umax+(dmb-dsqrt(dmb**2+ac4))/(2.d0*a)
        ssqu = dsqrt(1. - u0**2)
        if (u0 .ge. .99999d0) then
c if wave leaves hypocenter nearly horizontally (ie u goes to 1)
c    then compute tdir as wave travelling along top of layer leq
cd        print *, 'compute tdir as wave along top of eq layer'
          tdir = tjljll + delta*vi(leq)
          if (tdir .lt. tmin) then
c           travel time derivatives for hypocenter at top of a layer
            t = tdir
            if(flip) then
c             downgoing
              anin = v(lst)*vi(leq)
              ain =  deg*asin(anin)
              dtdh = -sqrt(1. - anin**2)*vi(lst)
              dtdd = vi(leq)
            else
c             upgoing
              ain = 90.
              dtdh = 0.0
              dtdd = vi(leq)
            endif
            return
          endif
          goto 42
        endif
        if (u0 .ge. umax-1.d-6) then
          u0 = umax-1.d-6
          ssqu = dsqrt(1. - u0**2)
        endif
        d0 = tkj*u0/ssqu
        vsqu(lst) = (thk(lst) - tkjst)/dsqrt( vsq(leq)/vsq(lst)-u0**2)
c       vsqu(lst) = (thk(lst) - tkjst)/dsqrt((v(leq)/v(lst))**2-u0**2)
        d0 = d0 + u0*vsqu(lst)
        if(lst+1 .le. leqm1) then
          do 112 l = lst+1, leqm1
            vsqu(l) = thk(l)/dsqrt( vsq(leq)/vsq(l)-u0**2)
c           vsqu(l) = thk(l)/dsqrt((v(leq)/v(l))**2-u0**2)
            d0 = d0 + u0*vsqu(l)
  112     continue
        endif
c set the distance accuracy of iteration.
        dlimit = .04d0
        if (u0 .lt. .05d0 ) goto 113
        dlimit = .015d0*v(leq)/u0
c test to see if new ray is within required distance accuracy.
  113   xtest = dabs(delta-d0)
        if (xtest  .lt.  dlimit) then
cd        print *, 'trvcon converged direct ray in ', ll, ' iterations'
          goto 220
        endif
c prepare to iterate again
c replace (u1, d1) or (u2, d2) by the new point (u0, d0)
        if (delta .lt. d2) goto 114
        d1 = d2
        u1 = u2
        d2 = d0
        u2 = u0
        goto 150
  114   if (delta .gt. d1) goto 116
        d2 = d1
        u2 = u1
        d1 = d0
        u1 = u0
        goto 150
  116   if (delta .lt. d0) goto 118
        d1 = d0
        u1 = u0
        goto 150
  118   d2 = d0
        u2 = u0
  150 continue
c if solution of direct wave does not converge in 25 iterations
      uu = asin(u0)*deg
      if (uu .lt. 0.0) uu = uu + 180.
      uu = 180. - uu
      write(punt, 172) msta, delta, z, uu, xtest, dlimit
  172 format(' travel-time solution for a direct wave from station ',
     *  a5, ' at distance ', f6.2, ' from depth ', f6.2,
     *  / ' emerging at an angle of ', f10.4,
     *  ' iterated to the limit.', /,
     *  ' came within ', f10.4, ' km.  xlimit = ', f10.4/)
c travel time & derivatives for direct wave below first layer.
  220 continue
      tdir = tkj*vi(leq)/ssqu
      do 240 l = lst, leqm1
        tdir = tdir + v(leq)*vsqu(l)/vsq(l)
240   continue
cd    print *, 'compare tdir and tmin ', tdir, tmin
      if (tdir .ge. tmin) goto 42
c     if refracted wave is faster than direct wave goto 42
c direct wave is faster
cd    print *, 'direct wave is faster than refracted'
      t = tdir
cd    print *, 'umax, u0 ', umax, u0
      if (umax-u0 .lt. .00001) then
cd      print *, 'umax - u0 .lt. .00001 '
cd      print *,
cd   *    'asin(umax), asin(u0) ', deg*asin(umax), asin(u0)
c       horizontal ray at lower limit
        if(flip) then
c         downgoing
          anin = v(lst)*vi(leq)
          ain = deg*asin(anin)
          dtdh = -sqrt(1. - anin**2)*vi(lst)
          dtdd = vi(leq)
        else
c         upgoing
          ain = 90.
          dtdh = 0.0
          dtdd = vi(leq)
        endif
        return
      endif
c compute partial derivative wrt distance (is independent of flip)
c     bot = 0.d0
c     top = 0.d0
c     do 250 l = lst, leqm1
c       term = (vsq(leq)*vsqu(l)**3)/(vsq(l)*thk(l)**2)
c       bot = bot + term
c       top = top + term*u0/v(leq)
c50   continue
c     dtdd1 = top/bot
c     simplify the formula to:
      dtdd = abs(u0)*vi(leq)
cd    print *, 'flip = ', flip
      if(flip) then
c       downgoing
cd	print *, 'downgoing, lst = ', lst
        anin = abs(u0*v(lst)*vi(leq))
        ain = deg*asin(anin)
        ssqu = sqrt(1.0 - anin**2)
c       dtdh1 = (v(lst)*anin*dtdd - 1.0)/(ssqu*v(lst))
c       simplify the formula to:
        dtdh = -sqrt(1. - anin**2)*vi(lst)
c	print *, 'dtdh fancy, plain = ', dtdh1, dtdh
      else
c       upgoing
cd	print *, 'upgoing, leq = ', leq
        anin = abs(u0)
        ain = 180. - deg*asin(anin)
c       dtdh1 = (1.0 - v(leq)*u0*dtdd)/(ssqu*v(leq))
c       simplify the formula to:
        dtdh = sqrt(1. - anin**2)*vi(leq)
c	print *, 'dtdh fancy, plain = ', dtdh1, dtdh
      endif
      return
      end
c end trvcon
      SUBROUTINE UTMCAL(ORLAT,ORLON,DLAT,DLON,XS,YS,DIST)
C--CALCULATE THE POSITION OF ONE POINT RELATIVE TO ANOTHER ON A UNIVERSAL
C  TRANSVERSE MERCATOR GRID

C      ORLAT AND ORLON ARE THE LATITUDE AND LONGITUDE OF THE REFERENCE POINT
C         IN DECIMAL DEGREES
C      DLAT AND DLON ARE THE LATITUDE AND LONGITUDE OF THE POINT
C         TO BE PROJECTED IN DECIMAL DEGREES
C      XS IS THE X COORDINATE OF THE PROJECTION
C      YS IS THE Y COORDINATE OF THE PROJECTION
C      DIST IS THE DISTANCE BETWEEN THE TWO POINTS

      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 ORLAT,ORLON,DLAT,DLON,XS,YS,DIST

      DATA A /6378206.4/
      DATA ESQ /0.00676866/
C      DATA AKO /0.9996/
      DATA AKO /1.0/

C      DEGRAD = 3.14159/180.
      DATA DEGRAD /.0174532/

      OLATD = ORLAT
      OLAT = OLATD*DEGRAD
      OLON = ORLON*DEGRAD
      ALATD = DLAT
      ALAT = ALATD*DEGRAD
      ALON = DLON*DEGRAD
      SLAT = DSIN(ALAT)
      CLAT = DCOS(ALAT)
      TLAT = DTAN(ALAT)

      EPSQ = ESQ/(1.- ESQ)
      BIGN = A/DSQRT(1. - ESQ*SLAT*SLAT)
      BIGT = TLAT*TLAT
      BIGC = EPSQ*CLAT*CLAT
      BIGA = (ALON-OLON)*CLAT

      BIGM  = 111132.0894*ALATD - 16216.94*DSIN(2.*ALAT) + 
     +          17.21*DSIN(4.*ALAT) - 0.02*DSIN(6.*ALAT)
      BIGMO = 111132.0894*OLATD - 16216.94*DSIN(2.*OLAT) + 
     +          17.21*DSIN(4.*OLAT) - 0.02*DSIN(6.*OLAT)
      
      BIGA2 = BIGA*BIGA
      BIGA3 = BIGA2*BIGA
      BIGA4 = BIGA3*BIGA
      BIGA5 = BIGA4*BIGA
      BIGA6 = BIGA5*BIGA

      BIGT2 = BIGT*BIGT
      BIGC2 = BIGC*BIGC

      X = AKO*BIGN*(BIGA + (1. - BIGT + BIGC)*BIGA3/6. + 
     +      (5. - 18.*BIGT + BIGT2 + 72*BIGC - 58.*EPSQ)*BIGA5/120.)

      Y = AKO*(BIGM - BIGMO + BIGN*TLAT*(BIGA2/2. + (5. - 
     +       BIGT + 9.*BIGC + 4.*BIGC2)*BIGA4/24. + (61. - 58.*BIGT + 
     +       BIGT2 + 600.*BIGC - 330.*EPSQ)*BIGA6/720.))

      XS = X/1000.
      YS = Y/1000.
      DIST = SQRT(X*X + Y*Y)/1000.

      RETURN
      END