      SUBROUTINE HYCIN
C--READS PICK DATA FROM A CUSP MEM FILE

      CHARACTER OPHS*6, OWT*6,STA*5, COMP1*1,COMP3*3, SNET*2
      CHARACTER DEVICE*3, SOUCODE*1

      INCLUDE 'common.inc'
C--THIS STORES THE CUSP PICK INDEX FOR EACH STATION TO HELP WITH LATER OUTPUT
C  IN HYCOUT
      COMMON /CUSPPICK/ KPICK(MAXPHS)

C--DECLARE DATA STRUCTURES USED TO STORE MEM FILE DATA
      INCLUDE 'mem_structure.inc'
      INCLUDE 'mem_record.inc'
      LOGICAL LMESS

      LMESS=KPRINT.GT.6 .AND. LPRT

C--INITIALIZATION BEFORE EACH EQ. (IN CASE IT IS NOT GIVEN A VALUE)
C?  SOME OF THESE MAY NOT BE NEEDED
      NUNK=0
      RMK1=' '
      RMK2=' '
      BMTYP=' '
C      MBMAG=0
      NBMAG=0
      BMAG=0.
      BMTYPX=' '
C      MBMAGX=0
      NBMAGX=0
      BMAGX=0.
      CP1=' '
      CP2=' '
      CP3=' '

      KYEAR=0
      KYEAR2=0
      KMONTH=0
      KDAY=0
      KHOUR=0
      KMIN=0
      SEC=0.
      T1=0.
      Z1=0.
      CLAT=0.
      CLON=0.
C--STATION INDEX
      K=0

      GOTO 6
C--END OF CUSP-ID FILE, SO QUIT THIS RUN
4     KEND=-1
      RETURN
C--OPTIONALLY READ THE CUSP ID NUMBER FROM A FILE
6     IF (JCP.EQ.7) THEN
        READ (14,1002,END=4) INST
1002    FORMAT (A)
        READ (INST,FORID,ERR=6) IDNO
        IF (IDNO.EQ.0) GOTO 6
C--ONLY GET MULTIPLE EVENTS FROM DISK MEM FILES
        MEMDSK=1
      END IF

C--TERMINATOR CARD & SHADOW FOR OPTIONAL ARCHIVE OUTPUT
      WRITE (TERM,'(62X,I10,8X)') IDNO
      WRITE (SHADO,'(''$'',61X,I10,8X)') IDNO
      LENSHA=80

C--GET DATA FROM CURRENT MEM FILE.
C--LID IS THE CUSP ID NO. REQUESTED, THE STRUCURES ARE RETURNED FULL,
C  AND IRESM IS AN ERROR FLAG. MEMDSK=0 TO GET FROM MEMORY, =1 FROM DISK.
      CALL MEM_DUMP (IDNO, MEMDSK, IRESM)
      IF (IRESM.LE.0) THEN
        WRITE (6,*) ' *** COULD NOT READ EVENT NUMBER ',IDNO
        WRITE (6,*) ' *** MEM_DUMP IRESM ERROR CODE ',IRESM
        IRES=IRESM-100
        KEND=-1
        RETURN
      END IF

C--OPTIONALLY GET TRIAL HYPO FROM PREVIOUS LOCATION, IF ONE IS DEFINED
      IF (IH71T.EQ.3 .AND. HHY.LAT.GT.0. .AND. HHY.LAT.LT.90.) THEN
        KYEAR= HHY.T.YR-ICENT
        KYEAR2= HHY.T.YR
        KMONTH=HHY.T.MO
        KDAY=  HHY.T.DY
        KHOUR= HHY.T.HR
        KMIN=  HHY.T.MN
        T1=    HHY.T.SEC

        CLAT=HHY.LAT
        CLON=-HHY.LON            !HI LONGITUDES ARE POSITIVE WEST
        Z1=-HHY.Z            !HI DEPTHS ARE POSITIVE
      END IF
      IX=0		!INITIALIZE THE PICK INDEX (INDEX TO PICK STRUCTURES)

C--PRINT REFERENCE LOCATION
      IF (LMESS) WRITE (15,1020)
     1 KYEAR2,KMONTH,KDAY,KHOUR,KMIN,T1,
     2 CLAT,CLON,Z1
1020  FORMAT (' --HYCIN: REFERENCE (TRIAL) TIME & LOCATION:',I5,4I3,
     2 F7.2/' --  CLAT=',F9.4,' CLON=',F9.4,' Z1=',F7.2)

C--PRINT EXPECTED DATA
      IF (LMESS) WRITE (15,1021)
     2 HID.NPX,HID.NCD,HID.NAF,HID.NAM
1021  FORMAT (' --HYCIN: EXPECTED NUMBER OF DATA: PICKS=',I3,
     2 ' CODAS=',I3,' AMPS=',I3,' WA-AMPS=',I3)

C--CLAMP TAPE & ID NOS. TO 0 IF THEY ARE UNDEFINED
      IATAP=HID.ATAP
      IF (IATAP.LT.0 .OR. IATAP.GT.999999999) IATAP=0
      IAID=HID.AID
      IF (IAID.LT.0 .OR. IAID.GT.999999999) IAID=0
      IAFIL=HID.AFIL
      IF (IAFIL.LT.0 .OR. IAFIL.GT.9999999) IAFIL=0

C--ASSEMBLE SUMMARY SHADOW CARD
C--THIS IS ONE OF THE FEW TIMES WHEN HYPOINVERSE READS/WRITES SHADOW CARDS
      WRITE (SHAD1(1),1100) HST(1).T.YR, HST(1).T.MO, HST(1).T.DY,
     2 HST(1).T.HR, HST(1).T.MN, HST(1).T.SEC, HST(1).NET,
     3 IATAP,IAID,IAFIL 

1100  FORMAT ('$1',I4,2I2.2,
     2 2I2.2,F6.3, A3,1X,
     3 2I10,I6)
      LSHA1(1)=50
      NSHA1=1

C--LOOP TO ASSIGN PHASE PICKS ********************************************
      DO 50 K=1,MAXPHS
C--WE WILL NOT TRY TO COMBINE P AND S DATA FROM THE SAME STATION.  HI ALLOWS
C  BOTH P AND S PICKS WITH THE SAME INDEX K.  CUSP USUALLY HAS P PICKS ON
C  VERTICALS AND S ON HORIZONTALS, ANYWAY.

C--INCREMENT THE INDEX TO THE PICK STRUCTURES.  EXCEPT FOR SKIPPING OVER
C  UNKNOWN STATIONS, THE PICK INDEX WOULD BE THE SAME AS THE HI PHASE INDEX
C  WHILE WE ARE READING PICKS.  K WILL LATER GET HIGHER FOR STATIONS WITH CODAS
C  BUT NO PICKS.
20      IX=IX+1

C--BOMB OUT WHEN WE RUN OUT OF PICKS
        IF (IX.GT.HID.NPX) GOTO 60

C--INITIALIZE VARIABLES WHICH MAY NOT BE GIVEN A VALUE
        P=0.
        KPRK(K)=' '
        LPWT=4
        S=0.
        KSRK(K)=' '
        LSWT=4
        KWT(K)=0

        KRMK(K)=' '
        KRMK6(K)='    '
        KSOU(K)=' '

        KFMP(K)=0
        KFWT(K)=0
        AMPK(K)=0.
        KAMPU(K)=0
        KAMPTYP(K)=0
        KXWT(K)=0
        KPER(K)=0
        KCAL(K)=0

C--BLANK OUT SHADOW CARD, THEN FILL IT IN AS WE FIND DATA
        KSHAD(K)='$ '
        
C--GET POINTERS TO PIN AND SET INFO
C  IP IS THE POINTER TO PIN INFO, THE ACTUAL PIN IS HPX(IX).PIN
C  IS IS THE POINTER TO SET INFO, THE ACTUAL SET IS HPN(IP).SET=HPX(IX).SET
        IP=HPX(IX).IP
        ISS=HPN(IP).IS

C--GET STATION NAME, COMPONENT & NET CODE.
C  WE WILL LATER CHOOSE HOW MANY COMPONENT LETTERS TO USE.
        STA =  HPN(IP).NAM            !USE FIRST 5 LETTERS OF 6
        COMP1= HPN(IP).TYP            !USE FIRST LETTER OF 3
        COMP3= HPN(IP).TYP            !USE ALL 3 LETTERS
        SNET=  HPN(IP).NET            !USE FIRST 2 LETTERS OF 3

C--SKIP LISTED UNKNOWN STATIONS AND TIME TRACES SO THEY WONT BE USED IN CALCS.
C--AT PRESENT, TIME TRACE DATA IS NOT BEING OUTPUT THROUGH HYPOINVERSE
        DO I=1,NLUNK
          IF (LUNK(I)(1:NSTLET) .EQ. STA(1:NSTLET)) THEN
            IF (LMESS) WRITE (15,1022) IX,K, HPX(IX).PIN, HPX(IX).SET,
     1      STA,SNET,COMP3

1022        FORMAT (' --HYCIN: SKIP STATION: PICK#=',I3,
     2      ' K=',I3,' PIN=',I3,' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-')
            GOTO 20
          END IF
        END DO

C--GET DATE & TIME OF PICK
        LYEAR= HPX(IX).T.YR-ICENT
        LYEAR2=HPX(IX).T.YR
        LMONTH=HPX(IX).T.MO
        LDAY=  HPX(IX).T.DY
        LHOUR= HPX(IX).T.HR
        LMIN=  HPX(IX).T.MN

C--SET THE REFERENCE TIME FROM THE FIRST PICK, UNLESS WE HAVE IT ALREADY
        IF (K.EQ.1 .AND. (IH71T.NE.3 .OR. KMONTH.EQ.0)) THEN
          KYEAR=LYEAR
          KYEAR2=LYEAR2
          KMONTH=LMONTH
          KDAY=LDAY
          KHOUR=LHOUR
          KMIN=LMIN
        END IF

C--GET PHASE DESCRIPTOR & WEIGHT
        CALL OPHASE (HPX(IX).PHZ, OPHS, OWT)

C--P TIME
        IF (OPHS(1:1).EQ.'P') THEN
          P = HPX(IX).T.SEC
          KPRK(K) = (OWT(3:3)//OPHS(1:1)//OWT(1:1))
          READ (OWT(2:2),'(I1)') LPWT
        END IF

C--S TIME
        IF (OPHS(1:1).EQ.'S') THEN
          S = HPX(IX).T.SEC
          KSRK(K) = (OWT(3:3)//OPHS(1:1))
          READ (OWT(2:2),'(I1)') LSWT
        END IF

C--DATA SOURCE
        DEVICE = HST(ISS).DEV
        CALL SOUTRAN (DEVICE,SOUCODE,DIG3,DIG1,DIGDEF,NDIG)
        KSOU(K) = SOUCODE
        KDEV(K) = DEVICE

C--TEST TO SEE IF THE STATION IS ON THE LOOK-UP LIST. GOTO 35 IF MATCH IS
C  COMPLETE.
        DO J=1,JSTA
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3    COMP3(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
            KINDX(K)=J
C--SAVE THE POINTER TO THE PICK STRUCTURE FOR LATER SAVING OF RESULTS.
            KPICK(K)=IX

C--WRITE OUT PICK OF A KNOWN STATION
            IF (LMESS) WRITE (15,1023) IX,K,J, HPX(IX).PIN,
     2      HPX(IX).SET, STA,SNET,COMP3,
     3      HPX(IX).PHZ, HPX(IX).T.SEC

1023        FORMAT (' --HYCIN: FOUND PICK: PICK#=',
     1      I3,' K=',I3,' J=',I4,' PIN=',I3,
     2      ' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-',
     3      ' PHASE=',A8,'TIME=',F9.2)
            GOTO 35
          END IF
        END DO

C--PRINT AN ERROR MESSAGE BECAUSE THE STATION IS NOT ON EITHER THE MASTER LIST
C  OR EXPECTED UNKNOWN LIST.
        IF (LPRT) WRITE (15,1004) STA,COMP3,SNET, IDNO
        IF (LERR) WRITE (6,1004) STA,COMP3,SNET, IDNO
1004    FORMAT (' *** IGNORE PICK OF UNKNOWN STATION:  '
     2  ,A5,1X,A3,1X,A2, ' ON EVENT ',I12)
        IRES=-21
        IF (LMESS) WRITE (15,1022) IX,K, STA,SNET,COMP3

C--TO SAVE THIS UNKNOWN STATION FOR OUTPUT AFTER LOCATION, ADD CODE HERE
C  TO STORE STATION NAME IN THE STRING 'PUNK'
        GOTO 20

C--CORRECT ARRIVAL TIMES TO SAME MINUTE
35      LSHIF=(((LDAY-KDAY)*24 +LHOUR-KHOUR)*60 +LMIN-KMIN)*60
C--STORE TIMES IN .01 SEC, ROUNDED TO NEAREST INTEGER
C        KP(K)=NINT(100.*(P+LSHIF))
C        KS(K)=NINT(100.*(S+LSHIF))

        LTMP = NINT( 100.* (P+LSHIF) ) 
        IF (LTMP .GT. TTMAX) THEN
          LTMP = TTOVER
        ELSE IF (LTMP .LT. TTMIN) THEN
          LTMP = TTUNDR
        END IF
        IF (LTMP .NE. NINT( 100.* (P+LSHIF) )) THEN
          IF (LPRT) WRITE (15,1036) 'P',STA,COMP3,SNET, IDNO
          IF (LERR) WRITE (6,1036) 'P',STA,COMP3,SNET, IDNO
1036      FORMAT (' *** TRAVEL TIME FOR ', A1, ' PICK OF STATION:  ',
     2            A5, 1X, A3, 1X, A2, ' ON EVENT ', I12,
     3            ' HAS BEEN TRUNCATED TO FIT' )
        END IF
        KP(K)= LTMP

        LTMP = NINT(100.* (S+LSHIF) ) 
        IF (LTMP .GT. TTMAX) THEN
          LTMP = TTOVER
        ELSE IF (LTMP .LT. TTMIN) THEN
          LTMP = TTUNDR
        END IF
        IF (LTMP .NE. NINT( 100.* (S+LSHIF) )) THEN
          IF (LPRT) WRITE (15,1036) 'S',STA,COMP3,SNET, IDNO
          IF (LERR) WRITE (6,1036) 'S',STA,COMP3,SNET, IDNO
        END IF
        KS(K)= LTMP

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

C--FILL IN PARTS OF SHADOW CARD FOR BASIC TRACE DATA
C--CODA & AMPLITUDE DATA WILL BE FILLED IN LATER, IF IT EXISTS
        LENWORD=HPN(IP).N/2	!SEISMOGRAM LENGTH IN WORDS
        KEYWORD=HPN(IP).KEY/2	!OFFSET TO START OF SEISMOGRAM IN WORDS
        TOFFSET= (HPN(IP).RTC -1.)*HST(ISS).DT
        ISET=HPX(IX).SET	!SET #
        IPIN=HPX(IX).PIN	!PIN #
C        ISET=HPN(IP).SET	!SET # (ALTERNATE)
C        IPIN=HPN(IP).PIN	!PIN # (ALTERNATE)
        
        WRITE (KSHAD(K)(51:95),1102) 
     2  ISET, IPIN,		!SET & PIN NOS.
     3  KEYWORD,		!OFFSET BEFORE FIRST WORD OF SEISMOGRAM
     4  TOFFSET,		!TIME OFFSET FROM REF TIME TO GRM START
     5  LENWORD,		!SEISMOGRAM LENGTH IN WORDS
     6  HST(ISS).DT,		!DIGITIZATION INTERVAL FOR THIS SET
     7  HST(ISS).DEV		!DIGITIZER DEVICE CODE
        
1102    FORMAT ('1',
     2  I2,I4,
     3  I10,
     4  F10.5,
     5  I7,
     6  F8.6,
     7  A3)

        KLSHA(K)=95

C--END OF PICK LOOP
50    CONTINUE
C****************************************************

C--WE RAN OUT OF ROOM IN HYPOINVERSE ARRAYS BEFORE CUSP DATA WAS EXHAUSTED
      KSTA=MAXPHS
      IF (LPRT) WRITE (15,1005) IDNO,STA,COMP3,SNET
      IF (LERR) WRITE (6,1005) IDNO,STA,COMP3,SNET
1005  FORMAT (' *** TOO MANY STATIONS FOR EVENT ',I12/
     2 ' LAST STATION FOR THIS EVENT IS:  ',A5,1X,A3,1X,A2)
      IRES=-22
C--DO NOT USE ANY MORE CUSP DATA BECAUSE THE NUMBER OF STATIONS MIGHT INCREASE
      RETURN

C--WE NOW HAVE "PICKS" FOR KSTA STATIONS.
60    KSTA=K-1

C--SKIP AN EVENT WITH FEWER THAN 3 PICKS
      IF (KSTA.LT.3) THEN
        IF (LPRT) WRITE (15,1006) KYEAR2,KMONTH,KDAY,KHOUR,KMIN,IDNO
        IF (LERR) WRITE (6,1006) KYEAR2,KMONTH,KDAY,KHOUR,KMIN,IDNO
1006    FORMAT (' *** SKIP EVENT WITH LESS THAN 3 PICKS:',I5,4I3,
     2 ' - ',I10)
        IRES=-52
        IF (JCP.EQ.7) GOTO 6
        KEND=-1
        RETURN
      END IF

      IF (LMESS) THEN
        WRITE (15,'('' --HYCIN: DONE READING PICKS'')')
        WRITE (15,1024) KSTA
1024    FORMAT (' --HYCIN: WE NOW HAVE',I4,' STATIONS')
      END IF

C------------------------------------------------------------------------
C--WE HAVE NO MORE PICKS, SO GO GET THE CODA INFORMATION.
C--LOOP OVER CODA STRUCTURES.  WE MUST ASSOCIATE EACH WITH A STATION.
C--WE WILL NOT STORE A POINTER FROM STATION K BACK TO STRUCTURE IC.
      DO 70 IC=1,HID.NCD

C--GET POINTERS TO PIN AND SET INFO
C  IP IS THE POINTER TO PIN INFO, THE ACTUAL PIN IS HCD(IC).PIN
C  IS IS THE POINTER TO SET INFO, THE ACTUAL SET IS HPN(IP).SET=HCD(IC).SET
        IP=HCD(IC).IP
        ISS=HPN(IP).IS

C--GET STATION NAME, COMPONENT & NET CODE.
C  WE WILL LATER CHOOSE HOW MANY COMPONENT LETTERS TO USE.
        STA =  HPN(IP).NAM            !USE FIRST 5 LETTERS OF 6
        COMP1= HPN(IP).TYP            !USE FIRST LETTER OF 3
        COMP3= HPN(IP).TYP            !USE ALL 3 LETTERS
        SNET=  HPN(IP).NET            !USE FIRST 2 LETTERS OF 3

C--SEARCH EXISTING STATIONS FOR WHICH WE ALREADY HAVE PICKS. IF THERE
C  IS A MATCH OF NAMES, LOAD CODA DATA WITH THAT PICK.
        DO K=1,KSTA
          J=KINDX(K)
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3    COMP3(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN

C--SAVE CODA AND WEIGHT
            TEMP=NINT(HCD(IC).TAU)
            IF (TEMP.LE.0. .OR. TEMP.GT.9999.) TEMP=0.
            KFMP(K)=NINT(TEMP)

C--GET THE CODA WEIGHT CODE, BUT DONT LET ALPHA DATA CAUSE A FATAL ERROR
C  TRANSLATE INTEGER VALUE, OR SET TO 4 IF WEIGHT CODE IS NOT AN INTEGER.
            IF (LCOWT) THEN
              KTEMP=ICHAR(HCD(IC).PHZ(4:4))-48
              IF (KTEMP.GE.7 .AND. KTEMP.LE.9) THEN
                KFWT(K)=0
              ELSE IF (KTEMP.EQ.5 .OR. KTEMP.EQ.6) THEN
                KFWT(K)=1
              ELSE IF (KTEMP.EQ.3 .OR. KTEMP.EQ.4) THEN
                KFWT(K)=2
              ELSE IF (KTEMP.EQ.1 .OR. KTEMP.EQ.2) THEN
                KFWT(K)=3
              ELSE
                KFWT(K)=4
              END IF
            END IF

C--WRITE CODA DATA ONTO THE SHADOW CARD
C--THE CODA PARAMETERS A* AND Q* CAN SOMETIMES BE UNDEFINED, SO CLAMP
C  THEM TO ZERO IF OUT OF RANGE

            AFIX=HCD(IC).AFX
            IF (AFIX.LT.-9. .OR. AFIX.GT.99.) AFIX=0.
            QFIX=HCD(IC).QFX
            IF (QFIX.LT.-9. .OR. QFIX.GT.99.) QFIX=0.
            AFREE=HCD(IC).AFR
            IF (AFREE.LT.-9. .OR. AFREE.GT.99.) AFREE=0.
            QFREE=HCD(IC).QFR
            IF (QFREE.LT.-9. .OR. QFREE.GT.99.) QFREE=0.
            CODRMS=HCD(IC).RMS
            IF (CODRMS.LT.-9. .OR. CODRMS.GT.99.) CODRMS=0.

            ITAUCD=NINT(HCD(IC).TAU)	!CODA TIME IN SECS AS MEASURED
            IAMPCD=NINT(HCD(IC).AMP)	!AMP OF SWAVE IN DIGITAL COUNTS
            IF (IAMPCD.GT.99999) IAMPCD=99999
        
            WRITE (KSHAD(K)(3:50),1106)
     1      HCD(IC).NEQ,		!NO. OF AMPLITUDE WINDOWS
     2      AFIX, QFIX,			!AFIX, QFIX
     3      AFREE, QFREE, 		!AFREE, QFREE
     4      CODRMS, 			!RMS OF CODA DURATION FIT
     5      HCD(IC).PHZ, 		!CODA PHASE DESCRIPTOR
     6      ITAUCD, 			!CODA DURATION AS DIRECTLY MEASURED
     7      IAMPCD			!AMP OF SWAVE IN DIGITAL COUNTS
        
1106        FORMAT (I3,
     2      2F5.2,
     3      2F5.2,
     4      F5.2,1X,
     5      A4, 
     6      I5,1X, 'AHS ',
     7      I5)

C--WRITE OUT CODA OF A KNOWN STATION
            IF (LMESS) WRITE (15,1025) IC,K,J, HCD(IC).PIN,
     2      HCD(IC).SET, STA,SNET,COMP3,
     3      HCD(IC).PHZ, HCD(IC).TAU

1025        FORMAT (' --HYCIN: FOUND CODA: CODA#=',
     1      I3,' K=',I3,' J=',I4,' PIN=',I3,
     2      ' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-',
     3      ' PHASE=',A8,' TAU=',F9.2)
            GOTO 70
          END IF
        END DO

C--WE DONT HAVE A PICK FOR THIS STATION, SO ADD IT IN.
C--STOP ADDING DATA IF WEVE EXCEEDED THE MAX NUMBER OF STATIONS.
        IF (KSTA .GE. MAXPHS) THEN
          IF (LPRT) WRITE (15,1005) IDNO,STA,COMP3,SNET
          IF (LERR) WRITE (6,1005) IDNO,STA,COMP3,SNET
C--DO NOT USE ANY MORE CUSP DATA BECAUSE THE NUMBER OF STATIONS MIGHT INCREASE
          RETURN
        END IF

        KSTA=KSTA+1
        K=KSTA

C--BLANK OUT ANY UNDEFINED DATA
        KPRK(K)=' '
        KSRK(K)=' '
        KWT(K)=0
C        KPSWT(K)=' '
        KRMK(K)=' '
        KRMK6(K)='    '
        KSOU(K)=' '

C        KLSHA(K)=0
        KFWT(K)=0
        AMPK(K)=0.
        KAMPU(K)=0
        KAMPTYP(K)=0
        KXWT(K)=0
        KPER(K)=0
        KCAL(K)=0

C--BLANK OUT SHADOW CARD, THEN FILL IT IN AS WE FIND DATA
        KSHAD(K)='$ '
        
C--THIS IS A NEW STATION FOR THIS EVENT. LOCATE THE STATION ON THE LOOK-UP LIST.
        DO J=1,JSTA
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3    COMP3(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN

C--SAVE CODA AND POINTER TO STATION NAME
            KINDX(K)=J
            TEMP=NINT(HCD(IC).TAU)
            IF (TEMP.LE.0. .OR. TEMP.GT.9999.) TEMP=0.
            KFMP(K)=NINT(TEMP)

C--GET THE CODA WEIGHT CODE, BUT DONT LET ALPHA DATA CAUSE A FATAL ERROR
C  TRANSLATE INTEGER VALUE, OR SET TO 4 IF WEIGHT CODE IS NOT AN INTEGER.
            IF (LCOWT) THEN
              KTEMP=ICHAR(HCD(IC).PHZ(4:4))-48
              IF (KTEMP.GE.7 .AND. KTEMP.LE.9) THEN
                KFWT(K)=0
              ELSE IF (KTEMP.EQ.5 .OR. KTEMP.EQ.6) THEN
                KFWT(K)=1
              ELSE IF (KTEMP.EQ.3 .OR. KTEMP.EQ.4) THEN
                KFWT(K)=2
              ELSE IF (KTEMP.EQ.1 .OR. KTEMP.EQ.2) THEN
                KFWT(K)=3
              ELSE
                KFWT(K)=4
              END IF
            END IF

C--SAVE DATA SOURCE
            DEVICE = HST(ISS).DEV
            CALL SOUTRAN (DEVICE,SOUCODE,DIG3,DIG1,DIGDEF,NDIG)
            KSOU(K) = SOUCODE
            KDEV(K) = DEVICE

C--WRITE CODA DATA ONTO THE SHADOW CARD
C--THE CODA PARAMETERS A* AND Q* CAN SOMETIMES BE UNDEFINED, SO CLAMP
C  THEM TO ZERO IF OUT OF RANGE

            AFIX=HCD(IC).AFX
            IF (AFIX.LT.-9. .OR. AFIX.GT.99.) AFIX=0.
            QFIX=HCD(IC).QFX
            IF (QFIX.LT.-9. .OR. QFIX.GT.99.) QFIX=0.
            AFREE=HCD(IC).AFR
            IF (AFREE.LT.-9. .OR. AFREE.GT.99.) AFREE=0.
            QFREE=HCD(IC).QFR
            IF (QFREE.LT.-9. .OR. QFREE.GT.99.) QFREE=0.
            CODRMS=HCD(IC).RMS
            IF (CODRMS.LT.-9. .OR. CODRMS.GT.99.) CODRMS=0.

            ITAUCD=NINT(HCD(IC).TAU)	!CODA TIME IN SECS AS MEASURED
            IAMPCD=NINT(HCD(IC).AMP)	!AMP OF SWAVE IN DIGITAL COUNTS
            IF (IAMPCD.GT.99999) IAMPCD=99999
        
            WRITE (KSHAD(K)(3:50),1106)
     1      HCD(IC).NEQ,		!NO. OF AMPLITUDE WINDOWS
     2      AFIX, QFIX,			!AFIX, QFIX
     3      AFREE, QFREE, 		!AFREE, QFREE
     4      CODRMS, 			!RMS OF CODA DURATION FIT
     5      HCD(IC).PHZ, 		!CODA PHASE DESCRIPTOR
     6      ITAUCD, 			!CODA DURATION AS DIRECTLY MEASURED
     7      IAMPCD			!AMP OF SWAVE IN DIGITAL COUNTS
        
C--FILL IN PARTS OF SHADOW CARD FOR BASIC TRACE DATA
            LENWORD=HPN(IP).N/2	!SEISMOGRAM LENGTH IN WORDS
            KEYWORD=HPN(IP).KEY/2 !OFFSET TO START OF SEISMOGRAM IN WORDS
            TOFFSET= (HPN(IP).RTC -1.)*HST(ISS).DT
            ISET=HCD(IC).SET	!SET #
            IPIN=HCD(IC).PIN	!PIN #
C            ISET=HPN(IP).SET	!SET # (ALTERNATE)
C            IPIN=HPN(IP).PIN	!PIN # (ALTERNATE)
        
            WRITE (KSHAD(K)(51:95),1102) 
     2      ISET, IPIN,		!SET & PIN NOS.
     3      KEYWORD,		!OFFSET BEFORE FIRST WORD OF SEISMOGRAM
     4      TOFFSET,		!TIME OFFSET FROM REF TIME TO GRM START
     5      LENWORD,		!SEISMOGRAM LENGTH IN WORDS
     6      HST(ISS).DT,		!DIGITIZATION INTERVAL FOR THIS SET
     7      HST(ISS).DEV		!DIGITIZER DEVICE CODE

            KLSHA(K)=95

C--WRITE OUT CODA OF A KNOWN STATION W/O A PICK
            IF (LMESS) WRITE (15,1026) IC,K,J, HCD(IC).PIN,
     2      HCD(IC).SET, STA,SNET,COMP3,
     3      HCD(IC).PHZ, HCD(IC).TAU

1026        FORMAT (' --HYCIN:NEW STATION: CODA#=',
     1      I3,' K=',I3,' J=',I4,' PIN=',I3,
     2      ' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-',
     3      ' PHASE=',A8,' TAU=',F9.2)
            IF (LMESS) WRITE (15,1024) KSTA
            GOTO 70
          END IF
        END DO

C--DECREMENT THE STATION INDEX SINCE THE SLOT IS UNUSED
        KSTA=KSTA-1

C--PRINT AN ERROR MESSAGE IF STATION NOT ON EXPECTED UNKNOWN LIST
        DO I=1,NLUNK
          IF (LUNK(I)(1:NSTLET) .EQ. STA(1:NSTLET)) GOTO 69
        END DO
        IF (LPRT) WRITE (15,1003) STA,COMP3,SNET,IDNO
        IF (LERR) WRITE (6,1003) STA,COMP3,SNET,IDNO
1003    FORMAT (' *** IGNORE CODA OF UNKNOWN STATION:  '
     2  ,A5,1X,A3,1X,A2,' IN EVENT NO.',I12)
        IRES=-23

69      IF (LMESS) WRITE (15,1029) IC,K, HCD(IC).PIN, HCD(IC).SET,
     1  STA,SNET,COMP3
1029    FORMAT (' --HYCIN: SKIP STATION: CODA#=',I3,
     2  ' K=',I3,' PIN=',I3,' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-')

C--END OF CODA LOOP
70    CONTINUE
      IF (LMESS) WRITE (15,'('' --HYCIN: DONE READING CODAS'')')

C------------------------------------------------------------------------
C--WE HAVE NO MORE CODAS, SO GO GET THE AMPLITUDE INFORMATION.
C--LOOP OVER AMP STRUCTURES.  WE MUST ASSOCIATE EACH WITH A STATION.
C--THERE MAY NOT BE A SEISMOGRAM, SO SHADOW CARD MAY NOT HAVE ANY DATA.
      DO 80 IA=1,HID.NAF

C--GET POINTERS TO PIN AND SET INFO
C  IP IS THE POINTER TO PIN INFO, THE ACTUAL PIN IS HAF(IA).PIN
C  IS IS THE POINTER TO SET INFO, THE ACTUAL SET IS HPN(IP).SET=HAF(IA).SET
        IP=HAF(IA).IP
        ISS=HPN(IP).IS

C--GET STATION NAME, COMPONENT & NET CODE.
C  WE WILL LATER CHOOSE HOW MANY COMPONENT LETTERS TO USE.
        STA =  HPN(IP).NAM            !USE FIRST 5 LETTERS OF 6
        COMP1= HPN(IP).TYP            !USE FIRST LETTER OF 3
        COMP3= HPN(IP).TYP            !USE ALL 3 LETTERS
        SNET=  HPN(IP).NET            !USE FIRST 2 LETTERS OF 3

C--SEARCH EXISTING STATIONS FOR WHICH WE ALREADY HAVE PICKS. IF THERE
C  IS A MATCH OF PIN NUMBERS, LOAD AMP DATA WITH THAT PICK.
        DO K=1,KSTA
          J=KINDX(K)
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3    COMP3(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN

C--FIND DIGITIZER DEVICE
            DEVICE = HST(ISS).DEV

C--SAVE PERIOD
            KPER(K)=NINT(100.*HAF(IA).PER1)
C--LIMIT PERIOD TO 10 SECS AS A REASONABLE VALUE & FOR OUTPUT FORMATS
            IF (KPER(K).GT.999) KPER(K)=999

C--SAVE AMPLITUDE IN DIGITIZER COUNTS, MARK UNITS AS DIGITIZER COUNTS
C--CONVERSION OF AMP TO MM OCCURS IN HYMAG
            AMPK(K)=HAF(IA).AMP1
            KAMPU(K)=2
C--HVO 14-BIT COUNTS
            IF (DEVICE.EQ.'OBI' .OR. DEVICE.EQ.'XOB') KAMPU(K)=3

C--REDUCE COUNTS TO HUNDREDS OF UNITS IF THEY EXCEED 1 MILLION
            IF (AMPK(K).GT.999999.) THEN
              AMPK(K)=.01*AMPK(K)
              KAMPU(K)=4
            END IF

C--RECORD AMPLITUDE TYPE
            CALL AMPTRAN (COMP3,IAMPTYP)
            KAMPTYP(K)=IAMPTYP

C--USE AMPLITUDE REMARK AS STATION REMARK
            KRMK(K)=HAF(IA).PHZ1

C--WRITE OUT AMP OF A KNOWN STATION
            IF (LMESS) WRITE (15,1027) IA,K,J, HAF(IA).PIN,
     2      HAF(IA).SET, STA,SNET,COMP3,
     3      HAF(IA).PHZ1, HAF(IA).AMP1

1027        FORMAT (' --HYCIN: FOUND  AMP:  AMP#=',
     1      I3,' K=',I3,' J=',I4,' PIN=',I3,
     2      ' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-',
     3      ' PHASE=',A8,' AMP=',F9.2)
     
            GOTO 80
          END IF
        END DO

C--WE DONT HAVE A PICK OR CODA FOR THIS STATION, SO ADD STATION IN.
C--STOP ADDING DATA IF WEVE EXCEEDED THE MAX NUMBER OF STATIONS.
        IF (KSTA .GE. MAXPHS) THEN
          IF (LPRT) WRITE (15,1005) IDNO,STA,COMP3,SNET
          IF (LERR) WRITE (6,1005) IDNO,STA,COMP3,SNET
C--DO NOT USE ANY MORE CUSP DATA BECAUSE THE NUMBER OF STATIONS MIGHT INCREASE
          RETURN
        END IF

        KSTA=KSTA+1
        K=KSTA

C--BLANK OUT ANY UNDEFINED DATA
        KPRK(K)=' '
        KSRK(K)=' '
        KWT(K)=0
C        KPSWT(K)=' '
        KRMK(K)=' '
        KRMK6(K)='    '

        KLSHA(K)=0
        KFWT(K)=0
        KFMP(K)=0
        KXWT(K)=0
        KCAL(K)=0

C--BLANK OUT SHADOW CARD, THEN FILL IT IN AS WE FIND DATA
        KSHAD(K)='$ '

C--THIS IS A NEW STATION FOR THIS EVENT.
C--LOCATE THE STATION ON THE LOOK-UP LIST.
        DO J=1,JSTA
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3    COMP3(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN
            KINDX(K)=J

C--SAVE DATA SOURCE
            DEVICE = HST(ISS).DEV
            CALL SOUTRAN (DEVICE,SOUCODE,DIG3,DIG1,DIGDEF,NDIG)
            KSOU(K) = SOUCODE
            KDEV(K) = DEVICE

C--SAVE PERIOD
            KPER(K)=NINT(100.*HAF(IA).PER1)
C--LIMIT PERIOD TO 10 SECS AS A REASONABLE VALUE & FOR OUTPUT FORMATS
            IF (KPER(K).GT.999) KPER(K)=999

C--SAVE AMPLITUDE IN DIGITIZER COUNTS, MARK UNITS AS DIGITIZER COUNTS
C--CONVERSION OF AMP TO MM OCCURS IN HYMAG
            AMPK(K)=HAF(IA).AMP1
            KAMPU(K)=2
C--HVO 14-BIT COUNTS
            IF (DEVICE.EQ.'OBI' .OR. DEVICE.EQ.'XOB') KAMPU(K)=3

C--REDUCE COUNTS TO HUNDREDS OF UNITS IF THEY EXCEED 1 MILLION
            IF (AMPK(K).GT.999999.) THEN
              AMPK(K)=.01*AMPK(K)
              KAMPU(K)=4
            END IF

C--RECORD AMPLITUDE TYPE
            CALL AMPTRAN (COMP3,IAMPTYP)
            KAMPTYP(K)=IAMPTYP

C--USE AMPLITUDE REMARK AS STATION REMARK
            KRMK(K)=HAF(IA).PHZ1

C--WRITE OUT AMP OF A KNOWN STATION W/O A PICK
            IF (LMESS) WRITE (15,1028) IA,K,J, HAF(IA).PIN,
     2      HAF(IA).SET, STA,SNET,COMP3,
     3      HAF(IA).PHZ1, HAF(IA).AMP1

1028        FORMAT (' --HYCIN:NEW STATION:  AMP#=',
     1      I3,' K=',I3,' J=',I4,' PIN=',I3,
     2      ' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-',
     3      ' PHASE=',A8,' AMP=',F9.2)
            IF (LMESS) WRITE (15,1024) KSTA

C--FILL IN PARTS OF SHADOW CARD FOR BASIC TRACE DATA
            LENWORD=HPN(IP).N/2	!SEISMOGRAM LENGTH IN WORDS
            KEYWORD=HPN(IP).KEY/2 !OFFSET TO START OF SEISMOGRAM IN WORDS
            TOFFSET= (HPN(IP).RTC -1.)*HST(ISS).DT
            ISET=HAF(IA).SET	!SET #
            IPIN=HAF(IA).PIN	!PIN #
C            ISET=HPN(IP).SET	!SET # (ALTERNATE)
C            IPIN=HPN(IP).PIN	!PIN # (ALTERNATE)
        
            WRITE (KSHAD(K)(51:95),1102) 
     2      ISET, IPIN,		!SET & PIN NOS.
     3      KEYWORD,		!OFFSET BEFORE FIRST WORD OF SEISMOGRAM
     4      TOFFSET,		!TIME OFFSET FROM REF TIME TO GRM START
     5      LENWORD,		!SEISMOGRAM LENGTH IN WORDS
     6      HST(ISS).DT,	!DIGITIZATION INTERVAL FOR THIS SET
     7      HST(ISS).DEV	!DIGITIZER DEVICE CODE

            KLSHA(K)=95

            GOTO 80
          END IF
        END DO

C--DECREMENT THE STATION INDEX SINCE THE SLOT IS UNUSED
        KSTA=KSTA-1

C--PRINT AN ERROR MESSAGE IF STATION NOT ON EXPECTED UNKNOWN LIST
        DO I=1,NLUNK
          IF (LUNK(I)(1:NSTLET) .EQ. STA(1:NSTLET)) GOTO 79
        END DO
        IF (LPRT) WRITE (15,1007) STA,COMP3,SNET,IDNO
        IF (LERR) WRITE (6,1007) STA,COMP3,SNET,IDNO
1007    FORMAT (' *** IGNORE AMP OF UNKNOWN STATION:  '
     2  ,A5,1X,A3,1X,A2,' IN EVENT NO.',I12)
        IRES=-24

79      IF (LMESS) WRITE (15,1030) IA,K, HAF(IA).PIN, HAF(IA).SET,
     1  STA,SNET,COMP3
1030    FORMAT (' --HYCIN: SKIP STATION:  AMP#=',I3,
     2  ' K=',I3,' PIN=',I3,' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-')

C--END OF AMP LOOP
80    CONTINUE
      IF (LMESS) WRITE (15,1031) 
1031  FORMAT (' --HYCIN: DONE READING AMPS.')

C------------------------------------------------------------------------
C--WE HAVE NO MORE AMPS, SO GO GET THE W-A AMPS INFORMATION.
C--LOOP OVER W-A AMP STRUCTURES.  WE MUST ASSOCIATE EACH WITH A STATION.
      DO 90 IW=1,HID.NAM

C--GET POINTERS TO PIN AND SET INFO
C  IP IS THE POINTER TO PIN INFO, THE ACTUAL PIN IS HAM(IW).PIN
C  IS IS THE POINTER TO SET INFO, THE ACTUAL SET IS HPN(IP).SET=HAM(IW).SET
        IP=HAM(IW).IP
        ISS=HPN(IP).IS

C--GET STATION NAME, COMPONENT & NET CODE.
C  WE WILL LATER CHOOSE HOW MANY COMPONENT LETTERS TO USE.
        STA =  HPN(IP).NAM            !USE FIRST 5 LETTERS OF 6
        COMP1= HPN(IP).TYP            !USE FIRST LETTER OF 3
        COMP3= HPN(IP).TYP            !USE ALL 3 LETTERS
        SNET=  HPN(IP).NET            !USE FIRST 2 LETTERS OF 3

C--SEARCH EXISTING STATIONS FOR WHICH WE ALREADY HAVE PICKS. IF THERE
C  IS A MATCH OF NAMES, LOAD W-A AMP DATA WITH THAT PICK.
C--$$$ THE COMPONENT NAMES MAY TAKE SPECIAL TESTING
        DO K=1,KSTA
          J=KINDX(K)
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3    COMP3(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN

C--FIND WA DIGITIZER DEVICE
            DEVICE = HST(ISS).DEV

C--SAVE WA PERIOD
            KPER(K)=NINT(100.*HAM(IW).PER1)
C--LIMIT PERIOD TO 10 SECS AS A REASONABLE VALUE & FOR OUTPUT FORMATS
            IF (KPER(K).GT.999) KPER(K)=999

C--SAVE WA AMPLITUDE. UNITS ARE COUNTS ONLY IF FROM A DIGITIZER.
            AMPK(K)=HAM(IW).AMP1
            KAMPU(K)=0				!PP MM
            IF (DEVICE.EQ.'HRD' .OR. DEVICE.EQ.'DST' .OR. 
     2      DEVICE.EQ.'REF') KAMPU(K)=2		!COUNTS
C--HVO 14-BIT COUNTS
            IF (DEVICE.EQ.'OBI' .OR. DEVICE.EQ.'XOB') KAMPU(K)=3

C--REDUCE COUNTS TO HUNDREDS OF UNITS IF THEY EXCEED 1 MILLION
            IF (AMPK(K).GT.999999.) THEN
              AMPK(K)=.01*AMPK(K)
              KAMPU(K)=4
            END IF

C--RECORD AMPLITUDE TYPE
C            CALL AMPTRAN (COMP3,IAMPTYP)
C            KAMPTYP(K)=IAMPTYP
C--TAKE THE BOLD STEP OF ASSUMING WA RESPONSE BECAUSE AMP IS IN WA TUPLE
            KAMPTYP(K)=1

C--USE AMPLITUDE REMARK AS STATION REMARK
            KRMK(K)=HAM(IW).PHZ1

C--WRITE OUT W-A AMP OF A KNOWN STATION
            IF (LMESS) WRITE (15,1032) IW,K,J, HAM(IW).PIN,
     2      HAM(IW).SET, STA,SNET,COMP3,
     3      HAM(IW).PHZ1, HAM(IW).AMP1

1032        FORMAT (' --HYCIN: FOUND  W-A:  W-A#=',
     1      I3,' K=',I3,' J=',I4,' PIN=',I3,
     2      ' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-',
     3      ' PHASE=',A8,' AMP=',F9.2)
            GOTO 90
          END IF
        END DO

C--WE DONT HAVE A PICK, CODA OR AMP FOR THIS STATION, SO ADD STATION IN.
C--STOP ADDING DATA IF WEVE EXCEEDED THE MAX NUMBER OF STATIONS.
        IF (KSTA .GE. MAXPHS) THEN
          IF (LPRT) WRITE (15,1005) IDNO,STA,COMP3,SNET
          IF (LERR) WRITE (6,1005) IDNO,STA,COMP3,SNET
C--DO NOT USE ANY MORE CUSP DATA BECAUSE THE NUMBER OF STATIONS MIGHT INCREASE
          RETURN
        END IF

        KSTA=KSTA+1
        K=KSTA

C--BLANK OUT ANY UNDEFINED DATA
        KPRK(K)=' '
        KSRK(K)=' '
        KWT(K)=0
C        KPSWT(K)=' '
        KRMK(K)=' '
        KRMK6(K)='    '

        KLSHA(K)=0
        KFWT(K)=0
        KFMP(K)=0
        KXWT(K)=0
        KCAL(K)=0

C--BLANK OUT SHADOW CARD
        KSHAD(K)='$ '
        KLSHA(K)=2

C--THIS IS A NEW STATION FOR THIS EVENT.
C--LOCATE THE STATION ON THE LOOK-UP LIST.
C--$$$ THE COMPONENT NAMES MAY TAKE SPECIAL TESTING
        DO J=1,JSTA
          IF (STA(1:NSTLET) .EQ. STANAM(J)(1:NSTLET) .AND.
     2    SNET(1:NETLET) .EQ. JNET(J)(1:NETLET) .AND.
     3    COMP3(1:NCOMP) .EQ. JCOMP3(J)(1:NCOMP)) THEN

            KINDX(K)=J

C--SAVE WA DATA SOURCE
            DEVICE = HST(ISS).DEV
            CALL SOUTRAN (DEVICE,SOUCODE,DIG3,DIG1,DIGDEF,NDIG)
            KSOU(K) = SOUCODE
            KDEV(K) = DEVICE

C--SAVE WA PERIOD
            KPER(K)=NINT(100.*HAM(IW).PER1)
C--LIMIT PERIOD TO 10 SECS AS A REASONABLE VALUE & FOR OUTPUT FORMATS
            IF (KPER(K).GT.999) KPER(K)=999

C--SAVE WA AMPLITUDE. UNITS ARE COUNTS ONLY IF FROM A DIGITIZER.
            AMPK(K)=HAM(IW).AMP1
            KAMPU(K)=0				!PP MM
            IF (DEVICE.EQ.'HRD' .OR. DEVICE.EQ.'DST' .OR. 
     2      DEVICE.EQ.'REF') KAMPU(K)=2		!COUNTS
C--HVO 14-BIT COUNTS
            IF (DEVICE.EQ.'OBI' .OR. DEVICE.EQ.'XOB') KAMPU(K)=3

C--REDUCE COUNTS TO HUNDREDS OF UNITS IF THEY EXCEED 1 MILLION
            IF (AMPK(K).GT.999999.) THEN
              AMPK(K)=.01*AMPK(K)
              KAMPU(K)=4
            END IF

C--RECORD AMPLITUDE TYPE
C            CALL AMPTRAN (COMP3,IAMPTYP)
C            KAMPTYP(K)=IAMPTYP
C--TAKE THE BOLD STEP OF ASSUMING WA RESPONSE BECAUSE AMP IS IN WA TUPLE
            KAMPTYP(K)=1

C--USE AMPLITUDE REMARK AS STATION REMARK
            KRMK(K)=HAM(IW).PHZ1

C--WRITE OUT W-A AMP OF A KNOWN STATION W/O A PICK
            IF (LMESS) WRITE (15,1033) IW,K,J, HAM(IW).PIN,
     2      HAM(IW).SET, STA,SNET,COMP3,
     3      HAM(IW).PHZ1, HAM(IW).AMP1

1033        FORMAT (' --HYCIN:NEW STATION:  W-A#=',
     1      I3,' K=',I3,' J=',I4,' PIN=',I3,
     2      ' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-',
     3      ' PHASE=',A8,' AMP=',F9.2)
            IF (LMESS) WRITE (15,1024) KSTA
            GOTO 90
          END IF
        END DO

C--DECREMENT THE STATION INDEX SINCE THE SLOT IS UNUSED
        KSTA=KSTA-1

C--PRINT AN ERROR MESSAGE IF STATION NOT ON EXPECTED UNKNOWN LIST
        DO I=1,NLUNK
          IF (LUNK(I)(1:NSTLET) .EQ. STA(1:NSTLET)) GOTO 89
        END DO
        IF (LPRT) WRITE (15,1041) STA,COMP3,SNET,IDNO
        IF (LERR) WRITE (6,1041) STA,COMP3,SNET,IDNO
1041    FORMAT ('WOOD-ANDERSON AMP FROM UNKNOWN STATION:',A5,A4,A3,I10)
        IRES=-25

89      IF (LMESS) WRITE (15,1034) IW,K, HAM(IW).PIN, HAM(IW).SET,
     1  STA,SNET,COMP3
1034    FORMAT (' --HYCIN: SKIP STATION:  W-A#=',I3,
     2  ' K=',I3,' PIN=',I3,' SET=',I2,' STA=',A5,'-',A2,'-'A3,'-')

C--END OF W-A AMP LOOP
90    CONTINUE
      IF (LMESS) WRITE (15,1035) KSTA
1035  FORMAT (' --HYCIN: DONE READING W-A AMPS.'/
     2 ' --HYCIN: WE HAVE A GRAND TOTAL OF',I4,' STATIONS')

C--SIGNAL WHETHER THIS IS THE LAST EVENT
      IF (JCP.EQ.6) KEND=1
      IF (JCP.EQ.7) KEND=0

      RETURN
      END
      
C      SUBROUTINE SOUTRAN (DEVICE,CODE)
C--TRANSLATES CUSP DEVICE CODES FROM THE SRC TUPLE (SET LEVEL) INTO
C  1-LETTER SOURCE CODES
C--INPUT - DEVICE - 3-LETTER DEVICE CODES FROM THE SRC TUPLE (SET LEVEL)
C--OUTPUT - CODE  - 1-LETTER SOURCE CODE
C      CHARACTER DEVICE*3, CODE*1
      
C      IF (DEVICE.EQ.'NTL') THEN			!NATIONAL DIGITIZER
C        CODE='N'
C      ELSE IF (DEVICE(1:2).EQ.'T2') THEN	!TUSTIN DIGITIZER #2
C        CODE='2'
C      ELSE IF (DEVICE.EQ.'ECL') THEN		!ECLIPSE
C        CODE='E'
C      ELSE IF (DEVICE.EQ.'ML1') THEN		!NATIONAL AT MAMMOTH
C        CODE='Q'
C      ELSE IF (DEVICE.EQ.'CH1') THEN		!NATIONAL AT CARR HILL
C        CODE='K'
C      ELSE IF (DEVICE(1:2).EQ.'T1') THEN	!TUSTIN DIGITIZER #1
C        CODE='1'
C      ELSE IF (DEVICE(1:2).EQ.'FM') THEN	!CUSP/VAX 750 DIGITIZER
C        CODE='F'
CC--HVO CUSP DIGITIZER
C      ELSE IF (DEVICE.EQ.'OBI' .OR. DEVICE.EQ.'XOB') THEN
C        CODE='C'
CC--UNR IMPORTED SEISMOGRAMS
C      ELSE IF (DEVICE.EQ.'IM1' .OR. DEVICE.EQ.'R32'
C     2 .OR. DEVICE.EQ.'RF1') THEN
C        CODE='I'
CC--CALTECH IMPORTED SEISMOGRAMS
C      ELSE IF (DEVICE.EQ.'IM2') THEN	!PASADENA TUSTIN
C        CODE='4'
C      ELSE IF (DEVICE.EQ.'IM3') THEN	!BAKERSFIELD
C        CODE='V'
C      ELSE IF (DEVICE.EQ.'IM4') THEN	!SIMMLER
C        CODE='Z'
CC--HRX -ANALOG STATIONS DIGITIZED BY NANO. HRD'S AT CENTRAL POINTS (SHZ COMPS)
C      ELSE IF (DEVICE.EQ.'HRX') THEN
C        CODE='X'
C      ELSE IF (DEVICE.EQ.'BM1') THEN		!NATIONAL AT BLACK MOUNTAIN
C        CODE='X'
CC--DIGITIZED AT SEISMOMETER
C      ELSE	!DIGITIZED AT SEISMOMETER (REF, HRD, DST, ETC.)
C        CODE='A'
C      END IF
C      RETURN
C      END

      SUBROUTINE SOUTRAN (DEVICE,SOUCODE,DIG3,DIG1,DIGDEF,NDIG)
C--TRANSLATES CUSP DEVICE CODES FROM THE SRC TUPLE (SET LEVEL) INTO
C  1-LETTER SOURCE CODES
C--INPUT - DEVICE - 3-LETTER DEVICE CODES FROM THE SRC TUPLE (SET LEVEL)
C--OUTPUT - SOUCODE  - 1-LETTER SOURCE CODE
      CHARACTER DEVICE*3, SOUCODE*1, DIG3(1)*3, DIG1(1)*1, DIGDEF*1
      
      DO I=1,NDIG
        IF (DIG3(I) .EQ. DEVICE) THEN
          SOUCODE=DIG1(I)
          RETURN
        END IF
      END DO

      SOUCODE=DIGDEF
      RETURN
      END

      SUBROUTINE AMPTRAN (C3,IA)
C--DETERMINES THE EXPECTED TYPE OF AMPLITUDE FROM THE SEISMOMETER TYPE
C  VIA THE COMPONENT CODE.  THESE ARE USGS MENLO DEFINITIONS.

C  CODE	PRINT	SEISMOMETER
C   IA	LETTER
C   0	BLANK	UNSPECIFIED, USE STATION INSTRUMENT TYPE FROM STATION CARD
C   1	W	WOOD-ANDERSON (DISPLACEMENT RESPONSE)
C   2	V	VELOCITY SEISMOMETER, THE USGS DEFAULT
C   3	A	ACCELEROMETER, NO MAGNITUDE
C   4	X	DO NOT CALCULATE A MAGNITUDE, PECULIAR INSTRUMENT
C   5	D	DILATOMETER

C  C3 IS INPUT COMP3, IA IS OUTPUT (K,I)AMPTYP

      CHARACTER C3*3, C2*2
      C2=C3			!FIRST 2 LETTERS OF COMPONENT CODE
      IA=0			!UNSPECIFIED TYPE
      IF (C2.EQ.'  ') RETURN

C--VELOCITY
      IF (C2.EQ.'VH' .OR. C2.EQ.'VL' .OR. C2.EQ.'VD') THEN
        IA=2
      ELSE IF (C2.EQ.'EH' .OR. C2.EQ.'EL' .OR. C2.EQ.'EP') THEN
        IA=2
      ELSE IF (C2.EQ.'VF' .OR. C2.EQ.'VL' .OR. C2.EQ.'EL') THEN
        IA=2
      ELSE IF (C2.EQ.'HH' .OR. C2.EQ.'BH') THEN
        IA=2

C--ACCELERATION
      ELSE IF (C2.EQ.'AD' .OR. C2.EQ.'AS' .OR. C2.EQ.'HN') THEN
        IA=3
      ELSE IF (C2.EQ.'HL' .OR. C2.EQ.'BL' .OR. C2.EQ.'BN') THEN
        IA=3

C--TIME TRACES, ETC
      ELSE IF (C2.EQ.'AT' .OR. C2.EQ.'T ') THEN
        IA=4

C--DILATOMETER
      ELSE IF (C2.EQ.'HV' .OR. (C3(1:1).EQ.'D'.AND.C3(3:3).EQ.'I')) THEN
        IA=5
      END IF
      RETURN
      END
