C--ARCPRINT REFORMATS A HYPOINVERSE ARCHIVE FILE INTO A FORMAT SUITABLE
C  FOR PRINTING. HANDLES BOTH OLD & Y2000 FORMAT FILES. 6/04 VERSION.
C--ARCPRINTS IS WRITTEN AS A FILTER & HAS FEWER OPTIONS.
C--BEHAVIOR IS CONTROLLED BY THE FLAG LIA, CHANGE LINES WITH CX:
C  LIA=T  INTERACTIVE, SUMLIST2000, ARCPRINT
C  LIA=F  NOT INTERACTIVE, SUMLIST2000S, ARCPRINTS

C--FORMAT IS SENSED BY THE FIRST SUMMARY LINE WITH THESE CHARACTERISTICS:
C INPUT FORMAT IFOR:
C 2 HYPOINV:      COL  9 NON-BLANK AND COL 17 NOT A DIGIT (NORMALLY BLANK OR 'S')
C 1 HYPOINV-2000: COL 12 NON-BLANK AND COL 17 A DIGIT

      LOGICAL  LASK
      EXTERNAL LASK

      DIMENSION E(3,3),IAZ(3),IDIP(3),SERR(3)
      CHARACTER STA*4, STA5*1, STAU*5, LSTAU*5, SLOC*2
      CHARACTER REMK3*3,REMK1*1,REMK2*1, CXMAG*4,CFMAG*4,CPMAG*4, C4*4
      CHARACTER ARCFIL*80, PRTFIL*80, CARD*132, SCARD*164
      CHARACTER PRMK*3, CPW*1, SRMK*2, CSW*1, CAMP*19
      CHARACTER NET*2, COMP1*1, COMP3*3, MONTH(12)*3
      CHARACTER CXWT*1, CFWT*1, STARMK*1, CDUR*13, CX*14, FMTYP*1
      CHARACTER SOU*1, DSOU(3)*1, CRUS*3, STAR*1
      CHARACTER BMTYP*1, PMTYP*1, FMTYP2*1, FMNOT*1,XMNOT*1
      CHARACTER XMTYP*1, XMTYP2*1, CF*14, VERS*2,AUTH*1
      CHARACTER EVTRMK(10)*14, EVTRM(10)*1, MAGLIN*53, WTCODE*1
      LOGICAL LPT
      DATA ARCFIL,PRTFIL,RDEG,LPT,ISEQ /2*' ',57.2958,.FALSE.,0/

CX    PARAMETER (IIN=2,IOUT=3)  !CX
      PARAMETER (IIN=5,IOUT=6)  !CX
      LOGICAL LDIG17, LIA
CX    DATA LIA /.TRUE./         !CX ARCPRINT
      DATA LIA /.FALSE./        !CX ARCPRINTS

C--REGION CODES & FULL NAMES
      CHARACTER CD(131)*3, FN(131)*25
      DATA CD /
C--NO. CALIF.
     2 'SFP','BLM','LOM','SAR','BUS','SJB','STN','PIN','HOL','PAI',
     3 'BVL','BIT','SLA','MID','GOL','HAY','MIS','CON','DAN','SUN',
     4 'ALU','SFL','CYN','CYS','QUI','GRN','HAM','ORT','PAN','CRV',
     5 'COA','SFB','SCV','ANN','MON','SAL','SUR','ROB','SSM','SIM',
     6 'MAR','ROG','GEY','TOL','GVL','PAR','MAA','BAR','MEN','EUR',
     7 'DEL','SAC','JQN','KLA','SHA','LAS','ALM','ORO','AUB','YOS',
     8 'WAK','MOB','BRC','KAI','LVC','VOT','RSM','SCA','BAK','ORE',
     9 'MOD','NEV','MCA','PON','POS','GLA','MOL','CHV','WHI','COS',
     9 'IWV','WWF','OWV','DEV','INC','WMO','NMO','EMO','SMO','DOM',
     1 'MAM','HCF','GAR','CAS','RVL','CHA','MOR','SHE','SIL','WCN',
     2 'WCS','SBA',
C-hawaii
     3 'SNC','SSC','SEC','SER','SME','KOA','SSF','SLE','SF1','SF2',
     4 'SF3','SF4','SF5','LER','MLO','LSW','GLN','SWR','INT','KAO',
     5 'DEP','DLS','DML','LOI','HUA','KOH','KEA','HIL','DIS'/

C--EVENT REMARKS
      DATA EVTRM /'Q','R','E','N','F','M','B','T','L',' '/
      DATA EVTRMK /
     2 'Quarry blast  ','Explosion     ','Explosion     ',
     3 'Nuclear Test  ','Felt          ','Multiple event',
     4 'Blast         ','Tremor assoc. ','Long period   ',' '/

C--MONTHS
      DATA MONTH /'JAN','FEB','MAR','APR','MAY','JUN',
     2            'JUL','AUG','SEP','OCT','NOV','DEC'/
      WTCODE=' '

C--GET & OPEN FILES
2     IF (LIA) THEN
        CALL ASKC('INPUT HYPOINVERSE ARCHIVE FILE',ARCFIL)
        CALL OPENR(IIN,ARCFIL,'F',IOS)
        IF (IOS.GT.0) THEN
          WRITE (6,*) 'CANT FIND INPUT ARC FILE'
          STOP
        END IF

        CALL ASKC('OUTPUT PRINT FILE',PRTFIL)
        CALL OPENW (IOUT,PRTFIL,'F',IOS,'S')
        IF (IOS.GT.0) THEN
          WRITE (6,*) 'CANT OPEN OUTPUT PRINT FILE'
          STOP
        END IF

        LPT = LASK('PRINT UNWEIGHTED STATIONS',LPT)
      END IF

C--ATTEMPT TO DETERMINE FILE FORMAT & INFORM USER
      READ (IIN,'(A)',END=91,ERR=90) SCARD
      IDIG17=ICHAR(SCARD(17:17))
      LDIG17=IDIG17.GT.47 .AND. IDIG17.LT.58   !T IF A NUMERICAL DIGIT
C     REWIND (IIN)

C--THESE TESTS COULD BE PERFORMED IN ANY ORDER, BUT DO MOST COMMON FIRST:
      IF (LDIG17 .AND. SCARD(12:12).NE.' ') THEN   !HYPOINV-2000
        IFOR=1
        IF (LIA) WRITE (6,*) 'READING HYPOINVERSE-2000 FORMAT'
      ELSE IF (.NOT.LDIG17 .AND. SCARD(9:9).NE.' ') THEN   !HYPOINVERSE
        IFOR=2
        IF (LIA) WRITE (6,*) 'READING OLD HYPOINVERSE FORMAT'
      ELSE
        WRITE (6,*) 'UNRECOGNIZED ARCHIVE FORMAT, ARCPRINT QUITS'
        STOP
      END IF
      GOTO 6

C--READ SUMMARY LINE
5     READ (IIN,1006,END=99) SCARD
C--SKIP IF A SHADOW RECORD
6     IF (SCARD(1:1).EQ.'$') GOTO 5

C--HYPOINVERSE 2000
      IF (IFOR.EQ.1) THEN
        READ (SCARD,2000,ERR=90) IY,IM,ID,IH,IN,SEC, LAT,XLAT,LON,XLON,
     2 Z,XMAG,NR,IGAP,MIND,RMS, (IAZ(I),IDIP(I),SERR(I),I=1,2),
     3 FMAG,REMK3,SERR(3),REMK1,REMK2, NS,ERH,ERZ,NFM,
     4 XMN,FMN,XMRMS,FMRMS, CRUS, AUTH,DSOU,FMTYP, NVR,XMTYP,
     5 BMTYP,BMAG,BMAGN, XMTYP2,XMAG2,XMAGN2, IDNO,
     6 PMTYP,PMAG,PMAGN, FMTYP2,FMAG2,FMAGN2, VERS

2000    FORMAT (I4,4I2,F4.2, I2,1X,F4.2,I3,1X,F4.2,
     2 F5.2,F3.2,3I3,F4.2, 2(I3,I2,F4.2),
     3 F3.2,A3,F4.2,2A1, I3,2F4.2,I3,
     4 2F4.1,2F3.2, A3, 5A1, I3,A1,
     5 2(A1,F3.2,F3.1), I10,
     6 2(A1,F3.2,F4.1), A2)

C--OLD HYPOINVERSE
      ELSE IF (IFOR.EQ.2) THEN
        READ (SCARD,1000,ERR=90) IY,IM,ID,IH,IN,SEC,
     1 LAT,XLAT,LON,XLON,Z,
     2 XMAG,NR,IGAP,MIND,RMS, (IAZ(I),IDIP(I),SERR(I),I=1,2),
     3 FMAG,REMK3,SERR(3),REMK1,REMK2, NS,ERH,ERZ,NFM,
     4 XMN,FMN,XMRMS,FMRMS, CRUS, AUTH,DSOU,FMTYP, NVR,XMTYP,
     5 BMTYP,BMAG,BMAGN, XMTYP2,XMAG2,XMAGN2, IDNO,
     6 PMTYP,PMAG,PMAGN, FMTYP2,FMAG2,FMAGN2, VERS

1000    FORMAT (5I2,F4.2, I2,1X,F4.2,I3,1X,F4.2,F5.2,
     2 F2.1,3I3,F4.2, 2(I3,I2,F4.2),
     3 F2.1,A3,F4.2,2A1, I2,2F4.2,I2,
     4 2F3.1,2F3.2, A3, 5A1, I3,A1,
     5 2(A1,F3.2,F3.1), I10,
     6 2(A1,F3.2,F3.1), A2)
      END IF

C--INITIALIZE FOR EACH EVENT
      LSTAU=' '
      NLPT=0
      IF (IY.LT.1900) IY=IY+1900
      ISEQ=ISEQ+1

C--COMPLETE ERROR ELLIPSE. ORIENTATION OF 3RD STD ERROR IS CROSS PRODUCT
C  OF FIRST TWO
      DO I=1,2
        E(I,3)=SIN(IDIP(I)/RDEG)
        T1=SQRT(1.-E(I,3)**2)
        E(I,1)=COS(IAZ(I)/RDEG)*T1
        E(I,2)=SIN(IAZ(I)/RDEG)*T1
      END DO

      DO I=1,3
        J=I+1
        K=I+2
        IF (J.GT.3) J=J-3
        IF (K.GT.3) K=K-3
        E(3,I)=E(1,J)*E(2,K)-E(1,K)*E(2,J)
      END DO

C--GET THE ORIENTATION OF SERR(3) FROM THE UNIT VECTORS
      IF (E(3,2).EQ.0. .AND. E(3,1).EQ.0.) THEN
        IAZ(3)=0.
      ELSE
        IAZ(3)=RDEG* ATAN2 (E(3,2), E(3,1))
      END IF
      IF (IAZ(3).LT.0) IAZ(3)=IAZ(3)+360
      IDIP(3)=RDEG* ABS( ATAN2( E(3,3), SQRT( E(3,1)**2 +E(3,2)**2)))

1004  FORMAT (I1)
1006  FORMAT (A)
1010  FORMAT (I4)

C--CHANGE MAGNITUDES TO ALPHA
      CXMAG='   '
      CFMAG='   '
      CPMAG='   '
      IF (XMAG.GT.0.) WRITE (CXMAG,1001) XMAG
      IF (FMAG.GT.0.) WRITE (CFMAG,1001) FMAG
      IF (PMAG.GT.0.) WRITE (CPMAG,1001) PMAG
1001  FORMAT (F4.2)

      CX=' '
      CF=' '
      IF (XMN.GT.0.) WRITE (CX,1002) XMN,XMRMS,XMTYP
      IF (FMN.GT.0.) WRITE (CF,1002) FMN,FMRMS,FMTYP
1002  FORMAT (F6.1,F6.2,1X,A1)

C--WRITE SUMMARY LOCATION DATA ---------------------------------
C--WRITE IDNO
      WRITE (IOUT,1011) ID,MONTH(IM),IY, IH,IN,
     2 ISEQ,IDNO
1011  FORMAT (/22('####'),/I3,1X,A3,I5,',', I3,':',I2.2,
     2 '  SEQUENCE NO.',I5, ', ID NO. ',I10)

C--WRITE ERROR ELLIPSE
      WRITE (IOUT,1022) (SERR(I),IAZ(I),IDIP(I),I=1,3)
1022  FORMAT ('ERROR ELLIPSE: <SERR AZ DIP>', 3('-<',F6.2,I4,I3,'>'))

C--WRITE LOCATION AND MAGNITUDES
      WRITE (IOUT,1005) IY,IM,ID,IH,IN,SEC, LAT,XLAT,LON,XLON,Z,
     4 RMS,ERH,ERZ, CXMAG,CFMAG,CPMAG, PMTYP,
     7 MIND,CRUS, IGAP,NFM,NR,NS,NVR, REMK3,REMK1,REMK2,VERS,
     8 CX,CF, DSOU 

1005  FORMAT (22('----')/'YEAR MO DA  --ORIGIN--  --LAT N',
     2 '-  --LON W--  DEPTH   RMS   ERH   ERZ  XMAG  FMAG   PMAG'/

     1 I4,'-',I2.2,'-',I2.2,2X,2I2.2,F6.2, I4,F6.2,I5,F6.2,F7.2,
     4 3F6.2, 3(2X,A4), A1,/ 75X,'SOURCE'/

     5 'DMIN MODEL GAP NFM NWR NWS NVR  REMARKS',
     6 '-VE N.XMAG-XMMAD-T  N.FMAG-FMMAD-T  L F X'/

     7 I4,2X,A3, I5,4I4,2X, A3,1X,2A1,2X,A2,1X,
     8 A14,2X,A14, 1X,3(1X,A1)/)

C--WRITE ANY ADDITIONAL MAGNITUDES
      IF (XMAG2.GT.0. .OR. FMAG2.GT.0. .OR. PMAG.GT.0.) THEN
        MAGLIN=' '

        IF (XMAG2.GT.0.) WRITE (MAGLIN(1:16),1014) XMAG2,XMAGN2,
     2 XMTYP2,DSOU(3)
        IF (FMAG2.GT.0.) WRITE (MAGLIN(19:34),1014) FMAG2,FMAGN2,
     2 FMTYP2,DSOU(2)
        IF (PMAG.GT.0.) WRITE (MAGLIN(40:53),1014) PMAG,PMAGN,PMTYP
1014    FORMAT (F5.2,F7.2,1X,A1,1X,A1)

        WRITE (IOUT,1026) MAGLIN
1026    FORMAT ('XMAG2-N.XMG2-T-S  FMAG2-N.FMG2-T-S',
     2 '  PREF.MAG-N.PMAG-T'/A/)
      END IF

      IF (BMAG.GT.0.) WRITE (IOUT,1025) BMAG,BMAGN,BMTYP
1025  FORMAT ('EXTERNAL (BERKELEY) MAG=',F5.2,
     2'  NUMBER READINGS=',F5.1,'  TYPE=',A1)

C--DETERMINE FULL TRANSLATION OF EVENT REMARK, IF THERE IS ONE
      DO I=1,SIZE(EVTRM)-1
        IF (REMK1.EQ.EVTRM(I)) EXIT
      END DO
      IT=I

C--TRNASLATE & WRITE REGION NAME
C  HANDLE KON AS A SPECIAL CASE BECAUSE IT IS USED IN BOTH NETS
      IF (REMK3 .EQ. 'KON') THEN
        IF (LON.LT.130) THEN
          WRITE (IOUT,1050) 'Konocti Bay',EVTRMK(IT)
        ELSE
          WRITE (IOUT,1050) 'South Kona ',EVTRMK(IT)
        END IF
        GOTO 41
      END IF
1050  FORMAT ('REGION= ',A25,'   EVENT REMARK=',A14)
1051  FORMAT ('REGION= ',A25)

      DO I=1,130
        IF (REMK3 .EQ. CD(I)) THEN
          IF (REMK1.EQ.' ') THEN
            WRITE (IOUT,1051) FN(I)
          ELSE
            WRITE (IOUT,1050) FN(I),EVTRMK(IT)
          END IF
          GOTO 41
        END IF
      END DO

C--WRITE OTHER REMARKS
      IF (REMK2.EQ.'-') WRITE (IOUT,*) 'DEPTH CONTROL IS POOR, ',
     2 'DEPTH HELD FIXED'
      IF (REMK2.EQ.'#') WRITE (IOUT,*) 'SOLUTION HAD CONVERGENCE ',
     2 'PROBLEMS AND MAY BE POOR'

C--STATION LIST HEADER
41    WRITE (IOUT,1041)
1041  FORMAT(/'STA NET COM L C DIST AZM  AN P/S WT  SEC  (TOBS -TCAL ',
     2 '-DLY  =RES)  WT   SR  INFO DUR-W-FMAG-T   AMP-PER-W-XMAG-T')
      GOTO 10

C--ERROR MESSAGE
93    WRITE (6,1093) CARD
      WRITE (IOUT,1093) CARD
1093  FORMAT (' *** BAD STATION ARCHIVE RECORD:'/1X,A)

C------------------ STATION LOOP ------------------------------
C--READ DATA FOR ONE STATION
10    READ (IIN,1006,END=91) CARD
      C4=CARD(1:4)

C--SKIP IF A SHADOW RECORD
      IF (CARD(1:1).EQ.'$') GOTO 10

C--SKIP CUSP TIME TRACE "STATIONS"
      IF (C4.EQ.'WWVB' .OR. C4.EQ.'IRG1' .OR. C4.EQ.'IRG2' .OR.
     2 C4.EQ.'IRG ') GOTO 10

C--IF THIS IS A TERMINATOR, LIST UNWEIGHTED STAS & LOOK FOR OPTIONAL ID NUMBER
      IF (C4 .EQ. '    ') THEN
        IF (NLPT.GT.0)
     2 WRITE (IOUT,'(I5,'' UNWEIGHTED STATIONS NOT PRINTED'')') NLPT
        READ (CARD,1007,ERR=92) IDNO2
1007    FORMAT (62X,I10)
C       IF (IDNO2.NE.0) WRITE (IOUT,1008) IDNO2
1008    FORMAT ('ID NUMBER OF ABOVE EVENT: ',I10)
        GOTO 5
      END IF

C--DECODE ALL DATA FOR THIS STATION
C--HYPOINVERSE 2000
      IF (IFOR.EQ.1) THEN
        READ (CARD,2009,ERR=93) STAU,NET,COMP1,COMP3,
     2 PRMK,IPW, JH,JN,P,PRES,PWT, 
     3 S,SRMK,ISW, SRES,RAMP,SWT, PDLY,SDLY,DIST,IAN, CXWT,CFWT,PER,
     4 STARMK,IDUR,JAZ, FMAG,XMAG,PINFO,SINFO, SOU,
     5 FMAGTYP,XMAGTYP, SLOC,XMNOT,FMNOT

2009    FORMAT (A5,A2,1X,A1,A3,
     2 1X,A3,I1, 8X,2I2,F5.2,F4.2,F3.2,
     3 F5.2,A2,1X,I1, F4.2,F7.2,2X,F3.2, 2F4.2,F4.1,I3, 2A1,F3.2,
     4 A1,I4,I3, 2F3.2,2F4.3, A1,
     5 2A1, A2,5X,2A1)

C--OLD HYPOINVERSE
      ELSE IF (IFOR.EQ.2) THEN
        READ (CARD,1009,ERR=93) STA,PRMK,IPW,COMP1, JH,JN,P,PRES,PWT, 
     2 S,SRMK,ISW, SRES,RAMP,SWT, PDLY,SDLY,DIST,IAN, CXWT,CFWT,PER,
     3 STARMK,IDUR,JAZ, FMAG,XMAG,PINFO,SINFO, WTCODE,SOU,
     4 FMAGTYP,XMAGTYP, STA5,COMP3,NET,SLOC

1009    FORMAT (A4,A3,I1,A1, 6X,2I2,F5.2,F4.2,F3.2,
     2 F5.2,A2,1X,I1, F4.2,F3.0,F3.2, 2F4.2,F4.1,I3, 2A1,F3.2,
     3 A1,I4,I3, 2F2.1,2F4.3, 2A1,
     4 3A1, A3,2A2)
        STAU=(STA//STA5)
        XMNOT=' '
        FMNOT=' '
      END IF
      
C--TURN SOME OF THE NUMERIC DATA TO ALPHA
      CPW=' '
      IF (IPW.GT.0) WRITE (CPW,1004) IPW

C--SET XMAG INFO
      IF (CXWT.EQ.'0') CXWT=' '
      CAMP=' '

C--MAKE SURE AMPS AND PERIODS ARE WITHIN RANGE
      IF (RAMP.GT.999.) THEN
        IAMP=RAMP
        WRITE (CAMP,1016) IAMP,PER,CXWT,XMAG,XMNOT, XMAGTYP
1016    FORMAT (I6,F4.1,1X,A1,F5.2,2A1)
      ELSE IF (RAMP.GT.0.) THEN
        WRITE (CAMP,1013) RAMP,PER,CXWT,XMAG,XMNOT, XMAGTYP
1013    FORMAT (F6.1,F4.1,1X,A1,F5.2,2A1)
      END IF

      IF (PER.LT.1. .AND. RAMP.GT.0.) THEN
        WRITE (CAMP(7:10),'(F4.2)') PER
        CAMP(7:7)=' '
      END IF

C--SKIP LISTING UNWEIGHTED STATIONS
      IF (LPT) GOTO 20
      READ (CFWT,'(I1)') IFWT
      READ (CXWT,'(I1)') IXWT

      IF ((IPW.GT.3 .OR. PRMK.EQ.'   ') .AND.
     2   (ISW.GT.3 .OR. SRMK.EQ.'  ') .AND.
     3   (IDUR.LE.0 .OR. IFWT.GT.3) .AND.
     4   (RAMP.EQ.0. .OR. IXWT.GT.3)) THEN
        NLPT=NLPT+1
        GOTO 10
      END IF

C--BLANK OUT STATION NAME IF ITS THE SAME AS THE LAST ONE
20    IF (STAU.EQ.LSTAU) THEN
        STAU=' '
      ELSE
        LSTAU=STAU
      END IF

C--SET FMAG INFO
      IF (CFWT.EQ.'0') CFWT=' '
      CDUR=' '
      IF (IDUR.GT.0) WRITE (CDUR,1023) IDUR,CFWT,FMAG,FMNOT,FMAGTYP
1023  FORMAT (I4,1X,A1,F5.2,2A1)

C--FILL IN P TRAVEL TIMES
      TOBS= ((JH-IH)*60 +(JN-IN))*60 +(P-SEC)
      TCAL=TOBS-PDLY-PRES

C--CANCEL 3 TIMES IF THEY ARE BOGUS
      IF (PRES.EQ.-9.99 .OR. PRES.EQ.99.99) THEN
        PRES=0.
        TCAL=0.
        TOBS=0.
      END IF

C--SET THE RESIDUAL FLAG
      STAR=' '
      IF (ABS(PRES) .GT. .5) STAR='*'
      IF (IPW.GE.4) STAR='X'

C--WRITE ONE LINE FOR S DATA AND NO P DATA-------------------
      IF ((IPW.GT.3 .OR. PRMK.EQ.'   ') .AND.
     2   (ISW.LE.3 .AND. SRMK.NE.'  ')) THEN

        CSW=' '
        IF (ISW.GT.0) WRITE (CSW,1004) ISW

C--FILL IN S TRAVEL TIMES
        TOBS=S-SEC
        TCAL=TOBS-SDLY-SRES

C--CANCEL 3 TIMES IF THEY ARE BOGUS
        IF (SRES.EQ.-9.99 .OR. SRES.EQ.99.99) THEN
          SRES=0.
          TCAL=0.
          TOBS=0.
        END IF

C--SET THE RESIDUAL FLAG
        STAR=' '
        IF (ABS(SRES) .GT. .5) STAR='*'
        IF (ISW.GE.4) STAR='X'

C--WRITE THE S DATA WITH THE BASIC STATION DATA
        WRITE (IOUT,1019) STAU,NET,COMP3,SLOC,COMP1, DIST,JAZ,IAN,
     1 SRMK,CSW,WTCODE,
     2 S,TOBS,TCAL,SDLY,SRES, STAR,SWT,SOU,STARMK, SINFO

1019    FORMAT (A5,A2,1X,A3,1X,A2,A1, F5.1,2I4, 1X,
     1 A2,2X,2A1,
     2 3F6.2,F5.2,F6.2, A1,F5.2,'S ',2A1, F6.3)
        GOTO 10
      END IF

C--WRITE THE P DATA------------------------
      WRITE (IOUT,1012) STAU,NET,COMP3,SLOC,COMP1, DIST,JAZ,IAN, PRMK,
     2 CPW,WTCODE, P,TOBS,TCAL,PDLY,PRES, STAR,PWT,SOU,STARMK,
     3 PINFO,CDUR,CAMP

1012  FORMAT (A5,A2,1X,A3,1X,A2,A1, F5.1,2I4, 1X,A3,
     2 1X,2A1, 3F6.2,F5.2,F6.2, A1,F5.2,2X,2A1,
     3 F6.3,A13,A19)

C--ALSO WRITE S DATA ON ANOTHER LINE IF THE S REMARK IS NON BLANK
      IF (SRMK.NE.'  ') THEN
        CSW=' '
        IF (ISW.GT.0) WRITE (CSW,1004) ISW

C--FILL IN S TRAVEL TIMES
        TOBS=S-SEC
        TCAL=TOBS-SDLY-SRES

C--CANCEL 3 TIMES IF THEY ARE BOGUS
        IF (SRES.EQ.-9.99 .OR. SRES.EQ.99.99) THEN
          SRES=0.
          TCAL=0.
          TOBS=0.
        END IF

C--SET THE RESIDUAL FLAG
        STAR=' '
        IF (ABS(SRES) .GT. .5) STAR='*'
        IF (ISW.GE.4) STAR='X'

C--WRITE THE S DATA
        WRITE (IOUT,1015) SRMK,CSW,WTCODE,
     2 S,TOBS,TCAL,SDLY,SRES, STAR,SWT,SOU,STARMK, SINFO

1015    FORMAT (29X, A2,2X,2A1,
     2 3F6.2,F5.2,F6.2, A1,F5.2,'S ',2A1, F6.3)
      END IF
      GOTO 10

C--ERROR MESSAGES
90    WRITE (6,1090) SCARD
      WRITE (IOUT,1090) SCARD
1090  FORMAT (' *** BAD SUMMARY (HEADER) RECORD:'/1X,A)
      STOP

91    WRITE (6,1091) IY,IM,ID,IH,IN
1091  FORMAT (' *** PREMATURE END-OF-FILE IN MIDDLE OF EVENT ',5I2)
      STOP

92    WRITE (6,1092) CARD
1092  FORMAT (' *** BAD TERMINATOR RECORD:'/1X,A)
99    STOP
      END
