c$NOFLOATCALLS
C--HYP IS THE VAX & DEC PC VERSION OF THE LOCATION PROGRAM HYPOINVERSE.
C--THE PROGRAM IS DESIGNED TO BE COMPACT, FAST, FILE ORIENTED AND
C--COMMAND DRIVEN.

C--WRITTEN BY FRED KLEIN, 1/85 VERSION
c
c   updates
c   nov 93 by jh : chance include file names to .inc, put in lower case
c                  remove refernece to file 20 and 25
c   feb 99       : ---------------    verison 7.0 check ---------------
c                  put hypinv1, hypinv2 and hypinv3 in main program
c                  PROGRAM ONLY USES FIRST 4 CHARS OF 5 CHAR STATION CODES
c    oct 2000    : read station minutes as f5.3 instead of f5.2

C--CHECK IN G COL REQUIRES GENERAL PARAM COMMON /D/ & /C/ (HYPCOM.inc)        *
C--CHECK IN C COL REQUIRES CRUST MODEL COMMON BLOCKS /M/ & /MC/ (HYPCOMC.inc
C--CHECK IN T COL REQUIRES THE TRAVEL TIME TABLE INCLUDE FILE HYPCOMT.INC  *
C--CHECK IN A COL REQUIRES THE INVERSION ARRAY INCLUDE FILE HYPCOMA.INC    *
C--CHECK IN P COL REQUIRES PLOT PARAMETER COMMON BLOCK /P/ (HYPCOMP.INC    *
C--CHECK IN V COL REQUIRES THE STATION NAME INCLUDE FILE HYPCOMV.INC
C--BLOCK /P/ IS FOR PLOT PARAMETERS & IS FUNCTIONAL ON THE PC350 ONLY.
C--COL O SPECIFIES THE OVERLAY BRANCH (R IS THE ROOT) IN THE PC350 ONLY.

C--FILES MARKED WITH * DIFFER SLIGHTLY BETWEEN VAX & PC350 VERSIONS.
C--PLACES WHERE CHANGES OCCUR ARE CLEARLY MARKED WITH "PC350" OR "VAX".

C++++++++++++++++ LIST OF REQUIRED SUBROUTINES +++++++++++++++++
C          G C T A P V O
C  HYP	   X X X X X X R * MAIN PROGRAM.
C  HYBDA   X X     X   R * BLOCK DATA INITIALIZATION OF COMMON.
C  HYBEG               1 * EXECUTABLE CODE TO INITIALIZE HYPOINVERSE.
C  HYCMD   X           1 * GETS AND IDENTIFIES COMMANDS.
C  HYCM1   X X         1 * PROCESSES PARAMETER & FILE COMMANDS.
C  HYSTA   X         X 1 * READS IN STATIONS.
C  HYCRH     X         1   READS IN HOMOGENOUS LAYER CRUSTAL MODELS.
C  HYCRT     X X       1   READS IN TRAVEL-TIME-TABLE CRUSTAL MODELS.
C  HYSTL   X X       X 4 * OUTPUTS STATIONS, CRUST & PARAMETERS TO PRINT FILE.
C			    ALSO OPENS FILES, ETC.
C  HYPHS   X         X 3   READS IN PHASE DATA FOR ONE EVENT.
C  HYPHS2  X         X 3   READS RAW PICKER DATA FROM A FILE.
C  HYTRL   X           3   SETS TRIAL HYPOCENTER.
C  HYLOC   X   X X     2 * LOCATES ONE EVENT.
C  HYSOL   X     X     2   PERFORMS INVERSION FOR ONE ITERATION.
C  HYSVD         X     2 * CANNED SINGLE-VALUE-DECOMPOSITION ROUTINE.
C  HYTRH   X X         2 * CALC TRAVEL TIMES AND DERIVS FOR HOMO LAYER MODEL.
C  HYTRT   X X X       2 * CALC TRAVEL TIMES AND DERIVS FROM TRAV-TIME TABLE.
C  HYMAG   X           3   COMPUTES ALL MAGNITUDES.
C  HYREP   X           3   REPORTS A LOCATION ON THE TERMINAL.
C  HYLST   X     X   X 3   OUTPUTS DATA BY STATION TO PRINT & ARCHIVE FILES.
C  HYSUM   X           3   OUTPUTS SUMMARY RECORD (FINAL LOCATION).
C  HYNEW   X           3   SETS UP NEW OUTPUT FILES FOR EACH DAY.
C  HYINP               4   FOR INTERACTIVE ENTRY OF PHASE DATA.

C  HYCM2           X   1   PROCESSES PLOT PARAMETER COMMANDS.
C  JDAT                R   STORES & RETRIEVES INTEGER STATION DATA.
C  HYPLT   X       X   5   PLOTS EVENTS FROM SUMMARY FILE ON MAP & AS LOCATED.
C  HYFRM           X   5   PLOTS MAP FRAME.
C  HYKEY           X   5   PLOTS SYMBOL KEY.
C  HYSHF           X   5   SHIFTS TIME INTERVALS AND REFRESHES THE SCREEN.
C  HYLIN           X   5   PLOTS LINES & STATIONS.
C  HYSYM           X   5   PLOTS ONE EARTHQUAKE.
C  SYMBOL              5   PLOTS AN EARTHQUAKE SYMBOL.
C  CURSOR              1   DIGITIZES A SCREEN COORDINATE TO RESET MAP CENTER.
C  HYPHS3  X         X 3   READS RAW PICKER DATA FROM THE COMM PORT.
C  NEWCHR              3   BUFFERS CHARACTERS FROM COMM PORT.
C			    (ABOVE 12 ROUTINES FOR PC350 VERSION ONLY)

C  CLASS               3   ASSIGNS A 3-LETTER NAME TO AN EVENT BASED ON LOCATION
C  KLASS               3   ASSIGNS A REGION NUMBER TO AN EVENT.
C  UPSTR               1   CONVERTS A STRING TO UPPER CASE.
C  JASK	             4,1   INTERACTIVE PROMPT & ENTRY OF AN INTEGER.
C  DAYJL             1,5   CALCULATES JULIAN DAY GIVEN DATE.
C  JDATE             1,5   CALCULATES DATE GIVEN JULIAN DAY.
C  ASKC                1   INTERACTIVE PROMPT AND ENTRY OF A STRING.
C  ASKR                1   INTERACTIVE PROMPT AND ENTRY OF A REAL VALUE.
C  LASK                1   INTERACTIVE PROMPT AND ENTRY OF A LOGICAL VALUE.
C  LENG              1,5   DETERMINES THE NON-BLANK LENGTH OF A STRING.

C++++++++++++++++ I/O DEVICE NUMBERS USED ++++++++++++++++++++++
C  3  KEYBOARD SIGNAL TO INTERRUPT REAL-TIME LOCATIONS (PC350 ONLY)
C  5  TERMINAL INPUT & OUTPUT.
C  6  ERROR MESSAGE OUTPUT TO TERMINAL.
C  7  ARCHIVE OUTPUT FILE.
C  8  COMMAND LINE SCRATCH FILE, & LINE PLOTTING INPUT FILE.
C  9  GRAPHICS OUTPUT (PC350 ONLY)
C 10  BINARY (CONTROL SEQUENCE) OUTPUT TO TERMINAL (PC350 ONLY)
C 11  SCRATCH FILES FOR PLOTTING INTERVALS.
C 12  SUMMARY OUTPUT FILE (& INPUT SUMMARY FILE FOR PLOTTING)
C 13  INPUT COMMAND FILE.
C 14  CRUST, STATION & PHASE INPUT FILES.
C 15  PRINT OUTPUT FILE.
C 16  COMMUNICATIONS PORT FOR PICKER INPUT (PC350 ONLY)

C	INCLUDE 'HYPCOM./LIST'
c$INCLUDE:'HYPCOM.'
      include 'hypcom.inc'

C	INCLUDE 'HYPCOMC./NOLIST'
c$INCLUDE:'HYPCOMC.'
      include 'hypcomc.inc'

C	INCLUDE 'HYPCOMP./NOLIST'	!PC350 VERSION ONLY
c$INCLUDE:'HYPCOMP.'
      include 'hypcomp.inc'

C	INCLUDE 'HYPCOMT./LIST'
c$INCLUDE:'HYPCOMT.'
       include 'hypcomt.inc'

C	INCLUDE 'HYPCOMV./LIST'
c$INCLUDE:'HYPCOMV.'
      include 'hypcomv.inc'
C	INCLUDE 'HYPCOMA./LIST'
c$INCLUDE:'HYPCOMA.'
      include 'hypcoma.inc'
C--THESE ARE FOR THE KEYPRESS BUFFER FOR INTERRUPTING LOCATIONS (PC350 ONLY)
	INTEGER STATQ(2),PRL(6)

	LOGICAL LPLT
	DATA LASDAY /0/

	DATA KEYBUF,PRL /0,0,1,4*0/
C  PRL(1) WILL HAVE THE ADDRESS OF KEYBUF (NEEDED BY QIO) ASSIGNED BY GETADR
C  PRL(2) TELLS QIO HOW MANY BYTES TO GET
C  KEYBUF WILL CONTAIN THE ASCII CODE OF THE KEY PRESSED

C--GO DO SOME EXECUTABLE INITIALIZATION
c	OPEN(25,FILE='OVSI.MEC',STATUS='unknown')
c	OPEN(20,FILE='OVSI.BOL',STATUS='unknown')
	CALL HYBEG (INP)
C	WRITE(*,767) INP
C767	FORMAT(I3)
C--GO GET A COMMAND AND EXECUTE IT. RETURN HERE IF CALLING A
C--SUBROUTINE WHICH CAN BE OVERLAYED WITH HYCMD.
5	CALL HYCMD (MOD)
	LPLT=.TRUE.
	LDRW=.FALSE.	
C!PC350 VERSION ONLY

C--ISTAT DIRECTS WHICH SUBROUTINE OR LOCATION SECTION TO INVOKE.
	GOTO (10,12,14,74,78,80,82,18,22,26), ISTAT
	GOTO 5

C--<CRH> READ A HOMOGENEOUS LAYER CRUSTAL MODEL
10	CALL HYCRH (MOD)
	CLOSE (14)
	GOTO 5

C--<CRT> READ A LINEAR GRADIENT CRUSTAL MODEL
12	CALL HYCRT (MOD,KDHR,KT)
	CLOSE (14)
	GOTO 5

C--<STA> READ STATION FILE
14	CALL HYSTA (STANAM)
	CLOSE (14)
	GOTO 5

C--<PLR> PLOT EVENTS FROM A SUMMARY FILE WITHOUT ERASING SCREEN (PC350 ONLY)
18	KODE=3
	GOTO 79

C--<LOR> CONTINUE LOCATING & PLOTTING EVENTS WITHOUT PLOTTING FROM A
C        SUMMARY FILE OR REDRAWING SCREEN. (PC350 ONLY)
22	KODE=6
	GOTO 81

C--<LOX> RESUME EQ. LOCATIONS AFTER REPLOTTING SCREEN FROM YMD.SUM FILES
C	(PC350 ONLY)
26	KODE=4
	GOTO 81

C--<INP> ENTER PHASE DATA MANUALLY INTO A CONDENSED FORMAT FILE
C	ALSO SET THE CONDENSED PHASE FORMAT FLAG TO TRUE
74	CALL HYINP
	GOTO 5

C--<PLT> PLOT EVENTS FROM SUMMARY FILE - PC350 VERSION ONLY
78	KODE=1

79	CONTINUE
C	CALL HYPLT
	GOTO 5

C--<LOP> PLOT EARTHQUAKES FROM SUMMARY FILE, THEN LOCATE A PHASE FILE,
C	PLOTTING EVENTS ALONG THE WAY. 
C	EVENT PLOTTING IS FUNCTIONAL IN PC350 VERSION ONLY.
80	KODE=2

81	CONTINUE
C	CALL HYPLT
	GOTO 84

C++++++++++++++++++++ EARTHQUAKE LOCATION SECTION ++++++++++++++++++

C--LOCATE ALL EARTHQUAKES IN THE SPECIFIED FILE, USING PRESENT PARAMETERS
C--<LOC>

82	LPLT=.FALSE.

C--GO OPEN FILES AND INITIALIZE SOME VALUES, ALSO
C--OPTIONALLY LIST AVAILABLE STATIONS & MODELS IN PRINT FILE
84	CALL HYSTL (STANAM)
	DO 85 I=1,MMAX
85	IMPORT(I)=0

C--STOP NOW IF THERE IS NO PHASE FILE
	IF (ISTAT.EQ.0) GOTO 5

C--SET PLOT CODE FOR LOCATE & PLOT MODE
	KODE=5

C--IF WE ARE LOCATING EQS IN REAL-TIME, QUEUE UP AN INTERRUPTING KEYPRESS
C  TO GO INTO KEYBUF. CALL QIO ONCE, THEN TEST TO SEE IF KEYBUF IS NON ZERO
C  WHENEVER IT IS CONVENIENT TO STOP THE LOCATIONS. THE 528 MEANS "READ
C  WITH NO ECHO".
	IF (JCP.EQ.5) THEN
C	  CALL GETADR (PRL(1),KEYBUF)
C	  CALL QIO (528,3,1,,STATQ,PRL)
	END IF

C--LOCATE ONE EARTHQUAKE FOR EACH PASS THRU THE FOLLOWING LOOP.
C--READ IN PHASE DATA FOR ONE EVENT
50	IF (JCP.LT.4) THEN

C--READ PHASE DATA IN 3 STANDARD FORMATS
	  CALL HYPHS (STANAM)
	ELSE
	  IF (JCP.EQ.4) THEN

C--READ RAW PICKER DATA FROM A FILE
C	    CALL HYPHS2 (STANAM)
	  ELSE

C--READ RAW PICKER DATA FROM THE COMM PORT
C	    CALL HYPHS3 (STANAM,LPLT,KEYBUF,PRL)
	  END IF
	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--OPTIONALLY CLOSE & REOPEN SUMMARY & ARCHIVE FILES AT END OF A DAY
C  (PC350 VERSION ONLY)
C	IF (LRTP .AND. LASDAY.NE.KDAY) CALL HYNEW

C--OPTIONALLY PLACE A PAGE EJECT BETWEEN EVENTS
	IF (LPRT.AND.LEJCT) WRITE (15,1012)
1012	FORMAT ('1')
	IF (LPRT.AND..NOT.LEJCT) WRITE (15,1008)
1008	FORMAT (1X,40('##'))

C--SET THE TRIAL HYPOCENTER
	CALL HYTRL

C--LOCATE THE EVENT
	CALL HYLOC (KDHR,KT,STANAM,A,W,R,IMPORT,MTCAL)

C--ASSIGN A 3-LETTER CODE BASED ON LOCATION
C	IF (NET.GT.0) CALL CLASS (REMK,NET,CLAT,-CLON,Z1)

C--CALCULATE THE EARTHQUAKE'S MAGNITUDE
	CALL HYMAG
C
C	IF(FMAG.EQ.0.) FMAG=XMAG
	IF(FMAG.GE.3.5) THEN
c	WRITE(20,681)
C	WRITE(25,681)
681	FORMAT('     ')
	END IF
C	IF(FMAG.GE.3.0) THEN
C	WRITE(25,681)
C	END IF
C--GENERATE PRINTED AND ARCHIVE OUTPUT
	CALL HYLST (STANAM,A,W,R,IMPORT,MTCAL)
C
C--OUTPUT SUMMARY DATA
	IF (NWR.GT.3) CALL HYSUM
C
C--OPTIONALLY PLOT THE EVENT ON THE SCREEN (PC350 VERSION ONLY)
C	LDRW = LNEWL .AND. LASDAY.NE.0 .AND. LASDAY.NE.KDAY
C	IF (LPLT .AND. NWR.GT.3) CALL HYPLT 

C--OUTPUT A MESSAGE ON THE CONSOLE FOR EACH EVENT
	IF (LREP) CALL HYREP (LPLT)

C--ABORT THE LOOP IF THERE ARE NOT ENOUGH READINGS
	IF (NWR.LT.4) GOTO 50

C--OUTPUT AN EVENT TERMINATOR TO ARCHIVE FILE
	IF (LARC) WRITE (7,1010)
1010	FORMAT (1X)

C--SAVE DAY TO SEE IF IT CHANGES
	LASDAY=KDAY

C--END OF LOCATION LOOP
	IF (KEND.EQ.0) GOTO 50

C--CLOSE FILES THEN GET ANOTHER COMMAND
70	IF (LSUM) CLOSE (12)
	IF (LARC) CLOSE (7)
	IF (LPRT) CLOSE (15)
c	IF (LPRT) CLOSE (20)
	CLOSE (14)
c	CLOSE (25)

C--IN THE PC350 VERSION, CLOSE THE CURRENT PLOT SCRATCH FILE
	IF (LINT.AND.LPLT) CLOSE (11)
 
C--IN THE PC350 VERSION, REASSIGN THE PRINTFILE UNIT # TO THE DISK
C--IN CASE OUTPUT WAS SENT DIRECTLY TO THE PRINTER.
C	CALL ASNLUN (15,'DW',1)
c	GOTO 5
	END
cccccccccccccccccccccccccccccc

c
c   changes
c
c   nov 93 by jh: include files to lower case and extension .inc
c                 hypinst to lower case
c
	SUBROUTINE HYBEG (INP)
C--EXECUTABLE INITIALIZATION OF HYPOINVERSE

C--AVOID PRINTING ERROR MESSAGES FOR THESE FORTRAN ERROR NUMBERS
C--(END OF FILE, NO SUCH FILE, LIST DIRECTED I/O SYNTAX)
C--PC350 VERSION ONLY
C	DIMENSION IERS(4)
C	DATA IERS/24,29,59,64/

C--DONT GIVE ERROR MESSAGES WHEN DATA OVERFLOW OUTPUT FIELDS
C--VAX VERSION ONLY
C	CALL ERRSET (63,.TRUE.,.FALSE.,.FALSE.,.FALSE.)

C--AVOID PRINTING CERTAIN ERROR MESSAGES - PC350 VERSION ONLY
C--DONT REPORT OUTPUT OVERFLOWS
C	CALL ERRSET (63,.TRUE.,.FALSE.,.FALSE.,.FALSE.,.TRUE.,.TRUE.)
C	DO 1 I=1,4
C	CALL ERRSET (IERS(I),.TRUE.,.FALSE.,.TRUE.,.FALSE.)
C1	CONTINUE

C--OPEN THE SCRATCH FILE FOR FREE-FORMAT DECODING OF PARAMETERS
	OPEN (8,FILE='HYTEMP.XXX',STATUS='unknown',FORM='FORMATTED')

C--SEND A MESSAGE TO THE TERMINAL. THIS ALSO ASSIGNS UNIT 5 TO THE
C  TERMINAL BEFORE UNIT 3 IS ASSIGNED THERE BY THE QIO CALL
	WRITE (*,1000)
1000	FORMAT (' HYPOINVERSE STARTING')

C--OPEN AND BEGIN READING THE OPTIONAL STARTUP COMMAND FILE HYPINST
 	INP=5
c       INP=0
	OPEN (13,FILE='hypinst',STATUS='OLD',FORM='FORMATTED',
     2IOSTAT=IOC)
	IF(IOC.GT.0) GO TO 5
	INP=13
5	RETURN
	END
	SUBROUTINE HYCMD (MOD)
C--CALLED BY HYPOINVERSE TO GET A COMMAND, THEN ACT ON IT.
C--SOME SIMPLE COMMANDS, SUCH AS TO PLOT OR LOCATE, ARE INTERPRETED HERE,
C--AND CONTROL IS IMMEDIATELY RETURNED TO HYP TO CALL APPROPRIATE ROUTINES.
C--PLOT COMMANDS ARE HANDLED IN HYCM2.
C--SETTING OF PARAMETERS & READING SOME INPUT FILES ARE HANDLED IN HYCM1.

C	INCLUDE 'HYPCOM./NOLIST'
c$INCLUDE:'HYPCOM.'
      include 'hypcom.inc'
	PARAMETER (NCMD=61)
	CHARACTER CMD(NCMD)*3
	LOGICAL LINST

C--CMD HOLDS THE NAMES OF ALL COMMANDS RECOGNIZED BY THIS ROUTINE.
C--THE STRUCTURE OF THIS STATEMENT MATCHES THAT OF THE COMPUTED GOTO
C--STATEMENTS IN THIS & THE HYCM1 & HYCM2 ROUTINES.
	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','CTR','SCA','SHF','LIN','STP','MAG','INT',
     6 'SYM','CLR','DEP','TIM','RES','SET','CUR','HUE',
     7 'STO','CRH','CRT','STA','INP','PLT','LOP','LOC',
     8 'PHS','RTP','FRM','TIT','DSK','DEV','PLR','LOR',
     9 'LOX','MIN','PIP','BAD','CLK'/

C++++++++++++++++++ COMMAND INTERPRETER ++++++++++++++++++++
C	WRITE(*,888) INP
C888	FORMAT(I3)
C--SUPPLY A PROMPT IF READING FROM THE TERMINAL
5	IF (INP.EQ.0) WRITE (*,1011)
1011    FORMAT (' COMMAND? ',$)

C--READ A COMMAND LINE
	READ (INP,1012,END=9) CM,INST
1012	FORMAT (A3,A80)

C--A STRING PRECEDED BY @ IS INTERPRETED AS A FILENAME TO HOP TO
	IF (CM(1:1).EQ.'@') THEN
	  IF (INP.EQ.13) CLOSE (13)
	  INP=13
	  INFILE(1:2)=CM(2:3)
	  INFILE(3:30)=INST
	  OPEN (13,FILE=INFILE,STATUS='OLD',FORM='FORMATTED',
     2IOSTAT=IOC)
	IF(IOC.GT.0) GO TO 32
	  GOTO 5
	END IF

C--IF THE FIRST CHARACTER IS #, EXECUTE THE SYSTEM COMMAND WHICH FOLLOWS
C--VAX VERSION ONLY:
C	IF (CM(1:1).EQ.'#') THEN
C	  INST(3:80)=INST
C	  INST(1:2)=CM(2:3)
C	  CALL LIB$SPAWN (INST)
C	  GOTO 5
C	END IF

C--DETERMINE WHETHER THE PARAMETER FIELD IS BLANK & IF SO SUPPLY PROMPTS
	LINST=INST(1:10).EQ.'          '
	IF (.NOT. LINST) THEN
C--WRITE THE PARAMETER FIELD TO A SCRATCH FILE FOR LATER DECODING
	  REWIND 8
	  WRITE (8,1013) INST
1013	  FORMAT (A80)
	  REWIND 8
	END IF

C--BE SURE THE COMMAND IS UPPERCASE
	CALL UPSTR (CM,3)

C--SEARCH THE COMMAND LIST
C--COMMANDS REFERENCING 500 ARE PROCESSED IN HYCM1,
C--COMMANDS REFERENCING 600 ARE PROCESSED IN HYCM2, THE REST ARE HANDLED HERE
	DO 8 I=1,NCMD
	ICMDX=I
	IF (CM.EQ.CMD(ICMDX)) GOTO (
     2 500,500,500,500,500,500,500,500,
     3 500,500,500,500,500,500,500,500,
     4 500,500,500,500,500,500,500,500,
     5 500,600,600,600,600,600,600,600,
     6 600,600,600,600,600,600,600,600,
     7 140,500,500,500,156,160,164,166,
     8 500,600,600,600,600,500,168,170,
     9 172,500,600,600,600), ICMDX
8	CONTINUE

C--OUTPUT AN ERROR MESSAGE
	WRITE (*,1001) CM
1001	FORMAT (' *** COMMAND NOT FOUND: 'A3'  ***')
	GOTO 5

C--RETURN TO INTERACTIVE MODE AT END OF COMMAND FILE
9	IF (INP.EQ.0) RETURN
	CLOSE (13)
C	INP=5
	INP=0
	GOTO 5

C******************** COMMAND PROCESSORS *************************

C--<STO> STOP THE PROGRAM
140	CLOSE (8,STATUS='DELETE')
	STOP

C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT FILES
C32	INP=5
32	INP=0
	WRITE (*,1015)
1015	FORMAT (' *** ERROR - INPUT FILE DOES NOT EXIST ***')
	GOTO 5

C--<INP> ENTER PHASE DATA MANUALLY
156	ISTAT=4
	RETURN

C--<PLT> PLOT EVENTS FROM SUMMARY FILE
160	ISTAT=5
	RETURN		
C !PC350 VERSION
C	GOTO 600	!VAX VERSION

C--<LOP> LOCATE & PLOT EVENTS
164	ISTAT=6
	RETURN		
C !PC350 VERSION
C	GOTO 600	!VAX VERSION

C--<LOC> LOCATE EVENTS
166	ISTAT=7
	RETURN

C--<PLR> RESUME PLOTTING SUMMARY EVENTS - DO NOT ERASE SCREEN
168	ISTAT=8
	RETURN		
C !PC350 VERSION
C	GOTO 600	!VAX VERSION

C--<LOR> RESUME LOCATING & PLOTTING - DO NOT ERASE SCREEN
170	ISTAT=9
	RETURN		
C !PC350 VERSION
C	GOTO 600	!VAX VERSION

C--<LOX> RESUME LOCATING & PLOTTING EVENTS AFTER REPLOTTING SCREEN
C        FROM YMD.SUM FILES
172	ISTAT=10
	RETURN		
C !PC350 VERSION
C	GOTO 600	!VAX VERSION

C--GO PROCESS THE PARAMETER & FILENAME COMMANDS IN HYCM1
500	CALL HYCM1 (ICMDX,LINST,MOD)

C--IF THE COMMAND REQUESTED READING A CRUST OR STATION FILE, DO IT IN
C--THE MAIN PROGRAM.
	IF (ISTAT.GT.0) RETURN
	GOTO 5

C--GO PROCESS A PLOT PARAMETER COMMAND IN HYCM2 (PC350 VERSION ONLY).
600	CONTINUE
C	CALL HYCM2 (ICMDX,LINST,CM,INST)

C--PRINT AN ERROR MESSAGE IN THE VAX VERSION
C	TYPE *,' COMMAND NOT AVAILABLE IN VAX VERSION'
	GOTO 5
	END
	SUBROUTINE UPSTR (STR,LEN)
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.
	CHARACTER STR,CHAR*26
	DATA CHAR/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
	DO 2 I=1,LEN
	J=ICHAR(STR(I:I))-96
	IF (J.GT.0 .AND. J.LT.27) STR(I:I)= CHAR(J:J)
2	CONTINUE
	RETURN
	END
	SUBROUTINE HYCM1 (ICMDX,LINST,MOD)
C--CALLED BY HYCMD TO DECODE & STORE TEST PARAMETERS FROM COMMANDS

c$INCLUDE:'HYPCOMC.'
      include 'hypcomc.inc'
c$INCLUDE:'HYPCOM.'
      include 'hypcom.inc'
	LOGICAL LINST

C--BRANCH TO THE APPROPRIATE COMMAND PROCESSOR
C--THIS GOTO CORRESPONDS IN STRUCTURE TO THE COMMAND LIST IN HYCMD
C--CERTAIN VALUES OF ICMDX (CORRESPONDING TO GOTO 5) SHOULD NEVER OCCUR
	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,  5,  5,  5,  5,  5,  5,  5,
     6   5,  5,  5,  5,  5,  5,  5,  5,
     7   5,144,148,152,  5,  5,  5,  5,
     8 168,  5,  5,  5,  5,172,  5,  5,
     9   5,176,  5,  5,  5), ICMDX
	GOTO 5

C******************** COMMAND PROCESSORS *************************

C--<SUM> SET SUMMARY OUTPUT FILENAME
10	IF (LINST) THEN
	  CALL ASKC('EARTHQUAKE SUMMARY FILE (NONE FOR NONE)',SUMFIL,
     2 30,39)
	ELSE
	  READ (8,*,ERR=3) SUMFIL
	END IF
	LSUM=.NOT. (SUMFIL(1:4).EQ.'NONE')
	GOTO 5

C--<ARC> SET ARCHIVE OUTPUT FILENAME
12	IF (LINST) THEN
	  CALL ASKC('ARCHIVE FILE (NONE FOR NONE)',ARCFIL,30,28)
	ELSE
	  READ (8,*,ERR=3) ARCFIL
	END IF
	LARC=.NOT. (ARCFIL(1:4).EQ.'NONE')
	GOTO 5

C--<PRT> SET PRINTER OUTPUT FILENAME
14	IF (LINST) THEN
	  CALL ASKC('PRINTOUT FILE (NONE FOR NONE)',PRTFIL,30,29)
	ELSE
	  READ (8,*,ERR=3) PRTFIL
	END IF
	LPRT=.NOT. (PRTFIL(1:4).EQ.'NONE')
	GOTO 5

C--<ERF> SEND ERROR MESSAGES TO TERMINAL AS WELL AS PRINT FILE
16	IF (LINST) THEN
C	  LERR=LASK('SEND ERROR MESSAGES TO TERMINAL',LERR,31)
	ELSE
	  READ (8,*,ERR=3) LERR
	END IF
	GOTO 5

C--<LST> FLAG TO LIST AVAILABLE STATIONS & CRUST ON THE PRINTER
20	IF (LINST) THEN
	  WRITE (*,1001)
1001	  FORMAT (' PRINT CODE: 0=EQS ONLY, 1=ADD PARAMS & FILES,')
	  JST=JASK('2=ADD STATIONS & CRUST',JST,22)
	ELSE
	  READ (8,*,ERR=3) JST
	END IF
	GOTO 5

C--<KPR> PARAMETER TO CONTROL AMOUNT OF PRINTOUT
22	IF (LINST) THEN
	  KPRINT=JASK('PRINT QUANTITY CONTROL (0-6)',KPRINT,28)
	ELSE
	  READ (8,*,ERR=3) KPRINT
	END IF
	GOTO 5

C--<TOP> FLAG TO PAGE EJECT BEFORE EACH EVENT
24	IF (LINST) THEN
C	  LEJCT=LASK('PRINT PAGE EJECT FOR EACH EVENT',LEJCT,31)
	ELSE
	  READ (8,*,ERR=3) LEJCT
	END IF
	GOTO 5

C--<REP> FLAG TO REPORT EACH EVENT ON TERMINAL AS LOCATED
26	IF (LINST) THEN
C	  LREP=LASK('REPORT EACH EVENT AS LOCATED',LREP,28)
	ELSE
	  READ (8,*,ERR=3) LREP
	END IF
	GOTO 5

C--<COP> READ PHASE DATA IN CONDENSED FORMAT
28	IF (LINST) THEN
	  JCP=JASK('PHASE FORMAT (1=FULL 2=CONDENSED 4=PIKR',JCP,39)
	ELSE
	  READ (8,*,ERR=3) JCP
	END IF
	GOTO 5

C--<CAR> WRITE ARCHIVE DATA IN CONDENSED FORMAT
30	IF (LINST) THEN
	  JCA=JASK('ARCHIVE FORMAT (1=FULL 2=CONDENSED',JCA,34)
	ELSE
	  READ (8,*,ERR=3) JCA
	END IF
	GOTO 5

C--<DLY> STATION DELAY PARAMETERS
34	READ (8,*,ERR=3) KDLY
	IF (KDLY.LT.3) GOTO 5
	REWIND 8
	READ (8,*,ERR=3) KDLY,DLYAZ,DLYWD,DLYLON,DLYLAT
	GOTO 5

C--<CON> TERMINATING LOCATION UPON CONVERGENCE
38	IF (LINST) THEN
	  ITRLIM=JASK('MAX ITERATIONS',ITRLIM,14)
	  DQUIT=ASKR('MIN HYPOCENTER ADJUSTMENT',DQUIT,25)
	  DRQT=ASKR('MIN RMS CHANGE',DRQT,14)
	ELSE
	  READ (8,*,ERR=3) ITRLIM,DQUIT,DRQT
	END IF
	GOTO 5

C--<DAM> ITERATION AND DAMPING CONTROLS
42	READ (8,*,ERR=3) DXFIX,DZMAX,DZAIR,DAMP,EIGTOL,RBACK,BACFAC
	GOTO 5

C--<DUR> DURATION MAG CONSTANTS
46	READ (8,*,ERR=3) FMA1,FMB1,FMZ1,FMD1,
     2 FMA2,FMB2,FMZ2,FMD2,FMBRK
	GOTO 5

C--<DIS> DISTANCE WEIGHT PARAMETERS
50	IF (LINST) THEN
	  ITRDIS=JASK('ITERATION TO BEGIN DISTANCE WEIGHTING',IRTDIS,37)
	  DISCUT=ASKR('DISCUT (KM)',DISCUT,11)
	  DISW1=ASKR('DISW1 FACTOR',DISW1,12)
	  DISW2=ASKR('DISW2 FACTOR',DISW2,12)
	ELSE
	  READ (8,*,ERR=3) ITRDIS,DISCUT,DISW1,DISW2
	END IF
	GOTO 5

C--<RMS> RMS WEIGHTING PARAMETERS
52	IF (LINST) THEN
	  ITRRES=JASK('ITERATION TO BEGIN RESIDUAL WEIGHTING',IRTRES,37)
	  RMSCUT=ASKR('RMSCUT (KM)',RMSCUT,11)
	  RMSW1=ASKR('RMSW1 FACTOR',RMSW1,12)
	  RMSW2=ASKR('RMSW2 FACTOR',RMSW2,12)
	ELSE
	  READ (8,*,ERR=3) ITRRES,RMSCUT,RMSW1,RMSW2
	END IF
	GOTO 5

C--<SWT> S ARRIVAL WEIGHTING FACTOR
54	IF (LINST) THEN
	  SWT=ASKR('S WEIGHT FACTOR',SWT,15)
	ELSE
	  READ (8,*,ERR=3) SWT
	END IF
	GOTO 5

C--<POS> VP/VS VELOCITY RATIO
56	IF (LINST) THEN
	  POS=ASKR('P/S VELOCITY RATIO',POS,18)
	ELSE
	  READ (8,*,ERR=3) POS
	END IF
	GOTO 5

C--<ZTR> TRIAL DEPTH
58	IF (LINST) THEN
	  ZTR=ASKR('TRIAL DEPTH, NEG TO FIX DEPTH',ZTR,29)
	ELSE
	  READ (8,*,ERR=3) ZTR
	END IF
	GOTO 5

C--<ERR> ESTIMATED READING & TIMING ERROR
60	READ (8,*,ERR=3) RDERR
	GOTO 5

C--<ERC> WEIGHTING FACTOR OF RMS IN ERROR CALCS
62	READ (8,*,ERR=3) ERCOF
	GOTO 5

C--<NET> NET FOR ASSIGNING 3-LET. NAMES BASED ON LOCATION
64	IF (LINST) THEN
	  NET=JASK('NET: 1=HAWAII 2=LONG-VAL',NET,24)
	ELSE
	  READ (8,*,ERR=3) NET
	END IF
	GOTO 5

C--<H71> SET SUMMARY FORMAT TYPE
66	IF (LINST) THEN
C	  LH71=LASK('SUMMARY FORMAT: F=HYPOINV T=HYPO71',LH71,34)
	ELSE
	  READ (8,*,ERR=3) LH71
	END IF
	GOTO 5

C--<SHO> WRITE INPUT FILENAMES
70	WRITE (*,1020)
1020	FORMAT (/' INPUT FILES:',$)
	WRITE (*,1021) INFILE,STAFIL,PHSFIL
1021	FORMAT (' COMMANDS: 'A/' STATIONS: 'A/' PHASES: 'A)

	DO 25 I=1,3
	IF (MODTYP(I).EQ.0) WRITE (*,1022) I,CRUFIL(I)
1022	FORMAT (' LINEAR  GRADIENT  CRUST'I2':  'A,$)
	IF (MODTYP(I).EQ.1) WRITE (*,1023) I,CRUFIL(I)
1023	FORMAT (' HOMOGENEOUS LAYER CRUST'I2':  'A,$)
25	CONTINUE

C--WRITE OUTPUT FILENAMES
	WRITE (*,1029)
1029	FORMAT (/' OUTPUT FILES:',$)
	IF (LPRT) WRITE (*,1030) PRTFIL
1030	FORMAT (' PRINTOUT: 'A,$)
	IF (LSUM) WRITE (*,1031) SUMFIL
1031	FORMAT (' SUMMARY:  'A,$)
	IF (LARC) WRITE (*,1032) ARCFIL
1032	FORMAT (' ARCHIVE:  'A,$)
	GOTO 5

C--<APP> INDICATE WHETHER OUTPUT FILES SHOULD BE APPENDED TO
C  ORDER IS 1=PRINT 2=SUMMARY 3=ARCHIVE
74	IF (LINST) THEN
C	  LAPP(1)=LASK('APPEND TO PRINT FILE',LAPP(1),20)
C	  LAPP(2)=LASK('APPEND TO SUMMARY FILE',LAPP(2),22)
C	  LAPP(3)=LASK('APPEND TO ARCHIVE FILE',LAPP(3),22)
	ELSE
	  READ (8,*,ERR=3) LAPP
	END IF
	GOTO 5

C--<CRH> READ ONE OF THE 3 HOMO LAYER CRUSTAL MODELS
144	IF (LINST) THEN
	  MOD=JASK('CRUST MODEL NO. (1-3)',1,21)
	  IF (MOD.LT.1 .OR. MOD.GT.3) THEN
	    WRITE (*,1014)
1014	    FORMAT (' INVALID CRUST MODEL NO.')
	    GOTO 5
	  END IF
	  CALL ASKC('CRUST MODEL FILENAME',CRUFIL(MOD),30,20)
	ELSE
	  READ (8,*,ERR=3) MOD,CRUFIL(MOD)
	END IF

C--OPEN FILE & READ MODEL
	OPEN (14,FILE=CRUFIL(MOD),STATUS='OLD',FORM='FORMATTED',
     2IOSTAT=IOC)
	IF(IOC.GT.0) GO TO 33
	LTRH=.TRUE.
	ISTAT=1
	RETURN

C--<CRT> READ ONE OF THE LINEAR GRADIENT CRUSTAL MODELS
148	IF (LINST) THEN

C--THIS LINE FOR THE VAX VERSION ONLY:
C	  MOD=JASK('CRUST MODEL NO. (1-3)',1,21)
C--THIS LINE FOR THE PC350 VERSION ONLY:
	  MOD=1
  	  CALL ASKC('CRUST MODEL FILENAME',CRUFIL(MOD),30,20)
	ELSE
	  READ (8,*,ERR=3) MOD,CRUFIL(MOD)
	  IF (MOD.LT.1 .OR. MOD.GT.LN) THEN
	    WRITE (*,1014)
	    GOTO 5
	  END IF
	END IF

C--OPEN FILE & READ MODEL
	OPEN (14,FILE=CRUFIL(MOD),STATUS='OLD',FORM='FORMATTED',
     2IOSTAT=IOC)
	IF (IOC.GT.0) GO TO 33
	LTRT=.TRUE.
	ISTAT=2
	RETURN

C--<STA> READ IN A LIST OF SEISMIC STATIONS
152	IF (LINST) THEN
	  CALL ASKC('STATION FILENAME',STAFIL,30,16)
	ELSE
	  READ (8,*,ERR=3) STAFIL
	END IF
	OPEN (14,FILE=STAFIL,STATUS='OLD',FORM='FORMATTED',
     2IOSTAT=IOC)
	IF (IOC.GT.0) GO TO 33
	ISTAT=3
	RETURN

C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT FILES
33	WRITE (*,1015)
1015	FORMAT (' *** ERROR - INPUT FILE DOES NOT EXIST ***')
	GOTO 5

C--<PHS> SPECIFY PHASE INPUT FILE
168	IF (LINST) THEN
	  CALL ASKC('PHASE FILENAME',PHSFIL,30,14)
	ELSE
	  READ (8,*,ERR=3) PHSFIL
	END IF
	GOTO 5

C--<DEV> SET DEV & DIR SPECIFIER FOR YMD.SUM & YMD.ARC FILES
172	IF (LINST) THEN
	  CALL ASKC('DEVICE & DIRECTORY FOR YMD.SUM & YMD.ARC FILES',
     2 DEV,20,46)
	ELSE
	  READ (8,*,ERR=3) DEV
	END IF
	NDEV=LENG(DEV,20)
	GOTO 5

C--<MIN> 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,39)
	ELSE
	  READ (8,*,ERR=3) MINSTA
	END IF
	GOTO 5

C--OUTPUT A MESSAGE ON A FREE-FORMAT DECODING ERROR
3	WRITE (*,1000) CM
1000	FORMAT (' *** ERROR IN 'A3' PARAMETERS - TRY AGAIN ***')

C--RETURN TO HYCMD
5	ISTAT=0
	RETURN
	END
	SUBROUTINE ASKC (PROMPT,STRING,MAXLEN,LENP)

C--ASKC PROMPTS THEN READS A CHARACTER STRING FROM THE TERMINAL.
C--THE ORIGINAL VALUE IS UNCHANGED BY A CR RESPONSE.
C	PROMPT = PROMPT STRING
C	STRING = CHARACTER RESPONSE, OR ORIGINAL STRING ON CR.
C	MAXLEN = MAX LENGTH OF THE ARGUMENT "STRING"
C	LENP   = BYTE LENGTH OF PROMPT STRING.

	CHARACTER PROMPT, STRING, TEMP*40
	I=LENG(STRING,MAXLEN)
3	WRITE (*,1000) PROMPT(1:LENP),STRING(1:I)
1000	FORMAT (1X,A/' [CR=',A,']?',$)
	READ (*,1001,ERR=3) TEMP
1001	FORMAT (A)
	IF(TEMP(1:2).EQ.'  ') THEN
	NCH=0
	ELSE
	NCH=1
	END IF
	IF (NCH.EQ.0) GOTO 9
	I=40
	IF (MAXLEN.LT.40) I=MAXLEN
	STRING(1:I)=TEMP(1:I)
9	RETURN
	END
	SUBROUTINE HYCRH (MOD)
C--READS A HOMOGENEOUS LAYER CRUSTAL MODEL FOR HYPOINVERSE
C	INCLUDE 'HYPCOMC./LIST'
c$INCLUDE: 'HYPCOMC.'
      include 'hypcomc.inc'
	MODTYP(MOD)=1
	LAY(MOD)=0
	READ (14,1002,END=20,ERR=20) MODNAM(MOD)
1002	FORMAT (A20)
C
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
C--DEFINE THK FOR HALFSPACE
20	THK(LAY(MOD),MOD)=999.
	RETURN
C
C--BAD DATA
22	WRITE (*,1001) MOD
1001	FORMAT (' BAD DATA FOR CRUST MODEL'I2)
	RETURN
	END
	SUBROUTINE HYCRT (MOD,KDHR,KT)
C--READS A TRAVEL TIME TABLE FOR A LINEAR GRADIENT CRUST MODEL
C--CALLED BY HYPOINV
C	INCLUDE 'HYPCOMC./LIST'
C	INCLUDE 'HYPCOMT./LIST'
c$INCLUDE: 'HYPCOMC.'
c$INCLUDE: 'HYPCOMT.'
      include 'hypcomc.inc'
      include 'hypcomt.inc'
C--IDENTIFY THE MODEL MOD AS A LINEAR GRADIENT TABLE
	MODTYP(MOD)=0
C
C--READ HEADER INFO
	READ (14,1000) MODNAM(MOD),LAY(MOD),REDV(MOD)
1000	FORMAT (A20,I2,F8.4)
C
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
C--READ DISTANCE & DEPTH GRID INFO
      READ (14,1003) DD1(MOD),ND1(MOD),DD2(MOD),ND2(MOD),
     2DZ1(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
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

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c$DEBUG
	SUBROUTINE HYSTA (STANAM)
C--READ IN STATION LIST & COORDINATES FOR HYPOINV
C	INCLUDE 'HYPCOM./NOLIST'
C	INCLUDE 'HYPCOMV./LIST'
c$INCLUDE: 'HYPCOM.'
c$INCLUDE: 'HYPCOMV.'
      include 'hypcom.inc'
      include 'hypcomv.inc'
C--THE INTEGER STATION DATA IN THE VAX VERSION IS STORED IN COMMON.
C--THE DATA IN THE PC350 VERSION IS STORED IN VIRTUAL MEMORY, WHICH IS
C--WRITTEN BY 1 CALL TO JDAT, AND READ BY FUNCTION ENTRIES TO JDAT.

C--LOOP TO READ STATIONS INTO LOOK-UP TABLE
	DO 20 J=1,MAXSTA
	JSTA=J-1
C--VAX VERSION
	READ (14,1000,END=30,ERR=40) STANAM(J),CTEMP,JLATD(J),ALAT,IS,
     2 JLOND(J),ALON,IE,PER,MODS,MODP,PD1,PD2,XMC,FMC,ITYPE,CAL
C--PC350 VERSION
C      READ (14,1000,END=30,ERR=40) STANAM(J),CTEMP,ILATD,ALAT,IS,
C     2ILOND,ALON,IE,PER,MODS,MODP,PD1,PD2,XMC,FMC,ITYPE,CAL
1000	FORMAT (A4,A1,I2,1X,F5.3,A1,I3,1X,F5.3,A1,4X,F3.1,1X,2I1,
     24(1X,F5.2),1X,I1,F6.2)

C--CORRECT VALUES WHICH ARE OUT OF RANGE
	IF (PER.GT.1.9) PER=1.9
	IF (PER.LT..1) PER=.2
	IF (CAL.LT.0.) CAL=0.
	IF (CAL.GT.49.9) CAL=49.9
	IF (MODP.LT.1 .OR. MODP.GT.3) MODP=1
	IF (MODS.LT.1 .OR. MODS.GT.3) MODS=MODP
	IF (ITYPE.GT.2) ITYPE=1

C--STORED LAT & LON ARE POSITIVE N & W
C--USE NEG LAT FOR SOUTH, NEG LON FOR EAST
	IF (IS.EQ.'S') THEN
	  JLATD(J)=-JLATD(J)	
C!VAX VERSION
C	  ILATD=-ILATD		
C!PC350 VERSION
	  ALAT=-ALAT
	END IF
	IF (IE.EQ.'E') THEN
	  JLOND(J)=-JLOND(J)	
C !VAX VERSION
C	  ILOND=-ILOND		
C!PC350 VERSION
	  ALON=-ALON
	END IF

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

C--STORE STATION WEIGHT IN UNITS OF 0.1 FROM 0.0 TO 1.0
	IF (CTEMP.EQ.'*') THEN
	  JWT=0
	ELSE
	  READ (CTEMP,1001) JWT
1001	  FORMAT (I1)
	  IF (CTEMP.EQ.' ') JWT=10
	END IF

C--STORE MAGNITUDE CORRECTIONS
	KTEMP=JNINT(XMC*10.)
	KTEMP2=JNINT(FMC*10.)
	JMCOR(J)=KTEMP2+KTEMP*100+2525	
C!VAX VERSION
C	IMCOR=KTEMP2+KTEMP*100+2525	
C!PC350 VERSION

C--STORE P DELAYS
	JPD1(J)=JNINT(PD1*100.)
C!VAX VERSION
	JPD2(J)=JNINT(PD2*100.)
C!VAX VERSION
C	IPD1=NINT(PD1*100.)	
C!PC350 VERSION
C	IPD2=NINT(PD2*100.)	
C!PC350 VERSION

C--STORE STATION WEIGHT & CRUST MODELS
	JMOD(J)=100*JWT+10*MODP+MODS	
C !VAX VERSION
C	IMOD=100*JWT+10*MODP+MODS	
C!PC350 VERSION

C--STORE STATION TYPE, CAL FACTOR & PERIOD
	KTEMP=JNINT(CAL*10.)
	KTEMP2=JNINT(PER*10.)
	JCAL(J)=ITYPE*10000+KTEMP2*500+KTEMP	
C !VAX VERSION
C	ICAL=ITYPE*10000+KTEMP2*500+KTEMP	
C!PC350 VERSION

C--NOW STORE DATA FOR ONE STATION IN VIRTUAL MEMORY (PC350 ONLY)
C	I=JDAT(J,ILATD,ILATM,ILOND,ILONM,ICAL,IMCOR,IMOD,IPD1,IPD2)

20	CONTINUE

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

C--COME HERE FOR READ ERROR
40	WRITE (*,1002)
1002	FORMAT (' ERROR READING STATION FILE')
	STOP
	END
	SUBROUTINE HYINP
C--CALLED BY HYPOINVERSE TO PROMPT FOR PHASE DATA & OUTPUT IT TO A FILE
C--IN CONDENSED FORMAT.
	LOGICAL LALL
	CHARACTER STA*4,STAS(100)*4,IFL*40,CHR*1,PRMK*4,SRMK*4,RMK*4
	CHARACTER SCHR(100)*1,ACHR(100)*1,CCHR(100)*1
C--TELL HYPOINVERSE TO READ THE NEXT PHASE FILE IN CONDENSED FORMAT
C	JCP=2
C--INITIALIZE DATA
	PRMK=' P  '
	SRMK=' S  '
	IY=0
	IM=0
	ID=0
	IH=0
	IN=0

C--PROMPT FOR & OPEN OUTPUT FILE
	WRITE (*,1000)
1000	FORMAT (' CONDENSED PHASE DATA OUTPUT FILENAME?',$)
	READ (*,1001) IFL
1001	FORMAT (A)
	OPEN (14,FILE=IFL,STATUS='unknown',FORM='FORMATTED')
C--LOOK FOR LIST OF STATIONS TO PROMPT FOR ON FILE 'STALIST.'
C--IF STALIST IS NOT THERE, REQUEST ANOTHER FILENAME.
	OPEN (12,FILE='STALIST.',STATUS='OLD',FORM='FORMATTED',
     2IOSTAT=IOC)
	IF(IOC.GT.0) GO TO 10
	GOTO 15
10	WRITE (*,1002)
1002	FORMAT (' FILE OF STATION NAMES TO PROMPT FOR NOT FOUND.'/
     2 ' (THE DEFAULT FILE IS STALIST.)'/' ENTER FILENAME: ',$)
	READ (*,1001) IFL
	OPEN (12,FILE=IFL,STATUS='OLD',FORM='FORMATTED',
     2IOSTAT=IOC)
	IF (IOC.GT.0) GO TO 10

C--READ IN LIST OF STATIONS TO PROMPT FOR
15	DO 18 I=1,100
18	READ (12,1003,END=20) STAS(I),SCHR(I),ACHR(I),CCHR(I)
1003	FORMAT (A4,3A1)
20	NSTA=I-1
	CLOSE (12)

C--SET THE FLAG THAT PROMPTS FOR A P REMARK, FIRST MOTION & WEIGHT
	WRITE (*,1007)
1007	FORMAT (' DO YOU WANT TO ENTER REMARKS, FIRST MOTIONS & WEIGHTS'/
     2 ' FOR ALL STATIONS (Y OR N)? ',$)
	READ (*,1008) CHR
1008	FORMAT (A1)
	LALL=CHR.EQ.'Y' .OR. CHR.EQ.'y'
	WRITE (*,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 (*,1004)
1004	FORMAT (' FOR THE NEXT EVENT:')
	IY=JASK(' YEAR',IY,5)
	IM=JASK('MONTH',IM,5)
	ID=JASK('  DAY',ID,5)
	IH=JASK(' HOUR',IH,5)
	IN=JASK('  MIN',IN,5)

C--WRITE EVENT HEADER TO PHASE FILE
	WRITE (14,1009) IY,IM,ID,IH,IN
1009	FORMAT (5I2)
	WRITE (*,1006)
1006	FORMAT (' ENTER P TIMES:',$)

C--LOOP OVER STATIONS IN THE PROMPTING LIST
	DO 50 I=1,NSTA

C--OPTIONALLY INPUT P REMARK, FIRST MOTION & WEIGHT
	IF (LALL) THEN
	  WRITE (*,1005) STAS(I)
1005	  FORMAT (' P REMK, FM & WEIGHT (A4) FOR 'A4': ',$)
	  READ (*,1003) PRMK
	  IF (PRMK.EQ.'    ') PRMK=' P  '
	END IF

C--INPUT P TIME IN FREE FORMAT, CR SKIPS THE STATION
30	WRITE (*,1010) STAS(I)
1010	FORMAT (1X,A4'(0.0 NO P): ',$)
	READ (*,1011,ERR=30) P
1011	FORMAT (F20.0)
	IF(P.EQ.0.0) THEN 
	NCHP=0
	ELSE
	NCHP=1
	END IF
C--OUTPUT TIME IN 1/100 SECONDS AS AN INTEGER
	IP=P*100.+.5
	IF (NCHP.EQ.0) PRMK=' P 4'

C--INPUT A DURATION IF THIS STATION WAS FLAGGED
	IF (CCHR(I).NE.' ') THEN
46	  WRITE (*,1027) STAS(I)
1027	  FORMAT (' CODA DURATION FOR 'A4'(0.0 NO CODA): ',$)
	  C=0.
	  READ (*,1011,ERR=46) C
	IF(C.EQ.0.0) THEN 
	NCHC=0
	ELSE
	NCHC=1
	END IF
	  IC=C+.5

C--OUTPUT P AND/OR CODA TIMES
	  IF (NCHC.NE.0 .OR. NCHP.NE.0)
     2	 WRITE (14,1013) STAS(I),PRMK,IP,IC
	ELSE
	  IF (NCHP.NE.0) WRITE (14,1013) STAS(I),PRMK,IP
	END IF
1013	FORMAT (2A4,I5,I4)

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

C--OPTIONALLY INPUT S REMARK & WEIGHT
	  IF (LALL) THEN
	    WRITE (*,1014) STAS(I)
1014	    FORMAT (' S REMK & WEIGHT (A4) FOR 'A4': ',$)
	    READ (*,1003) SRMK
	    IF (SRMK.EQ.'    ') SRMK=' S  '
	  END IF

C--INPUT S TIME IN FREE FORMAT, CR SKIPS THE STATION
40	  WRITE (*,1024) STAS(I)
1024	  FORMAT (' S TIME FOR 'A4'(0.0 NO S): ',$)
	  READ (*,1011,ERR=40) S
	IF(S.EQ.0.0) THEN 
	NCH=0
	ELSE
	NCH=1
	END IF
C--OUTPUT TIME IN 1/100 SECONDS AS AN INTEGER
	  IS=S*100.+.5
	  IF (NCH.NE.0) WRITE (14,1013) STAS(I),SRMK,IS
	END IF

C--INPUT AN AMPLITUDE IF THIS STATION WAS FLAGGED
	IF (ACHR(I).NE.' ') THEN
44	  WRITE (*,1025) STAS(I)
1025	  FORMAT (' AMPLITUDE FOR 'A4': ',$)
	  READ (*,1011,ERR=44) P
	  IF(P.EQ.0.0) THEN
	  NCH=0
	  ELSE
	  NCH=1
	  END IF
	  IF (NCH.NE.0) WRITE (14,1026) STAS(I),P
1026	  FORMAT (A4' A  'F5.0)
	END IF

C--END OF STATION LOOP
50	CONTINUE

C--OPTIONALLY ENTER A TIME FOR A STATION NOT ON PROMPT LIST
60	WRITE (*,1015)
1015	FORMAT (' ENTER ANOTHER P, S OR CODA FOR THIS EVENT (Y OR N)? ',$)
	READ (*,1008) CHR
	IF (CHR.NE.'Y' .AND. CHR.NE.'y') GOTO 70
C--GET STATION NAME & REMARK
	WRITE (*,1016)
1016	FORMAT (' STATION (A4)? ',$)
	READ (*,1003) STA
	WRITE (*,1017) 
1017	FORMAT (' P OR S REMARK & WEIGHT (A4)? ',$)
	READ (*,1003) RMK

C--GET STATION TIME
65	WRITE (*,1018)
1018	FORMAT (' P OR S TIME: ',$)
	READ (*,1011,ERR=65) P
	IF(P.EQ.0.0) THEN
	NCHP=0
	ELSE
	NCHP=1
	END IF
	IF (NCHP.EQ.0) RMK=' P 4'
	IP=P*100.+.5

C--GET CODA
67	WRITE (*,1029)
1029	FORMAT (' CODA: ',$)
	C=0.
	READ (*,1011,ERR=67) C
	IF(C.EQ.0.0) THEN
	NCHC=0
	ELSE
	NCHC=1
	END IF
	IC=C+.5

C--OUTPUT ARRIVAL TIME AND/OR CODA
	IF (NCHP.NE.0 .OR. NCHC.NE.0) THEN
	  IF (NCHC.EQ.0) THEN
	    WRITE (14,1013) STA,RMK,IP
	  ELSE
	    WRITE (14,1013) STA,RMK,IP,IC
	  END IF
	END IF
	GOTO 60

C--OPTIONALLY ENTER AN AMPLITUDE FOR ANY STATION
70	WRITE (*,1019)
1019	FORMAT (' ENTER AN AMPLITUDE FOR THIS EVENT (Y OR N)? ',$)
	READ (*,1008) CHR
	IF (CHR.NE.'Y' .AND. CHR.NE.'y') GOTO 80
C--GET STATION NAME
	WRITE (*,1016)
	READ (*,1003) STA

C--GET STATION AMPLITUDE
75	WRITE (*,1021)
1021	FORMAT (' AMPLITUDE: ',$)
	READ (*,1011,ERR=75) P
	IF(P.EQ.0.0) THEN
	NCH=0
	ELSE
	NCH=1
	END IF
	IF (NCH.EQ.0) GOTO 70
	IP=P+.5
	WRITE (14,1022) STA,CHR,IP
1022	FORMAT (A4' A  'I4'.')
	GOTO 70

C--WRITE TERMINATOR LINE
80	WRITE (14,1010)

C--DECIDE WHETHER TO ENTER ANOTHER EVENT
	WRITE (*,1023)
1023	FORMAT (' STOP ENTERING DATA & RETURN TO COMMAND LEVEL',
     2 ' (Y OR N)? ',$)
	READ (*,1008) CHR
	IF (CHR.NE.'Y' .AND. CHR.NE.'y') GOTO 25
	CLOSE (14)
	RETURN
	END
	SUBROUTINE HYSTL (STANAM)
C--CALLED BY HYPOINV TO LIST STATIONS & CRUST MODEL ON PRINT FILE & OPEN FILES
	CHARACTER DAT*9,TIM*8
C--THESE ARE NEEDED IN PC350 VERSION ONLY:
	INTEGER STATUS(2),IOSB(2)

C--OPTIONAL LINE DESCRIPTOR BLOCK WITH PORT SETTINGS
C	BYTE LDB(16)
C	DATA LDB/16,16,8,1,0,0,0,9*0/

c$INCLUDE:'HYPCOM.'
c$INCLUDE:'HYPCOMC.'
c$INCLUDE:'HYPCOMV.'

      include 'hypcom.inc'
      include 'hypcomc.inc'
      include 'hypcomv.inc'
C--OPEN PHASE DATA FILE
C	IF (JCP.EQ.5) THEN

C--ATTACH (OPEN) THE COMM PORT (USE IN PC350 VERSION ONLY)
C	  CALL CCATT (STATUS,16)
C--OPTIONALLY SET LINE CHARACTERISTICS TO 4800 BAUD SEND & RECEIVE,
C  8 DATA BITS, 1 STOP BIT, NO PARITY CHECKING, XON/XOFF ENABLED.
C	  CALL CCSMC (STATUS,16,LDB)
C--INITIATE THE CONNECTION IN ORIGINATE MODE (RAISE DTR & RTS)
C	  CALL CCORG (STATUS,16,IEFN,IOSB)
C--RESET THE PHASE FILE NAME, WHICH IS UNUSED
C	  PHSFIL='*COMM PORT*'
C	ELSE

C--OPEN PHASE FILE
      OPEN (14,FILE=PHSFIL,STATUS='OLD',FORM='FORMATTED',
     2IOSTAT=IOC)
	IF(IOC.GT.0) GO TO 33
C	END IF
	ISTAT=1

C--OPEN OUTPUT FILES
 	IF (LSUM .AND. LAPP(2)) OPEN (12,FILE=SUMFIL,FORM='FORMATTED')
	IF (LARC .AND. LAPP(3)) OPEN (7,FILE=ARCFIL,FORM='FORMATTED')
	IF (LPRT .AND. LAPP(1)) OPEN (15,FILE=PRTFIL,FORM='FORMATTED')

	IF (LSUM .AND. .NOT.LAPP(2)) OPEN(12,FILE=SUMFIL,STATUS='unknown')
	IF (LARC .AND. .NOT.LAPP(3)) OPEN (7,FILE=ARCFIL,STATUS='unknown')
	IF (LPRT .AND. .NOT.LAPP(1)) OPEN(15,FILE=PRTFIL,STATUS='unknown')
	GOTO 38

C--HERE IS THE ERROR MESSAGE FOR NON-EXISTENT PHASE FILES
33	WRITE (*,1010)
1010	FORMAT (' *** ERROR - PHASE FILE DOES NOT EXIST ***')
	ISTAT=0
	RETURN

C--INITIALIZE SOME VALUES
38	REMK=' '
	LOCNUM=0

C--SET FLAG USED TO INDICATE END OF PHASE CARD FILE
	KEND=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
C	CALL DATE (DAT)
C	CALL TIME (TIM)
	WRITE (15,1000)
1000	FORMAT ('1HYPOINVERSE (1/85 VERSION)'/)
	IF (JST.EQ.1) GOTO 18
	WRITE (15,1009)
1009	FORMAT (' STATIONS:'/3X'I NAME ---LAT---- ----LON---- PDLY1',
     3 ' PDLY2 FMC XMC WT PMOD SMOD CAL PER TYP'/)

C--LOOP TO DECODE PARAMETERS AND WRITE STATIONS
	DO 5 I=1,JSTA
	XLTM=ABS(JLATM(I)*.01)
	XLNM=ABS(JLONM(I)*.01)
	KTEMP2=JMCOR(I)-2525
	KTEMP=KTEMP2/100.
	KTEMP2=KTEMP2-KTEMP*100
	XMC=KTEMP*.1
	FMC=KTEMP2*.1
	PD1=.01*JPD1(I)
	PD2=.01*JPD2(I)
	JWT=JMOD(I)/100
	KTEMP=JMOD(I)-100*JWT
	MODP=KTEMP/10
	MODS=KTEMP-10*MODP
	WT=.1*JWT
	ITYPE=JCAL(I)/10000
	KTEMP=JCAL(I)-10000*ITYPE
	KTEMP2=KTEMP/500
	KTEMP=KTEMP-500*KTEMP2
	CAL=KTEMP*.1
	PER=KTEMP2*.1
	KTEMP=IABS(JLATD(I))
	KTEMP2=IABS(JLOND(I))
	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
5	WRITE (15,1001) I,STANAM(I),KTEMP,IS,XLTM,KTEMP2,IE,XLNM,PD1,
     2 PD2,FMC,XMC,WT,MODP,MODS,CAL,PER,ITYPE
1001	FORMAT (1X,I3,1X,A4,I4,A1,F5.2,I6,A1,F5.2,1X,2F6.2,3F4.1,I3,I5,
     2 F5.1,F4.1,I3)

C--PRINT THE CRUSTAL MODELS, ONE AT A TIME
	DO 15 I=1,3
	IF (MODTYP(I).EQ.-1) GOTO 15
	WRITE (15,1002) I,MODNAM(I)
1002	FORMAT (//' CRUST MODEL'I2': 'A20/)

C--PRINT THE LAYER PARAMETERS FOR THE MODEL
C--HANDLE HOMOGENEOUS LAYER & LINEAR GRADIENT MODELS SEPERATELY
	IF (MODTYP(I).EQ.0) THEN
	  WRITE (15,1003)
1003	  FORMAT (' LINEAR GRADIENT MODEL WITH VELOCITIES SPECIFIED AT',
     2 ' THE FOLLOWING DEPTHS:')
	ELSE
	  WRITE (15,1004)
1004	  FORMAT (' HOMOGENEOUS LAYER MODEL WITH THE FOLLOWING',
     2 ' VELOCITIES AND LAYER TOPS:')
	END IF
	WRITE (15,1005)
1005	FORMAT (4X'VELOCITY  DEPTH') 
	DO 10 J=1,LAY(I)
10	WRITE (15,1006) J,VEL(J,I),D(J,I)
1006	FORMAT (I3,2F8.3)
15	CONTINUE

C--PRINT THE COMPUTATIONAL PARAMETERS FOR THIS RUN
18	WRITE (15,1007)
1007	FORMAT (//' TEST PARAMETERS:'/3X'-ITERATION AND CONVERGENCE-',
     2 5X'-WEIGHTING AND ERRORS-')

	WRITE (15,1008) ITRLIM,DAMP,DISCUT,RMSCUT,
     2 DQUIT,DRQT,DISW1,RMSW1,
     3 DXFIX,EIGTOL,DISW2,RMSW2,
     4 DZMAX,RBACK,SWT,RDERR,
     5 DZAIR,BACFAC,ZTR,ERCOF,
     6 NET,LFIX
1008	FORMAT (
     1   I9'=ITRLIM'F8.3'=DAMP  'F8.3'=DISCUT'F8.3'=RMSCUT'/
     2 F9.3'=DQUIT 'F8.3'=DRQT  'F8.3'=DISW1 'F8.3'=RMSW1'/
     3 F9.3'=DXFIX 'F8.3'=EIGTOL'F8.3'=DISW2 'F8.3'=RMSW2'/
     4 F9.3'=DZMAX 'F8.3'=RBACK 'F8.3'=SWT   'F8.3'=RDERR'/
     5 F9.3'=DZAIR 'F8.3'=BACFAC'F8.3'=ZTR   'F8.3'=ERCOF'/
     6   I9'=NET   '  A8'=LFIX')

	WRITE (15,1014)
1014	FORMAT (/4X'-DURATION MAG CONSTANTS-'7X'-DELAYS-')

	WRITE (15,1015) FMA1,FMA2,DLYAZ,
     2 FMB1,FMB2,DLYWD,
     3 FMZ1,FMZ2,DLYLON,
     4 FMD1,FMD2,DLYLAT,
     5 FMBRK,POS,KDLY
1015	FORMAT (
     1 F9.3'=FMA1  'F8.3'=FMA2  'F8.3'=DLYAZ'/
     2 F9.3'=FMB1  'F8.3'=FMB2  'F8.3'=DLYWD'/
     3 F9.3'=FMZ1  'F8.3'=FMZ2  'F8.3'=DLYLON'/
     4 F9.3'=FMD1  'F8.3'=FMD2  'F8.3'=DLYLAT'/
     5 F9.3'=FMBRK 'F8.3'=POS   '  I8'=KDLY')

C--WRITE INPUT FILENAMES
	WRITE (15,1020)
1020	FORMAT (//' INPUT FILES:')
	WRITE (15,1021) INFILE,STAFIL,PHSFIL
1021	FORMAT (' COMMANDS: 'A/' STATIONS: 'A/' PHASES:   'A)

	DO 25 I=1,3
	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)
25	CONTINUE

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
1031	FORMAT (' ('L1') SUMMARY:  'A)
	IF (LARC) WRITE (15,1032) LAPP(3),ARCFIL
1032	FORMAT (' ('L1') ARCHIVE:  'A)

	WRITE (15,1034)
1034	FORMAT (//)
	RETURN
	END
	SUBROUTINE HYPHS (STANAM)
C--READS IN PHASE DATA FOR 1 HYPOINVERSE EARTHQUAKE
C--ALSO CHECK FOR TRIAL HYPOCENTER & MANY ERRORS IN DATA
c$INCLUDE:'HYPCOM.'
c$INCLUDE:'HYPCOMV.'
      include 'hypcom.inc'
      include 'hypcomv.inc'
	CHARACTER CSTA*4,TRMK*3,RMKS(7)*3
	REAL LASTA

C--RMKS IS THE ARRAY OF EVENT REMARKS WHICH ARE RECOGNIZED, ABBREVIATED
C  TO 1 LETTER & OUTPUT AS A SUPPLEMENTARY REMARK.
	DATA RMKS/'FLT','F  ','TRM','T  ','LPC','LPD','BLS'/

C--INITIALIZATION BEFORE EACH EQ.
8	LOCIN=0
	CCOR=0.
	RMK1=' '
	RMK2=' '
	LASTA=' '
	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.
	IF (JCP.GT.1) THEN
	  READ (14,1008,ERR=9,END=80) KYEAR,KMONTH,
     2 KDAY,KHOUR,KMIN,SEC,RMK1,RMK2
1008	  FORMAT (5I2,F4.2,62X,2A1)
	  IF (RMK2.EQ.'*') RMK2=' '
	END IF
	GOTO 10

C--READ ERROR
9	WRITE (*,1009)
	IF (LPRT) WRITE (15,1009)
1009	FORMAT (' BAD REFERENCE TIME - ASSUME ZEROS')
	KYEAR=0
	KMONTH=0
	KDAY=0
	KHOUR=0
	KMIN=0
	SEC=0.

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) INST
	IF (LERR) WRITE (6,1000) INST
1000	FORMAT (' SKIP BAD PHASE CARD:'/1X,A)

C--READ A PHASE CARD
15	READ (14,1001,END=80,ERR=12) INST
1001	FORMAT (A)

C--INTERPRET A CARD WITH A BLANK STATION NAME OR NUMERAL IN THE FIRST
C  COLUMN AS A TERMINATOR CARD
	CSTA=INST(1:4)
	I=ICHAR(INST(1:1))
	IF (CSTA.EQ.'    ' .OR. (I.LT.58 .AND. I.GT.47)) GOTO 60

	IF (JCP.GT.1) THEN
C--ASSUME THE CONDENSED PHASE CARD FORMAT.
C--INITIALIZE DATA IN CASE IT IS NOT GIVEN A VALUE READING CONDENSED FORMAT
	  KP(K)=0
	  KPRK(K)='  '
	  KWT(K)=0
	  KS(K)=0
	  KFMP(K)=0
	  KAMP(K)=0
	  KSRK(K)='  '
	  KRMK(K)=' '

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

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

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

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

C--ASSUME A FULL PHASE CARD
	READ (INST,1002,ERR=12) STA,KPRK(K),LPWT,LYEAR,LMONTH,LDAY,
     2 LHOUR,LMIN,P,S,KSRK(K),LSWT,AMP,IL,IT,TRMK,CCOR,KRMK(K),FMP
1002	FORMAT (A4,A3,I1,1X,5I2,F5.2,6X,F6.2,A2,1X,I1,4X,F3.0,7X,
     2 2I4,A3,F5.2,A1,F4.0)
	KAMP(K)=AMP+.5
	KFMP(K)=FMP+.5

C--KEEP THE LOCATION NO. LOCIN (IF PRESENT) AS THE CURRENT EVENT NO.
	IF (LOCIN.EQ.0 .AND. IT.EQ.0) LOCIN=IL

C--TEST ALL PHASE CARDS BUT THE FIRST FOR CLOSE TIME AGREEMENT
	IF (K.EQ.1) THEN
	  KYEAR=LYEAR
	  KMONTH=LMONTH
	  KDAY=LDAY
	  KHOUR=LHOUR
	  KMIN=LMIN
	ELSE
	  IF (LYEAR-KYEAR+LMONTH-KMONTH+LDAY-KDAY.NE.0 .OR.
     2 IABS((LHOUR-KHOUR)*60+LMIN-KMIN).GT.4) THEN
	    IF (LPRT) WRITE (15,1003) INST
	    IF (LERR) WRITE (6,1003) INST
1003	    FORMAT (' SKIP OVER PHASE CARD WITH WRONG TIME:'/1X,A)
	    GOTO 15
	  END IF
	END IF

C--DERIVE THE AUXILIARY REMARKS FROM CERTAIN EVENT REMARKS
18	DO 20 I=1,7
	IF (TRMK.EQ.RMKS(I)) THEN
	  IF (RMK1.EQ.' ') THEN
	    RMK1=TRMK(1:1)
	  ELSE
	    IF (RMK2.EQ.' ') RMK2=TRMK(1:1)
	  END IF
	  GOTO 24
	END IF
20	CONTINUE

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

C--TEST TO SEE IF THE STATION IS ON THE LOOK-UP LIST
	DO 30 J=1,JSTA
	IF (STA.EQ.STANAM(J)) GOTO 35
30	CONTINUE
C--PRINT AN ERROR MESSAGE & READ ANOTHER PHASE CARD
	IF (LPRT) WRITE (15,1004) INST
	IF (LERR) WRITE (6,1004) INST
1004	FORMAT (' SKIP PHASE CARD WITH UNKNOWN STATION:'/1X,A)
	GOTO 15

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

C--CORRECT ARRIVAL TIMES TO SAME MINUTE
	LSHIF=((LHOUR-KHOUR)*60+LMIN-KMIN)*60
C--STORE TIMES IN .01 SEC, ROUNDED TO NEAREST INTEGER
	KP(K)=JNINT(100.*(P+LSHIF+CCOR))
	KS(K)=JNINT(100.*(S+LSHIF+CCOR))
	KWT(K)=10*LSWT+LPWT
50	CONTINUE

C--TREAT REMAINING PHASE CARDS AS ANOTHER EVENT
	KSTA=MAXPHS
	IF (LPRT) WRITE (15,1005) INST
	IF (LERR) WRITE (6,1005) INST
1005	FORMAT (' TOO MANY STATIONS. TREAT REST AS ANOTHER EVENT.'/
     2 ' LAST STATION FOR THIS EVENT IS:'/1X,A)
C--ZERO THE TRIAL COORDINATES AS IF A BLANK CARD WAS READ
	T1=0.
	Z1=0.
	CLON=0.
	CLAT=0.
	RETURN

C--COME HERE FOR NORMAL EVENT TERMINATION WITH AN INSTRUCTION CARD
60	KSTA=K-1
C--SKIP AN EVENT WITH FEWER THAN MINSTA PHASE CARDS
	IF (KSTA.LT.MINSTA) THEN
	  IF (LPRT) WRITE (15,1006) MINSTA,KYEAR,KMONTH,KDAY,KHOUR,KMIN
	  IF (LERR) WRITE (6,1006) MINSTA,KYEAR,KMONTH,KDAY,KHOUR,KMIN
1006	  FORMAT (' SKIP EVENT WITH LESS THAN'I2' PHASE CARDS:'5I3)
	  GOTO 8
	END IF

C--GET TRIAL DATA (IF ANY) FROM TERMINATOR CARD
	READ (INST,1007,ERR=74) MHOUR,MINIT,T,LAT,IS,XLTM,LON,IE,XLNM,Z1
1007	FORMAT (6X,2I2,F4.2,I2,A1,F4.2,I3,A1,F4.2,F5.2)
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--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.
	IF (MHOUR+MINIT.EQ.0 .AND. T.EQ.0.) THEN
	  T1=0.
	ELSE
	  T1=T+((MHOUR-KHOUR)*60+MINIT-KMIN)*60
	END IF
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
	END
	SUBROUTINE HYTRL
C--SETS THE TRIAL HYPOCENTER FOR HYPOINVERSE & PRINTS THE PRINT HEADING
c$INCLUDE:'HYPCOM.'
      include 'hypcom.inc'
	CHARACTER XMON(12)*3
	DATA XMON/'JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP',
     2 'OCT','NOV','DEC'/
	KTEMP=30000
	KTMP2=2

C--INCREMENT THE LOCATION & SEQUENCE NUMBERS
	LOCNUM=LOCNUM+1
	INUM=INUM+1
	IF (LOCIN.NE.0) LOCNUM=LOCIN

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
C--K2 IS THE SECOND CLOSEST STATION
	K2=KTMP2
	KTMP2=K
	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--PRINT THE EVENT DATE AND TIME AS HEADING
	IF (LPRT .AND. KPRINT.GT.0) WRITE (15,1005) KDAY,XMON(KMONTH),
     2 KYEAR,KHOUR,KMIN,LOCNUM,INUM
1005	FORMAT (1X,I3,1X,A3,I3','I3':'I2,2X'SEQUENCE NO. 'I4
     2 ' LOCATION NO. 'I4)
	RETURN
	END
	SUBROUTINE HYLOC (KDHR,KT,STANAM,A,W,R,IMPORT,MTCAL)
C--LOCATES ONE EARTHQUAKE FOR THE PROGRAM HYPOINV
	LOGICAL CONERR,LZFIX,ZFIX,LPKTMP,LMESS,LDISWT,LRESWT

c$INCLUDE:'HYPCOM.'
c$INCLUDE:'HYPCOMT.'
c$INCLUDE:'HYPCOMV.'
c$INCLUDE:'HYPCOMA.'

      include 'hypcom.inc'
      include 'hypcomt.inc'
      include 'hypcomv.inc'
      include 'hypcoma.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.
	DATA NRES /2/

C--INITIALIZE VARIABLES
	N=3
	NLAST=N
	ITR=0
	DONE=.FALSE.
	RMSMIN=10000.
	OLDRMS=10000.
	RR=10000.
	D1=10000.
	D2=10000.
	LMESS=KPRINT.GT.1 .AND. LPRT

C--ZFIX INDICATES WHETHER DEPTH IS FIXED PERMANENTLY, & LZFIX INDICATES
C  WHETHER IT IS FIXED ON THIS ITERATION.
	IF (Z1.EQ.0.) Z1=ZTR
	ZFIX=Z1.LT.0.
	LZFIX=.TRUE.
	Z1=ABS(Z1)

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

30	M=0
	NWR=0
	ITR=ITR+1
	COSLAT=COS(CLAT/RDEG)

C--THESE FLAGS SIGNAL WHETHER WEIGHTING IS APPLIED IN THE CURRENT ITERATION
	LDISWT=ITR.GE.ITRDIS
	LRESWT=ITR.GE.ITRRES
	IF (ITR.EQ.ITRDIS .AND. LMESS) WRITE (15,1001)
1001	FORMAT (' BEGIN DISTANCE WEIGHTING')
	IF (ITR.EQ.ITRRES .AND. LMESS) WRITE (15,1002)
1002	FORMAT (' BEGIN RESIDUAL WEIGHTING')

C--DECIDE WHICH DELAY MODEL TO USE FOR THIS LOCATION.
C--DLYBAL MAY DEPEND ON EPI POSITION AND GIVES THE ACTUAL DELAY AS A
C--WEIGHTED AVERAGE OF THE 2 DELAY MODELS.

C--DELAY MODEL 1 OR DEFAULT IF KDLY IS OUT OF RANGE
	DLYBAL=0.
C--DELAY MODEL 2
	IF (KDLY.EQ.2) DLYBAL=1.
	IF (KDLY.GT.2) THEN
C--TWO DELAY MODELS SEPARATED BY A LINE
	  IF (KDLY.EQ.3) DF=-111.19*((CLAT-DLYLAT)*SIN(DLYAZ/RDEG)
     2 +COSLAT*(CLON-DLYLON)*COS(DLYAZ/RDEG))
C--TWO DELAY MODELS SEPARATED BY A CIRCLE
	  IF (KDLY.EQ.4) DF=111.19*SQRT((CLAT-DLYLAT)**2
     2 +((CLON-DLYLON)*COSLAT)**2)-DLYAZ
C--SET BALENCE FACTOR BETWEEN 2 DELAY MODELS
	  IF (DF.GT.DLYWD) DF=DLYWD
	  IF (DF.LT.-DLYWD) DF=-DLYWD
	  DLYBAL=.5+.5*SIN(1.5708*DF/DLYWD)
	END IF

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

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

C--DIST AND AZIMUTH FORMULAS ARE APPROXIMATE.
C--DISTANCE ERROR IS LESS THAN 3.E-10*D**3 FOR D IN KM AND LATS BETWEEN +/- 70
C--THIS GIVES A 1 KM ERROR AT 700 KM.
C--TEMP=LAT DIFFERENCE, TEMP2=LON DIFFERENCE TIMES COS OF LAT
	TEMP=JLATD(J)+JLATM(J)/6000.-CLAT
	TEMP2=(JLOND(J)+JLONM(J)/6000.-CLON)*COSLAT
C--CALCULATE AZIMUTH TO STATION IN DEG BETWEEN +/- 180
	KTEMP=0
	IF (TEMP*TEMP2 .NE. 0.)	KTEMP=RDEG*ATAN2(-TEMP2,TEMP)
	KAZEM(K)=180*KTEMP

C--DISTANCE IN .05 KM
	DELTKM=111.195*SQRT(TEMP**2+TEMP2**2)
	KDIS(K)=20.*DELTKM+.5

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

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

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

	DO 50 K=1,KSTA
	J=KINDX(K)
	DELTKM=KDIS(K)*.05

C-- APPLY DISTANCE AND STATION WEIGHTS
	KTEMP=JMOD(J)/100
	WFAC=.1*KTEMP
	IF (DELTKM.GE.TEMP .AND. LDISWT) THEN
	  IF (DELTKM.GT.TEMP2) THEN
	    WFAC=0.
	  ELSE
	    WFAC=(.5*COS(PI*(DELTKM-TEMP)/(TEMP2-TEMP))+.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),
C  RESERVE A PLACE FOR STATION BY PRETENDING TO LOG IN A P.
	LPKTMP=KPRK(K).NE.'  '
	IF (LPKTMP .OR. (KAMP(K)+KFMP(K).NE.0 .AND.
     2 KSRK(K).EQ.'  ')) THEN

C--LOG IN P ARRIVAL TIMES AND WEIGHTS
	  M=M+1
	  IF (M.GT.MMAX) GOTO 52
	  W(M)=0.
	  IF (LPWT.LT.4 .AND. LPKTMP) W(M)=.25*WFAC*(4-LPWT)
	  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.
	  IF (LSWT.LT.4) W(M)=.25*WFAC*(4-LSWT)*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) WRITE (15,1004)STANAM(J)
1004	FORMAT (' TOO MANY PHASES. LAST STATION INCLUDED IS 'A4)

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  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

	IF (LTRT) CALL HYTRT (A,KDHR,KT)
	IF (LTRH) CALL HYTRH (A)

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
	MTCAL(IM)=100.*A(IM,2)

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

C--CALC DELAYS, OBS ARRIVAL TIME, AND VEL INDEPENDENTLY FOR P AND S
	IF (KPS.NE.1) THEN
C--THIS IS A P WAVE
	  PSFAC=1.
	  TEMP2=KP(K)
	ELSE
C--THIS IS AN S WAVE
	  PSFAC=POS
	  TEMP2=KS(K)
	END IF
	DLY=PSFAC*(DLYBAL*JPD2(J)+(1.-DLYBAL)*JPD1(J))

C--CALC TRAVEL TIME RESIDUAL
	R(IM)=.01*(TEMP2-MTCAL(IM)*PSFAC-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.
	WNORM=0.
	NWR=0

C--ACCUMULATE RMSWT AND WEIGHTS
	DO 65 IM=1,M
	WNORM=WNORM+W(IM)**2
65	RMSWT=RMSWT+(W(IM)*R(IM))**2
	IF (WNORM.EQ.0.) GO TO 500
	RMSWT=SQRT(RMSWT/WNORM)
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 (LRESWT) 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
	WNORM=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
	WNORM=WNORM+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/WNORM)
	IF (NWR.LT.4) GO TO 500

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 (LRESWT .AND. LDISWT) DONE=(((ABS(OLDRMS-RMS).LT.DRQT) .OR.
     2 RR.LT.DQUIT) .AND. (.NOT.LZFIX .OR. ZFIX))
     3 .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
	CALL HYSOL (A,N,NLAST,Y,NFREE,LZFIX,W,R,IMPORT,MTCAL)

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

C--PREVENT HYPO FROM ITERATING INTO THE AIR
	IF (Z1+Y(4).LT.0.) THEN
	  IF (LMESS) WRITE (15,1210)
1210	  FORMAT (' AIRQUAKE PREVENTED')
	  CONERR=.TRUE.
	  TEMP=-DZAIR*Z1/Y(4)
	  Y(4)=-DZAIR*Z1
	  DO 110 I=1,3
110	  Y(I)=Y(I)*TEMP
	END IF

C--DAMP DEPTH ADJUSTMENT IF TOO LARGE
	IF (ABS(Y(4)).GT.DZMAX) THEN
	  IF (LMESS) WRITE (15,1220)
1220	  FORMAT (' DEPTH ADJ. 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+++++++++++++++ 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
	IF (CLON.LT.0.) IE='E'
	TEMP=ABS(CLON)	
	LON=TEMP
	XLNM=60.*(TEMP-LON)

C--OUTPUT ADJUSTMENTS TO PRINT FILE
	IF (LMESS) THEN
C--PRINT HEADING
	  IF (KPRINT.GT.4 .OR. ITR.EQ.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')
C--PRINT ADJUSTMENT
	  WRITE (15,1020) ITR,T1,LAT,IS,XLTM,LON,IE,XLNM,Z1,NWR,RMS,Y,RR,NFREE
1020	  FORMAT (1X,I2,F6.2,I4,A1,F5.2,I5,A1,F5.2,F6.2,I4,F5.2,F7.3,3F7.3
     2 ,F6.3,I2)
	END IF

C--IF HYPOCENTER IS FIXED (ITRLIM=0) ADJUST ORIGIN TIME TO REMOVE AV. RESIDUAL
	IF (ITRLIM.EQ.0) THEN
	  WNORM=0.
	  TEMP=0.
	  DO 124 IM=1,M
	  WNORM=WNORM+W(IM)
124	  TEMP=TEMP+R(IM)*W(IM)
	  IF (LMESS) WRITE (15,1221)
1221	  FORMAT (' AV RES REMOVED; O.T. ADJUSTED')
	  T1=T1+TEMP/WNORM
	END IF

	IF (DONE) GOTO 510

C--OPTIONALLY LIST ALL STATIONS NOW
C--VAX VERSION ONLY
C	IF (KPRINT.GT.5 .AND. LPRT) 
C	2 CALL HYLST (STANAM,A,W,R,IMPORT,MTCAL)

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
	NLAST=N
	N=3
	IF (RR.LT.DXFIX .AND. .NOT.ZFIX) 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,LOCNUM
	IF (LERR) WRITE (6,1052) NWR,LOCNUM
1052	FORMAT (1X,I1' PHASES CANT SOLVE NO.'I5)

C--FLAG THIS EVENT IF IT HAD CONVERGENCE PROBLEMS
510	IF (ITR.GT.ITRLIM .OR. NFREE.LT.4 .OR. CONERR) RMK2='*'
	RETURN
	END
	SUBROUTINE HYTRT (A,KDHR,KT)
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.

c$INCLUDE:'HYPCOMC.'
      include 'hypcomc.inc'
      INCLUDE 'hypcomt.inc'
      include 'hypcom.inc'
c$INCLUDE:'HYPCOM.'
C	VIRTUAL A(MMAX,5)	!PC350 VERSION
	DIMENSION A(MMAX,5)

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.

	DIMENSION VH(LN)	
C !VELOCITY AT HYPOCENTER
	DIMENSION DHRZ(LN)	
C !DIST AT WHICH HORIZ RAY EMERGES
	DIMENSION TZ(LN,42)	
C !TT AT EACH DISTANCE POINT
	DIMENSION DTZ(LN,42)	
C !TT DEPTH DERIV AT EACH DISTANCE POINT
	DATA SCFAC/2000./

C--LOOP OVER THE LN POSSIBLE MODELS, SKIPPING LOOP IF MODEL NOT USED.
	DO 35 MD=1,LN
	IF (MODTYP(MD).NE.0) GOTO 35

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
	TEMP=NZ1M*DZ1M
	IF ((.NOT.GZ1(MD) .OR. Z1.GT.TEMP) .AND. GD2(MD)) THEN
C--HYPO IN LOWER PART OF TABLE
	  I=NZ1M+(Z1-TEMP)/DZ2M+1.5001
	  IF (I.GE.NZM) I=NZM-1
	  IF (I.LT.NZ1M+2) I=NZ1M+2
	  H=DZ2M
	  X=(Z1-TEMP)/DZ2M-(I-NZ1M-1)
	ELSE
C--HYPO IN UPPER PART OF TABLE
	  I=Z1/DZ1M+1.5
	  IF (I.GT.NZ1M) I=NZ1M
	  IF (I.LT.2) I=2
	  H=DZ1M
	  X=Z1/DZ1M-(I-1)
	END IF

C--FIND EXACT VELOCITY AT HYPOCENTER
	DO 20 K=1,LAYM
	IF (D(K,MD).LT.Z1) L=K
20	CONTINUE
	VH(MD)=VEL(LAYM,MD)
	IF (L.LT.LAYM) VH(MD)=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
	DHRZ(MD)=(KDHR(MD,I)+X*(KDHR(MD,I+1)-KDHR(MD,I)))*.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(MD)=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(MD,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(MD,J)=(DA*KT(MD,I-1,J)+DB*KT(MD,I,J)+DC*KT(MD,I+1,J))/SCFAC
35	CONTINUE

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--DETERMINE MODEL FOR THIS STATION
	MD=JMOD(J)
C--REMOVE WEIGHT FLAG
	J=MD/100
	MD=MD-100*J
C--DETERMINE P & S MODEL NUMBERS
	MODP=MD/10
	MODS=MD-10*MODP
	MD=MODP
	IF (KPS.EQ.1) MD=MODS

C--CALC TRAVELTIME ONLY IF A LINEAR GRADIENT MODEL IS USED FOR THIS STA.
	IF (MODTYP(MD).NE.0) 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--FIND STATION DISTANCE
	DX=KDIS(KI)*.05

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(MD,J-1)+CB*TZ(MD,J)+CC*TZ(MD,J+1)
	A(I,4)=CA*DTZ(MD,J-1)+CB*DTZ(MD,J)+CC*DTZ(MD,J+1)
	DTDR=(DA*TZ(MD,J-1)+DB*TZ(MD,J)+DC*TZ(MD,J+1))/H
	IF (DTDR.LT.0.) DTDR=0.
	A(I,3)=DTDR

C--CALC EMERGENCE ANGLE
	CA=VH(MD)*DTDR
	IF (CA.GT..99999) CA=.99999
	AIN=RDEG*ASIN(CA)
	IF (DX.LT.DHRZ(MD)) AIN=180.-AIN
	A(I,1)=AIN

C--END OF LOOP OVER ARRIVALS
60	CONTINUE
	RETURN
	END
	SUBROUTINE HYTRH (A)
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

c$INCLUDE:'HYPCOMC.'
c$INCLUDE:'HYPCOM.'
      include 'hypcomc.inc'
      include 'hypcom.inc'

C	VIRTUAL A(MMAX,5)	!PC350 VERSION
	DIMENSION A(MMAX,5)	
	DIMENSION TINJ(13),DIDJ(13),TR(12)

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

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--FIND STATION MODEL 
	MD=JMOD(J)
	J=MD/100
	MD=MD-100*J
C--DETERMINE P & S MODEL NUMBERS
	MODP=MD/10
	MODS=MD-10*MODP
	MD=MODP
	IF (KPS.EQ.1) MD=MODS

C--CALC TRAVEL TIME ONLY IF A LAYER MODEL IS USED FOR THIS STATION
	IF (MODTYP(MD).NE.1) GOTO 270

C--FIND STATION DISTANCE
	DX=KDIS(KI)*.05

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
	SUBROUTINE HYSOL (A,N,NLAST,Y,NFREE,LZFIX,W,R,IMPORT,MTCAL)
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
c$INCLUDE:'HYPCOM.'
c$INCLUDE:'HYPCOMA.'
      include 'hypcom.inc'
      include 'hypcoma.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)
	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)
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


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

c
c   changes
c
c   nov 93 by jh : include files tolower case and name to .inc
c                  disable ovsi output
c
C     *********************  START OF SVD  *****************************

      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 !VAX VERSION
C	VIRTUAL 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 M<N , THEN EITHER
C           TRANSPOSE THE MATRIX A OR ADD ROWS OF ZEROS TO
C           INCREASE M TO N.
C
C     P = INTEGER VARIABLE.  IF P>0, 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
      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(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 = F/W
            SN = H/W
            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(H*H + F*F)
            S(I-1) = W
            CS = F/W
            SN = H/W
            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
C      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
      END
	SUBROUTINE HYMAG
C--CALCULATE MAGNITUDES FOR ALL STATIONS FOR HYPOINVERSE

c$INCLUDE:'HYPCOM.'
      include 'hypcom.inc'
C--INITIALIZE SUMS FOR AVERAGING
	NFMAG=0
	NXMAG=0
	XMAG=0.
	FMAG=0.

C--LOOP OVER STATIONS TO CALC AND AVERAGE FMAGS AND XMAGS
	DO 100 K=1,KSTA
	KFMAG=0
	KXMAG=0
C--GO NO FURTHER IF THERE IS NO AMP OR DUR MAG FOR THIS STATION
	IF (KFMP(K).EQ.0 .AND. KAMP(K).EQ.0) GOTO 100
	J=KINDX(K)
	KXCOR=JMCOR(J)/100
	KFCOR=JMCOR(J)-100*KXCOR-25
	KXCOR=KXCOR-25

C--COMPUTE FMAG IF DURATION IS POSITIVE
	IF (KFMP(K).LE.0) GOTO 50
	TEMP=KFMP(K)
C--USE A BI-LINEAR SCALE WITH DIST & DEPTH CORRECTIONS
	IF (TEMP.LT.FMBRK) THEN
	  KFMAG=10*(FMA1+FMB1*ALOG10(TEMP)+FMD1*KDIS(K)*.05+FMZ1*Z1)
	ELSE
	  KFMAG=10*(FMA2+FMB2*ALOG10(TEMP)+FMD2*KDIS(K)*.05+FMZ2*Z1)
	END IF

C--APPLY MAG CORRECTION
	KFMAG=KFMAG+KFCOR
	IF (KFCOR.GT.25) KFMAG=KFMAG-50
	IF (KFMAG.LT.0) KFMAG=0
C--DON'T INCLUDE MAG IN AVERAGE IF MAG CORRECTION GT 2.5
	IF (KFCOR.GT.25 .OR. KFMAG.EQ.0) GOTO 50
	FMAG=FMAG+KFMAG*.1
	NFMAG=NFMAG+1

C--CALCULATE AMPLITUDE MAG IF AMP IS POSITIVE
50	IF (KAMP(K).LE.0) GOTO 100

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 AT 5 HZ.
C--3: -LOG(A(0)), THE LOCAL MAGNITUDE DISTANCE CORRECTION
C--ALFRQ = LOG(FREQUENCY OF SIGNAL AT MAX AMPLITUDE / 5HZ.)
C--ALDSQ = LOG((HYPOCENTRAL DISTANCE)**2)

C--DECODE SEISMOMETER TYPE & CALIBRATION FACTOR
	ITYPE=JCAL(J)/10000
	KCAL=JCAL(J)-ITYPE*10000
	KPER=KCAL/500
	KCAL=KCAL-KPER*500
	IF (KCAL.EQ.0) GO TO 100

C--COMPUTE MAGNITUDE
	ALDSQ=ALOG10(Z1**2+(KDIS(K)*.05)**2)
	ALFRQ=ALOG10(2./KPER)
	TEMP=ALOG10(KAMP(K)*5./KCAL)
	IF (ITYPE.EQ.1) TEMP=TEMP-1.3-.95*ALFRQ
	IF (ITYPE.EQ.2) TEMP=TEMP+.41+.56*ALFRQ
	TEMP=TEMP-.15+.8*ALDSQ
	IF (ALDSQ.GT.4.6) TEMP=TEMP-3.23+.7*ALDSQ
	KXMAG=10*TEMP+.5

C--APPLY MAG CORRECTION
	KXMAG=KXMAG+KXCOR
	IF (KXCOR.GT.25) KXMAG=KXMAG-50
	IF (KXMAG.LT.0) KXMAG=0

C--DON'T INCLUDE MAG IN AVERAGE IF MAG CORRECTION GT 2.5
	IF (KXCOR.GT.25 .OR. KXMAG.EQ.0) GOTO 100
	XMAG=XMAG+KXMAG*.1
	NXMAG=NXMAG+1

C--STORE BOTH MAGS FOR THIS STATION
100	KMAG(K)=KXMAG*100+KFMAG

C--AVERAGE THE STATIONS TOGETHER
	IF (NXMAG.GT.0) XMAG=XMAG/NXMAG
	IF (NFMAG.GT.0) FMAG=FMAG/NFMAG
	IF (FMAG.EQ.0.) FMAG=XMAG
	RETURN
	END
	SUBROUTINE HYLST (STANAM,A,W,R,IMPORT,MTCAL)
C--DOES FINAL OUTPUT OF EVENT DATA BY STATION FOR HYPOINV

c$INCLUDE:'HYPCOM.'
c$INCLUDE:'HYPCOMA.'
c$INCLUDE:'HYPCOMV.'
      include 'hypcom.inc'
      include 'hypcoma.inc'
      include 'hypcomv.inc'
	CHARACTER XTEMP*4,FTEMP*4,TAMP*4,TFMP*4,CWT*1,C1*1,C3*3
	CHARACTER CRES*6,STAR*1,XLABL(4)*3
	DATA XLABL /'OT ','LAT','LON','Z  '/

C--OUTPUT EIGENDATA AND ERROR ELLIPSE
	IF (KPRINT.GT.2 .AND. LPRT) THEN
C--OUTPUT HEADING & EIGENVALUES
	  WRITE (15,1100) EIGVAL
1100	  FORMAT (/12X'EIGENVALUES'/4X'('4F6.3')'37X
     2 '#ERROR ELLIPSE'/4X'EIGENVECTORS OF ADJUSTMENT'
     3 11X'COVARIANCE'10X'ERRORS#  SERR AZ DIP')
C--COMPUTE STANDARD DEVIATIONS
	  DO 150 I=1,3
	  TEMP=SQRT(COVAR(I,I))

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

C--SET VALUES IN CASE OT MUST BE ADJUSTED
	T2=T1
	KMIN2=KMIN
	KHOUR2=KHOUR

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

C--ADJUST ORIGIN IF EVENT HAS ITERATED INTO ANOTHER MINUTE
C  AT FIRST, NT IS THE TIME SHIFT IN MINUTES, THEN IN HOURS
C  DO NOT ADJUST TIME IF EVENT IS STILL BEING LOCATED
	IF (DONE) THEN
	  NT=(T1+600.)/60.
	  NT=NT-10
	  T1=T1-NT*60.
	  KMIN=KMIN+NT
	  NT=(KMIN+60.)/60.
	  NT=NT-1
	  KMIN=KMIN-NT*60
	  KHOUR=KHOUR+NT

C--ADJUST ORIGIN IF EVENT HAS ITERATED INTO ANOTHER DAY
	  IF (KHOUR.LT.0) THEN
	    KDAY=KDAY-1
	    KHOUR=KHOUR+24
	  END IF
	END IF

C--COMPUTE LARGEST GAP AS MAXGAP
	MAXGAP=0
C--CALC DISTANCE TO NEAREST STA & NUMBER OF FIRST MOTIONS
	KTEMP=10000
	NFRM=0

C--EXAMINE ALL POSSIBLE GAPS FOR THE LARGEST BETWEEN ADJACENT STATIONS
	DO 30 IM=1,M
	IF (W(IM).LT..1) GO TO 30
	K=IND(IM)

C--REMOVE S FLAG FROM STATION INDEX
	IF (K.GT.10000) K=K-10000
C--TALLY FIRST MOTIONS WHEN THEY ARE NON-BLANK
	IF (KPRK(K)(3:3).NE.' ') NFRM=NFRM+1
C--FIND LEAST STATION DISTANCE
	IF (KDIS(K).LT.KTEMP) KTEMP=KDIS(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--SET DISTANCE TO CLOSEST STATION
	DMIN=KTEMP*.05

C++++++++++++++ OUTPUT THE LOCATION +++++++++++++++++
	IF (LPRT) THEN

C--STORE & OUTPUT MAGNITUDES AS A STRING WHICH IS BLANK IF NONE PRESENT
	  FTEMP=' '
	  XTEMP=' '
	  IF (FMAG.GT.0.) WRITE (FTEMP,1003) FMAG
	  IF (XMAG.GT.0.) WRITE (XTEMP,1003) XMAG

C--OUTPUT LOCATION TO PRINT FILE
	  WRITE (15,1027)
1027	  FORMAT(/1X,40('--')/' YR MO DA    ORIGIN'6X
     2 'LAT N     LON W    DEPTH   RMS   ERH   ERZ  XMAG  FMAG')
	  WRITE (15,1028) KYEAR,KMONTH,KDAY,KHOUR,KMIN,T1,LAT,IS,XLTM,
     2 LON,IE,XLNM,Z1,RMS,ERH,ERZ,XTEMP,FTEMP
1028	  FORMAT (1X,I2,2('-',I2),I4,I2,F6.2,I4,A1,F5.2,I5,A1,F5.2,F7.2,
     2 3F6.2,2(2X,A4))
C******ESCRIBA ENCABEZADO SUMARIO EN OVSI.BOL*****
c      IF(FMAG.GE.3.5) THEN
c	  WRITE (20,1328) KYEAR,KMONTH,KDAY,KHOUR,KMIN,T1,LAT,IS,XLTM,
c     2 LON,IE,XLNM,Z1,FMAG
c1328	  FORMAT (1X,3I2,I4,I2,F6.2,I4,A1,F5.2,I5,A1,F5.2,F7.2,
c     2 F3.1)
c      END IF
C**************************************************
C
	  WRITE (15,1029)
1029	  FORMAT(/' RMSWT  DMIN  DLYBAL  GAP  ITR  NFM  NWR  ',
     2 'NWS   REMARKS')

	  WRITE (15,1030) RMSWT,DMIN,DLYBAL,MAXGAP,ITR,NFRM,NWR,NWS,
     2 REMK,RMK1,RMK2
1030	  FORMAT (1X,F5.2,F6.1,F8.3,5I5,3X,A3,1X,2A1)
	END IF

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

	MOUT=0
	IF (KPRINT.GT.0 .AND. LPRT) WRITE (15,1031)
1031	FORMAT (/2X'STA DIST AZM  AN P/S W   SEC (TOBS -TCAL',
     2 ' -DLY  =RES) WT  R INFO AMP DUR XMG FMG')

C--LIST STATIONS IN DISTANCE ORDER
C--LSTDIS IS THE LEAST REMAINING DISTANCE AND WILL BE PRINTED ON THIS PASS
C--NXTDIS IS THE NEXT TO LEAST REMAINING DISTANCE,
C--AND WILL BE PRINTED ON THE NEXT PASS
C--OUTPUT PHASE DATA A OVSI.MEC *********
c	IF(FMAG.GE.3.0) THEN
c	ULAT=LAT+XLTM/60.
c	ULON=LON+XLNM/60.
c      WRITE(25,878) KYEAR,KMONTH,KDAY,KHOUR,KMIN,T1,ULAT,ULON,Z1,
c     2    FMAG,MAXGAP,RMS,ERH,ERZ
c878   FORMAT (1X,3I2,1X,2I2,1X,F6.3,1X,F6.3,1X,F6.3,1X,F6.2,
c     2    F5.2,1X,I4,1X,F6.2,1X,F6.2,1X,F6.2)
c	END IF
C
	NXTDIS=-1
C
C--START OUTER STATION LOOP
40	LSTDIS=NXTDIS
	NXTDIS=30000
	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
	K1=KDIS(K)

	IF (K1.NE.LSTDIS) THEN
	  IF (K1.GT.LSTDIS .AND. K1.LT.NXTDIS) NXTDIS=K1
	  GOTO 90
	END IF
	MOUT=MOUT+1

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
	DIST=K1*.05
	KAZ=KAZEM(K)/180
	KEM=IABS(KAZEM(K)-180*KAZ)
	IF (KAZ.LT.0) KAZ=KAZ+360
C--DECODE CALCULATED TRAVEL TIME
	TCAL=.01*MTCAL(IM)

C--NOW STORE XMAG AND FMAG AS ALPHAMERIC CODE
	XTEMP=' '
	FTEMP=' '
	TAMP=' '
	TFMP=' '
	KXMAG=KMAG(K)/100
	KFMAG=KMAG(K)-KXMAG*100
	TEMP=.1*KFMAG
	TMP2=.1*KXMAG
	AFMAG=.1*KFMAG
	AXMAG=.1*KXMAG
	IF (TEMP.GT.0.) WRITE (FTEMP,1003) TEMP
	IF (KFMP(K).NE.0) WRITE (TFMP,1004) KFMP(K)
	IF (TMP2.GT.0.) THEN
	  WRITE (XTEMP,1003) TMP2
	  WRITE (TAMP,1004) KAMP(K)
	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--PREPARE ARRIVAL TIME INFO, BUT FIRST DECIDE IF THIS IS P OR S
60	TEMP=.01*(DLYBAL*JPD2(J)+(1.-DLYBAL)*JPD1(J))
	IF (KPS.EQ.0) THEN

C--ASSUME A P ARRIVAL
	  DLY=TEMP
	  KPDLY=JNINT(100.*DLY)
	  C3=KPRK(K)
	  C1=' '
	  LWT=LPWT
	  SEC=KP(K)*.01
	  IMPORP=IMPORT(IM)
	  KPWT=100.*W(IM)
	ELSE

C--ASSUME AN S ARRIVAL
	  DLY=POS*TEMP
	  KSDLY=JNINT(100.*DLY)
	  C3=KSRK(K)
	  C1='S'
	  LWT=LSWT
	  SEC=KS(K)*.01
	  TCAL=TCAL*POS
	  IMPORS=IMPORT(IM)
	  KSWT=100.*W(IM)
	END IF

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

C--OUTPUT RESIDUAL AS A STRING AND FLAG IT IF LARGE
	STAR=' '
	RES=TOBS-TCAL-DLY
	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='*'
	  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=JNINT(100.*RES)
	  IF (KPRES.GT.9999) KPRES=9999
	  IF (KPRES.LT.-999) KPRES=-999
	ELSE
C--S WAVE
	  KSRES=JNINT(100.*RES)
	  IF (KSRES.GT.9999) KSRES=9999
	  IF (KSRES.LT.-999) KSRES=-999
	END IF
	STA=STANAM(J)

C--PRINT ARRIVAL TIME INFORMATION FOR ONE STATION
	IF (KPRINT.GT.0 .AND. LPRT) THEN
	  IF (K.NE.KLSTA) THEN

C--WRITE ALL DATA FOR FIRST PHASE (WHICH IS A P UNLESS ONLY S WAS GIVEN)
	    WRITE (15,1532) STA,DIST,KAZ,KEM,C3,CWT,SEC,TOBS,
     2   TCAL,DLY,CRES,STAR,W(IM),C1,KRMK(K),XIMPOR,
     3   TAMP,TFMP,AXMAG,AFMAG
1532	    FORMAT (1X,A4,F5.1,2I4,1X,A3,1X,A1,3F6.2,F5.2,A6,A1,F4.2,2A1,
     2   F5.3,2A4,1X,F3.1,1X,F3.1)
C*******ESCRIBE FASES EN ARCHIVO OVSI.BOL******
c        IF(FMAG.GE.3.5) THENc
c	    WRITE (20,1032) STA,DIST,KAZ,KEM,C3,CWT,SEC,TOBS,
c     2   TCAL,DLY,CRES,STAR,W(IM),C1,KRMK(K),XIMPOR,TAMP,TFMP,XTEMP,FTEMP
c1032	    FORMAT (1X,A4,F5.1,2I4,1X,A3,1X,A1,3F6.2,F5.2,A6,A1,F4.2,2A1,
c     2   F5.3,4A4)
c        END IF
C*****************************
c        IF(FMAG.GE.3.0) THEN
C--PRINT PHASE DATA HERE  OVSI.MEC ********
c      WRITE (25,1134) STA,C3,CWT,KHOUR,KMIN,SEC,
c     2     RES,DIST,KEM,KAZ
c1134  FORMAT (A4,1X,A3,1X,A1,1X,2I2,1X,F5.2,1X,F6.2,1X,F5.1,1X,
c     2     I4,1X,I4)
C*****************************
c	END IF
	  ELSE
C
C--WRITE ONLY ARRIVAL TIME INFO FOR AN S FOLLOWING A P
	    WRITE (15,1033) C3,CWT,SEC,TOBS,TCAL,DLY,CRES,STAR,W(IM),
     2   C1,KRMK(K),XIMPOR
C*******ESCRIBE FASES EN ARCHIVO OVSI.BOL******
c        IF(FMAG.GE.3.5) THENc
c	    WRITE (20,1033) C3,CWT,SEC,TOBS,TCAL,DLY,CRES,STAR,W(IM),
c     2   C1,KRMK(K),XIMPOR
1033        FORMAT (19X,A3,1X,A1,3F6.2,F5.2,A6,A1,F4.2,2A1,F5.3)
c        END IF
C
	  END IF
	END IF
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=KDIS(K)/2

	IF (LARC .AND. DONE .AND. NWR.GT.3) THEN
	  IF (JCA.NE.1) THEN

C--CONDENSED FORMAT
	    I=KP(K)-100.*T1+.5
	    K1=KFMP(K)

	    IF (K1.EQ.0) THEN
	      IF(KPRK(K).NE.'  ')WRITE(7,1006)STA,KPRK(K),LPWT,I
1006	      FORMAT (A4,A3,I1,I5,I4)
	    ELSE
C--COMBINE P TIME & CODA ON SAME LINE IF PICKER-STYLE FORMAT IS SELECTED
	      WRITE (7,1006) STA,KPRK(K),LPWT,I,K1
	    END IF

 	    I=KS(K)-100.*T1+.5
	    IF (KSRK(K).NE.'  ') WRITE(7,1005) STA,KSRK(K),LSWT,I
1005	    FORMAT (A4,A2,1X,I1,I5)

	    K1=KAMP(K)
	    IF (K1.NE.0) WRITE (7,1007) STA,K1
1007	    FORMAT (A4' A  'I4'.')
	  ELSE

C--FULL FORMAT
	    WRITE (7,1034) STA,KPRK(K),LPWT,KYEAR,
     2   KMONTH,KDAY,KHOUR2,KMIN2,KP(K),KPRES,KPWT,KS(K),KSRK(K),LSWT,
     3   KSRES,KAMP(K),KSWT,KPDLY,KSDLY,KTEMP,KEM,KRMK(K),
     4   KFMP(K),KAZ,KFMAG,KXMAG,IMPORP,IMPORS
1034	    FORMAT (A4,A3,I1,1X,5I2,I5,I4,I3,I5,A2,1X,I1,I4,I3,I3,
     2   3I4,I3,5X,A1,I4,I3,2I2,2I4)
	  END IF
	END IF
C
C--UPDATE THE LAST STATION INDEX
80	KLSTA=K
90	CONTINUE
	IF (MOUT.LT.M) GOTO 40
	RETURN
	END
	SUBROUTINE HYSUM
C--CALLED BY HYPOINV TO OUTPUT SUMMARY DATA

c$INCLUDE:'HYPCOM.'
      include 'hypcom.inc'

	DIMENSION KSIG(3)
	CHARACTER CARD*90,KSFL*1

C--ADJUST ORIGIN IF EVENT HAS ITERATED INTO ANOTHER MINUTE.
C--DO NOT MAKE THE ADJUSTMENT PERMANENT, BUT USE ONLY IN HYSUM.
C--ADJUSTMENT WILL BE MADE AGAIN IN HYLST.
	T2=T1
	KMIN2=KMIN
	KHOUR2=KHOUR
	KDAY2=KDAY
	NT=(T2+600.)/60.
	NT=NT-10
	T2=T2-NT*60.
	KMIN2=KMIN2+NT
	NT=(KMIN2+60.)/60.
	NT=NT-1
	KMIN2=KMIN2-NT*60
	KHOUR2=KHOUR2+NT

C--ADJUST ORIGIN IF EVENT HAS ITERATED INTO ANOTHER DAY
	IF (KHOUR2.LT.0) THEN
	  KDAY2=KDAY2-1
	  KHOUR2=KHOUR2+24
	END IF

C--CONVERT SOME DATA TO INTEGER FOR OUTPUT
	KLTM=XLTM*100.+.5
	KLNM=XLNM*100.+.5
	KT=T2*100.+.5
	KZ=Z1*100.+.5
	KFMAG=FMAG*10.+.5
	KXMAG=XMAG*10.+.5
	KDMIN=DMIN+.5
	KRMS=RMS*100.+.5
	KERH=ERH*100.+.5
	KERZ=ERZ*100.+.5
	DO 10 I=1,3
10	KSIG(I)=SERR(I)*100.

C--ENCODE THE SUMMARY DATA AS A STRING
	WRITE (CARD,1001) KYEAR,KMONTH,KDAY2,KHOUR2,KMIN2,KT,LAT,IS,
     2 KLTM,LON,IE,KLNM,KZ,KXMAG,NWR,MAXGAP,KDMIN,KRMS,
     3 (IAZ(I),IDIP(I),KSIG(I),I=1,2),KFMAG,REMK,KSIG(3),
     4 RMK1,RMK2,NWS,KERH,KERZ,NFRM
1001	FORMAT (5I2,I4,I2,A1,I4,I3,A1,I4,I5,I2,3I3,I4,2(I3,I2,I4),
     2 I2,A3,I4,2A1,I2,2I4,I2)
C
C--WRITE A RECORD TO ARCHIVE FILE
	IF (LARC) WRITE (7,1000) CARD
1000	FORMAT (A)
C
	IF (LSUM) THEN
C--WRITE A SUMMARY RECORD
C
C--HYPO71 FORMAT
	  IF (LH71) THEN
	    KSFL=' '
	    IF (NWS.GT.0) KSFL='S'
	    WRITE (12,1002) KYEAR,KMONTH,KDAY2,KHOUR2,KMIN2,T2,LAT,IS,
     2   XLTM,LON,IE,XLNM,Z1,FMAG,NWR,MAXGAP,DMIN,RMS,ERH,ERZ,KSFL
1002	    FORMAT (3I2,I3,I2,F6.2,I3,A1,F5.2,I4,A1,F5.2,2F7.2,
     2   I3,I4,F5.1,F5.2,2F5.1,1X,A1)
C	  ENDIF
	ELSE
C
C--HYPOINVERSE FORMAT
	    WRITE (12,1000) CARD
	  END IF
	END IF
	RETURN
	END
	SUBROUTINE HYREP (LPLT)
C--CALL BY HYPOINVERSE TO REPORT THE CURRENT EVENT ON THE CONSOLE
	LOGICAL LPLT
c$INCLUDE:'HYPCOM.'
      include 'hypcom.inc'

	IT=JNINT(XLTM)
	IN=JNINT(XLNM)
	IF (INUM.EQ.1 .OR. LPLT) WRITE (*,1000)
1000	FORMAT (' EVENT LOCATED: REMARK -LAT-  --LON-  DEPTH XMAG',
     2 ' FMAG NUM  ERH  ERZ')
	WRITE (*,1011) KYEAR,KMONTH,KDAY,KHOUR,KMIN,REMK,
     2 RMK1,RMK2,LAT,IT,LON,IN,Z1,XMAG,FMAG,NWR,ERH,ERZ
1011	FORMAT (I3'/'I2'/'I2,I3':'I2,1X,A3,1X,2A1,2I3,I5,I3,
     2 F7.2,2F5.1,I4,2F5.1)
	RETURN
	END
	BLOCK DATA
C--DATA INITIALIZATION FOR HYPOINV

C	INCLUDE 'HYPCOM./LIST'
C	INCLUDE 'HYPCOMC./LIST'
C	INCLUDE 'HYPCOMP./LIST'	!PC350 VERSION ONLY
c$INCLUDE:'HYPCOM.'
c$INCLUDE:'HYPCOMC.'
c$INCLUDE:'HYPCOMP.'	
      include 'hypcom.inc'
      include 'hypcomc.inc'
      include 'hypcomp.inc'
C!PC350 VERSION ONLY
	LOGICAL LNEWL,LCOPY
C--GENERAL PARAMETERS
	DATA PI,RDEG,LTRT,LTRH /3.14159,57.2958,2*.FALSE./
C--FILES AND OUTPUT CONTROLS
	DATA LSUM,LARC,LPRT,LERR,LH71,LAPP /6*.FALSE.,2*.TRUE./
	DATA JCP,JCA,LEJCT,LREP,KPRINT,JST /2*1,2*.TRUE.,3,2/
	DATA INFILE,DEV,NDEV /'HYPINST.',' ',0/
C--MISCELLANEOUS DATA FOR THIS EVENT
	DATA LOCNUM /0/
C--STATION DELAY PARAMETERS
	DATA KDLY,DLYAZ,DLYWD,DLYLON,DLYLAT /1,4*0./
C--TERMINATING LOCATION UPON CONVERGENCE
	DATA ITRLIM,DQUIT,DRQT /20,.04,.001/
C--ITERATION & DAMPING CONTROLS
	DATA DXFIX,DZMAX,DZAIR,DAMP,EIGTOL,RBACK,BACFAC
     2/7.,30.,.5,.9,.012,.02,.6/
C--DURATION MAG CONSTANTS
	DATA FMA1,FMB1,FMZ1,FMD1,FMA2,FMB2,FMZ2,FMD2,FMBRK
     2/-5.2,3.89,.013,.0037,-.905,2.026,.013,.0037,210./
C--MISCELLANEOUS PARAMETERS
	DATA DISCUT,DISW1,DISW2 /50.,1.,3./
	DATA RMSCUT,RMSW1,RMSW2 /.16,1.5,3./
	DATA SWT,POS,ZTR,RDERR,ERCOF,NET,MINSTA,ITRDIS,ITRRES
     2/1.,1.75,7.,.15,1.,0,3,2*0/
C--CRUST MODEL PARAMETERS
	DATA MODTYP /3*-1/

C--THE FOLLOWING ARE FOR THE PC350 VERSION ONLY
C--MAP PLOT PARAMETERS
	DATA BLAT,BLON,SCAL,LSTA,NLIN /19.33,-155.25,4.E5,.FALSE.,0/
	DATA JSSYM,SSIZ,JSCLR,TITL,ERHMAX,ERZMAX /2,.08,1,' ',2*99./
C--EARTHQUAKE SYMBOLS
	DATA NMAG,ASIZ,ACUT /5,.02,.04,.08,.14,.2,0.,1.,2.,3.,4.,10./
	DATA LCLR,JSYM,JCLR /.FALSE.,7*7,2,6,3,4*4/
	DATA NDEP,ZCUT /4,0.,5.,13.,20.,100.,3*0./
	DATA NTIM,JY,JM,JD,JH,JN,TJ /1,7*60,14*1,14*0,7*0.D0/
	DATA ID,IH,DT,JCFR,JCTX /1,0,1.D0,7,4/
C	DATA LINT,LRTP,LNEWL,LCOPY /4*.FALSE./
	DATA LINT,LRTP,LNEWL,LCOPY /.FALSE.,.FALSE.,.FALSE.,.FALSE./
C--RGB VALUES OF THE 8 DISPLAYABLE COLORS:
C              BLK   BLUE   RED   GREEN YELLOW MAGENT  CYAN   WHITE
C	DATA INTEN/3*0, 0,0,6, 7,0,0, 0,7,0, 7,7,0, 7,0,6, 0,7,6, 7,7,6/
C--COUNT ARRAYS
	DATA MMAG,MMAGT,MDEP,MDEPT,MTIM,MXPLT,MXPL /111*0/
	END
	FUNCTION JASK (PROMPT,IDFLT,LENP)

C--JASK PROMPTS THEN READS AN INTEGER VALUE FROM THE TERMINAL.
C--THE DEFAULT VALUE IS RETURNED ON A CR RESPONSE.
C	JASK   = INTEGER RESPONSE
C	PROMPT = PROMPT STRING
C	IDFLT  = DEFAULT SUPPLIED ON CARRIAGE RETURN, AND
C		 DISPLAYED IN PROMPT.
C	LENP   = BYTE LENGTH OF PROMPT STRING.

	CHARACTER PROMPT, TEMP*20
	WRITE (TEMP,1002) IDFLT
1002	FORMAT (I20)
	DO 3 I=1,20
	IF (TEMP(I:I).NE.' ') GOTO 5
3	CONTINUE
5	WRITE (*,1001) PROMPT(1:LENP),TEMP(I:20)
1001	FORMAT (1X,A,' [CR=',A,']? ',$)
	READ (*,1000,ERR=5) I
1000	FORMAT (I20)
	IF(I.EQ.0) THEN
	NCH=0
	ELSE
	NCH=1
	END IF
	IF (NCH.EQ.0) I=IDFLT
	JASK=I
	RETURN
	END
C	LOGICAL FUNCTION LASK (PROMPT,LDFLT,LENP)

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.
C	LDFLT= DEFAULT DISPLAYED IN PROMPT & RETURNED ON CR.
C	LENP= BYTE LENGTH OF PROMPT STRING

C	CHARACTER PROMPT
C	CHARACTER*1 L
C	LOGICAL LDFLT
C5	WRITE (*,1001) PROMPT(1:LENP),LDFLT
C1001	FORMAT (1X,A' [T OR F, CR='L1']? '$)
C	READ (*,1000,ERR=5) L
C1000	FORMAT (A1)
C	IF(L.NE.' ') THEN
C	IF(L.EQ.'T'.OR.L.EQ.'t') THEN
C	LASK=.TRUE.
C	NCH=1
C	ELSE
C	LASK=.FALSE.
C	NCH=1
C	END IF
C	ELSE
C	NCH=0
C	END IF
C	IF (NCH.GT.0) GOTO 9
C	LASK=LDFLT
C9	RETURN
C	END
	FUNCTION LENG (STRING,MAXLEN)
C--RETURNS THE NON-BLANK LENGTH OF STRING WHOSE PHYSICAL LENGTH IS MAXLEN
C--(RETURNS THE POSITION OF THE LAST NON-BLANK CHARACTER)
	CHARACTER STRING
	DO 5 I=MAXLEN,1,-1
	IF (STRING(I:I) .NE. ' ') GOTO 10
5	CONTINUE
	I=0
10	LENG=I
	RETURN
	END
	FUNCTION ASKR (PROMPT,DFLT,LENP)

C--ASKR PROMPTS THEN READS A REAL VALUE FROM THE TERMINAL.
C--THE DEFAULT VALUE IS RETURNED ON A CR RESPONSE.
C	ASKR   = REAL RESPONSE
C	PROMPT = PROMPT STRING
C	DFLT   = DEFAULT SUPPLIED ON CARRIAGE RETURN AND
C		 DISPLAYED IN PROMPT.
C	LENP   = BYTE LENGTH OF PROMPT (PC350 ONLY)

	CHARACTER PROMPT, TEMP*20
	WRITE (TEMP,1000) DFLT
1000	FORMAT (G20.5)
	DO 2 I=1,20
	IF (TEMP(I:I).NE.' ') GOTO 3
2	CONTINUE
3	DO 4 J=20,1,-1
	IF (TEMP(J:J).NE.' ')GOTO 5
4	CONTINUE
5	WRITE (*,1001) PROMPT(1:LENP), TEMP(I:J)
1001	FORMAT (1X,A,' [CR=',A,']? ',$)
	READ (*,1002,ERR=5,END=9) ASKR
1002	FORMAT (F20.0)
	IF(ASKR.EQ.0.0) THEN
	NCH=0
	ELSE
	NCH=1
	END IF
	IF (NCH.GT.0) GOTO 9
	ASKR=DFLT
9	RETURN
	END
C**************************************************
	FUNCTION HYDID (J,M,MD)
C--CALLED BY HYTRH IN PROGRAM HYPOINVERSE
C	INCLUDE 'HYPCOMC./NOLIST'
c$INCLUDE:'HYPCOMC.'
      include 'hypcomc.inc'
	HYDID=0.
	IF (M.EQ.1) GOTO 110
	DO 20 L=1,M-1
	SQT=SQRT(VSQ(M,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,M,MD)
C--CALLED BY HYTRH IN PROGRAM HYPOINVERSE
C	INCLUDE 'HYPCOMC./NOLIST'
c$INCLUDE:'HYPCOMC.'
      include 'hypcomc.inc'
	HYTID=0.
	IF (M.EQ.1) GOTO 110
	DO 20 L=1,M-1
	SQT=SQRT(VSQ(M,MD)-VSQ(L,MD))
	TIM=THK(L,MD)*SQT/(VEL(L,MD)*VEL(M,MD))
	FLJ=1.
	IF (L.GE.J) FLJ=2.
	HYTID=HYTID+FLJ*TIM
20	CONTINUE
110	RETURN
	END


	FUNCTION JDAT (J,KLATD,KLATM,KLOND,KLONM,KCAL,KMCOR,KMOD,
     2KPD1,KPD2)

C--USED IN THE PC350 VERSION OF HYPOINVERSE.
C--JDAT IS THE INPUT/OUTPUT ROUTINE FOR INTEGER STATION DATA IN VIRTUAL
C--MEMORY. THE HYPOINVERSE ROUTINE HYSTA READS STATION FILES & STORES
C--DATA ONE STATION AT A TIME. REFERENCES TO DATA IN OTHER ROUTINES ARE
C--RESOLVED AS FUNCTION ENTRY POINTS, WHICH LOOK IN THE CALLING ROUTINES
C--JUST LIKE A REFERENCE TO AN ARRAY IN COMMON IN THE VAX VERSION.

C--STATION NAMES ARE ALSO IN VIRTUAL STORAGE, BUT ACCESSED DIRECTLY,
C--NOT THRU FUNCTION CALLS TO JDAT.
c$INCLUDE:'HYPCOM.'
      include 'hypcom.inc'

	DIMENSION ID(9,MAXSTA)
C!THE NO. OF STATIONS AVAILABLE.
C	VIRTUAL ID (9,MAXSTA)	!THE VIRTUAL ARRAY HOLDING STATION DATA.
C--THE IDENTITY OF THE 9 DATA TYPES ARE:
C  1  LAT, DEG.
C  2  LAT, MIN.
C  3  LON, DEG.
C  4  LON, MIN.
C  5  STA TYPE, CAL FACTOR & PERIOD.
C  6  AMP & DUR MAG CORRECTIONS.
C  7  P & S CRUSTAL MODELS & STA WEIGHT.
C  8  P DELAY 1 IN .01 SEC.
C  9  P DELAY 2 IN .01 SEC.

C--THE MAIN ENTRY POINT STORES DATA FOR ONE STATION
	ID(1,J)=KLATD
	ID(2,J)=KLATM
	ID(3,J)=KLOND
	ID(4,J)=KLONM
	ID(5,J)= KCAL
	ID(6,J)=KMCOR
	ID(7,J)= KMOD
	ID(8,J)= KPD1
	ID(9,J)= KPD2
	JDAT=0
	RETURN

C--RETURN THE VALUE OF LAT IN DEG FOR STATION J
C	ENTRY JLATD(J)
	JLATD(J)=ID(1,J)
	RETURN

C--LAT MINUTES
C	ENTRY JLATM(J)
	JLATM(J)=ID(2,J)
	RETURN

C--LON DEG
C	ENTRY JLOND(J)
	JLOND(J)=ID(3,J)
	RETURN

C--LON MIN
C	ENTRY JLONM(J)
	JLONM(J)=ID(4,J)
	RETURN

C--CAL FACTOR ETC.
C	ENTRY JCAL(J)
	JCAL(J)=ID(5,J)
	RETURN

C--MAG CORRECTIONS
C	ENTRY JMCOR(J)
	JMCOR(J)=ID(6,J)
	RETURN

C--CRUST MODELS ETC.
C	ENTRY JMOD(J)
	JMOD(J)=ID(7,J)
	RETURN

C--P DELAY 1
C	ENTRY JPD1(J)
	JPD1(J)=ID(8,J)
	RETURN

C--P DELAY 2
C	ENTRY JPD2(J)
	JPD2(J)=ID(9,J)
	RETURN
	END
	FUNCTION JNINT (XNUM)
C--RETURNS THE NEAREST INTEGER ACCORDING TO [A+0.5*SIGN(A)]
	IXX=IFIX(XNUM)
	IF(IXX.GT.0) ISIGNO=1
	IF(IXX.LT.0) ISIGNO=-1
	JNINT= IFIX(XNUM+0.5*ISIGNO)
	RETURN
	END

c
c   changes
c
c   nov 93 by jh: include files to lower case and extension .inc
c                 hypinst to lower case
c

C	LOGICAL FUNCTION LASK (PROMPT,LDFLT,LENP)

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.
C	LDFLT= DEFAULT DISPLAYED IN PROMPT & RETURNED ON CR.
C	LENP= BYTE LENGTH OF PROMPT STRING

C	CHARACTER PROMPT
C	CHARACTER*1 L
C	LOGICAL LDFLT
C5	WRITE (*,1001) PROMPT(1:LENP),LDFLT
C1001	FORMAT (1X,A' [T OR F, CR='L1']? '$)
C	READ (*,1000,ERR=5) L
C1000	FORMAT (A1)
C	IF(L.NE.' ') THEN
C	IF(L.EQ.'T'.OR.L.EQ.'t') THEN
C	LASK=.TRUE.
C	NCH=1
C	ELSE
C	LASK=.FALSE.
C	NCH=1
C	END IF
C	ELSE
C	NCH=0
C	END IF
C	IF (NCH.GT.0) GOTO 9
C	LASK=LDFLT
C9	RETURN
C	END
