CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00010000
C                                                                       00020000
C PURPOSE: THIS ROUTINE CALCULATES AVERAGES OF B, BR, BT, BN, LAMBDA,   00030000
C    AND DELTA FROM STANDARD VOYAGER HOURLY AVERAGES.  AVERAGES ARE     00040000
C    CALCULATED FOR EACH OF TWO HEMISPHERES:                            00050000
C        (1) 0   <= LAMBDA < 180  (DEGREES)                             00060000
C        (2) 180 <= LAMBDA < 360  (DEGREES)                             00070000
C    AVERAGES ADJUSTED BY CORRECTIONS TO ZERO LEVELS INPUT ON UNIT 5.   00071009
C    THESE CORRECTIONS ARE ANALAGOUS TO THOSE OUTPUT BY THE             00072011
C    RFT ZERO ANALYSIS PROGRAM.  THE CORRECTIONS (IN BR, BT, BN) ARE    00073009
C    ADDED TO THE VALUES INPUT.                                         00074009
C                                                                       00080000
C VARIABLES:                                                            00090000
C    B     : MAG FIELD HOUR AVERAGE AS INPUT                            00100000
C    DELTA : DELTA ANGLE HOUR AVGERAGE AS INPUT                         00110000
C    LAMBDA: LAMBDA ANGLE HOUR AVERAGE AS INPUT                         00120000
C    N     : COUNT OF POINTS IN EACH HEMISPHERE AVERAGE                 00130000
C                                                                       00320000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00330000
      IMPLICIT REAL(L)                                                  00340000
      DIMENSION N(2), BSUM(2), BRSUM(2), BTSUM(2), BNSUM(2), LAMAVG(2), 00350000
     1          BAVG(2), BRAVG(2), BTAVG(2), BNAVG(2), BAVGC(2)         00351000
      CHARACTER*8 ZERO                                                  00360000
      WTAVG(B1,B2) = ((B1 * N(1)) + (B2 * N(2))) / (N(1) + N(2))        00361000
      READ (5,15) BRFIX, BTFIX, BNFIX                                   00362000
   15 FORMAT (3F6.2)                                                    00363000
      WRITE (6,18) BRFIX, BTFIX, BNFIX                                  00364010
   18 FORMAT (' CORRECTIONS TO BR, BT, BN =',3F6.2,//)                  00365010
      READ (10,10) IYRAVG, IDYAVG, IHRAVG, B, DELTA, LAMBDA,ICNT        00370012
              DELTA = DELTA * .01745329                                 00370302
              LAMBDA = LAMBDA * .01745329                               00370402
              BR = B * COS(DELTA) * COS(LAMBDA) + BRFIX                 00371000
              BT = B * COS(DELTA) * SIN(LAMBDA) + BTFIX                 00372000
              BN = B * SIN(DELTA) + BNFIX                               00373000
              B = SQRT(BR**2 + BT**2 + BN**2)                           00373101
              DELTA = ASIN(BN / B) * 57.29578                           00374000
              LAMBDA = ATAN2(BT, BR) * 57.29578                         00375000
              IF (LAMBDA .LT. 0) LAMBDA = LAMBDA + 360.                 00375107
   10 FORMAT (22X, I2, I3, I2, F5.2, 2F5.1,I2)                          00380012
   20 READ (5,30,END=100) ZERO, IYRBEG, IDYBEG, IHRBEG,                 00390000
     1                          IYREND, IDYEND, IHREND                  00400000
   30 FORMAT (A8, 6I5)                                                  00410000
      ITMBEG = IYRBEG * 100000 + IDYBEG * 100 + IHRBEG                  00420000
      ITMEND = IYREND * 100000 + IDYEND * 100 + IHREND                  00430000
      WRITE (6,5) ZERO, IYRBEG, IDYBEG, IHRBEG,                         00440000
     1                  IYREND, IDYEND, IHREND                          00450000
    5 FORMAT (1X,A8,2X,I2,'/',I3,':',I2,' TO ',I2,'/',I3,':',I2,/,      00460000
     1        T4, '<B>', T13, '|B|', T22,'<BR>',                        00470000
     2            T31, '<BT>', T40, '<BN>', T47, '<DELTA>', T56,        00480000
     3            '<LAMBDA>',T68, 'N', /, 1X,                           00490000
     4        '-------', 4(2X,'-------'), 2X, '-------', 2X,'--------', 00500000
     5        2X, '-----')                                              00510000
      DO 35 I=1,2                                                       00520000
          N(I) = 0                                                      00530000
          BSUM(I) = 0.                                                  00540000
          BRSUM(I) = 0.                                                 00550000
          BTSUM(I) = 0.                                                 00560000
          BNSUM(I) = 0.                                                 00570000
   35 CONTINUE                                                          00580000
   40     CONTINUE                                                      00590000
          ITMAVG = IYRAVG * 100000 + IDYAVG * 100 + IHRAVG              00600000
          IF (ITMAVG .LT. ITMBEG) GO TO 50                              00610000
          IF (ITMAVG .GT. ITMEND) GO TO 60                              00620000
              IF (LAMBDA .LT. 180.) THEN                                00630000
                  IH = 1                                                00640000
              ELSE                                                      00650000
                  IH = 2                                                00660000
              END IF                                                    00670000
              DELTA = DELTA * .01745329                                 00680000
              LAMBDA = LAMBDA * .01745329                               00690000
              BR = B * COS(DELTA) * COS(LAMBDA)                         00700006
              BT = B * COS(DELTA) * SIN(LAMBDA)                         00710006
              BN = B * SIN(DELTA)                                       00720006
              B = SQRT(BR**2 + BT**2 + BN**2)                           00721005
              BSUM(IH) = BSUM(IH) + B * ICNT                            00730012
              BRSUM(IH) = BRSUM(IH) + BR * ICNT                         00740012
              BTSUM(IH) = BTSUM(IH) + BT * ICNT                         00750012
              BNSUM(IH) = BNSUM(IH) + BN * ICNT                         00760012
              N(IH) = N(IH) + ICNT                                      00770012
   50         READ (10,10,END=60) IYRAVG, IDYAVG, IHRAVG, B, DELTA,     00780000
     1                            LAMBDA                                00790000
                  DELTA = DELTA * .01745329                             00790202
                  LAMBDA = LAMBDA * .01745329                           00790302
                  BR = B * COS(DELTA) * COS(LAMBDA) + BRFIX             00791000
                  BT = B * COS(DELTA) * SIN(LAMBDA) + BTFIX             00792000
                  BN = B * SIN(DELTA) + BNFIX                           00793000
                  B = SQRT(BR**2 + BT**2 + BN**2)                       00793101
                  DELTA = ASIN(BN / B) * 57.29578                       00794000
                  LAMBDA = ATAN2(BT, BR) * 57.29578                     00795000
                  IF (LAMBDA .LT. 0) LAMBDA = LAMBDA + 360.             00795107
              GO TO 40                                                  00800000
   60     CONTINUE                                                      00810000
          DO 80 I = 1, 2                                                00820000
              IF (N(I) .EQ. 0) THEN                                     00821000
                  BAVG(I) = 0.                                          00822000
                  BRAVG(I) = 0.                                         00823000
                  BTAVG(I) = 0.                                         00824000
                  BNAVG(I) = 0.                                         00825000
                  BAVGC(I) = 0.                                         00825100
                  DELAVG = 0.                                           00825200
                  LAMAVG(I) = 0.                                        00825300
              ELSE                                                      00826000
                  BAVG(I) = BSUM(I) / N(I)                              00830000
                  BRAVG(I) = BRSUM(I) / N(I)                            00840000
                  BTAVG(I) = BTSUM(I) / N(I)                            00850000
                  BNAVG(I) = BNSUM(I) / N(I)                            00860000
                  BAVGC(I) = SQRT(BRAVG(I)**2 + BTAVG(I)**2 +           00870000
     1                        BNAVG(I)**2)                              00871000
                  DELAVG = ASIN(BNAVG(I) / BAVGC(I)) * 57.29578         00880000
                  LAMAVG(I) = ATAN2(BTAVG(I), BRAVG(I)) * 57.29578      00890000
              END IF                                                    00891000
              IF (LAMAVG(I) .LT. 0.) LAMAVG(I) = LAMAVG(I) + 360.       00900000
              WRITE (6, 70) BAVG(I), BAVGC(I),                          00910000
     1                      BRAVG(I), BTAVG(I), BNAVG(I),               00911000
     2                      DELAVG, LAMAVG(I), N(I)                     00920000
   70         FORMAT(1X,5(F7.3,2X), 1X, F5.1, 5X,F5.1, 3X,I5)           00930000
   80     CONTINUE                                                      00940000
          IF ((N(1) .GT. 0) .AND. (N(2) .GT. 0)) THEN                   00940100
              BAVG(1) = WTAVG(BAVG(1), BAVG(2))                         00941000
              BAVGC(1) = WTAVG(BAVGC(1), BAVGC(2))                      00942000
              BRAVG(1) = WTAVG(BRAVG(1), BRAVG(2))                      00943000
              BTAVG(1) = WTAVG(BTAVG(1), BTAVG(2))                      00944000
              BNAVG(1) = WTAVG(BNAVG(1), BNAVG(2))                      00945000
              DELTA = ASIN(BNAVG(1) / BAVGC(1)) * 57.29578              00945100
              WRITE (6, 85) BAVG(1), BAVGC(1), BRAVG(1),                00946000
     1                      BTAVG(1), BNAVG(1), DELTA                   00947000
   85         FORMAT (1X, 6('-------',2X), '--------',2X, '-----',/,    00948000
     1                1X, 5(F7.3,2X), 1X, F5.1, T66, 'AVERAGES')        00949000
              DELAMB = LAMAVG(2) - LAMAVG(1)                            00949100
              DLAMER = .5 * (DELAMB - 180.)                             00950000
              DELZRO = BAVGC(1) * SIN(DLAMER * .01745329)               00960000
              WRITE (6,90) DELAMB, DLAMER, DELZRO                       00970000
   90         FORMAT (T57, F5.1, 4X, 'DEL LAMBDA',/                     00980000
     1                T56, F6.1, 4X, 'DEL LAMBDA ERROR', /              00990000
     2            T57, F6.2, 3X, 'DEL ZERO ERROR', //)                  01000000
          END IF                                                        01001000
      GO TO 20                                                          01010000
  100 STOP                                                              01020000
      END                                                               01030000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00010011
C                                                                       00020011
C PURPOSE: THIS ROUTINE CALCULATES AVERAGES OF B, BR, BT, BN, LAMBDA,   00030011
C    AND DELTA FROM STANDARD VOYAGER HOURLY AVERAGES.  AVERAGES ARE     00040011
C    CALCULATED FOR EACH OF TWO HEMISPHERES:                            00050011
C        (1) 0   <= LAMBDA < 180  (DEGREES)                             00060011
C        (2) 180 <= LAMBDA < 360  (DEGREES)                             00070011
C                                                                       00080011
C VARIABLES:                                                            00090011
C    B     : MAG FIELD HOUR AVERAGE AS INPUT                            00100011
C    DELTA : DELTA ANGLE HOUR AVGERAGE AS INPUT                         00110011
C    LAMBDA: LAMBDA ANGLE HOUR AVERAGE AS INPUT                         00120011
C    N     : COUNT OF POINTS IN EACH HEMISPHERE AVERAGE                 00130011
C                                                                       00320011
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00330011
      IMPLICIT REAL(L)                                                  00340011
      DIMENSION N(2), BSUM(2), BRSUM(2), BTSUM(2), BNSUM(2), LAMAVG(2), 00350011
     1          BAVG(2), BRAVG(2), BTAVG(2), BNAVG(2), BAVGC(2)         00351011
      CHARACTER*8 ZERO                                                  00360011
      WTAVG(B1,B2) = ((B1 * N(1)) + (B2 * N(2))) / (N(1) + N(2))        00361011
      READ (10,10) IYRAVG, IDYAVG, IHRAVG, B, DELTA, LAMBDA, ICNT       00370021
   10 FORMAT (22X, I2, I3, I2, F5.2, 2F5.1,I2)                          00380021
   20 READ (5,30,END=100) ZERO, IYRBEG, IDYBEG, IHRBEG,                 00390012
     1                          IYREND, IDYEND, IHREND                  00400011
   30 FORMAT (A8, 6I5)                                                  00410011
      ITMBEG = IYRBEG * 100000 + IDYBEG * 100 + IHRBEG                  00420011
      ITMEND = IYREND * 100000 + IDYEND * 100 + IHREND                  00430011
      WRITE (6,5) ZERO, IYRBEG, IDYBEG, IHRBEG,                         00440011
     1                  IYREND, IDYEND, IHREND                          00450011
    5 FORMAT (1X,A8,2X,I2,'/',I3,':',I2,' TO ',I2,'/',I3,':',I2,/,      00460015
     1        T4, '<B>', T13, '|B|', T22,'<BR>',                        00470015
     2            T31, '<BT>', T40, '<BN>', T47, '<DELTA>', T56,        00480012
     3            '<LAMBDA>',T68, 'N', /, 1X,                           00490012
     4        '-------', 4(2X,'-------'), 2X, '-------', 2X,'--------', 00500012
     5        2X, '-----')                                              00510016
      DO 35 I=1,2                                                       00520011
          N(I) = 0                                                      00530011
          BSUM(I) = 0.                                                  00540011
          BRSUM(I) = 0.                                                 00550011
          BTSUM(I) = 0.                                                 00560011
          BNSUM(I) = 0.                                                 00570011
   35 CONTINUE                                                          00580011
   40     CONTINUE                                                      00590011
          ITMAVG = IYRAVG * 100000 + IDYAVG * 100 + IHRAVG              00600011
          IF (ITMAVG .LT. ITMBEG) GO TO 50                              00610011
          IF (ITMAVG .GT. ITMEND) GO TO 60                              00620011
              IF (LAMBDA .LT. 180.) THEN                                00630011
                  IH = 1                                                00640011
              ELSE                                                      00650011
                  IH = 2                                                00660011
              END IF                                                    00670011
              DELTA = DELTA * .01745329                                 00680011
              LAMBDA = LAMBDA * .01745329                               00690011
              BR = B * COS(DELTA) * COS(LAMBDA)                         00700011
              BT = B * COS(DELTA) * SIN(LAMBDA)                         00710011
              BN = B * SIN(DELTA)                                       00720011
              BSUM(IH) = BSUM(IH) + B * ICNT                            00730021
              BRSUM(IH) = BRSUM(IH) + BR * ICNT                         00740021
              BTSUM(IH) = BTSUM(IH) + BT * ICNT                         00750021
              BNSUM(IH) = BNSUM(IH) + BN * ICNT                         00760021
              N(IH) = N(IH) + ICNT                                      00770021
   50         READ (10,10,END=60) IYRAVG, IDYAVG, IHRAVG, B, DELTA,     00780011
     1                            LAMBDA, ICNT                          00790021
              GO TO 40                                                  00800011
   60     CONTINUE                                                      00810011
          DO 80 I = 1, 2                                                00820011
              IF (N(I) .EQ. 0) THEN                                     00821019
                  BAVG(I) = 0.                                          00822019
                  BRAVG(I) = 0.                                         00823019
                  BTAVG(I) = 0.                                         00824019
                  BNAVG(I) = 0.                                         00825019
                  BAVGC(I) = 0.                                         00825119
                  DELAVG = 0.                                           00825219
                  LAMAVG(I) = 0.                                        00825319
              ELSE                                                      00826019
                  BAVG(I) = BSUM(I) / N(I)                              00830019
                  BRAVG(I) = BRSUM(I) / N(I)                            00840019
                  BTAVG(I) = BTSUM(I) / N(I)                            00850019
                  BNAVG(I) = BNSUM(I) / N(I)                            00860019
                  BAVGC(I) = SQRT(BRAVG(I)**2 + BTAVG(I)**2 +           00870019
     1                        BNAVG(I)**2)                              00871019
                  DELAVG = ASIN(BNAVG(I) / BAVGC(I)) * 57.29578         00880019
                  LAMAVG(I) = ATAN2(BTAVG(I), BRAVG(I)) * 57.29578      00890019
              END IF                                                    00891019
              IF (LAMAVG(I) .LT. 0.) LAMAVG(I) = LAMAVG(I) + 360.       00900011
              WRITE (6, 70) BAVG(I), BAVGC(I),                          00910011
     1                      BRAVG(I), BTAVG(I), BNAVG(I),               00911013
     2                      DELAVG, LAMAVG(I), N(I)                     00920013
   70         FORMAT(1X,5(F7.3,2X), 1X, F5.1, 5X,F5.1, 3X,I5)           00930018
   80     CONTINUE                                                      00940011
          IF ((N(1) .GT. 0) .AND. (N(2) .GT. 0)) THEN                   00940119
              BAVG(1) = WTAVG(BAVG(1), BAVG(2))                         00941019
              BAVGC(1) = WTAVG(BAVGC(1), BAVGC(2))                      00942019
              BRAVG(1) = WTAVG(BRAVG(1), BRAVG(2))                      00943019
              BTAVG(1) = WTAVG(BTAVG(1), BTAVG(2))                      00944019
              BNAVG(1) = WTAVG(BNAVG(1), BNAVG(2))                      00945019
              DELTA = ASIN(BNAVG(1) / BAVGC(1)) * 57.29578              00945119
              WRITE (6, 85) BAVG(1), BAVGC(1), BRAVG(1),                00946019
     1                      BTAVG(1), BNAVG(1), DELTA                   00947019
   85         FORMAT (1X, 6('-------',2X), '--------',2X, '-----',/,    00948019
     1                1X, 5(F7.3,2X), 1X, F5.1, T66, 'AVERAGES')        00949019
              DELAMB = LAMAVG(2) - LAMAVG(1)                            00949119
              DLAMER = .5 * (DELAMB - 180.)                             00950019
              DELZRO = BAVGC(1) * SIN(DLAMER * .01745329)               00960019
              WRITE (6,90) DELAMB, DLAMER, DELZRO                       00970019
   90         FORMAT (T57, F5.1, 4X, 'DEL LAMBDA',/                     00980019
     1                T56, F6.1, 4X, 'DEL LAMBDA ERROR', /              00990019
     2            T57, F6.2, 3X, 'DEL ZERO ERROR', //)                  01000011
          END IF                                                        01001019
      GO TO 20                                                          01010011
  100 STOP                                                              01020011
      END                                                               01030011
C
C WRITTEN BY SANDY KRAMER, 01/93.
C UPDATED AND VERIFIED 03/19/93 SBK
C READS MAG RECORD FROM SUMMARY TAPE.
C FILTERS 1.92 SEC AVGS TO CREATE NEW SUMMARY RECORD.
C
      CHARACTER*4 FLT
      CHARACTER*29 DSN
      INTEGER*2 TIME(6),ID
      LOGICAL*1 LAST
      REAL*4 FIN(568),MAG(496),HEADER(32),SEDR(40)
      EQUIVALENCE (FIN(1),HEADER(1)),(FIN(33),MAG(1)),
     &            (HEADER(4),TIME(1)),(HEADER(17),ID),
     &            (HEADER(3),FLT),(SEDR(1),FIN(529))
C
C SPECIFY FILTER PARAMETERS
C
      SIGMUL = 5.0
      IPASS = 3
      BAD = 999.0
      RMAX = 0.0
C
      WRITE(6,*) '******************************'
      WRITE(6,*)
      WRITE(6,*) 'ENTER FILTER ROUTINE'
      WRITE(6,*)
      WRITE(6,220) IPASS,' PASS FILTER'
  220 FORMAT(1X,I2,A)
      WRITE(6,221) 'REJECT AT ',SIGMUL,' * STD LEVEL'
  221 FORMAT(1X,A,F4.1,A)
      WRITE(6,*)
C     WRITE(6,222) 'NON-FILL PTS','BAD PTS','AVE (LAST 100 PTS)'
      WRITE(6,222) 'NON-FILL PTS','BAD PTS','    % BAD PTS      '
  222 FORMAT(1X,T7,A12,T36,A7,T56,A18)
      WRITE(6,*)
      WRITE(6,223) 'F1','B1','B2','B3','F1','B1','B2','B3',
     &             'F1','B1','B2','B3'
  223 FORMAT(1X,T3,A2,T9,A2,T15,A2,T21,A2,
     &       T28,A2,T34,A2,T40,A2,T46,A2,
     &       T53,A2,T61,A2,T69,A2,T77,A2)
      WRITE(6,*)
C
      IREC = 0
      LAST = .FALSE.
   30 CONTINUE
        READ(10,NUM=LEN,END=100,ERR=30) FIN
        IF (ID.NE.1) GO TO 30
        IREC = IREC + 1
C       IF (IREC.GT.50) GOTO 100
        READ(FLT,'(3X,I1)') ISC
C       WRITE(6,800) ISC,TIME
C
C CALL DATA BUFFERING ROUTINE
C
        CALL QUE(MAG,HEADER,SEDR,LAST,SIGMUL,IPASS,BAD,RMAX)
      GO TO 30
  100 CONTINUE
C
C FILTER REMAINING DATA IN BUFFER
C
      LAST = .TRUE.
      CALL QUE(MAG,HEADER,SEDR,LAST,SIGMUL,IPASS,BAD,RMAX)
C
      WRITE(6,*)
      WRITE(6,*) 'EXIT FILTER ROUTINE'
      WRITE(6,*)
      WRITE(6,810) IREC
      WRITE(6,*)
      WRITE(6,*) '******************************'
      STOP
  800 FORMAT(1X,I1,1X,I2,1X,I3.3,3(1X,I2.2),1X,I3.3)
  810 FORMAT(1X,I5.5,' LFM RECORDS READ')
      END
      SUBROUTINE CLEAN1(DATA1,NPTS,NTOTB,NTOTG,SIGMUL,BAD,AVE,PASS)
C
C PROGRAM TO AUTOMATICALLY FLAG AND ASSIGN 999.0 TO BAD POINTS
C IN A DATASET BASED ON STATISTICAL LOCAL CRITERION (E.G. THE
C DATA POINT IS MORE THAN K SIGMA AWAY FROM THE MEAN OF ITS NEAR
C NEIGHBORS).  EACH POINT IS ANALYZED USING A NUMBER OF LOCAL
C AVERAGES WITH EACH AVERAGE BEING THE SUM OF 100 POINTS; THE SUM
C MOVES PAST THE POINT.  ALL PARALLEL SERIES POINTS ARE DELETED.
C FLAGGED POINTS ARE REMOVED FROM THE SERIES AND NOT USED FOR
C SUBSEQUENT TESTS OF POINTS; THIS CLEANS "RATTY" SERIES MUCH BETTER.
C
      INTEGER*4 I100PT(100), IUP(100), IDN(100), PASS
      REAL*4 DATA1(1)
      REAL*8 SUM,SUMSQ,SIG
C
C MULTI-PASS LOOP
C
      NBD = 0
      DO IPASS = 1,PASS
C
C INITIALIZATION OF SUMS AND I100PT (INDEX LIST)
C ALSO OF IUP,IDN,I100PT,NTOTG,NTOTB
C
      DO IZERO=1, 100
        IUP(IZERO)=0
        IDN(IZERO)=0
        I100PT(IZERO)=0
      ENDDO
C
C REMOVE FILL DATA FROM DATA ARRAY
C
      NTOTG = 0
      NTOTB = 0    ! NTOTB = TOTAL NUMBER OF POINTS DELETED BY PROGRAM
      SUM = 0.0D0     ! SUM OF THE 100 DATA POINTS
      SUMSQ = 0.0D0   ! SUM OF THE SQUARES OF THE 100 POINTS
      AVE = BAD
C
C LEAVE ROUTINE IF STARTING WITH INSUFFICIENT NUMBER OF POINTS (100)
C
      IF (NPTS.LT.100) GOTO 200
      IPT = 1
      DO NPT1 = 1, 100
   25    IF (ABS(DATA1(IPT)-BAD).LT.0.01) THEN
            IPT = IPT + 1
            GOTO 25
         ENDIF
         SUM = SUM + DATA1(IPT)
         SUMSQ = SUMSQ + DATA1(IPT)**2
         NTOTG = NTOTG + 1
         I100PT(NPT1) = IPT
         IPT = IPT + 1
         IF (IPT.GT.NPTS) GOTO 200
      ENDDO
      AVE = SUM/100.0
      IF (SUM**2/100.0.GT.SUMSQ) THEN
       SIG = 0.0D0
      ELSE
       SIG = DSQRT((SUMSQ - SUM**2/100.0)/100.0)  ! DBLE PREC
      END IF
C
C TEST THE POINTS
C
   50 NLOCB = 0    ! NLOCB = THE NUMBER OF BAD POINTS THIS LOOP
      DO J = 1, 100
         I = I100PT(J)
         IF (ABS(DATA1(I)-AVE).GT.SIGMUL*SIG) THEN
            SUM = SUM - DATA1(I)
            SUMSQ = SUMSQ - DATA1(I)**2
            IDN(NLOCB+1) = I
            DATA1(I) = BAD
            NLOCB = NLOCB + 1
            NTOTB = NTOTB + 1
         ENDIF
      ENDDO
      IF (IPT.GT.NPTS) GOTO 200
C
C  UPDATE THE 100 POINT SET SUMS AND I100PT
C
      IPT = I100PT(100) + 1
      IF (IPT.GT.NPTS) GOTO 250
      IINC = 1
      IF (I100PT(1).NE.IDN(1)) THEN
         SUM = SUM - DATA1(I100PT(1))
         SUMSQ = SUMSQ - DATA1(I100PT(1))**2
      ENDIF
      IF (I100PT(1).EQ.IDN(1)) IINC = 0
      DO M = 1, NLOCB+IINC
  150    IF (IPT.GT.NPTS) GOTO 250
         IF (ABS(DATA1(IPT)-BAD).LT.0.01) THEN
            IPT = IPT + 1
            GOTO 150
         ENDIF
         IUP(M) = IPT
         SUM = SUM + DATA1(IPT)
         SUMSQ = SUMSQ + DATA1(IPT)**2
         IPT = IPT + 1
         NTOTG = NTOTG + 1
      ENDDO
  250 CONTINUE
      INC = 1
      DO N = 1, 100
         IF ((N+INC).LE.100) THEN
            DO LL = 1, NLOCB
               IF (I100PT(N+INC).EQ.IDN(LL)) INC = INC + 1
            ENDDO
            IF ((N+INC).LE.100) THEN
               I100PT(N) = I100PT(N+INC)
            ELSE
               I100PT(N) = IUP(N+NLOCB-100+IINC)
            END IF
         ELSE
  175       I100PT(N) = IUP(N+NLOCB-100+IINC)
         ENDIF
      ENDDO
      AVE = SUM/100.0
      IF (SUM**2/100.0.GT.SUMSQ) THEN
       SIG = 0.0D0
      ELSE
       SIG = DSQRT((SUMSQ - SUM**2/100.0)/100.0)
      END IF
      GOTO 50   ! LOOP BACK TO THE TEST FOR THIS SET OF POINTS
  200 CONTINUE
C
      IF (IPASS.EQ.1) NGD = NTOTG
      NBD = NBD + NTOTB
C
      END DO
C
      NTOTG = NGD
      NTOTB = NBD
C
C  UPDATE THE HISTORY AND SAVE
C
      FRACT = REAL(NTOTB)/REAL(NTOTG)
C      WRITE(6,'(1X,''FRACTION OF BAD PTS '',E10.4)') FRACT
C
      RETURN
      END
      SUBROUTINE QUE(MAG,HEAD,SEDR,LAST,SIGMUL,PASS,BAD,RMAX)
C
C BUFFER GAMMA VALUES FROM THREE MAGNETOMETER AXIS AND MAGNITUDE.
C WHEN SUFFICIENT NUMBER OF POINTS IS ACCUMULATED, PASS ARRAY TO
C FILTERING ROUTINE AND THEN AVERAGING ROUTINE.
C
      PARAMETER (IARR=25000,IPARM=4,MAX=1000,LEN=25,IFULL=20000)
      INTEGER*4 IBUFF,NTOTG(IPARM),NTOTB(IPARM),PASS
      INTEGER*4 NGOOD(IPARM),NBAD(IPARM),ISPARE(147)
      LOGICAL*1 CLEAN,LAST,PRIME
      REAL*4 MAG(496),DATA(8,25),BUFFER(IARR,8),AVE(IPARM)
      REAL*4 HEAD(32),SEDR(40),HEADBUFF(32,MAX),SEDRBUFF(40,MAX)
      REAL*4 PYLD(8),PYLDBUFF(8,MAX),SPARE(147)
      EQUIVALENCE(ISPARE(1),SPARE(1))
      SAVE NREC,IBUFF,BUFFER,HEADBUFF,SEDRBUFF,PYLDBUFF
      DATA IBUFF/0/
C
C     PRIME = .FALSE.
      PRIME = .TRUE.
C     CLEAN = .FALSE.
      CLEAN = .TRUE.
C
C INITIALIZE PRIME AREA
C
      IF (IBUFF.EQ.0) THEN
       DO J = 1,8
        DO I = 1,500
         BUFFER(I,J) = BAD
        END DO
       END DO
      END IF
C
C LOAD 1.92 SEC F2,B1,B2,B3,RMS1,RMS2,RMS3,#PTS INTO DATA ARRAY
C
      DO I = 1,LEN
C
       DATA(1,I) = MAG(66+I)
       DATA(2,I) = MAG(166+I)
       DATA(3,I) = MAG(191+I)
       DATA(4,I) = MAG(216+I)
       DATA(5,I) = MAG(241+I)
       DATA(6,I) = MAG(266+I)
       DATA(7,I) = MAG(291+I)
       DATA(8,I) = MAG(316+I)
C
C REMOVE DATA POINTS EXCEEDING THRESHOLD IF VALUE SET ABOVE ZERO
C
       IF (RMAX.GT.0.0.AND.DATA(1,I).GT.RMAX) THEN
        DATA(1,I) = BAD
        DATA(2,I) = BAD
        DATA(3,I) = BAD
        DATA(4,I) = BAD
       END IF
C
      END DO
C
      DO I = 1,8
       PYLD(I) = MAG(488+I)
      END DO
C
C GOTO FILTER ROUTINE IF END OF DATA REACHED IN MAIN PROGRAM
C
      IF (LAST) GOTO 100
C
C LOAD ONE MAG BLOCK OF DATA INTO BUFFER ARRAY
C
      DO I=1,LEN
C
       IBUFF = IBUFF + 1
C
       DO J = 1,8
C
        IF (.NOT.PRIME) BUFFER(IBUFF,J) = DATA(J,I)
        IF (PRIME) THEN
         BUFFER(IBUFF+500,J) = DATA(J,I)
C
C PRIME FILTER WITH FIRST 500 POINTS IN REVERSE ORDER
C
         IF (IBUFF.LE.500) BUFFER(501-IBUFF,J) = DATA(J,I)
        END IF
C
       END DO
C
      END DO
C
      NREC = INT((IBUFF-1)/LEN) + 1
C
C BUFFER HEADER DATA
C
      DO I = 1,32
       HEADBUFF(I,NREC) = HEAD(I)
      END DO
C
C BUFFER SEDR DATA
C
      DO I = 1,40
       SEDRBUFF(I,NREC) = SEDR(I)
      END DO
C
C BUFFER PAYLOAD DATA
C
      DO I = 1,8
       PYLDBUFF(I,NREC) = PYLD(I)
      END DO
C
C FILTER BUFFERED DATA
C
      IF (IBUFF.GE.IFULL) THEN
  100  CONTINUE
       IF (CLEAN) THEN
C
C ADD END DATA TO PRIME FILTER END WINDOW
C
        IF (PRIME) THEN
         ISK = 500
         IF (ISK.GT.IBUFF) ISK = IBUFF
         DO I = 1,ISK
          BUFFER(I+IBUFF,1) = BUFFER(IBUFF-I+1,1)
          BUFFER(I+IBUFF,2) = BUFFER(IBUFF-I+1,2)
          BUFFER(I+IBUFF,3) = BUFFER(IBUFF-I+1,3)
          BUFFER(I+IBUFF,4) = BUFFER(IBUFF-I+1,4)
         END DO
         NBUFF = IBUFF + ISK
        ELSE
         NBUFF = IBUFF
        END IF
C
C COUNT NUMBER OF NON-FILL POINTS INDEPEDENT OF FILTER STATS
C
        DO I = 1,4
         NGOOD(I) = 0
        END DO
C
        DO J = 1,4
         DO I = 1,IBUFF
          IF (PRIME) THEN
           IF (BUFFER(I+500,J).NE.BAD) NGOOD(J) = NGOOD(J) + 1
          ELSE
           IF (BUFFER(I,J).NE.BAD) NGOOD(J) = NGOOD(J) + 1
          END IF
         END DO
        END DO
C
        CALL CLEAN1(BUFFER(1,1),NBUFF,NTOTB(1),NTOTG(1),
     &              SIGMUL,BAD,AVE(1),PASS)
        CALL CLEAN1(BUFFER(1,2),NBUFF,NTOTB(2),NTOTG(2),
     &              SIGMUL,BAD,AVE(2),PASS)
        CALL CLEAN1(BUFFER(1,3),NBUFF,NTOTB(3),NTOTG(3),
     &              SIGMUL,BAD,AVE(3),PASS)
        CALL CLEAN1(BUFFER(1,4),NBUFF,NTOTB(4),NTOTG(4),
     &              SIGMUL,BAD,AVE(4),PASS)
C       WRITE(6,'(4(1X,I5),4(1X,I5),4(1X,F7.3))') NTOTG,NTOTB,
C    &       (100.0*REAL(NTOTB(I))/REAL(NTOTG(I)),I=1,4)
C
        DO I = 1,4
         NBAD(I) = 0
        END DO
C
        DO J = 1,4
         DO I = 1,IBUFF
          IF (PRIME) THEN
           IF (BUFFER(I+500,J).NE.BAD) NBAD(J) = NBAD(J) + 1
          ELSE
           IF (BUFFER(I,J).NE.BAD) NBAD(J) = NBAD(J) + 1
          END IF
         END DO
        END DO
C
        DO I = 1,4
         NBAD(I) = NGOOD(I) - NBAD(I)
        END DO
C
C OUTPUT FILTER STATS COMPUTED EXTERNAL TO SUBROUTINE CLEAN1
C
        WRITE(6,'(4(1X,I5),4(1X,I5),4(1X,F7.3))') NGOOD,NBAD,
     &       (100.0*REAL(NBAD(I))/REAL(NGOOD(I)),I=1,4)
       END IF
C
C EXTRACT SUMMARY RECORDS FROM CONCATENATED BUFFER ARRAYS
C
       DO I = 1,NREC
C
C EXTRACT ONE HEADER BLOCK
C
        DO IHDR = 1,32
         HEAD(IHDR) = HEADBUFF(IHDR,I)
        END DO
C
C EXTRACT ONE SCIENCE BLOCK
C
        DO J = 1,8
         DO K = 1,LEN
          L = (I-1)*LEN + K
          IF (PRIME) DATA(J,K) = BUFFER(L+500,J)
          IF (.NOT.PRIME) DATA(J,K) = BUFFER(L,J)
         END DO
        END DO
C
C EXTRACT ONE SEDR BLOCK
C
        DO ISDR = 1,40
         SEDR(ISDR) = SEDRBUFF(ISDR,I)
        END DO
C
C EXTRACT ONE PAYLOAD BLOCK
C
        DO IPYLD = 1,8
         PYLD(IPYLD) = PYLDBUFF(IPYLD,I)
        END DO
C
C RECORD FILTER PARAMETERS AND STATS
C
        ISPARE(1) = I
        ISPARE(2) = PASS
        SPARE(3) = SIGMUL
        ISPARE(4) = NGOOD(1)
        ISPARE(5) = NGOOD(2)
        ISPARE(6) = NGOOD(3)
        ISPARE(7) = NGOOD(4)
        ISPARE(8) = NBAD(1)
        ISPARE(9) = NBAD(2)
        ISPARE(10) = NBAD(3)
        ISPARE(11) = NBAD(4)
        SPARE(12) = RMAX
C
C CALL AVERAGE GENERATION AND OUTPUT ROUTINE
C
        CALL MAVE(DATA,PYLD,HEADBUFF(1,I),SEDRBUFF(1,I),SPARE)
C
       END DO
C
       IBUFF = 0
C
      END IF
C
      RETURN
      END
      SUBROUTINE MAVE(DATA,PYLD,HEAD,SEDR,SPARE)
C
C ROUTINE TO RECONSTRUCT MAG DATA OF LFM SUMMARY RECORD
C BASED ON FILTERED 1.92 SEC AVERAGES.
C
      INTEGER*2 TIME(6)
      INTEGER*4 IF19_6(5),IB9_6(3,5),IB48(3),NPTS(25)
      REAL*4 HEAD(32),SEDR(40),DATA(8,25),PYLD(8),SPARE(147)
      REAL*4 F1(25),F2(25),B(3,25),RMS(3,25),PNTS(25)
      REAL*4 F19_6(5),F29_6(5),B9_6(3,5),RMS9_6(3,5)
      REAL*4 B48(3),LAM48,RMS48(3)
      REAL*4 DELTA(25),LAMBDA(25)
      REAL*4 DEL9_6(5),LAM9_6(5)
      EQUIVALENCE(NPTS(1),PNTS(1))
C
      DO I = 1,25
C
       F1(I) = DATA(1,I)
       B(1,I) = DATA(2,I)
       B(2,I) = DATA(3,I)
       B(3,I) = DATA(4,I)
       RMS(1,I) = DATA(5,I)
       RMS(2,I) = DATA(6,I)
       RMS(3,I) = DATA(7,I)
       PNTS(I) = DATA(8,I)
C
C COMPUTE 1.92 SEC FIELD MODULUS
C
       IF ( B(1,I).NE.999.0 .AND.
     &      B(2,I).NE.999.0 .AND.
     &      B(3,I).NE.999.0 ) THEN
        F2(I) = SQRT(B(1,I)**2+B(2,I)**2+B(3,I)**2)
       ELSE
        F2(I) = 999.0
       END IF
C
C COMPUTE 1.92 SEC LATITUDINAL FIELD ANGLE
C
       IF ( B(3,I).NE.999.0 .AND. F2(I).NE.999.0 .AND.
     &      F2(I).NE.0.0 ) THEN
        DELTA(I) = ASIN( B(3,I)/F2(I) )*57.2957795D0
       ELSE
        DELTA(I) = 90.0
       END IF
C
C COMPUTE 1.92 SEC LONGITUDINAL FIELD ANGLE
C
       IF ( B(1,I).NE.999.0 .AND. B(2,I).NE.999.0 .AND.
     &      B(1,I).NE.0.0 ) THEN
        LAMBDA(I) = 180.0 - ATAN2( B(2,I),-B(1,I) )*57.2957795D0
       ELSE
        LAMBDA(I) = 45.0
       END IF
C
C      WRITE(6,888) F1(I),F2(I),B(1,I),B(2,I),B(3,I),DELTA(I),LAMBDA(I),
C    &              RMS(1,I),RMS(2,I),RMS(3,I),NPTS(I)
C
      END DO
C
  888 FORMAT(5(1X,F7.3),2(1X,F5.1),3(1X,F7.3),1X,I4)
C
C COMPUTE 9.6 SEC AVERAGES
C
      DO I = 1,5
C
       F19_6(I) = 0.0
       B9_6(1,I) = 0.0
       B9_6(2,I) = 0.0
       B9_6(3,I) = 0.0
       IF19_6(I) = 0
       IB9_6(1,I) = 0
       IB9_6(2,I) = 0
       IB9_6(3,I) = 0
C
       DO J = 1,5
C
        K = (I-1)*5 + J
C
        IF (F2(K).NE.999.0) THEN
         F19_6(I) = F19_6(I) + F2(K)
         IF19_6(I) = IF19_6(I) + 1
        END IF
C
        IF (B(1,K).NE.999.0) THEN
         B9_6(1,I) = B9_6(1,I) + B(1,K)
         IB9_6(1,I) = IB9_6(1,I) + 1
        END IF
C
        IF (B(2,K).NE.999.0) THEN
         B9_6(2,I) = B9_6(2,I) + B(2,K)
         IB9_6(2,I) = IB9_6(2,I) + 1
        END IF
C
        IF (B(3,K).NE.999.0) THEN
         B9_6(3,I) = B9_6(3,I) + B(3,K)
         IB9_6(3,I) = IB9_6(3,I) + 1
        END IF
C
       END DO
C
C COMPUTE 9.6 SEC FIELD MAGNITUDE
C
       IF (IF19_6(I).NE.0) THEN
        F19_6(I) = F19_6(I)/IF19_6(I)
       ELSE
        F19_6(I) = 999.0
       END IF
C
C COMPUTE 9.6 SEC RADIAL COMPONENT AND RMS
C
       RMS9_6(1,I) = 0.0
       IF (IB9_6(1,I).NE.0) THEN
        B9_6(1,I) = B9_6(1,I)/IB9_6(1,I)
        DO J = 1,5
         K = (I-1)*5 + J
         IF ( B(1,K).NE.999.0 )
     &   RMS9_6(1,I) = RMS9_6(1,I) + ( B(1,K) - B9_6(1,I) )**2
        END DO
        RMS9_6(1,I) = SQRT( RMS9_6(1,I)/IB9_6(1,I) )
       ELSE
        B9_6(1,I) = 999.0
        RMS9_6(1,I) = 999.0
       END IF
C
C COMPUTE 9.6 SEC TANGENTIAL COMPONENT AND RMS
C
       RMS9_6(2,I) = 0.0
       IF (IB9_6(2,I).NE.0) THEN
        B9_6(2,I) = B9_6(2,I)/IB9_6(2,I)
        DO J = 1,5
         K = (I-1)*5 + J
         IF ( B(2,K).NE.999.0 )
     &   RMS9_6(2,I) = RMS9_6(2,I) + ( B(2,K) - B9_6(2,I) )**2
        END DO
        RMS9_6(2,I) = SQRT( RMS9_6(2,I)/IB9_6(2,I) )
       ELSE
        B9_6(2,I) = 999.0
        RMS9_6(2,I) = 999.0
       END IF
C
C COMPUTE 9.6 SEC NORMAL COMPONENT AND RMS
C
       RMS9_6(3,I) = 0.0
       IF (IB9_6(3,I).NE.0) THEN
        B9_6(3,I) = B9_6(3,I)/IB9_6(3,I)
        DO J = 1,5
         K = (I-1)*5 + J
         IF ( B(3,K).NE.999.0 )
     &   RMS9_6(3,I) = RMS9_6(3,I) + ( B(3,K) - B9_6(3,I) )**2
        END DO
        RMS9_6(3,I) = SQRT( RMS9_6(3,I)/IB9_6(3,I) )
       ELSE
        B9_6(3,I) = 999.0
        RMS9_6(3,I) = 999.0
       END IF
C
C COMPUTE 9.6 SEC FIELD MODULUS
C
       IF ( B9_6(1,I).NE.999.0 .AND.
     &      B9_6(2,I).NE.999.0 .AND.
     &      B9_6(3,I).NE.999.0 ) THEN
        F29_6(I) = SQRT(B9_6(1,I)**2+B9_6(2,I)**2+B9_6(3,I)**2)
       ELSE
        F29_6(I) = 999.0
       END IF
C
C COMPUTE 9.6 SEC LATITUDINAL FIELD ANGLE
C
       IF ( B9_6(3,I).NE.999.0 .AND. F29_6(I).NE.999.0 .AND.
     &      F29_6(I).NE.0.0 ) THEN
        DEL9_6(I) = ASIN( B9_6(3,I)/F29_6(I) )*57.2957795D0
       ELSE
        DEL9_6(I) = 90.0
       END IF
C
C COMPUTE 9.6 SEC LONGITUDINAL FIELD ANGLE
C
       IF ( B9_6(1,I).NE.999.0 .AND. B9_6(2,I).NE.999.0 .AND.
     &      B9_6(1,I).NE.0.0 ) THEN
        LAM9_6(I) = 180.0 - ATAN2( B9_6(2,I),-B9_6(1,I) )*57.2957795D0
       ELSE
        LAM9_6(I) = 45.0
       END IF
C
C      WRITE(6,889) F19_6(I),F29_6(I),(B9_6(L,I),L=1,3),
C    &              DEL9_6(I),LAM9_6(I),RMS9_6(1,I),
C    &              RMS9_6(2,I),RMS9_6(3,I),IF19_6(I)
C
      END DO
C
  889 FORMAT(5(1X,F7.3),2(1X,F5.1),3(1X,F7.3),1X,I2)
C
C COMPUTE 48 SEC AVERAGES
C
      F148 = 0.0
      B48(1) = 0.0
      B48(2) = 0.0
      B48(3) = 0.0
      IF148 = 0
      IB48(1) = 0
      IB48(2) = 0
      IB48(3) = 0
C
      DO I = 1,5
C
       IF (F29_6(I).NE.999.0) THEN
        F148 = F148 + F29_6(I)
        IF148 = IF148 + 1
       END IF
C
       IF (B9_6(1,I).NE.999.0) THEN
        B48(1) = B48(1) + B9_6(1,I)
        IB48(1) = IB48(1) + 1
       END IF
C
       IF (B9_6(2,I).NE.999.0) THEN
        B48(2) = B48(2) + B9_6(2,I)
        IB48(2) = IB48(2) + 1
       END IF
C
       IF (B9_6(3,I).NE.999.0) THEN
        B48(3) = B48(3) + B9_6(3,I)
        IB48(3) = IB48(3) + 1
       END IF
C
      END DO
C
C COMPUTE 48 SEC FIELD MAGNITUDE
C
      IF (IF148.NE.0) THEN
       F148 = F148/IF148
      ELSE
       F148 = 999.0
      END IF
C
C COMPUTE 48 SEC RADIAL COMPONENT AND RMS
C
      RMS48(1) = 0.0
      IF (IB48(1).NE.0) THEN
       B48(1) = B48(1)/IB48(1)
       DO I = 1,5
        IF (B9_6(1,I).NE.999.0)
     &   RMS48(1) = RMS48(1) + ( B9_6(1,I) - B48(1) )**2
       END DO
       RMS48(1) = SQRT( RMS48(1)/IB48(1) )
      ELSE
       B48(1) = 999.0
       RMS48(1) = 999.0
      END IF
C
C COMPUTE 48 SEC TANGENTIAL COMPONENT AND RMS
C
      RMS48(2) = 0.0
      IF (IB48(2).NE.0) THEN
       B48(2) = B48(2)/IB48(2)
       DO I = 1,5
        IF (B9_6(2,I).NE.999.0)
     &   RMS48(2) = RMS48(2) + ( B9_6(2,I) - B48(2) )**2
       END DO
       RMS48(2) = SQRT( RMS48(2)/IB48(2) )
      ELSE
       B48(2) = 999.0
       RMS48(2) = 999.0
      END IF
C
C COMPUTE 48 SEC NORMAL COMPONENT AND RMS
C
      RMS48(3) = 0.0
      IF (IB48(3).NE.0) THEN
       B48(3) = B48(3)/IB48(3)
       DO I = I,5
        IF (B9_6(3,I).NE.999.0)
     &   RMS48(3) = RMS48(3) + ( B9_6(3,I) - B48(3) )**2
       END DO
       RMS48(3) = SQRT( RMS48(3)/IB48(3) )
      ELSE
       B48(3) = 999.0
       RMS48(3) = 999.0
      END IF
C
C COMPUTE 48 SEC FIELD MODULUS
C
      IF ( B48(1).NE.999.0 .AND.
     &     B48(2).NE.999.0 .AND.
     &     B48(3).NE.999.0 ) THEN
       F248 = SQRT(B48(1)**2+B48(2)**2+B48(3)**2)
      ELSE
       F248 = 999.0
      END IF
C
C COMPUTE 48 SEC LATITUDINAL FIELD ANGLE
C
       IF ( B48(3).NE.999.0 .AND. F248.NE.999.0 .AND. F248.NE.0.0 ) THEN
        DEL48 = ASIN( B48(3)/F248 )*57.2957795D0
       ELSE
        DEL48 = 90.0
       END IF
C
C COMPUTE 48 SEC LONGITUDINAL FIELD ANGLE
C
       IF ( B48(1).NE.999.0 .AND. B48(2).NE.999.0 .AND.
     &      B48(1).NE.0.0 ) THEN
        LAM48 = 180.0 - ATAN2( B48(2),-B48(1) )*57.2957795D0
       ELSE
        LAM48 = 45.0
       END IF
C
C     WRITE(6,890) F148,F248,B48(1),B48(2),B48(3),DEL48,LAM48,
C    &             RMS48(1),RMS48(2),RMS48(3),IF148
  890 FORMAT(5(1X,F7.3),2(1X,F5.1),3(1X,F7.3),1X,I2)
C
C PAYLOAD DATA
C
C     WRITE(6,891) (PYLD(I),I=1,8)
  891 FORMAT(3(1X,F7.3),1X,I4,4(1X,F7.3))
C
C OUTPUT FILTERED MAG SUMMARY RECORD
C
      WRITE(9) (HEAD(I),I=1,32),F148,F248,DEL48,LAM48,(B48(I),I=1,3),
     & (RMS48(I),I=1,3),IF148,(F19_6(I),I=1,5),(F29_6(I),I=1,5),
     & (DEL9_6(I),I=1,5),(LAM9_6(I),I=1,5),((B9_6(J,I),I=1,5),J=1,3),
     & ((RMS9_6(J,I),I=1,5),J=1,3),(IF19_6(I),I=1,5),(F1(I),I=1,25),
     & (F2(I),I=1,25),(DELTA(I),I=1,25),(LAMBDA(I),I=1,25),
     & ((B(J,I),I=1,25),J=1,3),((RMS(J,I),I=1,25),J=1,3),
     & (NPTS(I),I=1,25),(SPARE(I),I=1,147),(PYLD(I),I=1,8),
     & (SEDR(I),I=1,40)
C
      RETURN
      END
      SUBROUTINE HEAD (SEDREC)                                          00001006
      RETURN                                                            00004006
      END                                                               00005006
      SUBROUTINE NAV (ISDREC, RSDREC, NAVBYT)                           00006006
      INTEGER*4 ISDREC(1)                                               00007006
      REAL*4 RSDREC(1)                                                  00008006
      RETURN                                                            00009606
      END                                                               00009706
      SUBROUTINE PV(ISDREC, RSDREC)                                     00010000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC            00011000
C                                                                       00012000
C THIS CALCULATES CONTINUING DIFFERENCES IN S/C ORIENTATION             00013000
C BETWEEN POINTING VECTORS.  PRINTS THE TIME OF THE PV'S                00014010
C WHERE THE S/C ORIENTATION HAS DEVIATED BY MORE THAN                   00015010
C 1 DEGREE                                                              00016010
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC            00017000
      INTEGER*4 ISDREC(1)                                               00020000
      REAL*4 RSDREC(126), XVEC(3), YVEC(3), ZVEC(3),                    00030002
     1       DANG/1./,  XVECO(3), YVECO(3), ZVECO(3)                    00030100
      LOGICAL*4 FIRST/.TRUE./                                           00040000
C ELIMINATE EMPTY PV                                                    00040110
      IF (ISDREC(1) .EQ. 0) GO TO 70                                    00040208
      DO 5 I=1,3                                                        00041005
          XVEC(I) = RSDREC(11+I)                                        00042005
          YVEC(I) = RSDREC(14+I)                                        00042105
          ZVEC(I) = RSDREC(17+I)                                        00042205
    5 CONTINUE                                                          00043005
      IF (.NOT. FIRST) GO TO 20                                         00050000
          DO 10 I = 1, 3                                                00060000
              XVECO(I) = XVEC(I)                                        00070000
              YVECO(I) = YVEC(I)                                        00080000
              ZVECO(I) = ZVEC(I)                                        00090000
   10     CONTINUE                                                      00100000
          WRITE (6,15) (ISDREC(I),I=1,6)                                00100110
   15 FORMAT (/,5X,I4,'/',I3,':',I2,':',I2,':',I2,'.',I3)               00100210
          FIRST = .FALSE.                                               00100607
          GO TO 70                                                      00101000
   20 CONTINUE                                                          00110000
          XDEL = 0.                                                     00111000
          YDEL = 0.                                                     00112000
          ZDEL = 0.                                                     00113000
          DO 30 I=1,3                                                   00120000
              XDEL = XDEL + XVECO(I) * XVEC(I)                          00130000
              YDEL = YDEL + YVECO(I) * YVEC(I)                          00140000
              ZDEL = ZDEL + ZVECO(I) * ZVEC(I)                          00150000
   30     CONTINUE                                                      00160000
C CALCULATE ANGLE OF CHANGE                                             00161010
          XDEL = ARCOS(XDEL) * 57.29578                                 00170000
          YDEL = ARCOS(YDEL) * 57.29578                                 00180000
          ZDEL = ARCOS(ZDEL) * 57.29578                                 00190000
          IF ((XDEL .LT. DANG) .AND. (YDEL .LT. DANG)                   00200000
     1    .AND. (ZDEL .LT. DANG)) GO TO 70                              00210000
              WRITE (6,50) (ISDREC(I),I=1,6)                            00270010
   50 FORMAT (/,5X,I4,'/',I3,':',I2,':',I2,':',I2,'.',I3)               00280010
              DO 60 I = 1, 3                                            00320000
                  XVECO(I) = XVEC(I)                                    00330000
                  YVECO(I) = YVEC(I)                                    00340000
                  ZVECO(I) = ZVEC(I)                                    00350000
   60         CONTINUE                                                  00360000
   70 CONTINUE                                                          00370000
      RETURN                                                            00380000
      END                                                               00390000
C THIS ROUTINE IS DESIGNED TO COPY A VOYAGER DETAIL TAPE.  IT IS
C INTENDED TO BE USED TO COPY A DETAIL TAPE TO MSS WHERE THE BLOCKING
C DIFFERENT
      DIMENSION REC(50000)
   10 CONTINUE
      CALL FREAD (REC, 10, NBYTE, &30, &20)
      CALL FWRITE (REC, 20, NBYTE)
      GO TO 10
   20 CONTINUE
      WRITE (6, 25)
   25 FORMAT (' ERROR READING INPUT DETAIL TAPE')
      GO TO 10
   30 CONTINUE
      STOP
      END
C THIS ROUTINE IS DESIGNED TO COPY A VOYAGER DETAIL TAPE.  IT IS
C INTENDED TO BE USED TO COPY A DETAIL TAPE TO MSS WHERE THE BLOCKING
C DIFFERENT
      INTEGER*4 I4REC(3750)
      REAL*4 R4REC(3750)
      INTEGER*2 I2REC(7500), YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,
     1                       YREND, DAYEND, HREND, MINEND, SECEND
      EQUIVALENCE (I4REC(1), I2REC(1), R4REC(1))
      READ (5,10) ID
   10 FORMAT (A4)
      READ (5,20) YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,                 00000150
     1            YREND, DAYEND, HREND, MINEND, SECEND                  00000155
   20 FORMAT (10I4)                                                     00000160
  100 CONTINUE
      CALL FREAD (I4REC, 10, NBYTE, &300, &200)
      IF (ID .NE. I4REC(1)) GO TO 100
      IF (I2REC(7) .LT. YRBEG) GO TO 100                                00000230
      IF (I2REC(7) .GT. YRBEG) GO TO 130                                00000240
      IF (I2REC(8) .LT. DAYBEG) GO TO 100                               00000250
      IF (I2REC(8) .GT. DAYBEG) GO TO 130                               00000260
      IF (I2REC(9) .LT. HRBEG) GO TO 100                                00000270
      IF (I2REC(9) .GT. HRBEG) GO TO 130                                00000272
      IF (I2REC(10) .LT. MINBEG) GO TO 100                              00000274
      IF (I2REC(10) .GT. MINBEG) GO TO 130                              00000276
      IF (I2REC(11) .LT. SECBEG) GO TO 100                              00000278
  130 CONTINUE                                                          00000280
      IF (I2REC(7) .LT. YREND) GO TO 140                                00000290
      IF (I2REC(7) .GT. YREND) GO TO 100                                00000300
      IF (I2REC(8) .LT. DAYEND) GO TO 140                               00000310
      IF (I2REC(8) .GT. DAYEND) GO TO 100                               00000320
      IF (I2REC(9) .LT. HREND) GO TO 140                                00000330
      IF (I2REC(9) .GT. HREND) GO TO 100                                00000332
      IF (I2REC(10) .LT. MINEND) GO TO 140                              00000334
      IF (I2REC(10) .GT. MINEND) GO TO 100                              00000336
      IF (I2REC(11) .GT. SECEND) GO TO 100                              00000338
  140 CONTINUE                                                          00000340
      ICGD = 0
      DO 10000 I=1, 80
           IF (R4REC(32 + I) .NE. 999.) ICGD = ICGD + 1
10000 CONTINUE
      WRITE (6,170) I4REC(1), (I2REC(I),I=7,12), ICGD, R4REC(33)
  170 FORMAT (1X,A4,1X,6I4,1X,I5,F10.3)
      CALL FWRITE (I4REC, 20, NBYTE)
      GO TO 100
  200 CONTINUE
      WRITE (6, 210)
  210 FORMAT (' ERROR READING INPUT DETAIL TAPE')
      GO TO 100
  300 CONTINUE
      STOP
      END
      CHARACTER BUFIN(100000),BUFOUT(100000)                            00010035
      CHARACTER*1 M/'M'/,J/'J'/,S/'S'/                                  00020017
      LOGICAL FIRST/.TRUE./                                             00021014
      INTEGER IN, OUT/1/, NBIN, NBOUT/0/, NREC/0/,TOTBYTES              00030040
      TOTBYTES = 0                                                      00031040
   10 CONTINUE                                                          00040000
C        CALL FREAD (BUFIN, 10, NBIN, &40, &50)                         00050053
C                                                                       00050154
C OUTDATED FTIO CODE REPLACED WITH UNFORMATTED READ SBK 02/02/94        00050254
C                                                                       00050354
         READ(10,NUM=NBIN,END=40,ERR=50) BUFIN                          00050453
         NREC = NREC + 1                                                00050508
         IN = 1                                                         00060000
         DO 30 I = 1, NBIN                                              00080035
         IF (FIRST) GO TO 25                                            00081043
          IF ((BUFIN(I) .NE. M) .OR.                                    00090035
     1        (BUFIN(I+1) .NE. J) .OR.                                  00100035
     1        (BUFIN(I+2) .NE. S)) GO TO 30                             00110035
            IF (I .EQ. IN) GO TO 20                                     00120001
            CALL FMOVE (BUFOUT(OUT), I-IN, BUFIN(IN))                   00130034
            OUT = OUT + I - IN                                          00140000
            NBOUT = NBOUT + I -IN                                       00141001
            IN = I                                                      00150001
   20       CONTINUE                                                    00160001
            IF (NREC .EQ. 5757) WRITE(6,*)BUFOUT                        00162037
            TOTBYTES = TOTBYTES + NBOUT                                 00163040
C           WRITE (6,*) 'FWRITE NBOUT = ',NBOUT                         00164048
            CALL FWRITE(BUFOUT,20,NBOUT)                                00170028
            NREC = NREC + 1                                             00171044
C           WRITE(6,*) 'NREC = ',NREC                                   00172048
            OUT = 1                                                     00180001
            NBOUT = 0                                                   00190001
   25       CONTINUE                                                    00191007
            FIRST = .FALSE.                                             00192007
   30    CONTINUE                                                       00200001
         CALL FMOVE (BUFOUT(NBOUT),NBIN-IN+1,BUFIN(IN-1))               00210036
         OUT = OUT + NBIN - IN +1                                       00220028
         NBOUT = NBOUT + NBIN -IN +1                                    00230028
         GO TO 10                                                       00240001
   40 CONTINUE                                                          00250001
      CALL FMOVE (BUFOUT(OUT),NBIN-IN, BUFIN(IN))                       00260037
      NBOUT = NBOUT + NBIN -IN                                          00270028
      TOTBYTES = TOTBYTES + NBOUT                                       00271040
C     WRITE(6,*) 'NBOUT 2 = ',NBOUT                                     00272048
C     IF (NBOUT .GT. 11280) NBOUT = 11280                               00273049
      CALL FWRITE (BUFOUT, 20, NBOUT)                                   00280042
      NREC = NREC + 1                                                   00281044
C     WRITE(6,*)'NREC* =',NREC                                          00282048
      GO TO 70                                                          00290001
   50 CONTINUE                                                          00300001
      WRITE (6, 60)                                                     00310001
   60 FORMAT (' I/O ERROR READING INPUT FILE')                          00320001
   70 CONTINUE                                                          00330001
      WRITE(6,*) '*************************************'                00330141
      WRITE(6,*) 'END OF BLOCKING PROGRAM'                              00330241
      WRITE(6,*) 'TOTAL BYTES OUTPUT = ',TOTBYTES                       00331040
      STOP                                                              00340001
      END                                                               00350001
       CHARACTER BUFIN(400000),BUFOUT(400000)                           00010000
C  PROGRAM: EDRCCAT                                                     00001070
C  PROGRAMMER: T. MCCLANAHAN  1/12/93                                   00002070
C  THIS PROGRAM WILL CONCATENATE EDR'S. TO A SINGLE FILE.               00003070
       INTEGER*4 I4REC(10000),OUTTAPE/15/,INTAPE,NUMTAPE,TREC           00010072
       WRITE (6,*)'BEGINNING PROCESSING......'                          00041025
         DO WHILE (.TRUE.)                                              00042070
          CALL FREAD(I4REC,10,NBYTS,&100,&100)                          00060072
          CALL FWRITE(I4REC,20,NBYTS)                                   00061072
          TREC = TREC + 1                                               00062072
         END DO                                                         00070070
 100   WRITE(6,*) 'TOTAL RECORDS PROCESSED = ',TREC                     00342472
       STOP                                                             00343000
       END                                                              00350000
C-----------------------------------------------------------------------00010000
C   LISTS EDR TAPES. ---- BY ADS                                        00020000
C   THE ID IS 'MJS RS' WHERE                                            00030000
C         R=4   MAG                S=0   FLT2                           00040000
C         R=B   ENG                S=1   FLT1                           00050000
C         R=F   DECOM MAP                                               00060000
C   THE DATA MODE (DMD) IS                                              00070000
C         00   ENG        01   CR2        02   CR3                      00080000
C         03   CR4        04   CR5        05   CR6                      00090000
C         07   CR1        0A   GS3                                      00100000
C   LOGICAL SWITCHES:                                                   00110000
C    1  LDPI  PRINTS DPI'S (CR1-6,GS3)                                  00120000
C    2  LRAW  PRINTS RAW MAG DATA (CR6,GS3)                             00130000
C    3  LMST  PRINTS MSTART WORDS & MSTATUS (CR2,CR3)                   00140000
C                    PLS STATUS (CR6)                                   00150000
C    4  LMAS PRINTS MAG STATUS (CR1-6,GS3)                              00160000
C-----------------------------------------------------------------------00170000
      LOGICAL*1 LPLAY(4)/4*.FALSE./                                     00180000
      LOGICAL*1 LBUF(12000),LRSID(2),LDMD(2),LMAS/.FALSE./              00190000
      LOGICAL*1 LMOD60(2),LDPI/.FALSE./,LRAW/.FALSE./,LMST/.FALSE./     00200000
      INTEGER*4 PTYP(32)/'ENG ','CR2 ','CR3 ','CR4 ','CR5 ',            00210000
     X 'CR6 ','BAD ','CR1 ','BAD ','IM7 ','GS3 ','IM9 ','PB3 ',         00220000
     X 'PB2 ','PB1 ','GS4 ','BAD ','GS2 ','IM14','BAD ','IM12',         00230000
     X 'IM11','IM10','OC1 ','IM8 ','BAD ','IM6 ','IM5 ','IM4 ',         00240000
     X 'IM3 ','IM2 ','IM13'/                                            00250000
      INTEGER*2 IBUF(6000),ITM(6,2)/12*0/,RSID/0/,DMD,DMDA              00260000
      INTEGER*2 MOD60/0/,LINCNT,SCTM(6),ERTM(6),LOD216(2)               00270000
      INTEGER*2 FPLAY,PPLAY/'PB'/,BPLAY/'  '/                           00280000
      INTEGER*4 IOREC/0/,JBUF(3000),MTYP(32),PRID/'    '/               00290000
      INTEGER*4 PFLAG,TREG/'TREG'/,BLNK/'    '/,MOD216/0/               00300000
      REAL*8 TIME,TIMEP/-7.D75/,VOLSER,SUMTAP,TIME1/-7.D75/,TIME2/7.D75/00310000
      REAL*8 TIMF                                                       00320000
      EQUIVALENCE (LMOD60(1),MOD60),(IBUF(1),JBUF(1),LBUF(1))           00330000
      EQUIVALENCE (LRSID(1),RSID),(LDMD(1),DMD),(LPLAY(1),IPLAY)        00340000
      EQUIVALENCE (LOD216(1),MOD216)                                    00350000
      READ (4,1002,END=42) LDPI,LRAW,LMST,LMAS                          00360000
 1002 FORMAT (4L1)                                                      00370000
   42 WRITE (6,2011) LDPI,LRAW,LMST,LMAS                                00380000
 2011 FORMAT ('0SPECIAL REQUEST SWITCHES: ',4L1)                        00390000
      READ (5,1001,END=41) (ITM(I,1),I=1,5),(ITM(I,2),I=1,5)            00400000
 1001 FORMAT (10I4)                                                     00410000
      WRITE (6,2005) (ITM(I,1),I=1,6),(ITM(I,2),I=1,6)                  00420000
 2005 FORMAT ('0TIME INTERVAL IS ',2I4,3(':',I2),'.',I3,5X,             00430000
     X    2I4,3(':',I2),'.',I3/'0')                                     00440000
      TIME1 = TIMF(ITM(1,1))                                            00450000
      TIME2 = TIMF(ITM(1,2))                                            00460000
   41 DO  11  I = 1,32                                                  00470000
   11 MTYP(I) = 0                                                       00480000
      NREC = 0                                                          00490000
C**** READ A RECORD.                                                    00500000
   10 CALL FREAD (IBUF,10,NBYT,&51,&52)                                 00510000
      NREC =NREC + 1                                                    00520000
      CALL FMOVE (PRID,3,LBUF(1))                                       00530000
      LRSID(2) = LBUF(4)                                                00540000
      LDMD(2) = LBUF(7)                                                 00550000
      CALL SETMOD(DMD,DMDA)                                             00560000
      CALL DETIM (IBUF(13),SCTM)                                        00570000
      CALL DETIM (IBUF(5),ERTM)                                         00580000
      LMOD60(2) = LBUF(35)                                              00590000
      CALL FMOVE (LINCNT,2,LBUF(36))                                    00600000
      IMOD60 = MOD60                                                    00610000
      LOD216(2) = IBUF(17)                                              00620000
      TIME = TIMF(SCTM)                                                 00630000
C**** COMPUTE ONE WAY LIGHT TIME & FLAG TIME REGRESSIONS.               00640000
      OWLT = 0.E0                                                       00650000
      PFLAG = BLNK                                                      00660000
      IF (DMD.EQ.0)  GO TO 16                                           00670000
      OWLT = 1440.D0*(TIMF(ERTM) - TIME)                                00680000
      IF (TIME.LT.TIMEP)  PFLAG = TREG                                  00690000
      TIMEP = TIME                                                      00700000
C**** CHECK REQUESTED TIME INTERVAL.                                    00710000
   16 IF (TIME.LT.TIME1)  GO TO 10                                      00720000
      IF (TIME.GT.TIME2)  GO TO 53                                      00730000
C**** CHECK FOR PLAYBACK.                                               00740000
      LPLAY(4) = LBUF(8)                                                00750000
      FPLAY = BPLAY                                                     00760000
      IF (MOD(IPLAY,64).GE.32) FPLAY =PPLAY                             00770000
C**** PRINT A LINE FOR EACH EDR RECORD.                                 00780000
      WRITE (6,2001) NREC,IBUF(3),NBYT,PRID,RSID,PTYP(DMDA+1),SCTM      00790000
     X ,MOD216,MOD60,LINCNT,ERTM,OWLT,PFLAG,FPLAY                       00800000
 2001 FORMAT (1X,I4,'/',I4,2X,I5,' BYTES ',A4,Z2,1X,A4,1X,              00810000
     X  I2,'/',I3,3(':',I2),'.',I3,' SCET',1X,                          00820000
     X  I5,'.',I2,'.',I3,1X,                                            00830000
     X  I2,'/',I3,3(':',I2),'.',I3,' ERT',1X,F7.3,1X,A4,1X,A2)          00840000
C**** PRINT DPIS IF REQUESTED.                                          00850000
      IF (LDPI) CALL FINDPI(LBUF(75),DMD)                               00860000
C**** PRINT MSTART,MSTATUS AND PLS STATUS IF REQUESTED.                 00870000
      IF (.NOT.LMST) GO TO 12                                           00880000
      IF (DMD.EQ.5) WRITE (6,2010) JBUF(73)                             00890000
 2010 FORMAT (' PLS STATUS WORD = ',Z9)                                 00900000
      IF (DMD.EQ.1.AND.MOD(IMOD60,2).EQ.0)                              00910000
     X     WRITE (6,2009) LBUF(404),LBUF(405),LBUF(406)                 00920000
      IF (DMD.EQ.2)  WRITE (6,2009) LBUF(405),LBUF(406),LBUF(407)       00930000
 2009 FORMAT (' MSTART1,MSTART2,MSTATUS = ',3Z3)                        00940000
C**** PRINT RAW DATA IF REQUESTED.                                      00950000
   12 IF (LRAW) CALL DORAW(IBUF,LBUF,DMD)                               00960000
C**** PRINT MAG STATUS WORDS IF REQUESTED.                              00970000
      IF (LMAS) CALL MAGST(IBUF,DMD)                                    00980000
C**** COLLECT SUMMARY INFORMATION.                                      00990000
      DO 31  I = 1,32                                                   01000000
      IF (DMDA+1.EQ.I)  GO TO 32                                        01010000
   31 CONTINUE                                                          01020000
      I = 7                                                             01030000
   32 MTYP(I) = MTYP(I) + 1                                             01040000
      GO TO 10                                                          01050000
C**** END OF FILE.                                                      01060000
   51 WRITE (6,2002)                                                    01070000
 2002 FORMAT (' END OF FILE')                                           01080000
      GO TO 53                                                          01090000
C**** I/O ERROR.                                                        01100000
   52 WRITE (6,2003)                                                    01110000
 2003 FORMAT (' I/O ERROR')                                             01120000
      IOREC = IOREC + 1                                                 01130000
      IF (IOREC.LT.5)  GO TO 10                                         01140000
C**** PRINT SUMMARY INFORMATION.                                        01150000
   53 SUMTAP = VOLSER('FT10F001')                                       01160000
      WRITE (6,2004) SUMTAP                                             01170000
 2004 FORMAT (' LISTING OF VOLUME ',A8/'0')                             01180000
      MTT = 0                                                           01190000
      DO 17  I = 1,32                                                   01200000
      IF (MTYP(I).NE.0) WRITE (6,2006) PTYP(I),MTYP(I)                  01210000
 2006 FORMAT (1X,A4,1X,I5)                                              01220000
   17 MTT = MTT + MTYP(I)                                               01230000
      WRITE (6,2007) MTT                                                01240000
 2007 FORMAT ('0'/6X,I5)                                                01250000
      STOP                                                              01260000
      END                                                               01270000
      REAL FUNCTION TIMF*8 (ITM)                                        00000100
C-----------------------------------------------------------------------00000110
C  BY ADS                                                               00000115
C  INPUT:  ITM(1) = YEAR                   **  NOTE                     00000120
C          ITM(2) = DAY OF YEAR            **  THAT                     00000130
C          ITM(3) = HOUR OF DAY            **  ITM                      00000140
C          ITM(4) = MINUTE OF HOUR         **  IS                       00000150
C          ITM(5) = SECOND OF MINUTE       **  TYPED                    00000160
C          ITM(6) = MILLISECOND OF SECOND  **  INTEGER*2                00000170
C  OUTPUT: TIMF = DAYS SINCE 1977 DAY 0 (REAL*8)                        00000180
C-----------------------------------------------------------------------00000190
      INTEGER*2 ITM(6)                                                  00000200
      IYR = ITM(1)                                                      00000210
      IYR = MOD(IYR,1900) - 77                                          00000220
      TIMF = IYR*365.D0 + (ITM(2) + (ITM(3) + (ITM(4) + (ITM(5) +       00000230
     X .001D0*ITM(6))/60.D0)/60.D0)/24.D0) + MOD(IYR,4)                 00000240
      RETURN                                                            00000250
      END                                                               00000260
      SUBROUTINE DETIM (IBF,ITM)                                        00000270
C-----------------------------------------------------------------------00000280
C  INPUT:  IBF(1) = HOUR OF YEAR             **                         00000290
C          IBF(2) = SECOND OF HOUR           **  ARRAY                  00000300
C          IBF(3) = MILLISECOND OF SECOND    **  TYPED                  00000310
C          IBF(4) = YEAR IN HIGH ORDER BYTE  **  INTEGER*2              00000320
C  OUTPUT: ITM(1) = YEAR                   **                           00000330
C          ITM(2) = DAY OF YEAR            **                           00000340
C          ITM(3) = HOUR OF DAY            **                           00000350
C          ITM(4) = MINUTE OF HOUR         **  ARRAY                    00000360
C          ITM(5) = SECOND OF MINUTE       **  TYPED                    00000370
C          ITM(6) = MILLISECOND OF SECOND  **  INTEGER*2                00000380
C-----------------------------------------------------------------------00000390
      LOGICAL*1 LDUM(2)                                                 00000400
      INTEGER*2 IBF(1),ITM(1),IDUM                                      00000410
      EQUIVALENCE (LDUM(1),IDUM)                                        00000420
      ITM(2) = IBF(1)/24                                                00000430
      ITM(3) = IBF(1) - 24*ITM(2)                                       00000440
      ITM(4) = IBF(2)/60                                                00000450
      ITM(5) = IBF(2) - 60*ITM(4)                                       00000460
      ITM(6) = IBF(3)                                                   00000470
      IDUM = IBF(4)                                                     00000480
      LDUM(2) = LDUM(1)                                                 00000490
      LDUM(1) = .FALSE.                                                 00000500
      ITM(1) = IDUM                                                     00000510
      RETURN                                                            00000520
      END                                                               00000530
      INTEGER FUNCTION IREF*4 (LIN)                                     00000540
C-----------------------------------------------------------------------00000550
C  COMPUTE REFERENCE WORD FROM TWO INPUT BYTES.                         00000560
C-----------------------------------------------------------------------00000570
      LOGICAL*1 LIN(2),LT(2),LS,MASK/Z3F/                               00000580
      INTEGER*2 IT/0/                                                   00000590
      EQUIVALENCE (LT(1),IT),(LT(2),LS)                                 00000600
      LS = LIN(1)                                                       00000610
      IDUM = KNC(LS,MASK,1)                                             00000620
      IREF = 64*IT                                                      00000630
      LS = LIN(2)                                                       00000640
      IDUM = KNC(LS,MASK,1)                                             00000650
      IREF = IREF + IT                                                  00000660
      RETURN                                                            00000670
      END                                                               00000680
      SUBROUTINE FINDPI (LBUF,DMD)                                      00000690
C-----------------------------------------------------------------------00000700
C  WRITE DPIS FOR EACH DATA MODE.                                       00000710
C-----------------------------------------------------------------------00000720
      INTEGER*4 NLP(11)/0,3*40,60,150,0,80,0,0,159/                     00000730
      INTEGER*4 NIP(11)/0,3* 1, 1,  1,0, 1,0,0,  2/                     00000740
      INTEGER*2 MDPI(150),DMD                                           00000750
      LOGICAL*1 LBUF(1)                                                 00000760
      IF (DMD.GT.10)  RETURN                                            00000770
      NL = NLP(DMD+1)                                                   00000780
      IF (NL.EQ.0)  RETURN                                              00000790
      NI = NIP(DMD+1)                                                   00000800
      MC = 0                                                            00000810
      NC = 0                                                            00000820
      DO 10  I = 1,NL,NI                                                00000830
      NC = NC + 1                                                       00000840
      IF (.NOT.LBUF(I))  GO TO 10                                       00000850
      MC = MC + 1                                                       00000860
      MDPI(MC) = NC                                                     00000870
   10 CONTINUE                                                          00000880
      IF (MC.EQ.0)  WRITE (6,2001)                                      00000890
 2001 FORMAT (' NO DPIS FLAGGED')                                       00000900
      IF (MC.GT.0)  WRITE (6,2002) (MDPI(I), I = 1,MC)                  00000910
 2002 FORMAT (' DPIS FLAGGED:',20I4/(14X,20I4))                         00000920
      RETURN                                                            00000930
      END                                                               00000940
      SUBROUTINE DORAW (IBUF,LBUF,DMD)                                  00000950
C-----------------------------------------------------------------------00000960
C  PRINTS RAW DATA.                                                     00000970
C-----------------------------------------------------------------------00000980
      LOGICAL*1 LBUF(1),LCD(3)/'X','Y','Z'/                             00000990
      INTEGER*2 IBUF(1),HEXF/Z000F/,ISEG,DMD                            00001000
      INTEGER*4 MFA(2),JREF(2,9),NEW(9)/2,47,5,50,8,53,26,29,32/        00001010
      IF (DMD.NE.5) GO TO 21                                            00001020
C**** PRINT CR-6 RAW DATA.                                              00001030
      ISEG = IBUF(8)                                                    00001040
      IDUM = KNC(ISEG,HEXF,2)                                           00001050
      WRITE (6,2013) ISEG                                               00001060
 2013 FORMAT (' SEGMENT NUMBER ',I5)                                    00001070
      DO 19  IC = 1,3                                                   00001080
      DO 19  IMF = 1,25                                                 00001090
      JMF = 3*IMF + IC - 3                                              00001100
      JL = 3238 + 19*JMF                                                00001110
      JU = JL + 18                                                      00001120
      IRF1 = IREF(LBUF(JL))                                             00001130
      IRF2 = IREF(LBUF(JL+2))                                           00001140
      JMF = JMF + 75*(ISEG - 1)                                         00001150
   19 WRITE (6,2012) JMF,(LBUF(IW),IW=JL,JU),LCD(IC),IRF1,IRF2          00001160
 2012 FORMAT (' MF',I3,': ',19Z3,1X,A1,' REF WDS = ',2I5)               00001170
      RETURN                                                            00001180
C**** PRINT GS-3 LFM REFERENCE WORDS.                                   00001190
   21 IF (DMD.NE.10) RETURN                                             00001200
      WRITE (6,2002)                                                    00001210
 2002 FORMAT (' LFM REF WORDS IN ORDER: PX,PX,PY,PY,PZ,PZ,SX,SY,SZ')    00001220
      DO 25  MF = 1,40                                                  00001230
      DO 27  IC = 1,2                                                   00001240
      MFA(IC) = MF + 40*(IC-1)                                          00001250
      IBS = 512 + 75*(MFA(IC) - 1)                                      00001260
      DO 27  IW = 1,9                                                   00001270
   27 JREF(IC,IW) = IREF(LBUF(IBS + NEW(IW)))                           00001280
   25 WRITE (6,2001) MFA(1),(JREF(1,I),I=1,9),MFA(2),(JREF(2,I),I=1,9)  00001290
 2001 FORMAT (' MF',I3,': ',9I5,'    MF',I3,': ',9I5)                   00001300
      RETURN                                                            00001310
      END                                                               00001320
      SUBROUTINE MAGST (IB,DMD)                                         00001330
C-----------------------------------------------------------------------00001340
C  PRINTS MAG STATUS WORDS.                                             00001350
C-----------------------------------------------------------------------00001360
      INTEGER*2 IB(1),DMD                                               00001370
      IF (DMD.EQ.7) WRITE (6,2001) (IB(K), K = 135,150)                 00001380
      IF (DMD.EQ.1) WRITE (6,2001) (IB(K), K = 133,138)                 00001390
      IF (DMD.EQ.2) WRITE (6,2001) (IB(K), K= 133,144)                  00001400
      IF (DMD.EQ.3) WRITE(6,2001) (IB(K),K=129,148),(IB(K),K=151,154)   00001410
      IF (DMD.EQ.4) WRITE(6,2001) (IB(K),K=137,148),(IB(K),K=153,164)   00001420
      IF (DMD.EQ.5) WRITE (6,2001) (IB(K), K= 155,164)                  00001430
      IF (DMD.EQ.10) WRITE (6,2001) (IB(K), K = 125,144)                00001440
 2001 FORMAT (' MAG STATUS ',24Z5)                                      00001450
      RETURN                                                            00001460
      END                                                               00001470
      SUBROUTINE SETMOD (DMD,DMDA)                                      00001480
C-----------------------------------------------------------------------00001490
C  MODIFY THE DATA MODE. MANY MODES ARE EQUIVALENT TO GS-3              00001500
C-----------------------------------------------------------------------00001510
      INTEGER*2 DMD,DMDA                                                00001520
      IF (DMD.LT.0.OR.DMD.GT.31)  GO TO 40                              00001530
      DMDA = DMD                                                        00001540
      IF (DMD.GE.9.AND.DMD.LE.15) DMD = 10                              00001550
      IF (DMD.EQ.17.OR.DMD.EQ.18) DMD = 10                              00001560
      IF (DMD.GE.20.AND.DMD.LE.24) DMD = 10                             00001570
      IF (DMD.GE.26.AND.DMD.LE.31) DMD = 10                             00001580
      RETURN                                                            00001590
   40 DMD = 6                                                           00001600
      DMDA = 6                                                          00001610
      RETURN                                                            00001620
      END                                                               00001630
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00010000
C                                                                       00020000
C THIS ROUTINE READS RECORDS FROM A PRODUCTION EDR TAPE                 00030000
C ('EDR' - FT10F001) AND A PLAYBACK EDR TAPE ('PB' - FT20F001) AND      00040000
C WRITES AN EDR WITH MERGED RECORDS FROM THESE TAPES ('E' - FT30F001)   00050000
C                                                                       00060000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00070000
      LOGICAL*1 PBL1(12000), FLAGL1(4)                                  00080000
      INTEGER*4 BYTEDR/0/, BYTPB/0/, FLAG/0/, TCNT                      00090017
      INTEGER*2 EDR(6000),PB(6000),FDSEDR(3),FDSPB(3)                   00100000
      REAL*8 EDRRAT, PBRAT                                              00101006
      EQUIVALENCE (PBL1(1), PB(1)), (FLAGL1(1), FLAG)                   00110000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00120000
C                                                                       00130000
C 'MERGE' NAMELIST PARAMETERS:                                          00140000
C        NBEG = THE NUMBER OF THE PB RECORD WHERE PROCESSING IS TO      00150000
C               BEGIN.  IF 0, PROCESSING BEGINS AT THE FIRST EDR RECORD.00160000
C        NEND = THE NUMBER OF THE PB RECORD WHERE PROCESSING IS TO END. 00170000
C               IF 0, PROCESSING ENDS AT THE LAST EDR RECORD.           00180000
C        EDRRAT = RATIO TO BE USED FOR CHECKING OWLT OF EDR RECORDS     00181006
C        PBRAT  = RATIO TO BE USED FOR CHECKING OWLT OF PB RECORDS      00182006
C                                                                       00190000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00200000
      NAMELIST /MERGE/ NBEG,NEND,EDRRAT,PBRAT                           00210006
      READ (5,MERGE)                                                    00220000
      WRITE (6,5) NBEG,NEND,EDRRAT,PBRAT                                00230006
    5 FORMAT (' MERGE PARAMETERS: NBEG =',I10,' NEND =',I10,/,          00240006
     1        '                   EDR OWLT RATIO = ',E12.4,/,           00241006
     2        '                   PB  OWLT RATIO = ',E12.4)             00242006
C READ THE FIRST EDR RECORD                                             00250000
      CALL RDEDR (EDR,BYTEDR,FDSEDR,EDRRAT,&70)                         00260006
   10 CONTINUE                                                          00270000
C READ FIRST PB RECORD(S)                                               00280000
      CALL RDPB (PB,BYTPB,FDSPB,PBRAT,&90)                              00290006
C IF NBEG .EQ. 0   COMPARE EDR AND PB TIMES (20)                        00300000
C IF NBEG .GT. 0   BYPASS PB RECORDS LESS THAN NBEG                     00310000
      IF (NBEG) 20,20,30                                                00320000
   20 CONTINUE                                                          00330000
C IF FDSEDR .LT. FDSPB   WRITE EDR RECORD TO E TAPE                     00340000
C IF FDSEDR .GE. FDSPB   READ NEW PB RECORD                             00350000
      IF (ICOMP(FDSEDR,FDSPB)) 60,10,10                                 00360000
   30 CONTINUE                                                          00370000
C IF NUMBER OF PB RECORD IS LESS THAN NBEG, READ NEW PB RECORD (10)     00380000
      IF (PB(3) .LT. NBEG) GO TO 10                                     00390000
   40 CONTINUE                                                          00400000
C IF (FDSEDR .LT. FDSPB)  WRITE EDR RECORD TO E TAPE AND READ NEW EDR   00410000
C                         RECORD (60)                                   00420000
C IF (FDSEDR .EQ. FDSPB)  READ NEW PB RECORD, THEN WRITE EDR RECORD TO  00430000
C                         E TAPE AND READ NEW EDR RECORD (55)           00440000
C IF (FDSEDR .GT. FDSPB)  WRITE PB RECORD TO E TAPE AND READ A NEW      00450000
C                         PB RECORD (50)                                00460000
      IF (ICOMP(FDSEDR,FDSPB)) 60,55,50                                 00470000
   50 CONTINUE                                                          00480000
C WRITE PB RECORD TO E TAPE AND READ NEW PB RECORD                      00490000
C IF PB INDICATOR IS NOT SET, SET IT                                    00500000
      CALL FMOVE (FLAGL1(4), 1, PBL1(8))                                00510000
      IF (MOD(FLAG,64) .GE. 32) GO TO 52                                00520000
      FLAG = FLAG + 32                                                  00530000
      CALL FMOVE (PBL1(8), 1, FLAGL1(4))                                00540000
   52 CONTINUE                                                          00550000
      CALL FWRITE (PB,30,BYTPB)                                         00560000
      CALL RDPB (PB,BYTPB,FDSPB,PBRAT,&90)                              00570006
C COMPARE EDR AND PB TIMES (FDS)                                        00580000
      GO TO 40                                                          00590000
   55 CONTINUE                                                          00600000
C READ PB RECORD                                                        00610000
      CALL RDPB (PB,BYTPB,FDSPB,PBRAT,&90)                              00620006
   60 CONTINUE                                                          00630000
C WRITE EDR RECORD TO E TAPE AND READ NEW EDR RECORD                    00640000
      CALL FWRITE (EDR,30,BYTEDR)                                       00650000
      CALL RDEDR (EDR,BYTEDR,FDSEDR,EDRRAT,&70)                         00660006
C COMPARE EDR AND PB TIMES (FDS)                                        00670000
      GO TO 40                                                          00680000
   70 CONTINUE                                                          00690000
C END OF EDR TAPE - IF NEND = 0, PROCESSING IS COMPLETED                00700000
      IF (NEND .EQ. 0) GO TO 100                                        00710000
   80 CONTINUE                                                          00720000
      IF (BYTPB .EQ. 0) CALL RDPB (PB, BYTPB, FDSPB,PBRAT, &100)        00721006
C WHEN (NEND .GT. 0) WRITE PB RECORDS NUMBERED UP TO NEND ONTO E TAPE   00730000
      IF (PB(3) .GT. NEND) GO TO 100                                    00740000
      CALL FMOVE (FLAGL1(4), 1, PBL1(8))                                00750000
      IF (MOD(FLAG,64) .GE. 32) GO TO 85                                00760000
      FLAG = FLAG + 32                                                  00770000
      CALL FMOVE (PBL1(8), 1, FLAGL1(4))                                00780000
   85 CONTINUE                                                          00790000
      CALL FWRITE (PB,30,BYTPB)                                         00800000
      CALL RDPB (PB,BYTPB,FDSPB,PBRAT,&100)                             00810006
      GO TO 80                                                          00820000
   90 CONTINUE                                                          00830000
C END PB TAPE.  WRITE REMAINING EDR RECORDS TO E TAPE                   00840000
      CALL FWRITE (EDR,30,BYTEDR)                                       00850000
      CALL RDEDR (EDR,BYTEDR,FDSEDR,EDRRAT,&100)                        00860006
      GO TO 90                                                          00870000
  100 CONTINUE                                                          00880000
      STOP                                                              00890000
      END                                                               00900000
      FUNCTION ICOMP (FDSEDR,FDSPB)                                     00910000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00920000
C                                                                       00930000
C THIS FUNCTION COMPARES FDS COUNTS FROM EDR AND PB RECORDS             00940000
C IF THE EDR HAS A GREATER FDSC, +1 IS RETURNED                         00950000
C IF THE PB  HAS A GREATER FDSC, -1 IS RETURNED                         00960000
C IF THE TWO FDSC ARE EQUAL,      0 IS RETURNED                         00970000
C                                                                       00980000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00990000
      INTEGER*2 FDSEDR(3),FDSPB(3)                                      01000000
      IF (FDSEDR(1) - FDSPB(1)) 30,10,50                                01010000
   10 CONTINUE                                                          01020000
      IF (FDSEDR(2) - FDSPB(2)) 30,20,50                                01030000
   20 CONTINUE                                                          01040000
      IF (FDSEDR(3) - FDSPB(3)) 30,40,50                                01050000
   30 CONTINUE                                                          01060000
      ICOMP = -1                                                        01070000
      GO TO 60                                                          01080000
   40 CONTINUE                                                          01090000
      ICOMP = 0                                                         01100000
      GO TO 60                                                          01110000
   50 CONTINUE                                                          01120000
      ICOMP = 1                                                         01130000
   60 CONTINUE                                                          01140000
      RETURN                                                            01150000
      END                                                               01160000
      SUBROUTINE RDEDR (EDR,BYTEDR,FDSEDR,EDRRAT,*)                     01170006
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC01180000
C                                                                       01190000
C THIS ROUTINE PERFORMS THE FOLLOWING:                                  01200000
C    (1) READS EDR RECORDS FROM UNIT 10 (FT10F001)                      01210000
C    (2) RECORDS ARE BYPASSED AS REQUESTED VIA UNIT 11 (FT11F001)       01220000
C        IF ONE NUMBER IS INPUT, THAT RECORD IS PYPASSED                01221001
C        IF TWO NUMBERS ARE INPUT, THE RANGE OF RECORDS IS BYPASSED     01222001
C    (3) FDS COUNTS ARE EXTRACTED FROM THE RECORD                       01230000
C                                                                       01240000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC01250000
      REAL*8 ERT, SCET, OWLT, OWLTP,EDRRAT                              01251006
      INTEGER*2 EDR(6000),FDSEDR(3),EDRDEL, LIM/0/,TCNT                 01260019
      LOGICAL*1 FIRST/.TRUE./                                           01270000
      IF (.NOT. FIRST) GO TO 30                                         01280000
    5 CONTINUE                                                          01300000
C READ THE NUMBER OF THE RECORD (OR RANGE OF RECORDS) TO BE BYPASSED.   01310001
C IF 0, NO RECORDS WILL BE BYPASSED                                     01320000
      IF (LIM .EQ. 0) GO TO 7                                           01321001
      EDRDEL = EDRDEL + 1                                               01322001
      IF (EDRDEL .LE. LIM) GO TO 30                                     01323010
    7 CONTINUE                                                          01324001
      READ (11,10) EDRDEL, LIM                                          01330001
      WRITE(6,*) 'UNIT 11 VALUES EDRDEL,LIM = ',EDRDEL,LIM              01331017
   10 FORMAT (2I10)                                                     01340001
   30 CONTINUE                                                          01370000
C READ EDR RECORD                                                       01380019
      CALL FREAD (EDR,10,BYTEDR,&60,&40)                                01390000
C BYPASS EDR RECORD IF REQUESTED                                        01400000
      TCNT = TCNT + 1                                                   01400117
      WRITE(6,*) 'TCNT,EDR(3) = ',TCNT,EDR(3)                           01400219
      IF (TCNT .NE. EDRDEL) GO TO 25                                    01410017
          WRITE (6,20) EDRDEL                                           01410110
   20     FORMAT (' EDR RECORD',I11,' BYPASSED BY REQUEST')             01410210
          GO TO 5                                                       01410310
   25 CONTINUE                                                          01410410
      CALL TSET(EDR(5),ERT)                                             01410503
      CALL TSET(EDR(13), SCET)                                          01410603
      OWLT = ERT - SCET                                                 01410702
      IF (FIRST .OR. (EDRRAT .EQ. 9999.)) GO TO 35                      01410815
      IF (OWLT.GT.0.D0.AND.DABS(1.D0-OWLT/OWLTP).LT. EDRRAT) GO TO 35   01410906
      WRITE (6, 32) EDR(3), EDRRAT                                      01411008
C      WRITE (6, 32) EDR(3), EDRRAT, OWLTP, OWLT,ERT, SCET              01411109
   32 FORMAT (' EDR RECORD',I11,' BYPASSED DUE TO OWLT - LIM=',F5.3)    01411209
C     1                          ' OWLTP =',E13.6,/,                    01411305
C     2                          ' OWLT  =',E13.6,/,                    01411405
C     3                          ' ERT   =',E13.6,/,                    01411505
C     4                          ' SCET  =',E13.6)                      01411605
      GO TO 30                                                          01411702
   35 CONTINUE                                                          01411802
      OWLTP = OWLT                                                      01411905
      FIRST = .FALSE.                                                   01412002
C EXTRACT FDSC FROM EDR RECORD AND RETURN                               01420000
      CALL FDSCNT (EDR,FDSEDR)                                          01430000
      RETURN                                                            01440000
   40 CONTINUE                                                          01450000
C WRITE MESSAGE WHEN I/O ERROR OCCURS, THEN READ A NEW EDR RECORD.      01460000
      WRITE (6,50)                                                      01470000
   50 FORMAT (' I/O ERROR READING UNIT 10')                             01480000
      GO TO 30                                                          01490000
   60 CONTINUE                                                          01500000
C END OF FILE RETURN                                                    01510000
      RETURN 1                                                          01520000
      END                                                               01530000
      SUBROUTINE RDPB (PB,BYTPB,FDSPB,PBRAT,*)                          01540006
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC01550000
C                                                                       01560000
C THIS ROUTINE PERFORMS THE FOLLOWING:                                  01570000
C   (1) READ PB RECORD FROM UNIT 20 (FT20F001)                          01580000
C   (2) RECORDS ARE BYPASSED ,AS REQUESTED VIA UNIT 21 (FT21F001)       01590000
C        IF ONE NUMBER IS INPUT, THAT RECORD IS PYPASSED                01591001
C        IF TWO NUMBERS ARE INPUT, THE RANGE OF RECORDS IS BYPASSED     01592001
C   (3) FDS COUNTS ARE EXTRACTED FROM THE RECORD                        01600000
C                                                                       01610000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC01620000
      REAL*8 ERT, SCET, OWLT, OWLTP, PBRAT                              01621006
      INTEGER*2 PB(6000),FDSPB(3),PBDEL, LIM/0/                         01630001
      LOGICAL*1 FIRST /.TRUE./                                          01640000
      IF (.NOT. FIRST) GO TO 30                                         01650000
    5 CONTINUE                                                          01670000
C READ THE NUMBER OF THE PB RECORD (OR RANGE OF RECORDS) TO BE BYPASSED.01680001
C IF 0, NO RECORDS WILL BE BYPASSED.                                    01690000
      IF (LIM .EQ. 0) GO TO 7                                           01691001
      PBDEL = PBDEL + 1                                                 01691101
      IF (PBDEL .LE. LIM) GO TO 30                                      01692010
    7 CONTINUE                                                          01693001
      READ (21,10) PBDEL, LIM                                           01700001
   10 FORMAT (2I10)                                                     01710001
   30 CONTINUE                                                          01740000
C READ PB RECORD                                                        01750000
      CALL FREAD (PB,20,BYTPB,&60,&40)                                  01760000
C BYPASS PB RECORD IF REQUESTED                                         01770000
      IF (PB(3) .NE. PBDEL) GO TO 25                                    01780010
          WRITE (6,20) PBDEL                                            01780110
   20     FORMAT (' PB RECORD',I11,' BYPASSED BY REQUEST')              01780210
          GO TO 5                                                       01780310
   25 CONTINUE                                                          01780410
      CALL TSET(PB(5),ERT)                                              01781003
      CALL TSET(PB(13), SCET)                                           01782003
      OWLT = ERT - SCET                                                 01784002
      IF (FIRST .OR. (PBRAT .EQ. 9999.)) GO TO 35                       01785015
      IF (OWLT.GT.0.D0.AND.DABS(1.D0-OWLT/OWLTP).LT. PBRAT) GO TO 35    01786006
      WRITE (6, 32) PB(3), PBRAT                                        01787015
C      WRITE (6, 32) PB(3), PBRAT, OWLTP, OWLT, ERT, SCET               01787115
   32 FORMAT (' PB RECORD',I11,' BYPASSED DUE TO OWLT LIM =',F5.3)      01788015
C     1                       5X,' OWLTP =',E13.6,/,                    01788115
C     2                       5X,' OWLT  =',E13.6,/,                    01788215
C     3                       5X,' ERT   =',E13.6,/,                    01788315
C     4                       5X,' SCET  =',E13.6)                      01788415
      GO TO 30                                                          01789002
   35 CONTINUE                                                          01789102
      OWLTP = OWLT                                                      01789205
      FIRST = .FALSE.                                                   01789302
C EXTRACT FDSC FROM PB RECORD AND RETURN                                01790000
      CALL FDSCNT (PB,FDSPB)                                            01800000
      RETURN                                                            01810000
   40 CONTINUE                                                          01820000
C WRITE MESSAGE WHEN I/O ERROR OCCURS, THEN READ THE NEXT PB RECORD     01830000
      WRITE (6,50)                                                      01840000
   50 FORMAT (' I/O ERROR READING UNIT 20')                             01850000
      GO TO 30                                                          01860000
   60 CONTINUE                                                          01870000
C END OF FILE RETURN                                                    01880000
      RETURN 1                                                          01890000
      END                                                               01900000
      SUBROUTINE FDSCNT (EDREC,FDSC)                                    01910000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC01920000
C                                                                       01930000
C THIS SUBROUTINE EXTRACTS FDS COUNTS FROM EDR RECORDS                  01940000
C                                                                       01950000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC01960000
      INTEGER*2 EDREC(6000),RECORD(20),FDSC(3),NFDSC                    01970000
      LOGICAL*1 LREC(12000),MOD60(2)                                    01980000
      EQUIVALENCE (LREC(1),RECORD(1)),(MOD60(1),NFDSC)                  01990000
      CALL FMOVE (RECORD,40,EDREC)                                      02000000
      FDSC(1) = RECORD(17)                                              02010000
      NFDSC = 0                                                         02020000
      CALL FMOVE (MOD60(2),1,RECORD(18))                                02030000
      FDSC(2) = NFDSC                                                   02040000
      CALL FMOVE (FDSC(3),2,LREC(36))                                   02050000
      RETURN                                                            02060000
      END                                                               02070000
      SUBROUTINE TSET(EDR,TIME)                                         02080002
C     **********  =U2DRH.TSET  **********                               02090002
      INTEGER*2 EDR(3)                                                  02100004
      REAL*8 TIME                                                       02110002
C                                                                       02120002
      IHY = EDR(1)                                                      02140004
      ISEC = EDR(2)                                                     02150004
      MS = EDR(3)                                                       02160004
      MSEC = (MOD(IHY,24)*3600 + ISEC)*1000 + MS                        02170002
      IDAY = IHY/24                                                     02180002
      TIME = (IDAY-1) + MSEC/86400.0D3                                  02190002
      RETURN                                                            02200002
      END                                                               02210002
      CHARACTER BUFIN(100000)                                           00010045
      CHARACTER*1 M/'M'/,J/'J'/,S/'S'/,E2/ZE2/                          00020044
                                                                        00020144
      LOGICAL FIRST/.TRUE./                                             00021014
      INTEGER IN, OUT/1/, NBIN, NBOUT/0/, NREC/0/,TOTBYTES              00030040
      INTEGER TCNT/0/                                                   00031044
   10 CONTINUE                                                          00040000
      CALL FREAD (BUFIN, 10, NBIN, &50, &50)                            00050044
      TCNT = TCNT + 1                                                   00050144
C     IF ((TCNT .LT. 1292).OR.(TCNT .GT. 1482))                         00050252
C    1  CALL FWRITE(BUFIN,20,NBIN)                                      00050352
      IF (BUFIN(4) .EQ. E2) WRITE(6,*) 'E2 FOUND '                      00051051
      IF (BUFIN(4) .NE. E2) CALL FWRITE(BUFIN,20,NBIN)                  00060051
      IF ((TCNT .NE. 1).AND.(TCNT .NE. 2)) WRITE(6,*) 'TCNT = ',TCNT    00070051
      GO TO 10                                                          00290043
   50 CONTINUE                                                          00300001
      STOP                                                              00340001
      END                                                               00350001
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   00010000
C                                                                       00020000
C                                                                       00062000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC  00070000
      INTEGER*4 ADDR(2), LPYR/0/, ISW/0/,                               00071012
     1    IYR1, IDAY1, IHOUR1,                                          00072001
     2    IYR2, IDAY2, IHOUR2,                                          00073015
     3     ZERON(10,6)                                                  00074015
      REAL*4 ZERO1(10,6),                                               00080015
     1       ZERO2(10,6)                                                00090015
      REAL*8 NAME1, NAME2, NAME(2)/2*'NONAME  '/                        00100012
      CHARACTER*8 TABLE                                                 00100125
      CHARACTER*80 LINE                                                 00100225
      EQUIVALENCE (TABLE,NAME1)                                         00100325
      EXTERNAL ZEROLD                                                   00101000
C READ NAMES AND TIMES OF ZERO TABLES (TIMES ARE THE TIMES              00102000
C OF THE ROLL/MANEUVER FROM WHICH THIS TABLE WAS DERIVED)               00103000
      READ(5,10)  ISC                                                   00104023
      WRITE(6,10) ISC                                                   00105023
      DO I = 1,6                                                        00106025
  44  CONTINUE                                                          00107025
        READ (10,11,ERR=44) LINE                                        00110025
      END DO                                                            00110125
      DO WHILE (.TRUE.)                                                 00110225
C     READ (10,11) NUM, NAME1, IYR1, IDAY1, IHOUR1                      00110325
C     WRITE(6,11) NUM, NAME1, IYR1, IDAY1, IHOUR1                       00111025
      READ (10,11) NUM, NAME2, IYR2, IDAY2, IHOUR2                      00120025
      WRITE(6,11) NUM,NAME2, IYR2, IDAY2, IHOUR2                        00120125
   10 FORMAT(I1)                                                        00121023
   11 FORMAT (2X,I4,3X,A8,1X,I4,1X,I3,1X,I2)                            00130025
C     WRITE (6,20) ISC, NAME1, IYR1, IDAY1, IHOUR1,                     00140025
C    1             NAME2, IYR2, IDAY2, IHOUR2                           00150025
C  20 FORMAT (' SC = ',I1,2(/,1X, A8, 5X, 3I4))                         00160025
C READ IN ZERO LEVELS OF FIRST TABLE                                    00161000
C     CALL LOADER (NAME1, NAME(1), ADDR(1), &200, &200)                 00170025
C     ADDR(1) = ADDR(1) + 8                                             00171025
C     CALL LINK (ADDR(1), ZERO1, ZEROLD)                                00172025
C READ IN ZERO LEVELS OF SECOND TABLE                                   00173000
      CALL LOADER (NAME2, NAME(1), ADDR, &300, &300)                    00174025
      ADDR(1) = ADDR(1) + 8                                             00175025
      CALL LINK (ADDR(1), ZERO2, ZEROLD)                                00176025
C     IF(MOD(IYR1,4).EQ.0) LPYR=1                                       00177024
C     IF(IYR1.NE.IYR2)ISW=1                                             00178024
C     IYRST = IYR1                                                      00178124
C     IDAYST = IDAY1 + 1                                                00179024
C  23 CONTINUE                                                          00179124
C     IF (MOD(IDAYST,5) .EQ. 1) GO TO 27                                00179224
C         IDAYST = IDAYST + 1                                           00179324
C         GO TO 23                                                      00179424
C  27 CONTINUE                                                          00179524
C     IF (IDAYST .LT. 365) GO TO 30                                     00179624
C         IYRST = IYRST + 1                                             00179724
C         IDAYST = 1                                                    00179824
C  30 CONTINUE                                                          00179924
C     IYREN = IYR2                                                      00180024
C     IDAYEN = IDAY2                                                    00180124
C  33 CONTINUE                                                          00180224
C     IF (MOD(IDAYEN,5) .EQ. 1)  GO TO 37                               00180324
C         IDAYEN = IDAYEN - 1                                           00180424
C         GO TO 33                                                      00180524
C  37 CONTINUE                                                          00180624
C     IDAYEN = IDAYEN - 5                                               00180724
C     IF (IDAYEN .GT. 0) GO TO 40                                       00180824
C         IYREN = IYREN - 1                                             00180924
C         IDAYEN = 361                                                  00181024
C  40 CONTINUE                                                          00181124
C     CALL DELDAY (IYR1, IDAY1, IHOUR1, IYR2, IDAY2, IHOUR2, DAYROL)    00181224
C     IYRN = IYRST                                                      00181524
C     IDAYN = IDAYST                                                    00181624
C  50 CONTINUE                                                          00181724
C     CALL DELDAY (IYR1, IDAY1, IHOUR1, IYRN, IDAYN + 2, 12, DAY)       00181824
      DO 60 I = 1, 10                                                   00182101
      DO 60 J = 1, 6                                                    00182201
          ZERON(I, J) = ZERO2(I,J)                                      00182325
   60 CONTINUE                                                          00182525
      WRITE (6,70) IYRN, IDAYN,ISC,ISC, IYRN, IDAYN, ZERON              00182624
   70 FORMAT('F',I2,I3,'Z',I1,' CSECT   FLIGHT ',I1,' 19',              00182709
     1       I2,' DAY ',I3,/,9X,'GENDATE'/,                             00182809
     2        'XI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00182901
     3             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183001
     4        'YI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183101
     5             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183201
     6        'ZI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183301
     7             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183401
     8        'XO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183501
     9             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183601
     A        'YO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183701
     B             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183801
     C        'ZO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183901
     D             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00184001
     E             T10,'END')                                           00184101
      END DO                                                            00184225
C     IDAYN = IDAYN + 5                                                 00184324
C     IF (IDAYN .LT. 365) GO TO 80                                      00184424
C         IYRN = IYRN + 1                                               00184524
C         IDAYN = 1                                                     00184624
C  80 CONTINUE                                                          00184724
C     IF ((IYRN .EQ. IYREN) .AND. (IDAYN .GT. IDAYEN)) GO TO 400        00184824
C     GO TO 50                                                          00184924
  200 CONTINUE                                                          00185000
      WRITE (6, 210) NAME1                                              00190023
  210 FORMAT (' ERROR READING ', A8)                                    00200000
      GO TO 400                                                         00201000
  300 CONTINUE                                                          00210000
      WRITE (6, 310) NAME2                                              00220023
  310 FORMAT (' ERROR READING ', A8)                                    00230000
  400 CONTINUE                                                          00240000
      STOP                                                              00250000
      END                                                               00260000
      SUBROUTINE ZEROLD (TABIN, TABOUT)                                 00270001
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00280000
C                                                                       00290000
C THIS SUBROUTINE MOVES THE 0 TABLE VALUES INTO                         00300001
C A LOCAL ARRAY FROM THE CALLING PROGRAM                                00310000
C                                                                       00320000
C                                                                       00380000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00390000
      REAL*4 TABIN(10,6), TABOUT(10,6)                                  00400015
      DO 20 IRNG=1, 10                                                  00420001
          DO 10 ICOORD=1, 6                                             00430001
              TABOUT(IRNG, ICOORD) = TABIN(IRNG, ICOORD)                00450001
   10     CONTINUE                                                      00460000
   20 CONTINUE                                                          00470000
      RETURN                                                            00480000
      END                                                               00490000
      SUBROUTINE DELDAY (IYR1, IDAY1, IHOUR1,                           00500002
     1                   IYR2, IDAY2, IHOUR2, DAYS)                     00510002
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC    00520002
C                                                                       00530002
C PURPOSE: THIS SUBROUTINE CALCULATES THE NUMBER OF DAYS (INCLUDING     00540002
C     FRACTION) BETWEEN TIMES 1 AND 2.                                  00550002
C                                                                       00560002
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   00570002
      IF(MOD(IYR1,4).EQ.0) LPYR=1                                       00580002
      IF(IYR1.NE.IYR2)ISW=1                                             00590002
      DAY1 = FLOAT(IDAY1) + FLOAT(IHOUR1) / 24.                         00600003
      DAY2 = FLOAT(IDAY2) + FLOAT(IHOUR2) / 24.                         00610003
      IF (IYR1.NE.IYR2) DAY2 = DAY2 + 365. + LPYR                       00620002
      DAYS = DAY2 - DAY1                                                00630002
      RETURN                                                            00640002
      END                                                               00650002
      SUBROUTINE HEAD (SEDREC)                                          00010006
      WRITE (6,10)                                                      00020033
   10 FORMAT ('   READ HEADER RECORD')                                  00030033
      RETURN                                                            00140006
      END                                                               00150006
      SUBROUTINE NAV (ISDREC, RSDREC, NAVBYT)                           00160010
      INTEGER*4 ISDREC(1)                                               00170013
      REAL*4 RSDREC(1)                                                  00180025
      WRITE (6,10) (ISDREC(I),I=1,6)                                    00190046
   10 FORMAT (1X,'NAV ',4X,I4,'/',I3,':',I2,':',I2,':',I2,'.',I3)       00200046
C      WRITE (6,10) (ISDREC(I),I=1,6),RSDREC(55),RSDREC(56),RSDREC(57)  00210046
C   10 FORMAT (1X,'NAV ',4X,I4,'/',I3,':',I2,':',I2,':',I2,'.',I3,5X,   00230046
C     13(2X,F13.1))                                                     00230146
C     RDIST = RSDREC(155) / 24765.                                      00231060
C      WRITE (6,20) (ISDREC(I),I=1,5), RDIST, RSDREC(143),              00240060
C    1              RSDREC(144)                                         00241060
C  20 FORMAT (I6,4I4,F14.3,2F10.3)                                      00250060
      RETURN                                                            00260006
      END                                                               00270006
      SUBROUTINE PV(ISDREC, RSDREC)                                     00280010
      INTEGER*4 ISDREC(1)                                               00280110
      REAL*4 RSDREC(1)                                                  00280210
C     WRITE (6,10) (ISDREC(I),I=1,6)                                    00280358
C  10 FORMAT (5X,'PV ',1X,I4,'/',I3,':',I2,':',I2,':',I2,'.',I3)        00281158
      WRITE (6,10) (ISDREC(I),I=1,6), (RSDREC(J),J=12, 20)              00281358
   10 FORMAT (5X,'PV ',1X,I4,'/',I3,':',I2,':',I2,':',I2,'.',I3,/       00282058
     1        9X, 3(2X,F7.4),/,                                         00283058
     1        9X, 3(2X,F7.4),/,                                         00284058
     1        9X, 3(2X,F7.4))                                           00285058
C      WRITE (6,10) (ISDREC(I),I=1,6),ISDREC(8)                         00286053
C   10 FORMAT (5X,'PV ',1X,I4,'/',I3,':',I2,':',I2,':',I2,'.',I3,       00287053
C     1        ' MOD60 =',I12)                                          00288053
C      DO 20 I=1,126                                                    00289056
C          IF (ISDREC(I).NE.0) WRITE(6,30)ISDREC(I),ISDREC(I),ISDREC(I) 00289156
C   30     FORMAT (5X,'WORD ',I4,2X,,F9.7,2X,Z8)                        00289256
C   20 CONTINUE                                                         00289356
      RETURN                                                            00290006
      END                                                               00300006
C                      *************************************************00010000
C                      *             IMP- J  MAGNETIC FIELD            *00020000
C                      *          ZERO LEVEL PROCESSING PROGRAM        *00030000
C                      *************************************************00040000
      DIMENSION IFILE(25),DATA(1251),IDATA(1251)                        00050000
      EQUIVALENCE (DATA(1),IDATA(1))                                    00060000
      DIMENSION CAL1(3),CAL2(3),CAL3(3)                                 00070000
      DIMENSION SEN1(3),SEN2(3),SEN3(3)                                 00080000
      DIMENSION VOLSER(2)                                               00090000
      COMMON CAL1,CAL2,CAL3,SEN1,SEN2,SEN3                              00100000
      COMMON /MARKER/ KBEG,MBEG,KEND,MEND,NPTS                          00110000
      COMMON /QULTY/ FKAY,RMS0                                          00120000
      DIMENSION NEXT(4),IDEL(4)                                         00130000
      INTEGER*4 EXF(64),SHFTR                                           00140000
      DATA ILO/' LO '/,IHI/' HI '/,IBLANK/'    '/                       00150000
      DATA ID1/' D1 '/, ID3/'D3  '/                                     00160000
      DATA ISAT/'0100'/                                                 00170000
C                                                                       00180000
C        IMP-J WAS LAUNCHED  25 OCT 73  (DAY 298)                       00190000
C        IMP-J ACHIEVED ORBIT ON  ????                                  00200000
C        IMP-J NOMINAL ORBIT PERIOD IS  ????                            00210000
C                                                                       00220000
C                                                                       00230000
C        COMMENTS ON THIS PROGRAM                                       00240000
C    P1. PROCESSES IMP-J MAGNETIC FIELD EXPERIMENTER TAPES.             00250000
C    P2. COMPUTES AND PUBLISHES MAGNETOMETER ZERO LEVELS, ELECTRICAL    00260000
C        PHASES, AND SPATIAL ANGLES, BASED ON LEAST SQUARES FIT OF      00270000
C        TRIGONOMETRIC POLYNOMIAL TO SPIN MODULATED DATA.               00280000
C    P3. PROGRAM COMPUTES AND PUBLISHES SPIN-AXIS-FIELD DEPENDENCE OF   00290000
C        SPIN-PLANE MAGNETOMETER ZERO LEVELS, BASED ON LEAST SQUARES FIT00300000
C        OF STRAIGHT LINE TO ALL COMPUTED SPIN-PLANE ZERO LEVELS WHICH  00310000
C        SURVIVE EDITING.                                               00320000
C    P4. ZERO LEVELS AT RANGE  I  ARE COMPUTED EVERY  IDEL(I)  SEQUENCES00330000
C        WHERE  I=1,2,3  INDICATES RANGES  12, 36, 108  GAMMAS RESP.    00340000
C    P5. PROCESSES FULL-WORD MAGNETOMETER COUNTS ONLY (4 VALUES/SEQUENCE00350000
C        FROM EACH OF THE  3  SENSORS).  HENCE THE MAGNETOMETER DATA IS 00360000
C        SAMPLED APPROXIMATELY  4  TIMES PER SATELLITE REVOLUTION (SEE  00370000
C        COMMENT  E5)                                                   00380000
C    P6. NPTS = NUMBER OF DATA POINTS USED IN TRIG FITS                 00390000
C             = NUMBER OF COMPONENTS IN A "DATA VECTOR".                00400000
C    P7. MAGNETOMETER COUNTS RANGE FROM  0  TO  255 .  IN ORDER TO      00410000
C        DELETE SATURATED SIGNALS, ONLY DATA VECTORS HAVING COMPONENTS  00420000
C        SATISFYING  5 .LE. COUNTS .LE. 250 ARE FITTED FOR ZERO LEVELS. 00430000
C        (CLELL 17 OCT 72)                                              00440000
C    P8. SUBROUTINE  RICHRD  READS EXPERIMENTER TAPE.                   00450000
C        CALL RICHRD(DS,ARRAY,VOLSER,END DS, EOF, END TAPE,ERR)         00460000
C             (RICHRD WRITTEN BY D. HOWELL, JAN 73)                     00470000
C                                                                       00480000
C        COMMENTS ON IMP-J EXPERIMENTER TAPES                           00490000
C    T1. NO PARTIAL SEQUENCES (A SEQUENCE IS EITHER FULL OR FILL)       00500000
C    T2. SEQUENCE DATA QUALITY FLAGS=2 IMPLIES FILL SEQUENCE            00510000
C    T3. FILL DATA --> ALL BITS ZERO                                    00520000
C    T4. END TAPE CONSISTS OF TWO CONTIGUOUS END-OF-FILE MARKS          00530000
C    T5. ONE DATA RECORD CONTAINS  64  SEQUENCES OF DATA, WHICH CONTAIN 00540000
C        A TOTAL OF  64X4=256  FULL MAGNETOMETER COUNTS FROM EACH OF    00550000
C        THE  3  SENSORS, X,Y,Z.                                        00560000
C    T6. ALL PAGES SPAN SAME TIME INTERVAL, NAMELY, INTERVAL SPANNED    00570000
C        BY  64  CONSECUTIVE SEQUENCES (NOMINALLY 64 X 128 = 8192 MSEC) 00580000
C        FILL SEQUENCES DO NOT INCREMENT PSEUDO-SEQUENCE COUNT (PSC),   00590000
C        SO PSC CANNOT BE USED TO COMPUTE SEQUENCE TIME.  THE POSITION  00600000
C        OF A SEQUENCE WITHIN THE PAGE DETERMINES SEQUENCE TIME.        00610000
C                                                                       00620000
C        COMMENTS ON IMP-J MAGNETIC FIELD EXPERIMENT                    00630000
C    E1. MAGNETOMETER FLIPS EVERY 46.6 HOURS                            00640000
C    E2. CALIBRATION EVERY 11.6 HOURS                                   00650000
C    E3. CALIBRATION FIELDS REMAIN ON FOR  4  SEQUENCES .               00660000
C    E4. THREE RANGES, PLUS-MINUS 12, 36, 108 GAMMAS                    00670000
C    E5. NOMINAL SPIN PERIOD = 23 RPM                                   00680000
C                            = 1 REV/2.618 SECONDS                      00690000
C    E6. NOMINAL SEQUENCE PERIOD = 1.28 SECONDS                         00700000
C                                                                       00710000
C                                                                       00720000
      NUNIT=4                                                           00730000
      CALL KTIME(IY,ID,IH,IM,I)                                         00740000
      WRITE(8,8888)                                                     00750000
 8888 FORMAT(1H1,//10X,'IMP-J CALIBRATION DATA')                        00760000
      WRITE(8,3) ID,IY,IH,IM                                            00770000
      WRITE(6,1)                                                        00780000
    1 FORMAT(1H1////                                                    00790000
     C/10X,' **************************************'                    00800000
     C/10X,' * IMP  J  MAGNETIC FIELD EXPERIMENT  *'                    00810000
     C/10X,' *   ZERO LEVEL PROCESSING PROGRAM    *'                    00820000
     C/10X,' **************************************')                   00830000
      WRITE(6,3) ID,IY,IH,IM                                            00840000
    3 FORMAT(/10X,'PROCESSED ON DAY'I4,' OF YEAR'I5,' AT'I3,' HOURS,'I3,00850000
     C     ' MIN.'/)                                                    00860000
C                                                                       00870000
C                                                                       00880000
C          READ AND WRITE DATA CARDS                                    00890000
C                                                                       00900000
      WRITE(6,12)                                                       00910000
   12 FORMAT(//5X,'THE FOLLOWING VALUES (INITFI  THROUGH  RMS0) ARE TAKE00920000
     CN FROM DATA CARDS'/)                                              00930000
      READ(5,6) INITFI,LASTFI                                           00940000
    6 FORMAT(2I5)                                                       00950000
      WRITE(6,8) INITFI,LASTFI                                          00960000
    8 FORMAT(/10X,'INITFI=' I4,' LASTFI=' I4,'  ALL FILES BETWEEN FILE N00970000
     CUMBERS  INITFI  AND  LASTFI  ARE PROCESSED')                      00980000
      READ(5,26) (CAL1(I),I=1,3),(CAL2(I),I=1,3),(CAL3(I),I=1,3)        00990000
   26 FORMAT(3F10.1)                                                    01000000
      WRITE(6,27) (CAL1(I),I=1,3),(CAL2(I),I=1,3),(CAL3(I),I=1,3)       01010000
   27 FORMAT(//10X,'REFERENCE MAGNETOMETER CALIBRATION FIELDS'          01020000
     C           ,' (GAMMAS)'                                           01030000
     C        /10X,' RANGE       12       36      108'                  01040000
     C        /10X,'SENSOR'                                             01050000
     C        /10X,'    D1 '3F9.2                                       01060000
     C        /10X,'    D2 '3F9.2                                       01070000
     C        /10X,'    D3 '3F9.2 )                                     01080000
      READ(5,26)(SEN1(I),I=1,3),(SEN2(I),I=1,3),(SEN3(I),I=1,3)         01090000
      WRITE(6,7)(SEN1(I),I=1,3),(SEN2(I),I=1,3),(SEN3(I),I=1,3)         01100000
    7 FORMAT(//10X,'REFERENCE MAGNETOMETER SENSITIVITIES (GAMMAS/COUNT)'01110000
     C        /10X,' RANGE       12       36      108'                  01120000
     C        /10X,'SENSOR'                                             01130000
     C        /10X,'    D1'3F9.5                                        01140000
     C        /10X,'    D2'3F9.5                                        01150000
     C        /10X,'    D3'3F9.5   )                                    01160000
      READ(5,2) (IDEL(I),I=1,3)                                         01170000
    2 FORMAT(8I10)                                                      01180000
      WRITE(6,5) (IDEL(I),I=1,3)                                        01190000
    5 FORMAT(//10X,' NUMBER OF SEQUENCES BETWEEN ZERO LEVEL COMPUTATIONS01200000
     C'       /10X,' RANGE   PARAMETER   VALUE'                         01210000
     C        /10X,'    12     IDEL(1)' I8                              01220000
     C        /10X,'    36     IDEL(2)' I8                              01230000
     C        /10X,'   108     IDEL(3)' I8 )                            01240000
      READ(5,6) NPTS,NUMSEQ                                             01250000
      IF(NPTS .LT. 30  .OR.  NPTS .GT. 250) NPTS=60                     01260000
      IF(NUMSEQ .LT. 8  .OR.  NUMSEQ .GT. 60) NUMSEQ=14                 01270000
      WRITE(6,10) NPTS,NUMSEQ                                           01280000
   10 FORMAT(//10X,'NPTS ='I4,' = NUMBER OF DATA POINTS USED IN LEAST SQ01290000
     CUARES TRIG FITS.'/23X,'(PROGRAM ENFORCES  30 .LE. NPTS .LE. 250)' 01300000
     C//9X,'NUMSEQ='I4,' = NUMBER OF UNCALIBRATED SEQUENCES USED TO PROC01310000
     CESS CALIBRATION DATA.  NUMSEQ SHOULD BE EVEN.'                    01320000
     C/ 23X,'(PROGRAM ENFORCES  8 .LE. NUMSEQ .LE. 60 ,  DEFAULT NUMSEQ 01330000
     C = 14)')                                                          01340000
      NPTS1=NPTS+1                                                      01350000
      READ(5,26) FKAY,RMS0                                              01360000
      WRITE(6,4) FKAY,RMS0                                              01370000
    4 FORMAT(//10X,'COMPUTATIONS IN LINFIT USE FORMULA'                 01380000
     C        /10X,'QUALITY=2.0*FKAY*SQRT(LINPT)*STDEV/(RMS0+RMSE)'     01390000
     C        /13X,'FKAY='F10.4 /13X,'RMS0='F10.4)                      01400000
C                                                                       01410000
C          INITIALIZE COUNTERS AND CONSTANTS                            01420000
C                                                                       01430000
      NFILE=0                                                           01440000
      NUMREC=0                                                          01450000
      NEXT(1)=0                                                         01460000
      NEXT(2)=0                                                         01470000
      NEXT(3)=0                                                         01480000
      AVSPIN=0.0                                                        01490000
      KSPIN=0                                                           01500000
      LASCAL=0                                                          01510000
      KYR1=0                                                            01520000
      KYR2=0                                                            01530000
      START=0.0                                                         01540000
       STOP=0.0                                                         01550000
C                                                                       01560000
C                                                                       01570000
C          READ 1ST FILE HEADER RECORD                                  01580000
      CALL RICHRD('IMPJDATA',DATA,VOLSER,&999,&90,&102,&90)             01590000
      WRITE(6,91) VOLSER                                                01600000
   91 FORMAT(/' VOL=SER=' A4,A2)                                        01610000
      VOL1=VOLSER(1)                                                    01620000
      VOL2=VOLSER(2)                                                    01630000
C                                                                       01640000
C          INITIALIZE FILE SUMMARY REPORT                               01650000
C                                                                       01660000
      WRITE(3,1000) VOLSER(1),VOLSER(2),ID,IY,IH,IM                     01670000
 1000 FORMAT(1H1///10X,'IMP- J  MAGNETIC FIELD EXPERIMENT'              01680000
     C      '   ZERO LEVEL PROGRAM'                                     01690000
     C  //10X,'FILE SUMMARY OF EXPERIMENTER TAPE, VOL=SER=' A4,A2,      01700000
     C//10X,'PROCESSED ON DAY'I4,' OF YEAR'I5,' AT'I3,' HOURS,'I3,      01710000
     C    ' MIN.'//                                                     01720000
     C/' FILE PER-  **** FILE START TIME ******'                        01730000
     C      '  ***** FILE STOP TIME ******'                             01740000
     C '  SEQ  REC'                                                     01750000
     C '  AVG   BIT     FLIP NUM  PROC'                                 01760000
     C/' NUM  IGEE  YR DDA  HR   MIN  PSEUDOSEQ'                        01770000
     C      '  YR DDA  HR   MIN  PSEUDOSEQ'                             01780000
     C '  LAP  STA'                                                     01790000
     C ' SPIN  RATE CAL STAT REC  TIME')                                01800000
      GO TO 94                                                          01810000
C                                                                       01820000
C                                                                       01830000
   90 CONTINUE                                                          01840000
C                                                                       01850000
C          PUBLISH SUMMARY OF PRECEEDING FILE                           01860000
C                                                                       01870000
      CALL FTIMOT(T)                                                    01880000
      J=0                                                               01890000
      IF(KSPIN .GT. 0) J=0.5 + AVSPIN/KSPIN                             01900000
      AVSPIN=0.0                                                        01910000
      KSPIN=0                                                           01920000
C          CONVERT DAY TO 'DECIMAL DAY'                                 01930000
      IDA1=IDA1-1                                                       01940000
      IDA2=IDA2-1                                                       01950000
      IF(MOD(NFILE,50) .EQ. 0)                                          01960000
     C                 WRITE(3,1000) VOLSER(1),VOLSER(2),ID,IY,IH,IM    01970000
      WRITE(3,2000) NFILE,IFILE(17),IYR1,IDA1,IHR1,FMN1,IPS1,           01980000
     C   IYR2,IDA2,IHR2,FMN2,IPS2,LAP,                                  01990000
     C  IFILE(2),                                                       02000000
     C            J,IRATE1,IRATE2,ICAL,KD1,KD3,KRECRD,T                 02010000
 2000 FORMAT(I4,1X,I4,1X, 3I4,F7.2,I10,1X, 3I4,F7.2,I10,1X,I5,          02020000
     C    I5,               I6,2A3,A4,A3,A2,I4,1X,F6.2)                 02030000
      NUMREC=NUMREC+KRECRD                                              02040000
C                                                                       02050000
   94 CONTINUE                                                          02060000
C          FILE HEADER RECORD HAS EITHER JUST BEEN READ BY FIRST        02070000
C          CALL TO RICHRD, OR WHEN PRECEEDING EOF WAS READ.             02080000
C          SAVE FILE HEADER INFORMATION.                                02090000
      DO 95 I=1,25                                                      02100000
   95 IFILE(I)=IDATA(I)                                                 02110000
      IRATE1=IBLANK                                                     02120000
      IRATE2=IBLANK                                                     02130000
      ICAL=IBLANK                                                       02140000
      KD1=IBLANK                                                        02150000
      KD3=IBLANK                                                        02160000
      KALDEX=0                                                          02170000
      NFILE=NFILE+1                                                     02180000
C*****TEST*******TEST*******TEST*************TEST***********TEST********02190000
      WRITE(6,7777) NFILE                                               02200000
 7777 FORMAT(' FILE' I3)                                                02210000
C***********************************************************************02220000
      IF(NFILE .LT. INITFI) GO TO 98                                    02230000
      IF(NFILE .GT. LASTFI) GO TO 999                                   02240000
C                                                                       02250000
C          INITIALIZE PROCESSING TIMER                                  02260000
      CALL FTIMIN                                                       02270000
C                                                                       02280000
      GO TO 93                                                          02290000
C                                                                       02300000
C          SKIP A DATA FILE                                             02310000
C                                                                       02320000
   98 CONTINUE                                                          02330000
  104 CALL RICHRD('IMPJDATA',DATA,VOLSER,&999,&94,&94,&104)             02340000
      GO TO 104                                                         02350000
C                                                                       02360000
C          READ 1ST DATA RECORD IN THIS FILE (64 SEQUENCES)             02370000
   93 CONTINUE                                                          02380000
      CALL RICHRD('IMPJDATA',DATA,VOLSER,&999,&90,&102,&105)            02390000
      GO TO 107                                                         02400000
  105 WRITE(6,106) NFILE                                                02410000
  106 FORMAT( ' I/O ERR ON RECORD  1 OF FILE' I3)                       02420000
      GO TO 93                                                          02430000
  107 CONTINUE                                                          02440000
      KRECRD=1                                                          02450000
C          COMPUTE START TIME FOR THIS FILE                             02460000
      CALL BEGEND(IDATA,KBEG,MBEG,KEND,MEND)                            02470000
      IF(KBEG .EQ. 0) GO TO 93                                          02480000
      IYR1=IFILE(5) + 70                                                02490000
C CORRECTION ADDED 2/84 BY T.VOLLMER (GFSC), TO GIVE PROPER OUTPUT      02500000
C FOR YEARS 1980 - 1982.                                                02510000
      IF (IFILE(5) .LE. 2) IYR1 = IFILE(5) + 80                         02520000
C CORRECTION ADDED 2/84 BY T.VOLLMER (GSFC), TO GIVE PROPER OUTPUT      02530000
C FOR YEARS 1983 - 1989.  TO DETERMINE THE PROPER DECADE OF THE DATA,   02540000
C THE PERIGEE COUNT IS EXAMINED.  IF GREATER THAN 233 (APPROX. 10/82)   02550000
C IT IS THE 1980'S.                                                     02560002
      IF ((IFILE(5) .GE. 3) .AND. (IFILE(17) .GT. 233))                 02580000
     1     IYR1 = IFILE(5) + 80                                         02590000
C CORRECTION ADDED 5/9/90 BY T.VOLLMER(GSFC), TO GIVE PROPER OUTPUT     02591002
C FOR THE YEARS 1990-1999.  TO DETERMINE THE PROPER DECADE OF THE       02592002
C DATA, THE PERIGEE COUNT IS EXAMINED.  IF IT IS GREATER THAN           02593002
C 486 (APPROX 12/31/89 - 1/1/90) IT IS THE ROARING 1990'S.              02594002
C IF IMP LASTS TO 2000, THIS WILL HAVE TO BE DONE AGAIN.                02595002
      IF ((IFILE(5) .NE. 9) .AND. (IFILE(17) .GE. 486))                 02596002
     1       IYR1 = IFILE(5) + 90                                       02597002
      IF (IFILE(17) .GT. 486) IYR1 = IFILE(5) + 90                      02598002
      MPAGE=291*((KBEG-1)/16)                                           02600000
      IDA1=IDATA(MPAGE+1)                                               02610000
      NPAGE=MPAGE/291                                                   02620000
      ISEQ=KBEG - 16*NPAGE                                              02630000
      MSEC=IDATA(MPAGE+2) + 1280*(ISEQ-1)                               02640000
      IHR1=MSEC/3600000                                                 02650000
      FMN1=MOD(MSEC,3600000)/60000.0                                    02660000
      IPS1=IDATA(MBEG+3)                                                02670000
      IF(NFILE .EQ. 1) KYR1=IYR1                                        02680000
      IF(NFILE .EQ. 1) START=IDA1 - 1 + 60.0*(FMN1+60*IHR1)/86400.0     02690000
C                                                                       02700000
      IYR2=IFILE(8)+70                                                  02710000
C CORRECTION ADDED 2/84 BY T.VOLLMER (GFSC), TO GIVE PROPER OUTPUT      02720000
C FOR YEARS 1980 - 1982.                                                02730000
      IF (IFILE(8) .LE. 2) IYR2 = IFILE(5) + 80                         02740000
C CORRECTION ADDED 2/84 BY T.VOLLMER (GSFC), TO GIVE PROPER OUTPUT      02750000
C FOR YEARS 1983 - 1989.  TO DETERMINE THE PROPER DECADE OF THE DATA,   02760000
C THE PERIGEE COUNT IS EXAMINED.  IF GREATER THAN 233 (APPROX. 10/82)   02770000
C IT IS THE 1980'S.                                                     02780003
      IF ((IFILE(8) .GE. 3) .AND. (IFILE(17) .GT. 233))                 02800000
     1     IYR2 = IFILE(8) + 80                                         02810000
C CORRECTION ADDED 5/9/90 BY T.VOLLMER(GSFC), TO GIVE PROPER OUTPUT     02811003
C FOR THE YEARS 1990-1999.  TO DETERMINE THE PROPER DECADE OF THE       02812003
C DATA, THE PERIGEE COUNT IS EXAMINED.  IF IT IS GREATER THAN           02813003
C 486 (APPROX 12/31/89 - 1/1/90) IT IS THE ROARING 1990'S.              02814003
C IF IMP LASTS TO 2000, THIS WILL HAVE TO BE DONE AGAIN.                02815003
      IF ((IFILE(8) .NE. 9) .AND. (IFILE(17) .GE. 486))                 02816003
     1       IYR2 = IFILE(8) + 90                                       02817003
      IF (IFILE(17) .GT. 486) IYR2 = IFILE(8) + 90                      02818003
      MPAGE=291*((KEND-1)/16)                                           02820000
      IDA2=IDATA(MPAGE+1)                                               02830000
      NPAGE=MPAGE/291                                                   02840000
      ISEQ= KEND - 16*NPAGE                                             02850000
      MSEC=IDATA(MPAGE+2) + 1280*ISEQ                                   02860000
      IHR2=MSEC/3600000                                                 02870000
      FMN2=MOD(MSEC,3600000)/60000.0                                    02880000
      STOP=IDA2 - 1 + 60.0*(FMN2+60*IHR2)/86400.0                       02890000
      KYR2=IYR2                                                         02900000
C          COMPUTE NUMBER OF SEQUENCES IN FILE OVERLAP                  02910000
      IF(NFILE .GT. INITFI) GO TO 30                                    02920000
      LAP=0                                                             02930000
      GO TO 31                                                          02940000
   30 LAP=IPS2-IPS1                                                     02950000
      IF(IDATA(4) .EQ. 0) LAP=LAP/4                                     02960000
      LAP=LAP+1                                                         02970000
   31 CONTINUE                                                          02980000
      IPS2=IDATA(MEND+3)                                                02990000
C                                                                       03000000
      IF(IDATA(4) .EQ. 0) IRATE1=ILO                                    03010000
      IF(IDATA(4) .EQ. 1) IRATE2=IHI                                    03020000
      GO TO 101                                                         03030000
C                                                                       03040000
C          READ A DATA RECORD (64 SEQUENCES)                            03050000
C                                                                       03060000
  100 CALL RICHRD('IMPJDATA',DATA,VOLSER,&999,&90,&102,&108)            03070000
      GO TO 110                                                         03080000
C          END OF CURRENT TAPE                                          03090000
  102 CONTINUE                                                          03100000
      CALL FTIMOT(T)                                                    03110000
      J=0                                                               03120000
      IF(KSPIN .GT. 0) J=0.5 + AVSPIN/KSPIN                             03130000
      AVSPIN=0.0                                                        03140000
      KSPIN=0                                                           03150000
      IDA1=IDA1-1                                                       03160000
      IDA2=IDA2-1                                                       03170000
      WRITE(3,2000) NFILE,IFILE(17),IYR1,IDA1,IHR1,FMN1,IPS1,           03180000
     C   IYR2,IDA2,IHR2,FMN2,IPS2,LAP,IFILE(2),                         03190000
     C            J,IRATE1,IRATE2,ICAL,KD1,KD3,KRECRD,T                 03200000
      NUMREC=NUMREC + KRECRD                                            03210000
      WRITE(3,1001) NUMREC                                              03220000
      CALL KTIME(LY,LD,LH,LM,LS)                                        03230000
      PROC=((LS/100)+60*(LM+60*LH))/86400.0                             03240000
      PROC=LD - 1 + PROC                                                03250000
      WRITE(6,22) LY,PROC,IYR1,START,IYR2,STOP,IFILE(17),VOL1,VOL2,ISAT 03260000
      WRITE(20)   LY,PROC,IYR1,START,IYR2,STOP,IFILE(17),VOL1,VOL2,ISAT 03270000
   22 FORMAT(9X,' MARK IV'/' PROC YR  DDA     START YR  DDA      STOP YR03280000
     C DDA        ORB   TAPE     SAT'/3(I8,F8.3,2X),I5,2X,A4,A2,2X,A4//)03290000
      WRITE(3,1000) VOLSER,ID,IY,IH,IM                                  03300000
      WRITE(6,91) VOLSER                                                03310000
      KYR1=0                                                            03320000
      KYR2=0                                                            03330000
      START=0.0                                                         03340000
       STOP=0.0                                                         03350000
      VOL1=VOLSER(1)                                                    03360000
      VOL2=VOLSER(2)                                                    03370000
      NFILE=0                                                           03380000
      NUMREC=0                                                          03390000
      GO TO 94                                                          03400000
C                                                                       03410000
  108 WRITE(6,109) KRECRD,NFILE                                         03420000
  109 FORMAT(' I/O ERR ON RECORD'I3,' OF FILE'I3)                       03430000
      GO TO 100                                                         03440000
C                                                                       03450000
C          PROCESS CURRENT DATA RECORD                                  03460000
  110 CONTINUE                                                          03470000
      KRECRD=KRECRD+1                                                   03480000
      CALL OA(IDATA,SPIN,SEQ,AVSP)                                      03490000
      IF(SPIN .LT. 1.0) GO TO 111                                       03500000
      AVSPIN=AVSPIN + SPIN                                              03510000
      KSPIN = KSPIN + 1                                                 03520000
  111 CONTINUE                                                          03530000
C          COMPUTE STOP TIME FOR THIS FILE                              03540000
      CALL BEGEND(IDATA,KBEG,MBEG,KEND,MEND)                            03550000
      IF(KBEG .EQ. 0) GO TO 100                                         03560000
      MPAGE=291*((KEND-1)/16)                                           03570000
      IDA2=IDATA(MPAGE+1)                                               03580000
      NPAGE=MPAGE/291                                                   03590000
      ISEQ= KEND - 16*NPAGE                                             03600000
      MSEC=IDATA(MPAGE+2) + 1280*ISEQ                                   03610000
      IHR2=MSEC/3600000                                                 03620000
      FMN2=MOD(MSEC,3600000)/60000.0                                    03630000
      IPS2=IDATA(MEND+3)                                                03640000
      STOP=IDA2 - 1 + 60.0*(FMN2+60*IHR2)/86400.0                       03650000
  103 CONTINUE                                                          03660000
C                                                                       03670000
  101 CONTINUE                                                          03680000
C                                                                       03690000
C        THE FOLLOWING DO-LOOPS PROCESS THE 4 PAGES OF DATA IN CURRENT  03700000
C        RECORD.  (SEE IMP H DATA RECORD WORD MAP, R.F.T. OCT 72)       03710000
C        MPAGE POINTS TO WORD PRECEEDING 1ST WORD IN CURRENT PAGE       03720000
C        MSEQ  POINTS TO WORD PRECEEDING 1ST WORD IN CURRENT SEQUENCE   03730000
C                                                                       03740000
C        CHECK DATA RECORD FOR CALIBRATION SEQUENCE, FLIPPER POSITION,  03750000
C        AND BIT RATE                                                   03760000
      K=0                                                               03770000
      MPAGE=-291                                                        03780000
      DO 89 IPAGE=1,4                                                   03790000
      MPAGE=MPAGE + 291                                                 03800000
      MSEQ = MPAGE + 2                                                  03810000
      DO 89 ISEQ=1,16                                                   03820000
      K=K+1                                                             03830000
      IF(K .LT. KBEG) GO TO 87                                          03840000
      IF(K .GT. KEND) GO TO 86                                          03850000
      EXF(K)=SHFTR(IDATA(MSEQ+15),24)                                   03860000
      KON=EXF(K)                                                        03870000
      KCAL=KON/32                                                       03880000
      KCAL=MOD(KCAL,2)                                                  03890000
      IPSC=IDATA(MSEQ+3)                                                03900000
      IF(KCAL .EQ. 0  .AND.  IPSC .GT. LASCAL)                          03910000
     C      CALL CALI(K,ICAL,EXF,DATA,IDATA,NUMSEQ,MSEQ,LASCAL,IYR1)    03920000
      JD1=KON/4                                                         03930000
      JD1=MOD(JD1,2)                                                    03940000
      JD3=KON/8                                                         03950000
      JD3=MOD(JD3,2)                                                    03960000
      IF(JD1 .EQ. 1  .AND.  JD3 .EQ. 0) KD1=ID1                         03970000
      IF(JD3 .EQ. 1  .AND.  JD1 .EQ. 0) KD3=ID3                         03980000
      IF(IDATA(MSEQ+2) .EQ. 0) IRATE1=ILO                               03990000
      IF(IDATA(MSEQ+2) .EQ. 1) IRATE2=IHI                               04000000
   87 MSEQ=MSEQ + 15                                                    04010000
      IF(ISEQ .EQ. 8) MSEQ=MSEQ+3                                       04020000
   89 CONTINUE                                                          04030000
   86 CONTINUE                                                          04040000
C                                                                       04050000
C        COMPUTE KRGE=1,2,3 FOR RANGES 12, 36, 108 GAMMAS RESPECTIVELY  04060000
      KRB0=EXF(KBEG)/2                                                  04070000
      KRB0=MOD(KRB0,2)                                                  04080000
      KRB1=EXF(KBEG)                                                    04090000
      KRB1=MOD(KRB1,2)                                                  04100000
      KRGE=3 - KRB0 - 2*KRB1                                            04110000
      IF(KRGE .EQ. 0) KRGE=1                                            04120000
      IPSC=IDATA(MBEG + 3)                                              04130000
C                                                                       04140000
      IF(IPSC .GE. NEXT(KRGE))                                          04150000
     C  CALL ZERO(KRGE,IFILE,DATA,IDATA,EXF,NEXT,IDEL)                  04160000
C                                                                       04170000
C**** DO 99 I=1,2573                                                    04180000
      GO TO 100                                                         04190000
C          TERMINATE PROCESSING                                         04200000
  999 CONTINUE                                                          04210000
      CALL FTIMOT(T)                                                    04220000
      J=0                                                               04230000
      IF(KSPIN .GT. 0) J=0.5 + AVSPIN/KSPIN                             04240000
      IDA1=IDA1 - 1                                                     04250000
      IDA2=IDA2 - 1                                                     04260000
      WRITE(3,2000) NFILE,IFILE(17),IYR1,IDA1,IHR1,FMN1,IPS1,           04270000
     C   IYR2,IDA2,IHR2,FMN2,IPS2,LAP,IFILE(2),                         04280000
     C            J,IRATE1,IRATE2,ICAL,KD1,KD3,KRECRD,T                 04290000
      NUMREC=NUMREC + KRECRD                                            04300000
      WRITE(3,1001) NUMREC                                              04310000
 1001 FORMAT(/85X,'TOTAL RECORDS=' I6)                                  04320000
      CALL KTIME(LY,LD,LH,LM,LS)                                        04330000
      PROC=((LS/100)+60*(LM+60*LH))/86400.0                             04340000
      PROC=LD - 1 + PROC                                                04350000
      WRITE(6,22) LY,PROC,IYR1,START,IYR2,STOP,IFILE(17),VOL1,VOL2,ISAT 04360000
      WRITE(20)   LY,PROC,IYR1,START,IYR2,STOP,IFILE(17),VOL1,VOL2,ISAT 04370000
      IORB=IFILE(17)                                                    04380000
      CALL END ZRO(NPTS,ID,IY,IH,IM,IORB)                               04390000
      RETURN                                                            04400000
      END                                                               04410000
      SUBROUTINE ZERO(KRGE,IFILE,DATA,IDATA,EXF,NEXT,IDEL)              04420000
      DIMENSION IFILE(25),DATA(1),IDATA(1),NEXT(1),IDEL(1)              04430000
      INTEGER*4 EXF(120)                                                04440000
      DIMENSION CAL1(3),CAL2(3),CAL3(3)                                 04450000
      DIMENSION SEN1(3),SEN2(3),SEN3(3)                                 04460000
      COMMON CAL1,CAL2,CAL3,SEN1,SEN2,SEN3                              04470000
      COMMON /MARKER/ KBEG,MBEG,KEND,MEND,NPTS                          04480000
      COMMON /VECTOR/ Q2(250),Q3(250),X(256),Y(256),Z(256),             04490000
     C          A(9),XCOEF(3),YCOEF(3),ZCOEF(3),BX(3),BY(3),BZ(3),      04500000
     C          KPIV(3),LPIV(3)                                         04510000
      DIMENSION POOL(22,300),IPOOL(22,300)                              04520000
      EQUIVALENCE(POOL(1,1),IPOOL(1,1))                                 04530000
      DATA IFILL/Z00000000/,TWOPI/6.28318/,PIVMIN/1.0E-6/,IP/0/         04540000
      DATA NOGOOD/0/                                                    04550000
      IF(4*(KEND-KBEG+1) .LT. NPTS) RETURN                              04560000
      CALL OA(IDATA,SPIN,SEQ,AVSPIN)                                    04570000
      IF(SPIN .EQ. 0.0) RETURN                                          04580000
C                                                                       04590000
C          UNPACK AND DECODE FULL WORD MAGNETOMETER COUNTS              04600000
      CALL UNPACK(IDATA,X,Y,Z)                                          04610000
C                                                                       04620000
C        CHECK RECORD FOR FILL DATA, CALIBRATION SEQUENCES, FLIPPER     04630000
C        HEATER, RANGE CHANGE, MIXED BIT RATE, AND MISSING SEQUENCES.   04640000
      IRATE=IDATA(MBEG+2)                                               04650000
      IPSDEL=1                                                          04660000
      IF(IRATE .EQ. 0) IPSDEL=4                                         04670000
      IPSC1=IDATA(MBEG+3) - IPSDEL                                      04680000
      KDEL=(NPTS-1)/4                                                   04690000
      K1=KBEG                                                           04700000
      IPSC1=IDATA(MBEG+3) - IPSDEL                                      04710000
      GO TO 16                                                          04720000
   15 MSEQ=MSEQ + 15                                                    04730000
      IF(ISEQ .EQ. 8) MSEQ=MSEQ + 3                                     04740000
      IPSC1=IDATA(MSEQ+3) - IPSDEL                                      04750000
      K1=K + 1                                                          04760000
   16 K2=K1 + KDEL                                                      04770000
      IF(K2 .GT. 64) RETURN                                             04780000
      K=0                                                               04790000
      MPAGE=-291                                                        04800000
      DO 3 IPAGE=1,4                                                    04810000
      MPAGE=MPAGE + 291                                                 04820000
      MSEQ=MPAGE + 2                                                    04830000
      DO 3 ISEQ=1,16                                                    04840000
      K=K+1                                                             04850000
      IF(K .LT. K1) GO TO 2                                             04860000
      IF(K .GT. K2) GO TO 4                                             04870000
      IF(IDATA(MSEQ+5) .EQ. IFILL) GO TO 15                             04880000
      IF(IDATA(MSEQ+2) .NE. IRATE) GO TO 15                             04890000
      IF(IDATA(MSEQ+3) .NE. IPSC1+IPSDEL) GO TO 15                      04900000
      IPSC1=IDATA(MSEQ+3)                                               04910000
      KON=EXF(K)                                                        04920000
      KCAL=KON/32                                                       04930000
      KCAL=MOD(KCAL,2)                                                  04940000
      IF(KCAL .EQ. 0) GO TO 15                                          04950000
      KHTR=KON/64                                                       04960000
      KHTR=MOD(KHTR,2)                                                  04970000
      IF(KHTR .EQ. 0) GO TO 15                                          04980000
      KRB0=KON/2                                                        04990000
      KRB0=MOD(KRB0,2)                                                  05000000
      KRB1=KON                                                          05010000
      KRB1=MOD(KRB1,2)                                                  05020000
      JRGE=3 - KRB0 - 2*KRB1                                            05030000
      IF(JRGE .EQ. 0) JRGE=1                                            05040000
      IF(JRGE .NE. KRGE) GO TO 15                                       05050000
C        REJECT DATA VECTORS IF ANY COMPONENT IS NEAR MAGNETOMETER      05060000
C        SATURATION                                                     05070000
      I1=1 + 4*(K-1)                                                    05080000
      I2=I1 + 3                                                         05090000
      DO 1 I=I1,I2                                                      05100000
      IF(X(I) .LT. 5.0  .OR.  X(I) .GT. 250.0) GO TO 15                 05110000
      IF(Y(I) .LT. 5.0  .OR.  Y(I) .GT. 250.0) GO TO 15                 05120000
      IF(Z(I) .LT. 5.0  .OR.  Z(I) .GT. 250.0) GO TO 15                 05130000
    1 CONTINUE                                                          05140000
    2 MSEQ=MSEQ+15                                                      05150000
      IF(ISEQ .EQ. 8) MSEQ=MSEQ+3                                       05160000
    3 CONTINUE                                                          05170000
    4 CONTINUE                                                          05180000
      I1=1 + 4*(K1-1)                                                   05190000
C        NPTS OF DATA BEGINNING AT I1 HAVE PASSED ALL OF THE ABOVE      05200000
C        EDITS.  TRANSLATE THESE NPTS OF DATA TO THE BEGINNING OF       05210000
C        ARRAYS X, Y, Z TO FORM DATA VECTORS FOR LEAST SQUARES          05220000
C        TRIG FIT.                                                      05230000
      IF(I1 .EQ. 1) GO TO 18                                            05240000
      DO 17 I=1,NPTS                                                    05250000
      J=I1 + I - 1                                                      05260000
      X(I)=X(J)                                                         05270000
      Y(I)=Y(J)                                                         05280000
      Z(I)=Z(J)                                                         05290000
   17 CONTINUE                                                          05300000
   18 CONTINUE                                                          05310000
C                                                                       05320000
C                                                                       05330000
C                                                                       05340000
C          THE LEAST SQUARES MODEL IS THE 1ST DEGREE TRIGONOMETRIC      05350000
C          POLYNOMIAL,                                                  05360000
C          1*COEF(1) + SIN(C*W)*COEF(2) + COS(C*W)*COEF(3).             05370000
C          IN MATRIX NOTATION, THE CORRESPONDING SYSTEM OF              05380000
C          OVERDETERMINED EQUATIONS IS                                  05390000
C          Q * COEF = X   (USING X MAGNETOMETER DATA VECTOR AS EXAMPLE).05400000
C          THE CORRESPONDING SYSTEM OF NORMAL EQUATIONS IS,             05410000
C          A * COEF = BX                                                05420000
C          WHERE   A = Q'Q                                              05430000
C                  Q'= TRANSPOSE OF Q                                   05440000
C                 BX = Q'X                                              05450000
C                  (SIMILAR NOTATION FOR Y AND Z DATA VECTORS).         05460000
C          THE FIRST COLUMN OF Q HAS ALL ELEMENTS EQUAL TO 1.           05470000
C          LET Q2, Q3 BE THE 2ND AND 3RD COLUMNS OF Q.  COMPUTE Q2 AND  05480000
C          Q3.  (NOTE  X,Y,Z, CONTAIN 4 DATA SAMPLES PER SEQUENCE)      05490000
      W = TWOPI * (SEQ/SPIN) * 0.25                                     05500000
      DO 5 K=1,NPTS                                                     05510000
      C=K-1                                                             05520000
      Q2(K)=SIN(C*W)                                                    05530000
      Q3(K)=COS(C*W)                                                    05540000
    5 CONTINUE                                                          05550000
C                                                                       05560000
C          COMPUTE MATRIX A, THE COEFFICIENT MATRIX OF THE              05570000
C          NORMAL EQUATIONS.                                            05580000
      A(1)=NPTS                                                         05590000
      A(2)=SIGMA(Q2,NPTS)                                               05600000
      A(3)=SIGMA(Q3,NPTS)                                               05610000
      A(4)=A(2)                                                         05620000
      A(5)=XTY(Q2,Q2,NPTS)                                              05630000
      A(6)=XTY(Q2,Q3,NPTS)                                              05640000
      A(7)=A(3)                                                         05650000
      A(8)=A(6)                                                         05660000
      A(9)=XTY(Q3,Q3,NPTS)                                              05670000
      NDIM=3                                                            05680000
      CALL LUDCOM(A,KPIV,LPIV,NDIM,PIVMIN,IFLAG,ANORM,RHO)              05690000
C                                                                       05700000
C          COMPUTE ZERO LEVEL OF X MAGNETOMETER                         05710000
      BX(1)=SIGMA(X,NPTS)                                               05720000
      BX(2)=XTY(Q2,X,NPTS)                                              05730000
      BX(3)=XTY(Q3,X,NPTS)                                              05740000
      CALL LINSYS(A,XCOEF,BX,KPIV,LPIV,NDIM)                            05750000
      XAMPL=SQRT(XCOEF(2)**2+XCOEF(3)**2)                               05760000
C                                                                       05770000
C          COMPUTE ZERO LEVEL OF Y MAGNETOMETER.                        05780000
      BY(1)=SIGMA(Y,NPTS)                                               05790000
      BY(2)=XTY(Q2,Y,NPTS)                                              05800000
      BY(3)=XTY(Q3,Y,NPTS)                                              05810000
      CALL LINSYS(A,YCOEF,BY,KPIV,LPIV,NDIM)                            05820000
      YAMPL=SQRT(YCOEF(2)**2+YCOEF(3)**2)                               05830000
      FPERP=YAMPL*ABS(SEN2(KRGE))                                       05840000
C                                                                       05850000
C          COMPUTE ZERO LEVEL OF Z MAGNETOMETER                         05860000
      BZ(1)=SIGMA(Z,NPTS)                                               05870000
      BZ(2)=XTY(Q2,Z,NPTS)                                              05880000
      BZ(3)=XTY(Q3,Z,NPTS)                                              05890000
      CALL LINSYS(A,ZCOEF,BZ,KPIV,LPIV,NDIM)                            05900000
      ZAMPL=SQRT(ZCOEF(2)**2+ZCOEF(3)**2)                               05910000
C                                                                       05920000
C          REJECT DATA IF QUANTITIES USED AS DENOMINATORS ARE TOO SMALL 05930000
      IF(ABS(FPERP) .LT. 1.0E-4) RETURN                                 05940000
      IF(ABS(XCOEF(3)) .LT. 1.0E-4) RETURN                              05950000
      IF(ABS(YCOEF(3)) .LT. 1.0E-4) RETURN                              05960000
      IF(ABS(ZCOEF(3)) .LT. 1.0E-4) RETURN                              05970000
C                                                                       05980000
C          COMPUTE  YPHAZ  AND COMPENSATE FOR  ATAN  CONVENTION.        05990000
      YPHAZ=ATAN(YCOEF(2)/YCOEF(3))*360.0/TWOPI                         06000000
      IF(YCOEF(3) .LT. 0.0) YPHAZ=YPHAZ+180.0                           06010000
      IF(YCOEF(3) .GT. 0.0  .AND.  YCOEF(2) .LT. 0.0) YPHAZ=YPHAZ+360.0 06020000
C                                                                       06030000
      XRMS=0.0                                                          06040000
      YRMS=0.0                                                          06050000
      ZRMS=0.0                                                          06060000
      DO 6 K=1,NPTS                                                     06070000
      XRMS=XRMS+(XCOEF(1)+XCOEF(2)*Q2(K)+XCOEF(3)*Q3(K)-X(K))**2        06080000
      YRMS=YRMS+(YCOEF(1)+YCOEF(2)*Q2(K)+YCOEF(3)*Q3(K)-Y(K))**2        06090000
      ZRMS=ZRMS+(ZCOEF(1)+ZCOEF(2)*Q2(K)+ZCOEF(3)*Q3(K)-Z(K))**2        06100000
    6 CONTINUE                                                          06110000
      XRMS=SQRT(XRMS/NPTS)                                              06120000
      YRMS=SQRT(YRMS/NPTS)                                              06130000
      ZRMS=SQRT(ZRMS/NPTS)                                              06140000
C               ACCEPT COMPUTED ZEROS AND UPDATE NEXT(KRGE) IFF         06150000
C          RMS .LT. BOUND                                               06160000
      BOUND=5.0                                                         06170000
       IF(XRMS .GT. BOUND) GO TO 7                                      06180000
       IF(YRMS .GT. BOUND) GO TO 7                                      06190000
       IF(ZRMS .GT. BOUND) GO TO 7                                      06200000
      GO TO 8                                                           06210000
    7 NOGOOD=NOGOOD+1                                                   06220000
      RETURN                                                            06230000
C                                                                       06240000
    8 CONTINUE                                                          06250000
      IPSC=IDATA(MBEG+3)                                                06260000
      NEXT(KRGE)=IPSC+IDEL(KRGE)                                        06270000
      IP=IP+1                                                           06280000
      IF(IP .GT. 300) RETURN                                            06290000
C          ALL DATA IS DIVIDED INTO 6 STATES                            06300000
C          STATE   FLIP  RANGE                                          06310000
C            1      D1     1                                            06320000
C            2      D1     2                                            06330000
C            3      D1     3                                            06340000
C            4      D3     1                                            06350000
C            5      D3     2                                            06360000
C            6      D3     3                                            06370000
      JD3=EXF(K1)/8                                                     06380000
      JD3=MOD(JD3,2)                                                    06390000
      ISTATE=KRGE + 3*JD3                                               06400000
      IYR = IFILE(5) + 70                                               06410001
C CORRECTION ADDED 3/84 BY T.VOLLMER (GFSC), TO GIVE PROPER OUTPUT      06420001
C FOR YEARS 1980 - 1982.                                                06430001
      IF (IFILE(5) .LE. 2) IYR = IFILE(5) + 80                          06440001
C CORRECTION ADDED 3/84 BY T.VOLLMER (GSFC), TO GIVE PROPER OUTPUT      06450001
C FOR YEARS 1983 - 1989.  TO DETERMINE THE PROPER DECADE OF THE DATA,   06460001
C THE PERIGEE COUNT IS EXAMINED.  IF GREATER THAN 233 (APPROX. 10/82)   06470001
C IT IS THE 1980'S.                                                     06480003
      IF ((IFILE(5) .GE. 3) .AND. (IFILE(17) .GT. 233))                 06500001
     1     IYR = IFILE(5) + 80                                          06510001
C CORRECTION ADDED 5/9/90 BY T.VOLLMER(GSFC), TO GIVE PROPER OUTPUT     06511003
C FOR THE YEARS 1990-1999.  TO DETERMINE THE PROPER DECADE OF THE       06512003
C DATA, THE PERIGEE COUNT IS EXAMINED.  IF IT IS GREATER THAN           06513003
C 486 (APPROX 12/31/89 - 1/1/90) IT IS THE ROARING 1990'S.              06514003
C IF IMP LASTS TO 2000, THIS WILL HAVE TO BE DONE AGAIN.                06515003
      IF ((IFILE(5) .NE. 9) .AND. (IFILE(17) .GE. 486))                 06516003
     1       IYR = IFILE(5) + 90                                        06517003
      IF (IFILE(17) .GT. 486) IYR = IFILE(5) + 90                       06518003
      IPOOL(1,IP)=IYR                                                   06520001
      IPOOL(2,IP)=IDATA(1)-1                                            06530000
      IPOOL(3,IP)=IDATA(2)/3600000                                      06540000
       POOL(4,IP)=MOD(IDATA(2),3600000)/60000.0                         06550000
       POOL(5,IP)=XCOEF(1)                                              06560000
       POOL(6,IP)=XRMS                                                  06570000
       POOL(7,IP)=XAMPL                                                 06580000
       POOL(8,IP)=YCOEF(1)                                              06590000
       POOL(9,IP)=YRMS                                                  06600000
       POOL(10,IP)=YAMPL                                                06610000
       POOL(11,IP)=ZCOEF(1)                                             06620000
       POOL(12,IP)=ZRMS                                                 06630000
       POOL(13,IP)=ZAMPL                                                06640000
      IPOOL(14,IP)=ISTATE                                               06650000
C      POOL(15,IP)   NOT USED FOR IMP-J                                 06660000
C      POOL(16,IP)=BETA=ANGLE BETWEEN SPIN AXIS AND SPIN AXIS SENSOR    06670000
C      POOL(17,IP)=PHIZ=PHASE OF SPIN AXIS SENSOR (W.R.T. Y-SENSOR)     06680000
C      POOL(18,IP)=PHASE OF SPIN PLANE SENSOR (W.R.T. Y-SENSOR)         06690000
C     IPOOL(19,IP)=|X| - |Y| GAMMAS = DIFFERENCE OF SPIN PLANE FIELD    06700000
C                  MEASUREMENTS BY  X  AND  Y SENSORS.   (CAN BE USED   06710000
C                  TO MONITOR SENSITIVITIES OF  D1  AND  D3  WITH       06720000
C                  RESPECT TO  D2 )   UNITS = GAMMA/10                  06730000
C                                                                       06740000
C                                                                       06750000
      IF(JD3 .EQ. 1) GO TO 9                                            06760000
C                                                                       06770000
C        D1||SPIN AXIS                                                  06780000
      ZSEN=SEN1(KRGE)                                                   06790000
      XSEN=SEN3(KRGE)                                                   06800000
      GO TO 10                                                          06810000
C                                                                       06820000
C        D3||SPIN AXIS                                                  06830000
    9 ZSEN=SEN3(KRGE)                                                   06840000
      XSEN=SEN1(KRGE)                                                   06850000
   10 CONTINUE                                                          06860000
      GAMMA=ZAMPL*ABS(ZSEN)                                             06870000
       POOL(16,IP)=ARSIN(GAMMA/FPERP)*360.0/TWOPI                       06880000
      ZPHAZ=ATAN(ZCOEF(2)/ZCOEF(3))*360.0/TWOPI                         06890000
C          COMPENSATE FOR ATAN CONVENTION                               06900000
      IF(ZCOEF(3) .LT. 0.0) ZPHAZ=ZPHAZ+180.0                           06910000
      IF(ZCOEF(3) .GT. 0.0  .AND.  ZCOEF(2) .LT. 0.0) ZPHAZ=ZPHAZ+360.0 06920000
       POOL(17,IP)=ZPHAZ-YPHAZ                                          06930000
      IF(POOL(17,IP) .LT. 0.0) POOL(17,IP)=POOL(17,IP)+360.0            06940000
      XPHAZ=ATAN(XCOEF(2)/XCOEF(3))*360.0/TWOPI                         06950000
C          COMPENSATE FOR ATAN CONVENTION                               06960000
      IF(XCOEF(3) .LT. 0.0) XPHAZ=XPHAZ+180.0                           06970000
      IF(XCOEF(3) .GT. 0.0  .AND.  XCOEF(2) .LT. 0.0) XPHAZ=XPHAZ+360.0 06980000
       POOL(18,IP)=XPHAZ-YPHAZ                                          06990000
      IF(POOL(18,IP) .LT. 0.0) POOL(18,IP)=POOL(18,IP)+360.0            07000000
       POOL(19,IP)=XAMPL*ABS(XSEN) - YAMPL*ABS(SEN2(KRGE))              07010000
      IPOOL(19,IP)=10.0*POOL(19,IP) + 0.5                               07020000
      POOL(20,IP)=SEQ                                                   07030000
      POOL(21,IP)=SPIN                                                  07040000
      POOL(22,IP)=AVSPIN                                                07050000
      RETURN                                                            07060000
C                                                                       07070000
C          TERMINATE PROCESSING                                         07080000
C                                                                       07090000
       ENTRY END ZRO(NPTS,ID,IY,IH,IM,IORB)                             07100000
C                                                                       07110000
      WRITE(6,24)                                                       07120000
   24 FORMAT(///////////////////////////////////////////////            07130000
     C   2X,'*************  DATA CARD IMAGES FOLLOW  *********'///)     07140000
      IF(IP .EQ. 0) RETURN                                              07150000
      LAST=IP                                                           07160000
      IF(IP .GT.300) LAST=300                                           07170000
      K=1                                                               07180000
      M=50                                                              07190000
   25 IF(M .GT. LAST) M=LAST                                            07200000
      WRITE(9,1500) ID,IY,IH,IM,IORB                                    07210000
 1500 FORMAT(1H1,'   IMP- J  TRIG FIT DATA POOL'                        07220000
     C/10X,'PROCESSED ON DAY'I4,' OF YEAR'I5,' AT'I3,' HOURS,'I3,' MIN.'07230000
     C/'  ORBIT'I4, / 78X,'       Z-SENSOR'23X,'REFINED  AVERAGE'       07240000
     C       /'     DEC           ******  X  *****   ******  Y  *****   07250000
     C*****  Z  ****             ORIENTATION X-Y |X|-|Y|   SEQ     SPIN 07260000
     C O-A SPIN'                                                        07270000
     C       /'  YR DAY HR  MIN   ZERO   RMS  AMPL   ZERO   RMS  AMPL   07280000
     CZERO  RMS AMPL STATE       BETA  PHIZ PHASE GAM/10  PERIOD  PERIOD07290000
     C   PERIOD'/)                                                      07300000
      WRITE(9,2000) ((IPOOL(I,J),I=1,3),(POOL(I,J),I=4,13),             07310000
     CIPOOL(14,J),(POOL(I,J),I=16,18),IPOOL(19,J),(POOL(I,J),I=20,22),  07320000
     C     J=K,M)                                                       07330000
 2000 FORMAT(1X,I3,1X,I3,1X,I2,1X,F4.1,1X,F6.1,1X,F5.2,1X,F5.1,         07340000
     C                                 1X,F6.1,1X,F5.2,1X,F5.1,         07350000
     C                                 1X,F6.1,1X,F5.2,1X,F5.1,1X,      07360000
     CI2,1X, 5X ,1X,F5.2,F6.1,F6.1,1X, I6 ,1X,F7.1,1X,F7.1,1X,F7.1)     07370000
      IF(M .EQ. LAST) GO TO 26                                          07380000
      K=K+50                                                            07390000
      M=M+50                                                            07400000
      GO TO 25                                                          07410000
   26 CONTINUE                                                          07420000
      WRITE(9,2500) IP,NO GOOD,BOUND                                    07430000
 2500 FORMAT(/10X,'TRIG FIT DATA POOL CONTAINS' I4,' LINES.'            07440000
     C      //10X,I4,' COMPUTED ZEROS REJECTED FOR RMS EXCEEDING'F7.1,  07450000
     C//10X,'  ALL DATA IS CATEGORIZED INTO 6 STATES'                   07460000
     C /10X,'           FLIP  SPIN AXIS  '                              07470000
     C /9X,'STATE RANGE  POS  SENSOR'                                   07480000
     C /10X,'  1    12  FLIP     D1'                                    07490000
     C /10X,'  2    36  FLIP     D1'                                    07500000
     C /10X,'  3   108  FLIP     D1'                                    07510000
     C /10X,'  4    12  NORM     D3'                                    07520000
     C /10X,'  5    36  NORM     D3'                                    07530000
     C /10X,'  6   108  NORM     D3' )                                  07540000
      WRITE(9,27) (CAL1(I),I=1,3),(CAL2(I),I=1,3),(CAL3(I),I=1,3)       07550000
   27 FORMAT(//10X,'REFERENCE MAGNETOMETER CALIBRATION FIELDS (GAMMAS)' 07560000
     C        /10X,' RANGE       12       36      108'                  07570000
     C        /10X,'SENSOR'                                             07580000
     C        /10X,'    D1 '3F9.2                                       07590000
     C        /10X,'    D2 '3F9.2                                       07600000
     C        /10X,'    D3 '3F9.2 )                                     07610000
      WRITE(9,28) (SEN1(I),I=1,3),(SEN2(I),I=1,3),(SEN3(I),I=1,3)       07620000
   28 FORMAT(//10X,'REFERENCE MAGNETOMETER SENSITIVITIES (GAMMAS/COUNT)'07630000
     C        /10X,' RANGE       12       36      108'                  07640000
     C        /10X,'SENSOR'                                             07650000
     C        /10X,'    D1'3F9.5                                        07660000
     C        /10X,'    D2'3F9.5                                        07670000
     C        /10X,'    D3'3F9.5   )                                    07680000
      WRITE(9,29) (IDEL(I),I=1,3)                                       07690000
   29 FORMAT(//10X,' NUMBER OF SEQUENCES BETWEEN ZERO LEVEL COMPUTATIONS07700000
     C'       /10X,' RANGE   PARAMETER   VALUE'                         07710000
     C        /10X,'    12     IDEL(1)' I8                              07720000
     C        /10X,'    36     IDEL(2)' I8                              07730000
     C        /10X,'   108     IDEL(3)' I8     )                        07740000
      RMSMP=2.0                                                         07750000
      WRITE(9,30)                                                       07760000
   30 FORMAT(1H1//' IMP - J'                                            07770000
     C           /' APPARENT SPIN-PLANE SENSOR ZEROS  VS  SPIN-AXIS SENS07780000
     COR COUNTS  (ORDINATE  VS  ABSCISSA)')                             07790000
      WRITE(9,37) RMSMP                                                 07800000
   37 FORMAT(  //' 2ND LINFIT ON DATA HAVING DEVIATION  .LT.  ('F4.1,   07810000
     C           '*RMS )  IN FIRST LINFIT'/' STATES WITH FEWER THAN 15 P07820000
     COINTS ARE NOT PROCESSED FOR LINEAR FIT'//)                        07830000
      IDA=(IPOOL(2,1) + IPOOL(2,LAST))/2                                07840000
      JY=IY - 1900                                                      07850000
C                                                                       07860000
C          FOR EACH OF 6 STATES, COMPUTE PARAMETERS FOR ZEROS VS SPIN   07870000
C          AXIS FIELD                                                   07880000
C                                                                       07890000
C                                                                       07900000
C        1ST  3  STATES  ''FLIPPED''   D1||SPIN AXIS                    07910000
      DO 34 ISTATE=1,3                                                  07920000
      KNT=0                                                             07930000
      DO 31 IP=1,LAST                                                   07940000
      IF(IPOOL(14,IP) .NE. ISTATE) GO TO 31                             07950000
      KNT=KNT+1                                                         07960000
      X(KNT)=POOL(5,IP)                                                 07970000
      Y(KNT)=POOL(8,IP)                                                 07980000
      Z(KNT)=POOL(11,IP)                                                07990000
      IF(KNT .EQ. 100) GO TO 32                                         08000000
   31 CONTINUE                                                          08010000
   32 CONTINUE                                                          08020000
      WRITE(9,33) ISTATE,KNT                                            08030000
   33 FORMAT(//' IMP-J STATE'I2,','I3,' DATA POINTS')                   08040000
      IF(KNT .LE. 15) GO TO 34                                          08050000
      WRITE(9,47)                                                       08060000
      WRITE(9,49) IPOOL(1,1),IPOOL(2,1),IPOOL(2,LAST),IORB              08070000
      WRITE(9,52) ISTATE,ISTATE                                         08080000
      CALL LINFIT(Z,Y,KNT,YCOEF,YRMS,YQUAL,RMSMP)                       08090000
      WRITE(9,48)                                                       08100000
      WRITE(9,49) IPOOL(1,1),IPOOL(2,1),IPOOL(2,LAST),IORB              08110000
      WRITE(9,51) ISTATE,ISTATE                                         08120000
      CALL LINFIT(Z,X,KNT,XCOEF,XRMS,XQUAL,RMSMP)                       08130000
C                                                                       08140000
C                                                                       08150000
C        PUNCH DATA CARDS                                               08160000
C   |******DATA******|******** Y *******|******** X *******|PROCESSED|  08170000
C   |ORB YR DDA STATE|SLO INTER QUAL RMS|SLO INTER QUAL RMS|  YR DAY |  08180000
C                                                                       08190000
C                                                                       08200000
      WRITE(7,20) IORB,IPOOL(1,1),IDA,ISTATE,YCOEF(2),YCOEF(1),YQUAL,   08210000
     C  YRMS,XCOEF(2),XCOEF(1),XQUAL,XRMS,JY,ID                         08220000
   20 FORMAT(I3,1X,I2,1X,I3,1X,I1,1X,2(F8.5,1X,F7.2,1X,F7.2,1X,F5.2),   08230000
     C     1X,I2,1X,I3)                                                 08240000
      WRITE(6,22) IORB,IPOOL(1,1),IDA,ISTATE,YCOEF(2),YCOEF(1),YQUAL,   08250000
     C  YRMS,XCOEF(2),XCOEF(1),XQUAL,XRMS,JY,ID                         08260000
   22 FORMAT(5X,I3,1X,I2,1X,I3,1X,I1,1X,2(F8.5,1X,F7.2,1X,F7.2,1X,F5.2),08270000
     C     1X,I2,1X,I3)                                                 08280000
   34 CONTINUE                                                          08290000
   45 FORMAT(/5X,'D2 VS D3')                                            08300000
   46 FORMAT(/5X,'D1 VS D3')                                            08310000
   47 FORMAT(/5X,'D2 VS D1')                                            08320000
   48 FORMAT(/5X,'D3 VS D1')                                            08330000
   49 FORMAT(5X,'YEAR' I3,', DAY'I4,' TO DAY'I4,'   ORBIT'I4)           08340000
   51 FORMAT(4X,' XSLOPE('I2,')  XINT('I2,')  QUALITY')                 08350000
   52 FORMAT(4X,' YSLOPE('I2,')  YINT('I2,')  QUALITY')                 08360000
C                                                                       08370000
C                                                                       08380000
C          LAST  3  STATES  ''NORMAL''   D3||SPIN AXIS                  08390000
      DO 38 ISTATE=4,6                                                  08400000
      KNT=0                                                             08410000
      DO 35 IP=1,LAST                                                   08420000
      IF(IPOOL(14,IP) .NE. ISTATE) GO TO 35                             08430000
      KNT=KNT+1                                                         08440000
      X(KNT)=POOL(5,IP)                                                 08450000
      Y(KNT)=POOL(8,IP)                                                 08460000
      Z(KNT)=POOL(11,IP)                                                08470000
      IF(KNT .EQ. 100) GO TO 36                                         08480000
   35 CONTINUE                                                          08490000
   36 CONTINUE                                                          08500000
      WRITE(9,33) ISTATE,KNT                                            08510000
      IF(KNT .LE. 15) GO TO 38                                          08520000
      WRITE(9,45)                                                       08530000
      WRITE(9,49) IPOOL(1,1),IPOOL(2,1),IPOOL(2,LAST),IORB              08540000
      WRITE(9,52) ISTATE,ISTATE                                         08550000
      CALL LINFIT(Z,Y,KNT,YCOEF,YRMS,YQUAL,RMSMP)                       08560000
      WRITE(9,46)                                                       08570000
      WRITE(9,49) IPOOL(1,1),IPOOL(2,1),IPOOL(2,LAST),IORB              08580000
      WRITE(9,51) ISTATE,ISTATE                                         08590000
      CALL LINFIT(Z,X,KNT,XCOEF,XRMS,XQUAL,RMSMP)                       08600000
C                                                                       08610000
C                                                                       08620000
C        PUNCH DATA CARDS                                               08630000
C   |******DATA******|******** Y *******|******** X *******|PROCESSED|  08640000
C   |ORB YR DDA STATE|SLO INTER QUAL RMS|SLO INTER QUAL RMS|  YR DAY |  08650000
C                                                                       08660000
C                                                                       08670000
      WRITE(7,20) IORB,IPOOL(1,1),IDA,ISTATE,YCOEF(2),YCOEF(1),YQUAL,   08680000
     C  YRMS, XCOEF(2),XCOEF(1),XQUAL,XRMS,JY,ID                        08690000
      WRITE(6,22) IORB,IPOOL(1,1),IDA,ISTATE,YCOEF(2),YCOEF(1),YQUAL,   08700000
     C  YRMS, XCOEF(2),XCOEF(1),XQUAL,XRMS,JY,ID                        08710000
   38 CONTINUE                                                          08720000
C          COMPUTE BETA AND PHIZ USING ONLY HIGH RANGE DATA FOR WHICH   08730000
C          SPIN MODULATION OF THE SPIN AXIS SENSOR HAS AN AMPLITUDE     08740000
C          .GE. THRESH                                                  08750000
      THRESH=1.8                                                        08760000
      BETA00=0.0                                                        08770000
      BETA90=0.0                                                        08780000
      PHIZ00=0.0                                                        08790000
      PHIZ90=0.0                                                        08800000
      KNT00=0                                                           08810000
      KNT90=0                                                           08820000
      DO 41 IP=1,LAST                                                   08830000
      IF(IPOOL(14,IP) .GT. 3) GO TO 40                                  08840000
      IF(POOL(7,IP) .LT. THRESH) GO TO 41                               08850000
      KNT00=KNT00+1                                                     08860000
      BETA00=BETA00+POOL(16,IP)                                         08870000
      PHIZ00=PHIZ00+POOL(17,IP)                                         08880000
      GO TO 41                                                          08890000
   40 CONTINUE                                                          08900000
      IF(POOL(7,IP) .LT. THRESH) GO TO 41                               08910000
      KNT90=KNT90+1                                                     08920000
      BETA90=BETA90+POOL(16,IP)                                         08930000
      PHIZ90=PHIZ90+POOL(17,IP)                                         08940000
   41 CONTINUE                                                          08950000
      IF(KNT00 .EQ.0) GO TO 42                                          08960000
      BETA00=BETA00/KNT00                                               08970000
      PHIZ00=PHIZ00/KNT00                                               08980000
   42 IF(KNT90 .EQ. 0) GO TO 43                                         08990000
      BETA90=BETA90/KNT90                                               09000000
      PHIZ90=PHIZ90/KNT90                                               09010000
   43 CONTINUE                                                          09020000
      B0RMS=0.0                                                         09030000
      B9RMS=0.0                                                         09040000
      P0RMS=0.0                                                         09050000
      P9RMS=0.0                                                         09060000
      DO 55 IP=1,LAST                                                   09070000
      IF(IPOOL(14,IP) .GT. 3) GO TO 54                                  09080000
      B0RMS=B0RMS + (POOL(16,IP) - BETA00)**2                           09090000
      P0RMS=P0RMS + (POOL(17,IP) - PHIZ00)**2                           09100000
      GO TO 55                                                          09110000
   54 B9RMS=B9RMS + (POOL(16,IP) - BETA90)**2                           09120000
      P9RMS=P9RMS + (POOL(17,IP) - PHIZ90)**2                           09130000
   55 CONTINUE                                                          09140000
      IF(KNT00 . EQ. 0) GO TO 56                                        09150000
      B0RMS = SQRT(B0RMS/KNT00)                                         09160000
      P0RMS=SQRT(P0RMS/KNT00)                                           09170000
   56 IF(KNT90 .EQ. 0) GO TO 57                                         09180000
      B9RMS=SQRT(B9RMS/KNT90)                                           09190000
      P9RMS=SQRT(P9RMS/KNT90)                                           09200000
   57 CONTINUE                                                          09210000
C                                                                       09220000
C                                                                       09230000
C        PUNCH DATA CARDS                                               09240000
C   |******DATA******|******************|******************|PROCESSED|  09250000
C   |ORB YR DDA STATE|    BETA00        |    PHIZ00        |  YR DAY |  09260000
C   |ORB YR DDA STATE|    BETA90        |    PHIZ90        |  YR DAY |  09270000
C                                                                       09280000
C                                                                       09290000
      IF(KNT00 .EQ. 0) GO TO 58                                         09300000
      ISTATE=7                                                          09310000
      WRITE(7,21) IORB,IPOOL(1,1),IDA,ISTATE,B0RMS,BETA00,P0RMS,PHIZ00, 09320000
     C    JY,ID                                                         09330000
   21 FORMAT(I3,1X,I2,1X,I3,1X,I1,1X,F8.4,1X,F7.3,14X,F8.4,1X,F7.2,15X, 09340000
     C   I2,1X,I3)                                                      09350000
      WRITE(6,23) IORB,IPOOL(1,1),IDA,ISTATE,B0RMS,BETA00,P0RMS,PHIZ00, 09360000
     C    JY,ID                                                         09370000
   23 FORMAT(5X,I3,1X,I2,1X,I3,1X,I1,1X,F8.4,1X,F7.3,14X,F8.4,1X,F7.2,1509380000
     C X,I2,1X,I3)                                                      09390000
   58 IF(KNT90 .EQ. 0) GO TO 59                                         09400000
      ISTATE=8                                                          09410000
      WRITE(7,21) IORB,IPOOL(1,1),IDA,ISTATE,B9RMS,BETA90,P9RMS,PHIZ90, 09420000
     C    JY,ID                                                         09430000
      WRITE(6,23) IORB,IPOOL(1,1),IDA,ISTATE,B9RMS,BETA90,P9RMS,PHIZ90, 09440000
     C    JY,ID                                                         09450000
   59 WRITE(9,44) THRESH,KNT00,BETA00,PHIZ00,B0RMS,P0RMS                09460000
     C                  ,KNT90,BETA90,PHIZ90,B9RMS,P9RMS                09470000
   44 FORMAT(//10X,'IMP -J'                                             09480000
     C        /10X,'BETA AND PHIZ CALCULATED FROM HIGH RANGE DATA FOR'  09490000
     C        /10X,'WHICH AMPLITUDE OF SPIN MODULATION ON SPIN AXIS '   09500000
     C        /10X,'SENSOR SATISFIES AMPL .GE.'F5.1,' COUNTS.'          09510000
     C//10X,' D1||SPIN-AXIS'I3,' DATA POINTS, BETA(1)='F7.3,', PHIZ(1)='09520000
     C      F8.2/45X,'RMS='F7.4,'      RMS='F7.4                        09530000
     C//10X,' D3||SPIN-AXIS'I3,' DATA POINTS, BETA(2)='F7.3,', PHIZ(2)='09540000
     C       F8.2/45X,'RMS='F7.4,'      RMS='F7.4)                      09550000
      RETURN                                                            09560000
      END                                                               09570000
C                                                                       09580000
C                                                                       09590000
      SUBROUTINE CALI(K,ICAL,EXF,DATA,IDATA,NUMSEQ,MSEQ,LASCAL,IYR)     09600000
C                                                                       09610000
      DIMENSION DATA(1),IDATA(1)                                        09620000
      COMMON /MARKER/ KBEG,MBEG,KEND,MEND,NPTS                          09630000
      COMMON /VECTOR/ Q2(250),Q3(250),X(256),Y(256),Z(256),             09640000
     C          A(9),XCOEF(3),YCOEF(3),ZCOEF(3),BX(3),BY(3),BZ(3),      09650000
     C          KPIV(3),LPIV(3)                                         09660000
      INTEGER*4 EXF(64),SHFTL,SHFTR                                     09670000
      DATA PIVMIN/1.0E-5/, TWOPI/6.28318/                               09680000
      DIMENSION CAL1(3),CAL2(3),CAL3(3)                                 09690000
      DIMENSION SEN1(3),SEN2(3),SEN3(3)                                 09700000
      COMMON CAL1,CAL2,CAL3,SEN1,SEN2,SEN3                              09710000
      DATA LCAL/' CAL'/                                                 09720000
C                                                                       09730000
C                                                                       09740000
C          K SEQUENCE K IS FIRST CALIBRATED SEQUENCE IN RECORD          09750000
C     NUMSEQ NUMBER OF UNCALIBRATED SEQUENCES IN CALIBRATION DATA VECTOR09760000
C     LASCAL PSEUDOSEQUENCE COUNT OF LAST CALIBRATION SEQUENCE WHICH    09770000
C            HAS BEEN PROCESSED  (PREVENT DUPLICATE COMPUTATIONS)       09780000
C                                                                       09790000
      IF(K .EQ. KEND) RETURN                                            09800000
C                                                                       09810000
C          ALWAYS  KBEG  .LE.  K  .LT.  KEND                            09820000
C          COMPUTE  NCAL , THE NUMBER OF CALIBRATION SEQUENCES TO BE    09830000
C          PROCESSED.     NOTE   2  .LE.  NCAL  .LE.  4                 09840000
      NCAL=KEND - K + 1                                                 09850000
      IF(NCAL .GT. 4) NCAL = 4                                          09860000
      IF(KEND-KBEG+1 .LT. NCAL+NUMSEQ) RETURN                           09870000
C                                                                       09880000
C          CHECK FOR CONSECUTIVE CALIBRATION SEQUENCES                  09890000
      K1=K+1                                                            09900000
      K2=K+NCAL-1                                                       09910000
      J=0                                                               09920000
      MPAGE=-291                                                        09930000
      DO 2 IPAGE=1,4                                                    09940000
      MPAGE=MPAGE + 291                                                 09950000
      NSEQ=MPAGE + 2                                                    09960000
      DO 2 ISEQ=1,16                                                    09970000
      J=J+1                                                             09980000
      IF(J .LT. K1) GO TO 1                                             09990000
      IF(J .GT. K2) GO TO 3                                             10000000
      IPSC=IDATA(NSEQ+3)                                                10010000
C        IPSC .LE. LASCAL TESTS FOR FILL DATA (IPSC=0)                  10020000
      IF(IPSC .LE. LASCAL) RETURN                                       10030000
      KON=SHFTR(IDATA(NSEQ+15),24)                                      10040000
      KCAL=KON/32                                                       10050000
      KCAL=MOD(KCAL,2)                                                  10060000
      IF(KCAL .EQ. 1) RETURN                                            10070000
    1 NSEQ=NSEQ + 15                                                    10080000
      IF(ISEQ .EQ. 8) NSEQ=NSEQ + 3                                     10090000
    2 CONTINUE                                                          10100000
    3 CONTINUE                                                          10110000
      ICAL=LCAL                                                         10120000
      LASCAL=IDATA(MSEQ+3) + 3                                          10130000
C                                                                       10140000
C          LASCAL IS PSEUDOSEQUENCE COUNT OF 4TH CALIBRATED SEQUENCE    10150000
C          COMPUTE  N1 , N2 , THE NUMBER OF UNCALIBRATED SEQUENCES      10160000
C          IN THE DATA VECTOR BEFORE AND AFTER THE CALIBRATION          10170000
C          SEQUENCES.  NOTE   N1 + N2 = NUMSEQ                          10180000
      N1=K-KBEG                                                         10190000
      N2=KEND-(KCAL+NCAL-1)                                             10200000
      NUM2=NUMSEQ/2                                                     10210000
      IF(N1 .GT. NUM2) N1=NUM2                                          10220000
      IF(N2 .GT. NUM2) N2=NUM2                                          10230000
      IF(N1 .LT. NUM2) N2=N2+(NUM2-N1)                                  10240000
      IF(N2 .LT. NUM2) N1=N1+(NUM2-N2)                                  10250000
C                                                                       10260000
C          COMPUTE SEQUENCE INDICES  K1, K2, K3, K4 , NEEDED TO         10270000
C          FORM DATA VECTORS USED IN LEAST SQUARES FIT                  10280000
      K1=K-N1                                                           10290000
      IF(N1 .EQ. 0) K1=0                                                10300000
      K2=K-1                                                            10310000
      K3=K+NCAL                                                         10320000
      K4=K3+N2-1                                                        10330000
      IF(N2 .EQ. 0) K4=0                                                10340000
C                                                                       10350000
      CALL EXFLAG(IDATA,EXF)                                            10360000
      KON=EXF(K)                                                        10370000
      KRB1=MOD(KON,2)                                                   10380000
      KRB0=KON/2                                                        10390000
      KRB0=MOD(KRB0,2)                                                  10400000
      KRGE=3 - KRB0 - 2*KRB1                                            10410000
      IF(KRGE .EQ. 0) KRGE=1                                            10420000
      JD3=KON/8                                                         10430000
      JD3=MOD(JD3,2)                                                    10440000
      ISTATE=KRGE + 3*JD3                                               10450000
      IDA=IDATA(1) - 1                                                  10460000
      IMS=IDATA(2)                                                      10470000
      IHR=IMS/3600000                                                   10480000
      FMN=MOD(IMS,3600000)/60000.0                                      10490000
      WRITE(8,88) IDA,IYR,IHR,FMN,ISTATE                                10500000
   88 FORMAT(///3X,'CALIBRATION ON DDAY'I4,' OF YEAR'I3,' AT' I3,       10510000
     C  ' HOURS,'F6.1,' MINUTES.'/10X,'STATE='I3)                       10520000
C                                                                       10530000
C          CHECK DATA VECTORS FOR HEATER ON OR RANGE CHANGE             10540000
      J1=K1                                                             10550000
      IF(K1 .EQ. 0) J1=KBEG                                             10560000
      J2=K4                                                             10570000
      IF(K4 .EQ. 0) J2=KEND                                             10580000
      DO 8 J=J1,J2                                                      10590000
      KON=EXF(J)                                                        10600000
      JHTR=KON/64                                                       10610000
      JHTR=MOD(JHTR,2)                                                  10620000
      IF(JHTR .EQ. 0) GO TO 9                                           10630000
      KRB1=MOD(KON,2)                                                   10640000
      KRB0=KON/2                                                        10650000
      KRB0=MOD(KRB0,2)                                                  10660000
      IRGE=3-KRB0-2*KRB1                                                10670000
      IF(IRGE .EQ. 0) IRGE=1                                            10680000
    8 CONTINUE                                                          10690000
      GO TO 13                                                          10700000
    9 WRITE(8,10)                                                       10710000
   10 FORMAT(10X,'CALIBRATION DATA REJECTED. HEATER ON.')               10720000
      GO TO 97                                                          10730000
C  11 WRITE(8,12)                                                       10740000
   12 FORMAT(10X,'CALIBRATION DATA REJECTED. MIXED RANGES.')            10750000
C     GO TO 97                                                          10760000
   13 CONTINUE                                                          10770000
C                                                                       10780000
C                                                                       10790000
C          FORM DATA VECTORS X, Y, Z AND TRIG MODEL VECTORS Q2, Q3.     10800000
C          ( SEE SUBROUTINE ZERO FOR DISCUSSION OF Q2, Q3. )            10810000
C          REJECT DATA VECTORS IF ANY COMPONENT IS NEAR SATURATION.     10820000
C          SEARCH RELEVANT PORTIONS OF DATA FOR FILL DATA               10830000
C                                                                       10840000
      CALL OA(IDATA,SPIN,SEQ,AVSPIN)                                    10850000
      IF(SPIN .GT. 500.0) GO TO 19                                      10860000
      WRITE(8,18)                                                       10870000
   18 FORMAT(10X,'CALIBRATION DATA REJECTED.  SPIN .LE. 500.')          10880000
      RETURN                                                            10890000
   19 CONTINUE                                                          10900000
      CALL UNPACK(IDATA,X,Y,Z)                                          10910000
      W=TWOPI * (SEQ/SPIN) * 0.25                                       10920000
C        (N.B. DATA VECTORS X,Y,Z WILL HAVE 4 COMPONENTS FROM EACH      10930000
C              SEQUENCE PROCESSED)                                      10940000
C          INDEX GIVES POSITION OF SEQUENCE DATA IN X,Y,Z               10950000
      L=0                                                               10960000
      J=0                                                               10970000
      MPAGE=-291                                                        10980000
      DO 14 IPAGE = 1,4                                                 10990000
      MPAGE=MPAGE + 291                                                 11000000
      NSEQ=MPAGE + 2                                                    11010000
      DO 14 ISEQ = 1,16                                                 11020000
      J=J+1                                                             11030000
      IF(K1 .EQ. 0) GO TO 17                                            11040000
      IF(J .LT. K1) GO TO 7                                             11050000
      IF(J .GT. K2) GO TO 4                                             11060000
      GO TO 5                                                           11070000
    4 IF(K4 .EQ. 0) GO TO 7                                             11080000
   17 IF(J .LT. K3) GO TO 7                                             11090000
      IF(J .GT. K4) GO TO 40                                            11100000
    5 IPSC=IDATA(NSEQ+3)                                                11110000
C        IPSC .EQ. 0   TESTS FOR FILL DATA                              11120000
      IF(IPSC .EQ. 0) GO TO 15                                          11130000
      INDEX=64*(IPAGE-1) + 4*(ISEQ-1) + 2                               11140000
      DO 6 I=1,4                                                        11150000
      L=L+1                                                             11160000
      X(L)=X(INDEX)                                                     11170000
      Y(L)=Y(INDEX)                                                     11180000
      Z(L)=Z(INDEX)                                                     11190000
      IF(X(L) .LT. 5.0  .OR.  X(L) .GT. 250.0) GO TO 38                 11200000
      IF(Y(L) .LT. 5.0  .OR.  Y(L) .GT. 250.0) GO TO 38                 11210000
      IF(Z(L) .LT. 5.0  .OR.  Z(L) .GT. 250.0) GO TO 38                 11220000
      Q2(L)=SIN(INDEX*W)                                                11230000
      Q3(L)=COS(INDEX*W)                                                11240000
      INDEX=INDEX+1                                                     11250000
      IF(INDEX .GT. 256) GO TO 40                                       11260000
    6 CONTINUE                                                          11270000
    7 NSEQ=NSEQ + 15                                                    11280000
      IF(ISEQ .EQ. 8) NSEQ=NSEQ + 3                                     11290000
   14 CONTINUE                                                          11300000
      GO TO 40                                                          11310000
   15 WRITE(8,16)                                                       11320000
   16 FORMAT(10X,'CALIBRATION DATA REJECTED. FILL DATA.')               11330000
      GO TO 97                                                          11340000
C                                                                       11350000
   38 WRITE(8,39)                                                       11360000
   39 FORMAT(10X,'CALIBRATION DATA REJECTED.  DATA NEAR SATURATION.')   11370000
      GO TO 97                                                          11380000
C                                                                       11390000
C          COMPUTE A, THE COEFFICIENT MATRIX OF NORMAL EQUATIONS.       11400000
C          ( SEE SUBROUTINE ZERO FOR DISCUSSION OF TRIG MODEL AND A. )  11410000
   40 MPTS=L                                                            11420000
      A(1)=MPTS                                                         11430000
      A(2)=SIGMA(Q2,MPTS)                                               11440000
      A(3)=SIGMA(Q3,MPTS)                                               11450000
      A(4)=A(2)                                                         11460000
      A(5)=XTY(Q2,Q2,MPTS)                                              11470000
      A(6)=XTY(Q2,Q3,MPTS)                                              11480000
      A(7)=A(3)                                                         11490000
      A(8)=A(6)                                                         11500000
      A(9)=XTY(Q3,Q3,MPTS)                                              11510000
      NDIM=3                                                            11520000
      CALL LUDCOM(A,KPIV,LPIV,NDIM,PIVMIN,IFLAG,ANORM,RHO)              11530000
C                                                                       11540000
C                                                                       11550000
C          LEAST SQUARES FIT TRIG MODEL TO DATA VECTORS.                11560000
      BX(1)=SIGMA(X,MPTS)                                               11570000
      BX(2)=XTY(Q2,X,MPTS)                                              11580000
      BX(3)=XTY(Q3,X,MPTS)                                              11590000
      CALL LINSYS(A,XCOEF,BX,KPIV,LPIV,NDIM)                            11600000
      BY(1)=SIGMA(Y,MPTS)                                               11610000
      BY(2)=XTY(Q2,Y,MPTS)                                              11620000
      BY(3)=XTY(Q3,Y,MPTS)                                              11630000
      CALL LINSYS(A,YCOEF,BY,KPIV,LPIV,NDIM)                            11640000
      BZ(1)=SIGMA(Z,MPTS)                                               11650000
      BZ(2)=XTY(Q2,Z,MPTS)                                              11660000
      BZ(3)=XTY(Q3,Z,MPTS)                                              11670000
      CALL LINSYS(A,ZCOEF,BZ,KPIV,LPIV,NDIM)                            11680000
      XRMS=0.0                                                          11690000
      YRMS=0.0                                                          11700000
      ZRMS=0.0                                                          11710000
      DO 41 J=1,MPTS                                                    11720000
      XRMS=XRMS+(XCOEF(1)+XCOEF(2)*Q2(J)+XCOEF(3)*Q3(J)-X(J))**2        11730000
      YRMS=YRMS+(YCOEF(1)+YCOEF(2)*Q2(J)+YCOEF(3)*Q3(J)-Y(J))**2        11740000
      ZRMS=ZRMS+(ZCOEF(1)+ZCOEF(2)*Q2(J)+ZCOEF(3)*Q3(J)-Z(J))**2        11750000
   41 CONTINUE                                                          11760000
      XRMS=SQRT(XRMS/MPTS)                                              11770000
      YRMS=SQRT(YRMS/MPTS)                                              11780000
      ZRMS=SQRT(ZRMS/MPTS)                                              11790000
C                                                                       11800000
C        UNPACKED DATA HAS BEEN SHUFFLED IN FORMING DATA VECTORS.       11810000
C        REPEAT UNPACK TO OBTAIN CALIBRATED DATA POINTS.                11820000
C        (SIMPLE BUT CLUMSY)                                            11830000
      CALL UNPACK(IDATA,X,Y,Z)                                          11840000
      J1=2 + 4*(K-1)                                                    11850000
      J2=J1 + 4*NCAL - 1                                                11860000
      XCAL=0.0                                                          11870000
      YCAL=0.0                                                          11880000
      ZCAL=0.0                                                          11890000
      DO 44 J=J1,J2                                                     11900000
      IF(X(J) .LT. 5.0  .OR.  X(J) .GT. 250.0) GO TO 38                 11910000
      IF(Y(J) .LT. 5.0  .OR.  Y(J) .GT. 250.0) GO TO 38                 11920000
      IF(Z(J) .LT. 5.0  .OR.  Z(J) .GT. 250.0) GO TO 38                 11930000
      C=J*W                                                             11940000
      XCAL=XCAL+  (XCOEF(1)+XCOEF(2)*SIN(C)+XCOEF(3)*COS(C)-X(J))       11950000
      YCAL=YCAL+  (YCOEF(1)+YCOEF(2)*SIN(C)+YCOEF(3)*COS(C)-Y(J))       11960000
      ZCAL=ZCAL+  (ZCOEF(1)+ZCOEF(2)*SIN(C)+ZCOEF(3)*COS(C)-Z(J))       11970000
   44 CONTINUE                                                          11980000
      XCAL=XCAL/(4*NCAL)                                                11990000
      YCAL=YCAL/(4*NCAL)                                                12000000
      ZCAL=ZCAL/(4*NCAL)                                                12010000
      WRITE(8,92) AVSPIN,SPIN,MPTS,SEQ                                  12020000
   92 FORMAT(10X,'AVSPIN='F8.1,'  SPIN='F8.1,'  MPTS='I4,'  SEQ='F9.1)  12030000
      WRITE(8,93)   KRGE,XCAL,XRMS,YCAL,YRMS,ZCAL,ZRMS                  12040000
   93 FORMAT(//10X,'RANGE='I3,                                          12050000
     C      //10X,'XCAL='F8.2,' COUNTS,  XRMS='F8.2                     12060000
     C       /10X,'YCAL='F8.2,' COUNTS,  YRMS='F8.2                     12070000
     C       /10X,'ZCAL='F8.2,' COUNTS,  ZRMS='F8.2)                    12080000
      IF(ISTATE .GT. 3) GO TO 21                                        12090000
C                                                                       12100000
C        D1||SA   FLIPPED                                               12110000
      XSEN = SEN3(KRGE)                                                 12120000
      YSEN = SEN2(KRGE)                                                 12130000
      ZSEN = SEN1(KRGE)                                                 12140000
      XFLD = CAL3(KRGE)                                                 12150000
      YFLD = CAL2(KRGE)                                                 12160000
      ZFLD = CAL1(KRGE)                                                 12170000
      GO TO 22                                                          12180000
C                                                                       12190000
C        D3||SA  NORMAL                                                 12200000
   21 XSEN = SEN1(KRGE)                                                 12210000
      YSEN = SEN2(KRGE)                                                 12220000
      ZSEN = SEN3(KRGE)                                                 12230000
      XFLD = CAL1(KRGE)                                                 12240000
      YFLD = CAL2(KRGE)                                                 12250000
      ZFLD = CAL3(KRGE)                                                 12260000
   22 CONTINUE                                                          12270000
      XGAM=XCAL*XSEN                                                    12280000
      YGAM=YCAL*YSEN                                                    12290000
      ZGAM=ZCAL*ZSEN                                                    12300000
      XSAN = XFLD/XCAL                                                  12310000
      YSAN = YFLD/YCAL                                                  12320000
      ZSAN = ZFLD/ZCAL                                                  12330000
      WRITE(8,90)  XGAM, YGAM, ZGAM,                                    12340000
     C             XFLD, YFLD, ZFLD,                                    12350000
     C             XSAN, YSAN, ZSAN,                                    12360000
     C             XSEN, YSEN, ZSEN                                     12370000
   90 FORMAT(68X,'      X         Y         Z'                          12380000
     C/10X,'CALIBRATION FIELD ASSUMING REFERENCE SENSITIVITY  (GAMMAS)' 12390000
     C   3F10.2                                                         12400000
     C /30X,'REFERENCE CALIBRATION FIELDS  (GAMMAS)' 3F10.2/            12410000
     C /17X,'SENSITIVITY ASSUMING REFERENCE CAL FIELDS (GAM/CNT)'3F10.5 12420000
     C/20X,'SENSITIVITY REFERENCES FROM DATA CARDS (GAM/CNT)'   3F10.5) 12430000
C                                                                       12440000
C                                                                       12450000
C                                                                       12460000
C        PUNCH DATA CARDS                                               12470000
C        STATE  YR  DDA  CAL=0  XCAL  XRMS  YCAL  YRMS  ZCAL  ZRMS      12480000
C                                                                       12490000
      IZRO=0                                                            12500000
      WRITE(6,23)                                                       12510000
   23 FORMAT(////3X,'CALIBRATION DATA IMAGE FOLLOWS')                   12520000
      WRITE(7,20) ISTATE,IYR,IDA,IZRO,XCAL,XRMS,YCAL,YRMS,ZCAL,ZRMS     12530000
   20 FORMAT(I3,1X,I2,1X,I3,1X,I1,1X,F8.2,1X,F7.2,1X,F7.2,6X,           12540000
     C    F8.2,1X,F7.2,1X,F7.2)                                         12550000
      WRITE(6,24) ISTATE,IYR,IDA,IZRO,XCAL,XRMS,YCAL,YRMS,ZCAL,ZRMS     12560000
   24 FORMAT(5X,I3,1X,I2,1X,I3,1X,I1,1X,F8.2,1X,F7.2,1X,F7.2,6X,        12570000
     C    F8.2,1X,F7.2,1X,F7.2)                                         12580000
   97 CONTINUE                                                          12590000
      RETURN                                                            12600000
      END                                                               12610000
      SUBROUTINE LINFIT(X,Y,N,COEF,RMSE,QUAL,RMSMP)                     12620000
C       THIS PROGRAM COMPUTES THE COEFFICIENTS OF THE LINEAR POLYNOMIAL 12630000
C       WHICH FITS THE N DATA POINTS (X,Y) IN THE LEAST SQUARES NORM.   12640000
C      1. THIS PROGRAM IMPLICITLY FORMS MATRIX Q CONTAINING THE         12650000
C         COEFFICIENTS OF THE OVERDETERMINED SYSTEM Q*C=B OF 1ST DEGREE 12660000
C         POLYNOMIAL EQUATIONS, WHERE B(I)=Y(I), I=1,...,N ARE          12670000
C         THE N VALUES OF THE DEPENDENT VARIABLE CORRESPONDING TO       12680000
C         VALUES OF THE INDEPENDENT VARIABLE T(I)=X(I).                 12690000
C         IF N.GT.100, THE PROGRAM DOES NOTHING.                        12700000
C      2. IEDIT IS AN ARRAY OF FLAGS USED BY THE PROGRAM TO EDIT        12710000
C         THE DATA B(I)...                                              12720000
C                  IEDIT(I)=0....B(I) WILL NOT BE USED AS DATA          12730000
C                  IEDIT(I)=1....B(I) WILL BE USED AS DATA              12740000
C      3. THE PROGRAM FORMS AND SOLVES THE LEAST SQUARES NORMAL EQUATION12750000
C         Q'*Q*C=Q*B WHERE Q' IS THE TRANSPOSE OF Q.  THE PROGRAM       12760000
C         COMPUTES A=Q'*Q AND QB=Q'*B.                                  12770000
C      4. UPON RETURN TO THE CALLING PROGRAM, COEF CONTAINS THE COMPUTED12780000
C         COEFFICIENTS OF THE 1ST DEGREE POLYNOMIAL P(Z) WHICH FITS THE 12790000
C         DATA IN THE LEAST SQUARES SENSE. P(Z)=COEF(1)+COEF(2)*Z.      12800000
C          N.B. C=(COEF(1),COEF(2))                                     12810000
C      5. SUBROUTINES REQUIRED....                                      12820000
C          1. SIGMA                                                     12830000
C          2. XTY                                                       12840000
C          3. LUDCOM                                                    12850000
C          4. LINSYS                                                    12860000
      DIMENSION IEDIT(100)                                              12870000
      DIMENSION X(100),Y(100),COEF(1),FIT(100)                          12880000
      DIMENSION B(100),T(100),A(4),QB(2),K(2),L(2)                      12890000
C          T IS WORKING ARRAY FOR INDEPENDENT VARIABLE                  12900000
C          B IS WORKING ARRAY FOR DATA                                  12910000
      COMMON /QULTY/ FKAY,RMS0                                          12920000
      DATA NDIM/2/,PIVMIN/1.0E-6/                                       12930000
      IF(N .LT. 15 .OR. N .GT. 100) RETURN                              12940000
C                                                                       12950000
C          CREATE DATA VECTORS                                          12960000
      M=N                                                               12970000
      KEY=0                                                             12980000
      DO 1 I=1,N                                                        12990000
      T(I)=X(I)                                                         13000000
      B(I)=Y(I)                                                         13010000
    1 CONTINUE                                                          13020000
    2 CONTINUE                                                          13030000
C                                                                       13040000
C          SOLVE Q'*Q*C=Q'*B.  NOTATION:  C=(COEF(1),COEF(2))           13050000
C                                         A=Q'*Q                        13060000
C                                        QB=Q'*B                        13070000
      A(1)=FLOAT(M)                                                     13080000
      A(2)=SIGMA(T,M)                                                   13090000
      A(3)=A(2)                                                         13100000
      A(4)=XTY(T,T,M)                                                   13110000
      QB(1)=SIGMA(B,M)                                                  13120000
      QB(2)=XTY(T,B,M)                                                  13130000
      CALL LUDCOM(A,K,L,NDIM,PIVMIN,IFLAG,ANORM,RHO)                    13140000
      CALL LINSYS(A,COEF,QB,K,L,NDIM)                                   13150000
      RMSE=0.0                                                          13160000
      DO 3 I=1,M                                                        13170000
      FIT(I)=COEF(1)+COEF(2)*T(I)                                       13180000
    3 RMSE=RMSE+(FIT(I)-B(I))**2                                        13190000
      DENOM=FLOAT(M)                                                    13200000
      RMSE=SQRT(RMSE/DENOM)                                             13210000
      IF(KEY .EQ. 1) GO TO 7                                            13220000
C                                                                       13230000
C          EDIT DATA                                                    13240000
      EDIT=RMSMP*RMSE                                                   13250000
      M=0                                                               13260000
      DO 6 I=1,N                                                        13270000
      IEDIT(I)=0                                                        13280000
      IF(ABS(FIT(I)-B(I)) .LE. EDIT) GO TO 5                            13290000
      GO TO 6                                                           13300000
    5 M=M+1                                                             13310000
      IEDIT(I)=1                                                        13320000
      T(M)=X(I)                                                         13330000
      B(M)=Y(I)                                                         13340000
    6 CONTINUE                                                          13350000
      KEY=1                                                             13360000
      LINPT=M                                                           13370000
      IF(M .GT. 5) GO TO 2                                              13380000
      RETURN                                                            13390000
    7 CONTINUE                                                          13400000
C          COMPUTE STD DEV OF ABSCISSA                                  13410000
      XBAR=SIGMA(T,M)/M                                                 13420000
      STDEV=0.                                                          13430000
      DO 9 I=1,M                                                        13440000
    9 STDEV=STDEV+(T(I)-XBAR)**2                                        13450000
      STDEV=SQRT(STDEV/M)                                               13460000
C                                                                       13470000
C        QUAL AS PER R. LEPPING, 28 AUG 73                              13480000
      EM=LINPT                                                          13490000
      QUAL=2.0*FKAY*SQRT(EM)*STDEV/(RMS0+RMSE)                          13500000
   15 FORMAT(4X,F10.6,1X,F10.2,F9.3)                                    13510000
      WRITE(9,15) COEF(2),COEF(1),QUAL                                  13520000
      WRITE(9,11) (X(I),Y(I),IEDIT(I),I=1,N)                            13530000
      WRITE(9,10) XBAR,STDEV                                            13540000
      WRITE(9,12) QUAL                                                  13550000
      WRITE(9,13) COEF(2),COEF(1)                                       13560000
      WRITE(9,14) RMSE,LINPT                                            13570000
   14 FORMAT(78X,'RMS='F10.6/78X,'LINPT='I3)                            13580000
   10 FORMAT(78X,'FINAL ABSCISSA MEAN=XBAR=' F7.1/78X,'STD DEV='F6.1)   13590000
   11 FORMAT(//77X,' ABSCISSA  ORDINATE    EDIT'/(76X,2F10.3,I6))       13600000
   12 FORMAT(78X,'QUALITY='F12.5)                                       13610000
   13 FORMAT(78X,'SLOPE=' F10.6,',  INTERCEPT=' F10.3)                  13620000
      RETURN                                                            13630000
      END                                                               13640000
C                                                                       13650000
C                                                                       13660000
C     SUBROUTINES  UNPACK  EXFLAG  BEGEND   OA                          13670000
C                                                                       13680000
      SUBROUTINE UNPACK(IDATA,X,Y,Z)                                    13690000
      DIMENSION IDATA(1251),X(1),Y(1),Z(1) ,IFULL(4)                    13700000
      INTEGER*4 EXF(1),SHFTL,SHFTR                                      13710000
      DATA I0/Z00000000/, L0/Z00008000/, MASK/Z00FFFFFF/                13720000
      DATA ZMASK/Z00000080/                                             13730000
C        LOR  AND  LXOR  ARE SESD/360 LIBRARY ROUTINES FOR PERFORMING   13740000
C        OR  OPERATIONS, AND  EXCLUSIVE-OR  OPERATIONS, RESPECTIVELY.   13750000
C                                                                       13760000
C          UNPACK AND DECODE  8-BIT  EXPERIMENT COUNTS FOR  X, Y, Z     13770000
C          FROM THE  24-BIT  REGISTER DATA IN CURRENT RECORD            13780000
C          (256 VALUES FOR EACH OF X,Y,Z)                               13790000
C                                                                       13800000
      J=0                                                               13810000
      MPAGE=-291                                                        13820000
      DO 2 IPAGE=1,4                                                    13830000
      MPAGE=MPAGE + 291                                                 13840000
      MSEQ=MPAGE + 2                                                    13850000
C                                                                       13860000
      DO 2 ISEQ=1,16                                                    13870000
C        UNPACK THE  4  24-BIT REGISTER FULL WORDS IN THIS SEQUENCE     13880000
      IFULL(1)=SHFTR(IDATA(MSEQ+5),8)                                   13890000
      IFULL(2)=SHFTL(IDATA(MSEQ+7),16)                                  13900000
      IFULL(2)=SHFTR(IFULL(2),8)                                        13910000
        I     =SHFTR(IDATA(MSEQ+8),24)                                  13920000
      IFULL(2)=LOR(IFULL(2),I)                                          13930000
      IFULL(3)=SHFTR(IDATA(MSEQ+10),8)                                  13940000
      IFULL(4)=SHFTL(IDATA(MSEQ+12),16)                                 13950000
      IFULL(4)=SHFTR(IFULL(4),8)                                        13960000
         I    =SHFTR(IDATA(MSEQ+13),24)                                 13970000
      IFULL(4)=LOR(IFULL(4),I)                                          13980000
C                                                                       13990000
C        UNPACK AND DECODE X, Y, Z COUNTS FROM THE FULL WORDS           14000000
      DO 1 I=1,4                                                        14010000
      IWRD=LXOR(IFULL(I),MASK)                                          14020000
      NX=SHFTL(IWRD,24)                                                 14030000
      NX=SHFTR(NX,24)                                                   14040000
      NY=SHFTL(IWRD,16)                                                 14050000
      NY=SHFTR(NY,24)                                                   14060000
      NZ=SHFTR(IWRD,16)                                                 14070000
      NZ=LXOR(NZ,ZMASK)                                                 14080000
      J=J+1                                                             14090000
      X(J)=255-NX                                                       14100000
      Y(J)=255-NY                                                       14110000
      Z(J)=255-NZ                                                       14120000
    1 CONTINUE                                                          14130000
      MSEQ=MSEQ + 15                                                    14140000
      IF(ISEQ .EQ. 8) MSEQ=MSEQ + 3                                     14150000
    2 CONTINUE                                                          14160000
      RETURN                                                            14170000
C                                                                       14180000
C                                                                       14190000
      ENTRY EXFLAG(IDATA,EXF)                                           14200000
      K=0                                                               14210000
      MPAGE=-291                                                        14220000
      DO 4 IPAGE=1,4                                                    14230000
      MPAGE=MPAGE+291                                                   14240000
      MSEQ=MPAGE+2                                                      14250000
      DO 3 ISEQ=1,16                                                    14260000
      MSEQ=MSEQ+15                                                      14270000
      K=K+1                                                             14280000
      EXF(K)=SHFTR(IDATA(MSEQ),24)                                      14290000
      IF(ISEQ .EQ. 8) MSEQ=MSEQ+3                                       14300000
    3 CONTINUE                                                          14310000
    4 CONTINUE                                                          14320000
      RETURN                                                            14330000
C                                                                       14340000
      ENTRY BEGEND(IDATA,KBEG,MBEG,KEND,MEND)                           14350000
C                                                                       14360000
C        FIND FIRST AND LAST NON-FILL SEQUENCES.                        14370000
C         1ST NON-FILL SEQUENCE IS  KBEG  HAVING  MSEQ = MBEG           14380000
C        LAST NON-FILL SEQUENCE IS  KEND  HAVING  MSEQ = MEND           14390000
      KBEG=0                                                            14400000
      K=0                                                               14410000
      MPAGE=-291                                                        14420000
      DO 85 IPAGE=1,4                                                   14430000
      MPAGE=MPAGE + 291                                                 14440000
      MSEQ =MPAGE + 2                                                   14450000
      DO 85 ISEQ=1,16                                                   14460000
      K=K+1                                                             14470000
C                                                                       14480000
C        CHECK 1ST FULL COUNT XYZ FOR ZERO FILL                         14490000
      KNTFUL=IDATA(MSEQ + 5)                                            14500000
      IF(KBEG .NE. 0) GO TO 83                                          14510000
      IF(KNTFUL .EQ. 0) GO TO 84                                        14520000
      KBEG=K                                                            14530000
      MBEG=MSEQ                                                         14540000
      KEND=K                                                            14550000
      MEND=MSEQ                                                         14560000
      GO TO 84                                                          14570000
   83 IF(KNTFUL .EQ. 0) GO TO 84                                        14580000
      KEND=K                                                            14590000
      MEND=MSEQ                                                         14600000
   84 MSEQ=MSEQ + 15                                                    14610000
      IF(ISEQ .EQ. 8) MSEQ=MSEQ + 3                                     14620000
   85 CONTINUE                                                          14630000
      RETURN                                                            14640000
C                                                                       14650000
C                                                                       14660000
      ENTRY OA(IDATA,SPIN,SEQ,AVSPIN)                                   14670000
C                                                                       14680000
C                                                                       14690000
C        UNPACK  O-A  DATA FOR PAGE 1 AND PAGE 4                        14700000
      IWRD1=IDATA(247)                                                  14710000
      IWRD4=IDATA(1120)                                                 14720000
      SPIN=0.0                                                          14730000
      IF(IWRD1 .EQ. 0  .OR.  IWRD4 .EQ. 0) RETURN                       14740000
C                                                                       14750000
C        COMPUTE SEQUENCE PERIOD = SEQ  (MILLISECONDS)                  14760000
      SEQ=FLOAT(IDATA(875) - IDATA(2))/48.0                             14770000
C                                                                       14780000
C        COMPUTE REFINED SPIN PERIOD = SPIN  (MILLISECONDS)             14790000
      ISP1=IWRD1                                                        14800000
      ISP4=IWRD4                                                        14810000
      IST1=SHFTR(IWRD1,16)                                              14820000
      IST4=SHFTR(IWRD4,16)                                              14830000
      L=L0                                                              14840000
      JSP1=I0                                                           14850000
      JSP4=I0                                                           14860000
      JST1=I0                                                           14870000
      JST4=I0                                                           14880000
C        UNPACK 16-BIT O-A DATA, SPIN AND SUN-TIME.                     14890000
C        DECODE O-A DATA BY LEFT-RIGHT REVERSING BITS AND ADDING 1 .    14900000
C        LOR IS SESD/360 LIBRARY ROUTINE FOR OR OPERATIONS.             14910000
C        I=LOR(J,K) CAUSES  I  TO HAVE A 1-BIT WHEREVER  J  OR  K  HAVE 14920000
C        A 1-BIT, ALL OTHER BITS WILL BE ZERO.                          14930000
      DO 20 I=1,16                                                      14940000
      IF(MOD(ISP1,2) .EQ. 1) JSP1=LOR(JSP1,L)                           14950000
      IF(MOD(ISP4,2) .EQ. 1) JSP4=LOR(JSP4,L)                           14960000
      IF(MOD(IST1,2) .EQ. 1) JST1=LOR(JST1,L)                           14970000
      IF(MOD(IST4,2) .EQ. 1) JST4=LOR(JST4,L)                           14980000
      ISP1=SHFTR(ISP1,1)                                                14990000
      ISP4=SHFTR(ISP4,1)                                                15000000
      IST1=SHFTR(IST1,1)                                                15010000
      IST4=SHFTR(IST4,1)                                                15020000
   20 L=SHFTR(L,1)                                                      15030000
      JSP1=JSP1 + 1                                                     15040000
      JSP4=JSP4+1                                                       15050000
      JST1=JST1+1                                                       15060000
      JST4=JST4+1                                                       15070000
      MSEC1=IDATA(2)                                                    15080000
      MSEC4=IDATA(875)                                                  15090000
      IF(MSEC1 .EQ. 0  .OR.  MSEC4 .EQ. 0) RETURN                       15100000
C       SEQ CONSIDERED EXACT (MSEC1, MSEC4 DERIVED FROM TELEMETRY RATE) 15110000
C       COMPUTE REFINED CLOCK RATE,  RCLOCK , FROM EXACT RATIO          15120000
C                  RCLOCK/6.4 = 1280/SEQ                                15130000
      RCLOCK=6.4*1280.0/SEQ                                             15140000
      SP1=FLOAT(JSP1)/RCLOCK                                            15150000
      SP4=FLOAT(JSP4)/RCLOCK                                            15160000
      AVSPIN=0.5*(SP1+SP4)                                              15170000
      DT=(JST4-JST1)/RCLOCK                                             15180000
      DT=DT+(MSEC4-MSEC1)                                               15190000
      NREV=0.5 + DT/AVSPIN                                              15200000
      SPIN=DT/NREV                                                      15210000
      RETURN                                                            15220000
      END                                                               15230000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00010000
C                                                                       00020000
C THIS ROUTINE READS A STANDARD VOYAGER SUMMARY TAPE AND EXTRACTS       00030000
C RECORDS FOR A SPECIFIED TIME PERIOD, AND COPIES THESE TO AN           00040000
C OUTPUT SUMMARY TAPE.  ONLY LFM RECORDS ARE COPIED.                    00050000
C                                                                       00060000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00070000
      INTEGER*2 I2REC(2500), YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,      00080000
     1                       YREND, DAYEND, HREND, MINEND, SECEND       00090000
      INTEGER*4 I4REC(1250), INREC/0/, INUNIT/10/,                      00100000
     1          OUTUNT/20/                                              00110003
      CHARACTER*4  RECTYP, L/'L   '/,                                   00111003
     1          LFM/'LFM '/, M/'M   '/, E1/'E1  '/, E2/'E2  '/          00120003
      EQUIVALENCE (I2REC(1), I4REC(1), RECTYP)                          00130004
    5 CONTINUE                                                          00140000
      READ (5,10) YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,                 00150000
     1            YREND, DAYEND, HREND, MINEND, SECEND                  00160000
   10 FORMAT (10I4)                                                     00170000
      WRITE (6,15) YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,                00190000
     1             YREND, DAYEND, HREND, MINEND, SECEND                 00200000
   15 FORMAT (' INPUT TIME BOUNDARIES:',10I4)                           00210000
   20 CONTINUE                                                          00220000
      INREC = INREC + 1                                                 00230000
      CALL FREAD (I4REC, INUNIT, NBYT, *70, *50)                        00240003
      IF (RECTYP .EQ. LFM) GO TO 25                                     00250003
      GO TO 20                                                          00300000
   25 CONTINUE                                                          00310000
      IF (I2REC(7) .LT. YRBEG) GO TO 20                                 00320000
      IF (I2REC(7) .GT. YRBEG) GO TO 30                                 00330000
      IF (I2REC(8) .LT. DAYBEG) GO TO 20                                00340000
      IF (I2REC(8) .GT. DAYBEG) GO TO 30                                00350000
      IF (I2REC(9) .LT. HRBEG) GO TO 20                                 00360000
      IF (I2REC(9) .GT. HRBEG) GO TO 30                                 00370000
      IF (I2REC(10) .LT. MINBEG) GO TO 20                               00380000
      IF (I2REC(10) .GT. MINBEG) GO TO 30                               00390000
      IF (I2REC(11) .LT. SECBEG) GO TO 20                               00400000
   30 CONTINUE                                                          00410000
      IF (I2REC(7) .LT. YREND) GO TO 40                                 00420000
      IF (I2REC(7) .GT. YREND) GO TO 70                                 00430002
      IF (I2REC(8) .LT. DAYEND) GO TO 40                                00440000
      IF (I2REC(8) .GT. DAYEND) GO TO 70                                00450002
      IF (I2REC(9) .LT. HREND) GO TO 40                                 00460000
      IF (I2REC(9) .GT. HREND) GO TO 70                                 00470002
      IF (I2REC(10) .LT. MINEND) GO TO 40                               00480000
      IF (I2REC(10) .GT. MINEND) GO TO 70                               00490002
      IF (I2REC(11) .GT. SECEND) GO TO 70                               00500002
   40 CONTINUE                                                          00510000
      CALL FWRITE (I4REC, OUTUNT, NBYT)                                 00520000
      GO TO 20                                                          00530000
   50 CONTINUE                                                          00540000
      WRITE (6,60) INREC                                                00550000
   60 FORMAT (' ERROR READING RECORD',I6)                               00560000
      GO TO 20                                                          00570000
   70 CONTINUE                                                          00580000
      STOP                                                              00590000
      END                                                               00600000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   00010000
C                                                                       00020000
C PROGRAM: LINTERP0                                                     00021000
C                                                                       00022000
C PURPOSE: PERFORM A LINEAR INTEROPLATION OF ZERO TABLE VALUES.         00030000
C    CREATE INTERPOLATED ZERO TABLES AT 5 DAY INTERVALS BETWEEN         00040000
C    THE INITIAL TABLES (PRESUMABLY OBTAINED FROM ROLLS).               00050000
C                                                                       00060000
C WRITTEN BY T. VOLLMER 12/10/90                                        00061000
C                                                                       00062000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC  00070000
      INTEGER*4 ADDR(2), LPYR/0/, ISW/0/,                               00071012
     1    IYR1, IDAY1, IHOUR1,                                          00072001
     2    IYR2, IDAY2, IHOUR2,                                          00073015
     3     ZERON(10,6)                                                  00074015
      REAL*4 ZERO1(10,6),                                               00080015
     1       ZERO2(10,6)                                                00090015
      REAL*8 NAME1, NAME2, NAME(2)/2*'NONAME  '/                        00100012
      EXTERNAL ZEROLD                                                   00101000
C READ NAMES AND TIMES OF ZERO TABLES (TIMES ARE THE TIMES              00102000
C OF THE ROLL/MANEUVER FROM WHICH THIS TABLE WAS DERIVED)               00103000
      READ(5,10)  ISC                                                   00104023
      WRITE(6,10) ISC                                                   00105023
      READ (5,11) NAME1, IYR1, IDAY1, IHOUR1                            00110023
      WRITE(6,11) NAME1, IYR1, IDAY1, IHOUR1                            00111023
      READ (5,11) NAME2, IYR2, IDAY2, IHOUR2                            00120023
      WRITE(6,11) NAME2, IYR2, IDAY2, IHOUR2                            00120123
   10 FORMAT(I1)                                                        00121023
   11 FORMAT (A8,3I4)                                                   00130023
      WRITE (6,20) ISC, NAME1, IYR1, IDAY1, IHOUR1,                     00140001
     1             NAME2, IYR2, IDAY2, IHOUR2                           00150001
   20 FORMAT (' SC = ',I1,2(/,1X, A8, 5X, 3I4))                         00160003
C READ IN ZERO LEVELS OF FIRST TABLE                                    00161000
      CALL LOADER (NAME1, NAME(1), ADDR(1), &200, &200)                 00170012
      ADDR(1) = ADDR(1) + 8                                             00171012
      CALL LINK (ADDR(1), ZERO1, ZEROLD)                                00172012
C READ IN ZERO LEVELS OF SECOND TABLE                                   00173000
      CALL LOADER (NAME2, NAME(1), ADDR, &300, &300)                    00174012
      ADDR(1) = ADDR(1) + 8                                             00175012
      CALL LINK (ADDR(1), ZERO2, ZEROLD)                                00176012
      IF(MOD(IYR1,4).EQ.0) LPYR=1                                       00177001
      IF(IYR1.NE.IYR2)ISW=1                                             00178001
      IYRST = IYR1                                                      00178101
      IDAYST = IDAY1 + 1                                                00179010
   23 CONTINUE                                                          00179110
      IF (MOD(IDAYST,5) .EQ. 1) GO TO 27                                00179210
          IDAYST = IDAYST + 1                                           00179310
          GO TO 23                                                      00179410
   27 CONTINUE                                                          00179510
      IF (IDAYST .LT. 365) GO TO 30                                     00179601
          IYRST = IYRST + 1                                             00179701
          IDAYST = 1                                                    00179801
   30 CONTINUE                                                          00179901
      IYREN = IYR2                                                      00180001
      IDAYEN = IDAY2                                                    00180110
   33 CONTINUE                                                          00180210
      IF (MOD(IDAYEN,5) .EQ. 1)  GO TO 37                               00180310
          IDAYEN = IDAYEN - 1                                           00180410
          GO TO 33                                                      00180510
   37 CONTINUE                                                          00180610
      IDAYEN = IDAYEN - 5                                               00180710
      IF (IDAYEN .GT. 0) GO TO 40                                       00180801
          IYREN = IYREN - 1                                             00180901
          IDAYEN = 361                                                  00181001
   40 CONTINUE                                                          00181101
      CALL DELDAY (IYR1, IDAY1, IHOUR1, IYR2, IDAY2, IHOUR2, DAYROL)    00181201
      IYRN = IYRST                                                      00181501
      IDAYN = IDAYST                                                    00181601
   50 CONTINUE                                                          00181701
      CALL DELDAY (IYR1, IDAY1, IHOUR1, IYRN, IDAYN + 2, 12, DAY)       00181801
      DO 60 I = 1, 10                                                   00182101
      DO 60 J = 1, 6                                                    00182201
          ZERON(I, J) = INT(ZERO1(I,J) +                                00182317
     1      (DAY * (ZERO2(I,J) - ZERO1(I,J)) / DAYROL) + .5)            00182421
   60 CONTINUE                                                          00182501
      WRITE (20,70) IYRN, IDAYN,ISC,ISC, IYRN, IDAYN, ZERON             00182622
   70 FORMAT('F',I2,I3,'Z',I1,' CSECT   FLIGHT ',I1,' 19',              00182709
     1       I2,' DAY ',I3,/,9X,'GENDATE'/,                             00182809
     2        'XI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00182901
     3             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183001
     4        'YI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183101
     5             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183201
     6        'ZI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183301
     7             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183401
     8        'XO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183501
     9             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183601
     A        'YO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183701
     B             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183801
     C        'ZO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00183901
     D             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00184001
     E             T10,'END')                                           00184101
      IDAYN = IDAYN + 5                                                 00184201
      IF (IDAYN .LT. 365) GO TO 80                                      00184301
          IYRN = IYRN + 1                                               00184401
          IDAYN = 1                                                     00184501
   80 CONTINUE                                                          00184601
      IF ((IYRN .EQ. IYREN) .AND. (IDAYN .GT. IDAYEN)) GO TO 400        00184701
      GO TO 50                                                          00184801
  200 CONTINUE                                                          00185000
      WRITE (6, 210) NAME1                                              00190023
  210 FORMAT (' ERROR READING ', A8)                                    00200000
      GO TO 400                                                         00201000
  300 CONTINUE                                                          00210000
      WRITE (6, 310) NAME2                                              00220023
  310 FORMAT (' ERROR READING ', A8)                                    00230000
  400 CONTINUE                                                          00240000
      STOP                                                              00250000
      END                                                               00260000
      SUBROUTINE ZEROLD (TABIN, TABOUT)                                 00270001
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00280000
C                                                                       00290000
C THIS SUBROUTINE MOVES THE 0 TABLE VALUES INTO                         00300001
C A LOCAL ARRAY FROM THE CALLING PROGRAM                                00310000
C                                                                       00320000
C                                                                       00380000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00390000
      REAL*4 TABIN(10,6), TABOUT(10,6)                                  00400015
      DO 20 IRNG=1, 10                                                  00420001
          DO 10 ICOORD=1, 6                                             00430001
              TABOUT(IRNG, ICOORD) = TABIN(IRNG, ICOORD)                00450001
   10     CONTINUE                                                      00460000
   20 CONTINUE                                                          00470000
      RETURN                                                            00480000
      END                                                               00490000
      SUBROUTINE DELDAY (IYR1, IDAY1, IHOUR1,                           00500002
     1                   IYR2, IDAY2, IHOUR2, DAYS)                     00510002
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC    00520002
C                                                                       00530002
C PURPOSE: THIS SUBROUTINE CALCULATES THE NUMBER OF DAYS (INCLUDING     00540002
C     FRACTION) BETWEEN TIMES 1 AND 2.                                  00550002
C                                                                       00560002
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   00570002
      IF(MOD(IYR1,4).EQ.0) LPYR=1                                       00580002
      IF(IYR1.NE.IYR2)ISW=1                                             00590002
      DAY1 = FLOAT(IDAY1) + FLOAT(IHOUR1) / 24.                         00600003
      DAY2 = FLOAT(IDAY2) + FLOAT(IHOUR2) / 24.                         00610003
      IF (IYR1.NE.IYR2) DAY2 = DAY2 + 365. + LPYR                       00620002
      DAYS = DAY2 - DAY1                                                00630002
      RETURN                                                            00640002
      END                                                               00650002
C     PROGRAM READS VOYAGER ELECTRON COMPRESSED SUMMARY TAPES.          00000040
C     SEARCHES AND LISTS WHAT DAYS ARE ON THE TAPE.                     00000050
      DIMENSION RDATA(600),RPROTN(150),ELECTN(80)                       00000060
      INTEGER*2 ITIME(6),KDAT(16),ITLMOD,ICLK                           00000070
      LOGICAL*4 ID,IDTEST(2)/'M   ','E1  '/,SC                          00000080
      LOGICAL*1 LSTAT(4)                                                00000090
      EQUIVALENCE (ID,RDATA(1)),(RPROTN(1),RDATA(33)),(SC,RDATA(3))     00000100
     1 ,(ELECTN(1),RDATA(33)),(ITIME(1),RDATA(4)),(LSTAT(1),RDATA(15))  00000110
     2 ,(KDAT(1),RDATA(163)),(JSTAT,LSTAT(1))                           00000120
      IERR = 0                                                          00000130
      INUM = 0                                                          00000140
    1  CONTINUE                                                         00000150
       CALL FREAD(RDATA,8,LEN,&100,&200)                                00000160
       DO 3 I = 1,2                                                     00000170
       IF(ID.EQ.IDTEST(I)) GO TO 2                                      00000180
    3  CONTINUE                                                         00000190
       GO TO 1                                                          00000200
    2  INUM = INUM + 1                                                  00000210
      IF(INUM.EQ.1) PRINT 998,SC                                        00000220
      IF(INUM.EQ.1) IDAY = ITIME(2)                                     00000230
      IF(IDAY.EQ.ITIME(2).AND.INUM.NE.1) GO TO 1                        00000240
      IDAY = ITIME(2)                                                   00000250
      PRINT 995,ID,ITIME                                                00000260
      GO TO 1                                                           00000270
C     READ ERROR                                                        00000280
  200 CONTINUE                                                          00000290
      DO 400 K=1,46                                                     00000300
  400 CALL FREAD(RDATA,8,LEN,&100,&200)                                 00000310
      IERR = IERR + 1                                                   00000320
      PRINT 997,IERR                                                    00000330
      GO TO 1                                                           00000340
C     END OF TAPE                                                       00000350
  100 PRINT 996,INUM                                                    00000360
C     FORMAT STATEMENTS                                                 00000370
  998 FORMAT(1H0,'SPACECRAFT ID = ',A4)                                 00000380
  997 FORMAT(1H0,'READ ERROR OCCURRED',I8)                              00000390
  996 FORMAT(1H0,'END OF JOB',I8)                                       00000400
  995 FORMAT(1H0,'ID,TIME = ',A4,4X,6I6)                                00000410
      STOP                                                              00000420
      END                                                               00000430
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00010000
C                                                                       00020000
C THIS ROUTINE READS A STANDARD VOYAGER SUMMARY TAPE AND EXTRACTS       00030000
C RECORDS FOR THE SPECIFIED RECORD TYPE AND TIME PERIOD.                00031000
C THESE RECORDS ARE COPIED TO AN OUTPUT SUMMARY TAPE (OR OTHER FILE)    00040000
C                                                                       00050000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00070000
      INTEGER*2 I2REC(2500), YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,      00080000
     1                       YREND, DAYEND, HREND, MINEND, SECEND       00090000
      INTEGER*4 I4REC(1250), INREC/0/, RECTYP, INUNIT/10/,              00100000
     1          OUTUNT/20/                                              00110000
      EQUIVALENCE (I2REC(1), I4REC(1))                                  00130000
      READ (5,5) RECTYP                                                 00141000
    5 FORMAT (A4)                                                       00142000
      READ (5,10) YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,                 00150000
     1            YREND, DAYEND, HREND, MINEND, SECEND                  00160000
   10 FORMAT (10I4)                                                     00170000
      WRITE (6,15) YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,                00190000
     1             YREND, DAYEND, HREND, MINEND, SECEND                 00200000
   15 FORMAT (' INPUT TIME BOUNDARIES:',10I4)                           00210000
   20 CONTINUE                                                          00220000
      INREC = INREC + 1                                                 00230000
      CALL FREAD (I4REC, INUNIT, NBYT, &70, &50)                        00240000
      IF (I4REC(1) .EQ. RECTYP) GO TO 25                                00250001
      GO TO 20                                                          00300000
   25 CONTINUE                                                          00310000
      IF (I2REC(7) .LT. YRBEG) GO TO 20                                 00320000
      IF (I2REC(7) .GT. YRBEG) GO TO 30                                 00330000
      IF (I2REC(8) .LT. DAYBEG) GO TO 20                                00340000
      IF (I2REC(8) .GT. DAYBEG) GO TO 30                                00350000
      IF (I2REC(9) .LT. HRBEG) GO TO 20                                 00360000
      IF (I2REC(9) .GT. HRBEG) GO TO 30                                 00370000
      IF (I2REC(10) .LT. MINBEG) GO TO 20                               00380000
      IF (I2REC(10) .GT. MINBEG) GO TO 30                               00390000
      IF (I2REC(11) .LT. SECBEG) GO TO 20                               00400000
   30 CONTINUE                                                          00410000
      IF (I2REC(7) .LT. YREND) GO TO 40                                 00420000
      IF (I2REC(7) .GT. YREND) GO TO 70                                 00430000
      IF (I2REC(8) .LT. DAYEND) GO TO 40                                00440000
      IF (I2REC(8) .GT. DAYEND) GO TO 70                                00450000
      IF (I2REC(9) .LT. HREND) GO TO 40                                 00460000
      IF (I2REC(9) .GT. HREND) GO TO 70                                 00470000
      IF (I2REC(10) .LT. MINEND) GO TO 40                               00480000
      IF (I2REC(10) .GT. MINEND) GO TO 70                               00490000
      IF (I2REC(11) .GT. SECEND) GO TO 70                               00500000
   40 CONTINUE                                                          00510000
      CALL FWRITE (I4REC, OUTUNT, NBYT)                                 00520000
      GO TO 20                                                          00530000
   50 CONTINUE                                                          00540000
      WRITE (6,60) INREC                                                00550000
   60 FORMAT (' ERROR READING RECORD',I6)                               00560000
      GO TO 20                                                          00570000
   70 CONTINUE                                                          00580000
      STOP                                                              00590000
      END                                                               00600000
C THIS ROUTINE PRINTS VOYAGER MICROFICHE DATA FROM A STANDARD           00010009
C VOYAGER MICROFICHE TAPE.  0, 1, OR 2 COPIES ARE PRINTED DEPENDING     00020009
C ON THE CONTENTS THE PARM FIELD WHEN THE PROGRAM IS INVOKED.           00030009
C IF ONE COPY IS TO BE PRINTED, IT IS PRINTED ON FT10F001.  IF TWO      00040009
C COPIES AREW REQUESTED, ONE IS PRINTED ON FT10F001, AND THE OTHER IS   00050009
C PRINTED ON FT11F001.  (NOTE: THIS IS THE SECOND VERSION OF THIS       00060009
C PROGRAM, THE ORIGINAL HAVING BEEN LOST, AND MYSTERIOUSLY CEASED TO    00070009
C WORK - 4/15/85)                                                       00080009
      LOGICAL*1 LINE(133)                                               00090009
      LOGICAL*1 NLIST, ZERO/'0'/, ONE/'1'/, TWO/'2'/                    00100009
      CALL PARM (NBYTE, NLIST)                                          00110009
C     WRITE (6,1) NBYTE, NLIST                                          00120009
C   1 FORMAT (' NBYTE =',I5,5X,A1)                                      00130009
      IF (NLIST .EQ. ZERO) STOP                                         00140009
    5 CALL FREAD (LINE, 5, NBYTE, &200, &100)                           00150009
      WRITE (10, 10) (LINE(I),I=1,NBYTE)                                00160009
   10 FORMAT (133A1)                                                    00170009
      IF (NLIST .EQ. TWO) WRITE (11, 10) (LINE(I),I=1,NBYTE)            00180009
      GO TO 5                                                           00190009
  100 CONTINUE                                                          00200009
      WRITE (6, 110)                                                    00210009
  110 FORMAT (' I/O ERROR')                                             00220009
      GO TO 5                                                           00230009
  200 CONTINUE                                                          00240009
      STOP                                                              00250009
      END                                                               00260009
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00000000
C                                                                       00000100
C PROGRAMMER: T. W. VOLLMER (GSFC)                                      00000201
C                                                                       00000301
C DATE: JUNE 14, 1984                                                   00000401
C                                                                       00000501
C THIS ROUTINE READS A STANDARD VOYAGER SUMMARY TAPE AND COPIES IT TO   00000600
C MASS STORAGE.  ENGINEERING RECORDS ARE NOT COPIED. VOYAGER 2 PLASMA   00000701
C DATA AFTER 80/330 ARE NOT COPIED BECAUSE THE PLS EXPERIMENT CEASED    00000801
C WORKING ON THAT DAY.                                                  00000901
C                                                                       00001001
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00001500
      INTEGER*2 I2REC(2500)                                             00001600
      INTEGER*4 I4REC(1250), INREC/0/, INUNIT/10/,                      00001700
     1          OUTUNT/20/,ENG/'ENG '/,FLT1/'FLT1'/,                    00001800
     1         M/'M   '/,L/'L   '/,E1/'E1  '/,E2/'E2  '/                00001900
      EQUIVALENCE (I2REC(1), I4REC(1))                                  00002000
   20 CONTINUE                                                          00002100
      INREC = INREC + 1                                                 00002200
      CALL FREAD (I4REC, INUNIT, NBYT, &70, &50)                        00002300
      IF (I4REC(1) .EQ. ENG) GOTO 20                                    00002400
      IF (I4REC(3) .NE. FLT1) GO TO 30                                  00002503
      IF (I2REC(7)  .GT. 80) GO TO 40                                   00002603
      IF (I2REC(7)  .EQ. 80 .AND. I2REC(8) .GE. 330) GO TO 40           00002703
      GO TO 30                                                          00002803
  40  CONTINUE                                                          00002903
      IF (I4REC(1) .EQ. M) GO TO 20                                     00003003
      IF (I4REC(1) .EQ. L) GO TO 20                                     00003103
      IF (I4REC(1) .EQ. E1) GO TO 20                                    00003203
      IF (I4REC(1) .EQ. E2) GO TO 20                                    00003303
   30 CALL FWRITE (I4REC, OUTUNT, NBYT)                                 00003400
      GO TO 20                                                          00003500
   50 CONTINUE                                                          00003600
      WRITE (6,60) INREC                                                00003700
   60 FORMAT (' ERROR READING RECORD',I6)                               00003800
      GO TO 20                                                          00003900
   70 CONTINUE                                                          00004000
      STOP                                                              00004100
      END                                                               00005000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00000000
C                                                                       00000100
C PROGRAMMER: T. W. VOLLMER (GSFC)                                      00000201
C                                                                       00000301
C DATE: JUNE 14, 1984                                                   00000401
C                                                                       00000501
C THIS ROUTINE READS A STANDARD VOYAGER SUMMARY TAPE AND COPIES IT TO   00000600
C MASS STORAGE.  ENGINEERING RECORDS ARE NOT COPIED. VOYAGER 2 PLASMA   00000701
C DATA AFTER 80/330 ARE NOT COPIED BECAUSE THE PLS EXPERIMENT CEASED    00000801
C WORKING ON THAT DAY.                                                  00000901
C                                                                       00001001
C THIS VERSION OF THE PROGRAM (MTOMSSV1) IS INTENDED FOR USE WITH       00001102
C V1 DATA AFTER THE DEMISE OF THE PLASMA INSTRUMENT.  THIS ROUTINE      00001202
C COPIES ALL RECORDS (EXCEPT ENG) TO MSS.  THIS VERSION IS BY SPECIAL   00001302
C REQUEST ONLY (USUALLY BY MIT)                                         00001402
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00001500
      INTEGER*2 I2REC(2500)                                             00001600
      INTEGER*4 I4REC(1250), INREC/0/, INUNIT/10/,                      00001700
     1          OUTUNT/20/,ENG/'ENG '/,FLT1/'FLT1'/,                    00001800
     1         M/'M   '/,L/'L   '/,E1/'E1  '/,E2/'E2  '/                00001900
      EQUIVALENCE (I2REC(1), I4REC(1))                                  00002000
   20 CONTINUE                                                          00002100
      INREC = INREC + 1                                                 00002200
      CALL FREAD (I4REC, INUNIT, NBYT, &70, &50)                        00002300
      IF (I4REC(1) .EQ. ENG) GOTO 20                                    00002400
C     IF (I4REC(3) .NE. FLT1) GO TO 30                                  00002502
C     IF (I2REC(7)  .GT. 80) GO TO 40                                   00002602
C     IF (I2REC(7)  .EQ. 80 .AND. I2REC(8) .GE. 330) GO TO 40           00002702
C     GO TO 30                                                          00002802
C 40  CONTINUE                                                          00002902
C     IF (I4REC(1) .EQ. M) GO TO 20                                     00003002
C     IF (I4REC(1) .EQ. L) GO TO 20                                     00003102
C     IF (I4REC(1) .EQ. E1) GO TO 20                                    00003202
C     IF (I4REC(1) .EQ. E2) GO TO 20                                    00003302
   30 CALL FWRITE (I4REC, OUTUNT, NBYT)                                 00003400
      GO TO 20                                                          00003500
   50 CONTINUE                                                          00003600
      WRITE (6,60) INREC                                                00003700
   60 FORMAT (' ERROR READING RECORD',I6)                               00003800
      GO TO 20                                                          00003900
   70 CONTINUE                                                          00004000
      STOP                                                              00004100
      END                                                               00005000
      SUBROUTINE HEAD(SEDREC)                                           00001001
      INTEGER*4 IC/0/,SEDREC(1)                                         00001101
      IC = IC + 1                                                       00001200
C     WRITE (6,10) IC, SEDREC(14)                                       00001302
C  10 FORMAT (' HEADER #',I3,3X,A4)                                     00001402
      RETURN                                                            00002000
      END                                                               00003000
      SUBROUTINE NAV (NAVREC, NAVBYT)                                   00010000
      INTEGER*4 NAVREC(252),NAVBYT                                      00020000
      WRITE (6,10) (NAVREC(I),I=1,6), NAVREC(83)                        00030006
   10 FORMAT (' NAV ',I5,'/',I3,':',I2,':',I2,':',I2,'.',I3,            00040003
     1        /,'    RANGE =',E22.11)                                   00050007
      RETURN                                                            00060000
      END                                                               00070000
      SUBROUTINE PV (PVREC)                                             00080000
C     INTEGER*4 PVREC(126)                                              00090002
C     WRITE (6,10) (PVREC(I),I=1,6),PVREC(101)                          00100002
C  10 FORMAT (' PV  ',I5,'/',I3,':',I2,':',I2,':',I2,'.',I3,' WD 101 =',00110002
C    1        Z8)                                                       00120002
      RETURN                                                            00130000
      END                                                               00140000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00010024
C                                                                       00020032
C PURPOSE: THIS ROUTINE CALCULATES AVERAGES OF BZ IN PAYLOAD            00030032
C    FROM STANDARD VOYAGER HOURLY AVERAGES.  THIS AVERAGE               00040040
C    SHOULD BE 0, ACCORDING TO THE PARKER MODE.  IF THE HOUR AVERAGE    00050040
C    IS IN HG COORDINATES, THE BR COMPONENT IS ANALYZED.                00051040
C    THE NAME OF THE ZERO TABLE TO BE ADJUSTED IS READ.  THE Z          00052040
C    COMPONENT OF THIS TABLE IS ADJUSTED, AND A NEW TABLE IS OUTPUT     00052140
C    WITH THE SAME NAME AS THE INPUT TABLE, WITH THE FIRST LETTER       00052240
C    CHANGED TO "B".                                                    00052340
C                                                                       00052440
C                       *****************                               00052540
C                       **** WARNING ****                               00052640
C                       *****************                               00052740
C    IT IS ESSENTIAL THAT THE Z COMPONENT OF THIS TABLE IS IDENTICAL    00053040
C    WITH THE Z COMPONENT OF THE ZEROS USED TO CALCULATE THE            00054040
C    HOUR AVERAGES.                                                     00055040
C                                                                       00060032
C VARIABLES:                                                            00070032
C    F1    : MAG FIELD HOUR AVERAGE AS INPUT                            00080040
C    DELTA : DELTA ANGLE HOUR AVGERAGE AS INPUT                         00090032
C    LAMBDA: LAMBDA ANGLE HOUR AVERAGE AS INPUT                         00100032
C    N     : COUNT OF POINTS IN AVERAGE                                 00110040
C                                                                       00120032
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00130011
      IMPLICIT REAL(L)                                                  00130138
      EXTERNAL ZEROLD                                                   00131036
      LOGICAL*1 LETTER, B/'B'/, FIRST/.TRUE./                           00150041
      INTEGER*2 ICOORD, HG/'HG'/, PL/'PL'/, ICRDSV                      00150141
      INTEGER*4 ADDR(2), ZERON(10,3,2)                                  00150243
      REAL*4 ZERO(10,3,2), SENS(10,3,2)                                 00150338
      REAL*8 ZERNAM, SENNAM, NAME(2)/2*'NONAME  '/                      00151038
      EQUIVALENCE (LETTER, ZERNAM)                                      00153035
C                                                                       00200023
C                                                                       00250023
      N = 0                                                             00320035
      BZSUM = 0.                                                        00350035
   20 CONTINUE                                                          00360036
          READ (10,30, END=60) ICOORD, IYRAVG, IDYAVG, IHRAVG,          00361036
     1                 F1, DELTA, LAMBDA, ICNT                          00361140
   30     FORMAT (1X, A2, 19X, I2, I3, I2, F5.2, 2F5.1, I2)             00362036
C         IF (IYRAVG .LT. IYRB) GO TO 20                                00363054
C         IF (IYRAVG .GT. IYRB) GO TO 40                                00364054
C         IF (IDYAVG .LT. IDAYB) GO TO 20                               00365054
C         IF (IDYAVG .GT. IDAYB) GO TO 40                               00366054
C         IF (IHRAVG .LT. IHRB) GO TO 20                                00367054
C  40     CONTINUE                                                      00368054
C         IF (IYRAVG .LT. IYRE) GO TO 50                                00369054
C         IF (IYRAVG .GT. IYRE) GO TO 60                                00369154
C         IF (IDYAVG .LT. IDAYE) GO TO 50                               00369254
C         IF (IDYAVG .GT. IDAYE) GO TO 60                               00369354
CC        IF (IHRAVG .GT. IHRE) GO TO 60                                00369454
CC 50     CONTINUE                                                      00369554
          IF ((ICOORD .NE. HG) .AND. (ICOORD .NE. PL)) GO TO 200        00369656
C         IF (ICOORD .NE. HG) GO TO 200                                 00369757
          IF (.NOT. FIRST) GO TO 53                                     00369841
              WRITE (6, 52) ICOORD                                      00369941
   52         FORMAT (' COORDINATE SYSTEM: ',A2)                        00370041
              ICRDSV = ICOORD                                           00370141
              FIRST = .FALSE.                                           00370241
   53     CONTINUE                                                      00370341
          IF (ICOORD .NE. ICRDSV) WRITE (6, 54) ICOORD, ICRDSV          00370441
   54     FORMAT (' COORDINATE SYSTEM ',A2, ' DOES NOT MATCH ',         00370541
     1            'INITIAL SYSTEM ', A2)                                00370641
C                                                                       00371023
C  CONVERT TO BZ                                                        00380036
C                                                                       00390023
          DELTA = DELTA * .01745329                                     00400036
          LAMBDA = LAMBDA * .01745329                                   00410036
          IF (ICOORD .EQ. HG) BZ = F1 * COS(DELTA) * COS(LAMBDA)        00420041
          IF (ICOORD .EQ. PL) BZ = F1 * SIN(DELTA)                      00440041
          WRITE (6,57) IYRAVG, IDYAVG, IHRAVG, BZ, DELTA,LAMBDA         00441048
   57     FORMAT (1X,I2,'/',I3,':',I2,1X,F7.3,3X,(2X,2F7.3))            00442050
          BZSUM = BZSUM + (BZ * ICNT)                                   00460055
          N = N + ICNT                                                  00490036
          GO TO 20                                                      00520036
   60 CONTINUE                                                          00530036
      IF (N .EQ. 0) GO TO 300                                           00540039
      BZAVG = BZSUM / N                                                 00560036
      WRITE (6, 70) BZAVG                                               00570036
   70 FORMAT(////,' BZAVG',1X,F7.3)                                     00580036
C                                                                       00581036
C READ ZERO AND SENSITIVITY TABLE NAMES                                 00590034
C                                                                       00591036
      READ (5, 80) ZERNAM, SENNAM                                       00600036
   80 FORMAT (A8, 1X, A8)                                               00600136
C                                                                       00600236
C READ ZERO AND SENSITIVITY TABLES                                      00600336
C                                                                       00600436
      CALL LOADER (ZERNAM, NAME(1), ADDR(1), &400, &400)                00601043
      ADDR(1) = ADDR(1) + 8                                             00604036
      CALL LINK (ADDR(1), ZERO, ZEROLD)                                 00605036
      DO 87 IMAG=1,2                                                    00605143
          DO 85 ICRD=1,3                                                00605243
             DO 83 IRNG=1,10                                            00605343
                 ZERON(IRNG,ICRD,IMAG) = INT(ZERO(IRNG,ICRD,IMAG))      00605443
   83        CONTINUE                                                   00605543
   85     CONTINUE                                                      00605643
   87 CONTINUE                                                          00605743
      WRITE ( 6,111) ZERNAM, ZERON                                      00606046
      CALL LOADER (SENNAM, NAME(2), ADDR(2), &500, &500)                00608043
      ADDR(2) = ADDR(2) + 8                                             00609036
      CALL LINK (ADDR(2), SENS, ZEROLD)                                 00609136
C                                                                       00609236
C CORRECT THE ZERO TABLE                                                00609336
C                                                                       00609459
C IMAG = 1,1 APPLIES THE OFFSETS TO THE SECONDARY MAG ONLY. INBOARD     00609560
C TIM MCCLANAHAN 11/30/92. FOR SINGLE MAG ONLY (FILTER) V2              00609659
C                                                                       00609736
      DO 100 IMAG = 1,1                                                 00609860
          DO 90 IRNG = 1,8                                              00609936
              ZERON(IRNG, 3, IMAG) = INT(ZERO(IRNG, 3, IMAG)            00610043
     1              + (BZAVG / SENS(IRNG, 3, IMAG)) + .5)               00610136
   90     CONTINUE                                                      00610236
  100 CONTINUE                                                          00610336
      LETTER = B                                                        00611037
      WRITE (06,111) ZERNAM, ZERON                                      00612046
      WRITE (20,110) ZERNAM, ZERON                                      00620043
  110 FORMAT(A8, ' CSECT',                                              00630039
     1          /,9X,'GENDATE'/,                                        00640037
     2        'XI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00650037
     3             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00660037
     4        'YI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00670037
     5             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00680037
     6        'ZI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00690037
     7             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00691037
     8        'XO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00692037
     9             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00693037
     A        'YO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00694037
     B             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00695037
     C        'ZO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00696037
     D             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00697037
     E             T10,'END')                                           00698037
  111 FORMAT(1X,A8, ' CSECT',                                           00698146
     1          /,9X,'GENDATE'/,                                        00698246
     2        ' XI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698347
     3             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00698446
     4        ' YI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698547
     5             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00698646
     6        ' ZI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698747
     7             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00698846
     8        ' XO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698947
     9             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00699046
     A        ' YO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00699147
     B             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00699246
     C        ' ZO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00699347
     D             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00699446
     E             T10,'END')                                           00699546
      GO TO 1000                                                        00699639
  200 CONTINUE                                                          00699739
      WRITE (6, 210)                                                    00699839
  210 FORMAT (' ***** HOUR AVERAGE IS NOT HG OR PL *****')              00699941
      GO TO 1000                                                        00700039
  300 CONTINUE                                                          00700139
      WRITE (6, 310)                                                    00700239
  310 FORMAT (' ***** NO HOUR AVERAGES IN REQUESTED PERIOD *****')      00700339
      GO TO 1000                                                        00700443
  400 CONTINUE                                                          00700543
      WRITE (6, 410) ZERNAM                                             00700643
  410 FORMAT (' ERROR READING ', A8)                                    00700743
      GO TO 1000                                                        00700843
  500 CONTINUE                                                          00700943
      WRITE (6, 410) SENNAM                                             00701043
 1000 STOP                                                              00701139
      END                                                               00701242
      SUBROUTINE ZEROLD (TABIN, TABOUT)                                 00701336
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00702036
C                                                                       00703036
C THIS SUBROUTINE MOVES THE 0 TABLE VALUES INTO                         00704036
C A LOCAL ARRAY FROM THE CALLING PROGRAM                                00705036
C                                                                       00706036
C                                                                       00707036
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00708036
      REAL*4 TABIN(10,6), TABOUT(10,6)                                  00709036
      DO 20 IRNG=1, 10                                                  00709136
          DO 10 ICOORD=1, 6                                             00709236
              TABOUT(IRNG, ICOORD) = TABIN(IRNG, ICOORD)                00709336
   10     CONTINUE                                                      00709436
   20 CONTINUE                                                          00709536
      RETURN                                                            00709636
      END                                                               00710011
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00010000
C                                                                       00020000
C THIS ROUTINE READS A STANDARD VOYAGER SUMMARY TAPE AND EXTRACTS       00030000
C RECORDS FOR A SPECIFIED TIME PERIOD, AND COPIES THESE TO AN           00040000
C OUTPUT SUMMARY TAPE.  ONLY E1,E2,L,M RECORDS ARE COPIED.              00050001
C                                                                       00060000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00070000
      INTEGER*2 I2REC(2500), YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,      00080000
     1                       YREND, DAYEND, HREND, MINEND, SECEND       00090000
      INTEGER*4 I4REC(1250), INREC/0/, INUNIT/10/,                      00100000
     1          OUTUNT/6/, ENG/'ENG '/, L/'L   '/,                      00110004
     2          LFM/'LFM '/, M/'M   '/, E1/'E1  '/, E2/'E2  '/          00120000
      EQUIVALENCE (I2REC(1), I4REC(1))                                  00130000
    5 CONTINUE                                                          00140000
      READ (5,10) YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,                 00150000
     1            YREND, DAYEND, HREND, MINEND, SECEND                  00160000
   10 FORMAT (10I4)                                                     00170000
      WRITE (6,15) YRBEG, DAYBEG, HRBEG, MINBEG, SECBEG,                00190000
     1             YREND, DAYEND, HREND, MINEND, SECEND                 00200000
   15 FORMAT (' INPUT TIME BOUNDARIES:',10I4)                           00210000
   20 CONTINUE                                                          00220000
      INREC = INREC + 1                                                 00230000
      CALL FREAD (I4REC, INUNIT, NBYT, &70, &50)                        00240000
      IF ((I4REC(1) .EQ. E1) .OR.                                       00250002
     1    (I4REC(1) .EQ. E2) .OR.                                       00260003
     2    (I4REC(1) .EQ. L) .OR.                                        00270003
     3    (I4REC(1) .EQ. M)) GO TO 25                                   00280002
      GO TO 20                                                          00290002
   25 CONTINUE                                                          00300002
      IF (I2REC(7) .LT. YRBEG) GO TO 20                                 00320000
      IF (I2REC(7) .GT. YRBEG) GO TO 30                                 00330000
      IF (I2REC(8) .LT. DAYBEG) GO TO 20                                00340000
      IF (I2REC(8) .GT. DAYBEG) GO TO 30                                00350000
      IF (I2REC(9) .LT. HRBEG) GO TO 20                                 00360000
      IF (I2REC(9) .GT. HRBEG) GO TO 30                                 00370000
      IF (I2REC(10) .LT. MINBEG) GO TO 20                               00380000
      IF (I2REC(10) .GT. MINBEG) GO TO 30                               00390000
      IF (I2REC(11) .LT. SECBEG) GO TO 20                               00400000
   30 CONTINUE                                                          00410000
      IF (I2REC(7) .LT. YREND) GO TO 40                                 00420000
      IF (I2REC(7) .GT. YREND) GO TO 70                                 00430000
      IF (I2REC(8) .LT. DAYEND) GO TO 40                                00440000
      IF (I2REC(8) .GT. DAYEND) GO TO 70                                00450000
      IF (I2REC(9) .LT. HREND) GO TO 40                                 00460000
      IF (I2REC(9) .GT. HREND) GO TO 70                                 00470000
      IF (I2REC(10) .LT. MINEND) GO TO 40                               00480000
      IF (I2REC(10) .GT. MINEND) GO TO 70                               00490000
      IF (I2REC(11) .GT. SECEND) GO TO 70                               00500000
   40 CONTINUE                                                          00510000
      CALL FWRITE (I4REC, OUTUNT, NBYT)                                 00520000
      GO TO 20                                                          00530000
   50 CONTINUE                                                          00540000
      WRITE (6,60) INREC                                                00550000
   60 FORMAT (' ERROR READING RECORD',I6)                               00560000
      GO TO 20                                                          00570000
   70 CONTINUE                                                          00580000
      STOP                                                              00590000
      END                                                               00600000
      END                                                               00010062
      READ (5, 80) ZERNAM, SENNAM                                       00600036
   80 FORMAT (A8, 1X, A8)                                               00600136
C                                                                       00600236
C READ ZERO AND SENSITIVITY TABLES                                      00600336
C                                                                       00600436
      CALL LOADER (ZERNAM, NAME(1), ADDR(1), &400, &400)                00601043
      ADDR(1) = ADDR(1) + 8                                             00604036
      CALL LINK (ADDR(1), ZERO, ZEROLD)                                 00605036
      DO 87 IMAG=1,2                                                    00605143
          DO 85 ICRD=1,3                                                00605243
             DO 83 IRNG=1,10                                            00605343
                 ZERON(IRNG,ICRD,IMAG) = INT(ZERO(IRNG,ICRD,IMAG))      00605443
   83        CONTINUE                                                   00605543
   85     CONTINUE                                                      00605643
   87 CONTINUE                                                          00605743
      WRITE ( 6,111) ZERNAM, ZERON                                      00606046
      CALL LOADER (SENNAM, NAME(2), ADDR(2), &500, &500)                00608043
      ADDR(2) = ADDR(2) + 8                                             00609036
      CALL LINK (ADDR(2), SENS, ZEROLD)                                 00609136
C                                                                       00609236
C CORRECT THE ZERO TABLE                                                00609336
C                                                                       00609459
C IMAG = 1,1 APPLIES THE OFFSETS TO THE SECONDARY MAG ONLY. INBOARD     00609560
C TIM MCCLANAHAN 11/30/92. FOR SINGLE MAG ONLY (FILTER) V2              00609659
C                                                                       00609736
      DO 100 IMAG = 1,1                                                 00609860
          DO 90 IRNG = 1,8                                              00609936
              ZERON(IRNG, 3, IMAG) = INT(ZERO(IRNG, 3, IMAG)            00610043
     1              + (BZAVG / SENS(IRNG, 3, IMAG)) + .5)               00610136
   90     CONTINUE                                                      00610236
  100 CONTINUE                                                          00610336
      LETTER = B                                                        00611037
      WRITE (06,111) ZERNAM, ZERON                                      00612046
      WRITE (20,110) ZERNAM, ZERON                                      00620043
  110 FORMAT(A8, ' CSECT',                                              00630039
     1          /,9X,'GENDATE'/,                                        00640037
     2        'XI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00650037
     3             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00660037
     4        'YI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00670037
     5             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00680037
     6        'ZI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00690037
     7             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00691037
     8        'XO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00692037
     9             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00693037
     A        'YO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00694037
     B             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00695037
     C        'ZO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00696037
     D             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00697037
     E             T10,'END')                                           00698037
  111 FORMAT(1X,A8, ' CSECT',                                           00698146
     1          /,9X,'GENDATE'/,                                        00698246
     2        ' XI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698347
     3             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00698446
     4        ' YI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698547
     5             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00698646
     6        ' ZI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698747
     7             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00698846
     8        ' XO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698947
     9             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00699046
     A        ' YO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00699147
     B             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00699246
     C        ' ZO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00699347
     D             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00699446
     E             T10,'END')                                           00699546
      GO TO 1000                                                        00699639
  200 CONTINUE                                                          00699739
      WRITE (6, 210)                                                    00699839
  210 FORMAT (' ***** HOUR AVERAGE IS NOT HG OR PL *****')              00699941
      GO TO 1000                                                        00700039
  300 CONTINUE                                                          00700139
      WRITE (6, 310)                                                    00700239
  310 FORMAT (' ***** NO HOUR AVERAGES IN REQUESTED PERIOD *****')      00700339
      GO TO 1000                                                        00700443
  400 CONTINUE                                                          00700543
      WRITE (6, 410) ZERNAM                                             00700643
  410 FORMAT (' ERROR READING ', A8)                                    00700743
      GO TO 1000                                                        00700843
  500 CONTINUE                                                          00700943
      WRITE (6, 410) SENNAM                                             00701043
 1000 STOP                                                              00701139
      END                                                               00701242
      SUBROUTINE ZEROLD (TABIN, TABOUT)                                 00701336
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00702036
C                                                                       00703036
C THIS SUBROUTINE MOVES THE 0 TABLE VALUES INTO                         00704036
C A LOCAL ARRAY FROM THE CALLING PROGRAM                                00705036
C                                                                       00706036
C                                                                       00707036
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00708036
      REAL*4 TABIN(10,6), TABOUT(10,6)                                  00709036
      DO 20 IRNG=1, 10                                                  00709136
          DO 10 ICOORD=1, 6                                             00709236
              TABOUT(IRNG, ICOORD) = TABIN(IRNG, ICOORD)                00709336
   10     CONTINUE                                                      00709436
   20 CONTINUE                                                          00709536
      RETURN                                                            00709636
      END                                                               00710011
C
C
C
C
C
C     Z E R O    L E V E L    C O M P U T A T I O N S    U S I N G
C
C     3 - D    L I N E A R    M E T H O D    O F     M . H . A C U N A
C
C     A P P L I E D    T O    V O Y A G E R    4 8    S E C    A V G
C
C
C
C     ------------------------------------- 87APR08 -------------------
C     UPDATED TO COMPUTE SYMMETRY FACTORS;
C        WEIGHT AVERAGES BY SYMMETRY FACTORS;
C        AVERAGE CONDITION NUMBERS;
C        READ OPTIONAL OFFSET VALUES.
C     J.A.JONES SAR 1987 APRIL 6
C     RECONSIDERED:
C        DO NOT WEIGHT BY SYMMETRY FACTORS;
C        ROTATE AVERAGE VECTOR INTO HG COORDINATES, IF POSSIBLE;
C        CONVERT TO FORTRAN 77.
C     JAJ 87APR08
C     -----------------------------------------------------------------
C
C
      INTEGER*2 YR1, DAY1, OUR1, YR2, DAY2, OUR2
      INTEGER*2 HALF(35), IYR, IDA, IHR, MIN, ISC
      REAL*8 X1, Y1, Z1, X2, Y2, Z2, DX, DY, DZ
      REAL*8  ATA(3,3), E(3), V(3,3), AKI, AKJ, SUM, ERR
      DIMENSION KP1(3), LP2(3), KKK(3), LLL(3), S(9), TT(9), YY(9)
      DIMENSION CON(50), XPL(50), YPL(50), ZPL(50)
C
C     ------------------------------------- 87APR08 -------------------
C --> DATA PIVMI/1.0E-9/
      REAL PIVMI/1.0E-9/
C
C --> DATA NO AVG/'    '/,  IN AVG/'****'/
C --> DATA PL/'PL  '/
      CHARACTER*4 $NO AVG/'    '/,  $IN AVG/'****'/
      CHARACTER*4 $PL/'PL  '/
      EQUIVALENCE (NOAVG, $NOAVG), (INAVG, $INAVG), (PL, $PL)
C     ----------------------------------------------------------------
C
C
      DIMENSION A(4500), AA(4500), X(3), B(1500), BB(1500)
C
C
C
      DIMENSION DATA(1100), IDTA(1100)
      EQUIVALENCE (DATA(1), IDTA(1), HALF(1))
C
      EQUIVALENCE       (IYR,HALF(  7)),(IDA,HALF(  8)),(IHR,HALF(  9)),
     C  (MIN,HALF( 10)),(ISC,HALF( 11)),
     C    (X48, DATA(37)), (Y48, DATA(38)), (Z48, DATA(39))
C
C
C          MATRIX   Q   ROTATES    HG    TO    PL     Q * HG = PL
C
      EQUIVALENCE (DATA(560),Q11), (DATA(563),Q12), (DATA(566),Q13),
     C            (DATA(561),Q21), (DATA(564),Q22), (DATA(567),Q23),
     C            (DATA(562),Q31), (DATA(565),Q32), (DATA(568),Q33)
C
C
C        FOLLOWING DIMENSION ESTABLISHES MAXIMUM NKASE = 50
      DIMENSION X PL EST(50), Y PL EST(50), Z PL EST(50)
      DIMENSION X HG EST(50), Y HG EST(50), Z HG EST(50)
C     ------------------------------------- 87APR08 -------------------
      DIMENSION WGT X(50), WGT Y(50), WGT Z(50)
      DIMENSION CN STAR(50), CN ALL(50)
      LOGICAL FIXUP
      CHARACTER*7 PRT X, PRT Y, PRT Z
C
C
C
C --> DATA HDR1/'HDR1'/, LFM/'LFM '/
      CHARACTER*4 $HDR1/'HDR1'/, $LFM/'LFM '/
      EQUIVALENCE (HDR1, $HDR1), (LFM, $LFM)
C     -----------------------------------------------------------------
C
C
C               --- DATA B1 -------   -- DIFF B1-B2  ----
      DIMENSION OCTANT(8), ICTANT(8), OCTENT(8), ICTENT(8)
C
      KPAY = 0
      WRITE(3,109)
  109 FORMAT(   ///2X,'UNIT  3  PRINTOUT' //)
C
      WRITE(4,110)
  110 FORMAT(                            //////2X,'UNIT  4  PRINTOUT'//)
C
      WRITE(6,49)
   49 FORMAT(////2X,'UNIT  6  PRINTOUT  TAPE HEADER RECORD' //)
      WRITE(8,111)
  111 FORMAT(                            //////2X,'UNIT  8  PRINTOUT'//)
C
C
      WRITE(4,52)
      WRITE(8,52)
   52 FORMAT(
     C//10X,'VOYAGER  ZERO  LEVEL  COMPUTATION  USING'
     C//10X,'THE  3-D  LINEAR  METHOD  OF'
     C//10X,'M. H. ACUNA   (CHORD PERPENDICULAR TO RADIUS)'///)
C
C
C     ------------------------------------- 87APR06 -------------------
C     READ IN OFFSETS TO "FIXUP" THE INPUT VALUES.
C     IF NO OFFSETS ARE FOUND ON UNIT 5, NO FIXUP WILL BE DONE.
C
      FIXUP = .FALSE.
      READ (5, *, END = 5012) X OFF, Y OFF, Z OFF
         FIXUP = .TRUE.
         WRITE (4, 4010) X OFF, Y OFF, Z OFF
 4010    FORMAT (5X, 12('*****'),
     C           /T6,'*',T65,'*',
     C           /10X,'OFFSETS ADDED TO INPUT VALUES', 3F7.3,
     C            T6,'*',T65,'*',
     C           /T6,'*',T65,'*',
     C           /5X, 12('*****') // )
 5012 CONTINUE
C     -----------------------------------------------------------------
C
C
      M = 500
      M = 1000
      M = 1500
      M = 200
      M = 400
C
C
      WRITE(4,1) M
    1 FORMAT(/10X,'VOYAGER  48  SECOND  HG  DATA ROTATED INTO PAYLOAD BE
     CFORE PROCESSING'   //8X, I5,' DATA PAIRS PER ESTIMATE'//)
      WRITE(8,53)
   53 FORMAT(/10X,'PRECEEDING PAYLOAD ESTIMATES ROTATED BACK INTO HELIOG
     CRAPHIC COORDINATES'    )
C
C
C
C
      WRITE(4,50)
C     ------------------------------------- 87APR03 -------------------
   50 FORMAT(///
     C/11X,'*',6X,'P A Y L O A D',6X,'LEAST     FIELD DIRECTIONS',
     C       7X, 'SYMMETRY FACTORS'
     C/11X,'O    E S T I M A T E S   SQUARES    DISTRIBUTION',
     C    9X, '100 - |%(+) - %(-)|', 4X,'AVERAGE     LOG'
     C/11X,'K     OX     OY     OZ    ERROR     IN OCTANTS (%)',
     C   10X, 'X      Y      Z',
     C    7X, 'FIELD    COND   YR   DA   HR   MN' //)
C     -----------------------------------------------------------------
C
      WRITE(8,54)
   54 FORMAT(///
     C/11X,'*       HELIOGRAPHIC'
     C/11X,'O    E S T I M A T E S',9X,'MATRICES USED TO ROTATE'
     C/11X,'K     OX     OY     OZ',9X,'ESTIMATES, PL TO HG',
     C                         10X,'YR   DA   HR   MN' //)
C
C
      KERR = 0
C
C
C
C
C         S K I P    D A T A    B E F O R E    D A Y   1 ,   O U R 1
C
C         E N D   J O B    A F T E R    D A Y 2 ,    O U R 2
C
C
C        DAYS  34  THROUGH  37
      YR1 = 78
      DAY1 = 34
      OUR1 = 0
      YR2 = 78
      DAY2 = 37
      OUR2 = 24
C
C
C
C        DAYS  159  THROUGH  183
      YR1 = 78
      DAY1 = 159
      OUR1 = 0
      YR2 = 78
      DAY2 = 183
      OUR2 = 24
C
C
C        PROCESS ENTIRE   VOL=SER..... NO TIME LIMIT
C
      YR1 = 0
      DAY1 = 0
      OUR1 = 0
      YR2 = 99
      DAY2 = 500
      OUR2 = 50
C
C
C
C
C
C
C
C
C
   46 CONTINUE
C ->5 CALL FREAD(DATA,  20, LENGTH, &1001, &46)
    5 CALL FREAD(DATA,  20, LENGTH, *1001, *46)
C
C
C
      IF(DATA(1) - HDR1) 104, 101, 104
  101 WRITE(  6  ,102) DATA(1),DATA(3),DATA(13),DATA(93),DATA(94),
     C   DATA(95),DATA(96),DATA(97),DATA(98), DATA(65), DATA(66)
  102 FORMAT(//
     C//10X,'    RECORD IDENTIFIER  ', A4
     C//10X,'        SPACECRAFT ID  ', A4
     C//10X,'    COORDINATE SYSTEM  ', A4
     C//10X,'        NAME OF ZEROS  ',2A4
     C//10X,'NAME OF SENSITIVITIES  ',2A4
     C//10X,' NAME OF CALIBRATIONS  ',2A4
     C//10X,'SUMMARY TAPE  VOL=SER  ',2A4    ////)
C
      IF (DATA(13) .EQ. PL) KPAY = 1
      GO TO 5
C
C
  104 IF(IDTA(1) - LFM) 5,105,5
C
C
  105 CONTINUE
C
C
C
      IF(IYR - YR1) 5,43,43
   43 CONTINUE
C
      IF(IDA - DAY 1) 5,6,6
    6 CONTINUE
C
C
      IF(IHR - OUR1) 5,41,41
   41 CONTINUE
C
C
C        G E T    1 S T    P O I N T    O F    1 S T    D A T A    P A I
C
C
      X1 = X48
      Y1 = Y48
      Z1 = Z48
C
      IF (KPAY .EQ. 1) GO TO 70
C        R O T A T E    T O    P A Y L O A D
      X1 = Q11 * X48  +  Q12 * Y48  +  Q13 * Z48
      Y1 = Q21 * X48  +  Q22 * Y48  +  Q23 * Z48
      Z1 = Q31 * X48  +  Q32 * Y48  +  Q33 * Z48
C
   70 CONTINUE
C
C     ------------------------------------- 87APR06 -------------------
      IF (FIXUP) X1 = X1 + X OFF
      IF (FIXUP) Y1 = Y1 + Y OFF
      IF (FIXUP) Z1 = Z1 + Z OFF
C     -----------------------------------------------------------------
C
C
C     ------------------------------------- 87APR03 -------------------
C
C
C
C       G E N E R A T E    A V E R A G E S    O F     Z E R O
C
C        E S T I M A T E S    S A T I S F Y I N G    F O L L O W I N G
C
C    1   LEAST SQUARE ERROR / AVERAGE FIELD  .LT.  ERR MAX
C
C    2   LOG CONDITION    .LT.    CON MAX
C
C    3   FOR EACH COMPONENT, SYMMETRY FACTOR  .GE.  SYM MIN
C
C
C    NOTE:  THE SYMMETRY FACTOR IS A MEASURE OF THE DISTRIBUTION
C      OF THE VECTORS WRT EACH COORDINATE AXIS.  COMPUTE THE
C      FRACTION OF VECTORS WITH A POSITIVE PROJECTION ON THE AXIS,
C      %(+), AND THE FRACTION WITH NEGATIVE PROJECTION, %(-).
C      THE SYMMETRY FACTOR IS
C           SYM = 100 - ABS(%(+) - %(-)) ,
C           0 .LE. SYM .LE. 100 .
C      THUS, IF THE VECTORS ARE EVENLY DISTRIBUTED BETWEEN THE TWO
C      HEMISPHERES, %(+) = %(-), AND SYM = 100.
C      IF THE VECTORS ARE ALL IN THE SAME HEMISPHERE, SAY %(+) = 100%,
C      AND %(-) = 0%, THEN SYM = 0.
C      A LOW VALUE OF THE SYMMETRY FACTOR IMPLIES AN ASYMMETRICAL
C      DISTRIBUTION, A HIGH VALUE IMPLIES AN EVEN DISTRIBUTION.
C      AS A RULE, A SMALL SYMMETRY FACTOR FOR AN AXIS IS DIAGNOSTIC
C      FOR AN UNRELIABLE ZERO OFFSET ESTIMATE.
C      (JAJ 1987 APRIL 3)
C
C     -----------------------------------------------------------------
      ERR MAX = 0.015
      SYM MIN = 10.0
C
      CON MAX = 0.3
      MIN PCT = 20
      MAX PHI = 80
C
      MIN PCT = 10
      MAX PHI = 90
C
      KNT AVG = 0
C
C
C
C
C
C
C                 E D I T    1
C
C         // B 1  -  B 2  //   .GT.   D I F M I N
C
      DIF MIN = 0.2
      K DIF ED = 0
      IDIT 1 = 1
      IDIT 1 = 0
C
C
C
C
C           E D I T   2
C
C     ABS(//B1// - //B2//) / (//B1// + //B2//)  .LT.  BOUND
C
      BOUND = 0.15
      BOUND = 0.025
      BOUND = 0.050
      BOUND = 0.100
      BOUND = 0.200
      L DIF ED = 0
      IDIT 2 = 0
      IDIT 2 = 1
C
C
C
C
C             E D I T    3
C
C        A N G L E ( B1 , B2 )  . G T .    D E L  A N G
C
C
      DEL ANG = 4.0
      DEL ANG = 3.0
      DEL ANG = 2.0
      K ANG ED = 0
      IDIT 3 = 0
      IDIT 3 = 1
C
C
C
      NKASE = 200
      NKASE = 50
      KNT = 0
      DO 1000 KASE = 1, NKASE
C
C
      DO 123 I=1,8
      OCTENT(I) = 0.0
  123 OCTANT(I) = 0.0
C
C
C
C
      ID1 = IDA
      IH1 = IHR
      IM1 = MIN
C
C
C
C
      SUM = 0.0
C
C
C
C
C        E D I T   D A T A   A N D   C R E A T E   M   D A T A   P A I R
C
      DO 100 I=1,M
C
C        G E T   2 N D   P O I N T   O F   D A T A   P A I R
C
    3 CONTINUE
C
C --> CALL FREAD(DATA,  20 , LENGTH, &1001,  &3 )
      CALL FREAD(DATA,  20 , LENGTH, *1001,  *3 )
      IF(DATA(1) - HDR1) 107,106,107
  106 WRITE(  6  ,102) DATA(1),DATA(3),DATA(13),DATA(93),DATA(94),
     C   DATA(95),DATA(96),DATA(97),DATA(98), DATA(65), DATA(66)
      IF (DATA(13) .EQ. PL) KPAY = 1
      GO TO 3
C
C
C
  107 IF(IDTA(1) - LFM) 3,108,3
  108 CONTINUE
C
C
C
C
C
      IF(IYR - YR 2)  2,44,1001
   44 CONTINUE
C
C
      IF(IDA - DAY 2) 2,42,1001
C
   42 IF(IHR - OUR2) 2,2,1001
C
C
C
C
    2 CONTINUE
C
C
      X2 = X48
      Y2 = Y48
      Z2 = Z48
C
      IF (KPAY .EQ. 1) GO TO 71
C         R O T A T E    T O    P A Y L O A D
      X2 = Q11 * X48  +  Q12 * Y48  +  Q13 * Z48
      Y2 = Q21 * X48  +  Q22 * Y48  +  Q23 * Z48
      Z2 = Q31 * X48  +  Q32 * Y48  +  Q33 * Z48
C
   71 CONTINUE
C
C     ------------------------------------- 87APR06 -------------------
      IF (FIXUP) X2 = X2 + X OFF
      IF (FIXUP) Y2 = Y2 + Y OFF
      IF (FIXUP) Z2 = Z2 + Z OFF
C     -----------------------------------------------------------------
C
      F1 = DSQRT(X1*X1 + Y1*Y1 + Z1*Z1)
      F2 = DSQRT(X2*X2 + Y2*Y2 + Z2*Z2)
C
C
C     *********** E D I T   P A I R   *********************************
C     *********** E D I T   P A I R   *********************************
C
C      E D I T    P A I R
C
C
C
C
C
C
      IF(IDIT 1) 23,23,25
   25 CONTINUE
C                 E D I T   1
C     R E Q U I R E   // B 1 - B 2 //  . G T .   D I F M I N
C
      DX = X1 - X2
      DY = Y1 - Y2
      DZ = Z1 - Z2
      DIF = DSQRT(DX*DX + DY*DY + DZ*DZ)
C
      IF(DIF - DIF MIN) 22,22,23
C
   22 K DIF ED = K DIF ED + 1
      IS1 = IS2
      X 1 = X 2
      Y 1 = Y 2
      Z 1 = Z 2
C
      GO TO 3
C
C
   23 IF(IDIT 2) 29,29,26
   26 CONTINUE
C
C
C            E D I T   2
C
C     ABS(//B1// - //B2//) / (//B1// + //B2//)  .LT.  BOUND
C
      IF( ( ABS(F1 - F2) / (F1 + F2) )  -  BOUND) 29,28,28
   28 L DIF ED = L DIF ED + 1
      IS1 = IS2
      X 1 = X 2
      Y 1 = Y 2
      Z 1 = Z 2
      GO TO 3
C
C
C
   29 IF(IDIT 3) 32,32,30
   30 CONTINUE
C
C        E D I T   3
C
C        A N G L E ( B1 , B2 )   . G T .   D E L   A N G
C
      C B1 B2 = (X1*X2 + Y1*Y2 + Z1*Z2)/(F1*F2)
      IF( ABS(C B1 B2) - 1.0) 48,48,31
   48 CONTINUE
      ANGL = ARCOS(C B1 B2)/(1.74533 E-2)
      IF(ANGL - DEL ANG) 31,31,32
   31 K ANG ED = K ANG ED + 1
      IS1 = IS2
      X 1 = X 2
      Y 1 = Y 2
      Z 1 = Z 2
      GO TO 3
C
C
   32 CONTINUE
C
C
C
C
C     ******************************************************************
C     ******************************************************************
C
      SUM = SUM + F1 + F2
C
C
C
C        A D D    C U R R E N T    D A T A    P A I R    T O
C
C        L I N E A R    S Y S T E M    F O R    3 D    M E T H O D
C
C        O F     M .  H .  A C U N A  .
C
      IJ = 3*(I - 1)
C
      A(IJ + 1) = 2.0*(X2 - X1)
      A(IJ + 2) = 2.0*(Y2 - Y1)
      A(IJ + 3) = 2.0*(Z2 - Z1)
C
      DX = X1*X1 - X2*X2
      DY = Y1*Y1 - Y2*Y2
      DZ = Z1*Z1 - Z2*Z2
C
      B(I) = DX + DY + DZ
C
C
C       M A I N T A I N     O C T A N T    S T A T I S T I C S
C       F O R    D A T A    B 1
C
      EX = X 1
      WY = Y 1
      ZE = Z 1
C
      PHI = ANGLE(WY, EX)
      RR = SQRT(EX*EX + WY*WY)
      THETA = ANGLE(RR, ZE)
      INDEX = 1 + PHI/90.0
      IF(THETA - 90.0) 14,14,13
   13 INDEX = INDEX + 4
   14 IF(INDEX) 16,16,15
   15 IF(INDEX - 8) 17,17,16
   16 KERR = KERR + 1
      GO TO 18
   17 OCTANT(INDEX) = OCTANT(INDEX) + 1
   18 CONTINUE
C
C          MAINTAIN  OCTENT  STATISTICS FOR DIFFERENCES  B1 - B2
C
      DX = X1 - X2
      DY = Y1 - Y2
      DZ = Z1 - Z2
C
      PHI = ANGLE(DY,DX)
      RR = DSQRT(DX*DX + DY*DY)
      THETA = ANGLE(RR,DZ)
C
      INDEX = 1 + PHI/90.0
      IF(THETA - 90.0) 64,64,63
   63 INDEX = INDEX + 4
   64 IF(INDEX) 66,66,65
   65 IF(INDEX - 8) 67,67,66
   66 KERR = KERR + 1
      GO TO 68
   67 OCTENT(INDEX) = OCTENT(INDEX) + 1
   68 CONTINUE
C
C
C      R E T A I N   2 N D   P O I N T   F O R   N E X T   D A T A   P A
      IS1 = IS2
      X 1 = X 2
      Y 1 = Y 2
      Z 1 = Z 2
C
C
  100 CONTINUE
C
C
      AVG = SUM/(2*M)
C
C
C        COPY  A ,  B  FOR LEAST SQUARES ERROR COMPUTATION
      MN = M*3
      DO 8 I=1,MN
    8 AA(I) = A(I)
      DO 9 I=1,M
    9 BB(I) = B(I)
C
C
C
C     ******************* BEGIN CONDITION ANALYSIS  ********************
C
C        A C C U M U L A T E   U P P E R   T R I A N G L E   O F    A T
C
      DO 11 I=1,3
      DO 11 J=I,3
      SUM = 0.0
      DO 10 K=1,M
      KK = 3*(K-1)
      KI = KK + I
      KJ = KK + J
      AKI = A(KI)
      AKJ = A(KJ)
      SUM = SUM + AKI*AKJ
   10 CONTINUE
   11 ATA(I,J) = SUM
C
C        F I L L   I N   L O W E R   T R I A N G L E   O F   A T A
      ATA(2,1) = ATA(1,2)
      ATA(3,1) = ATA(1,3)
      ATA(3,2) = ATA(2,3)
C
C
C
      NVAL = 3
      NVEC = 0
C
      CALL GIVHO(ATA, E, V, NVAL, NVAL, NVEC)
      COND = DSQRT(E(1) / E(NVAL))
      CNLOG = ALOG(COND) / 2.30259
C
C
C     *******************  END CONDITION ANALYSIS  *********************
C
C
      N = 3
      IRANK = 0
C
      CALL SEUDO(A, X, B, M, N, PIVMI,IRANK,KP1,LP2,KKK,LLL,S,TT,YY)
C
C
C
C      C O M P U T E   L E A S T    S Q U A R E S    E R R O R
      ERR = 0.0
      DO 20 I=1,M
C
C
      IJ = 3*(I - 1)
      FIT = AA(IJ+1)*X(1) + AA(IJ+2)*X(2) + AA(IJ+3)*X(3)
C
      EPSQ = (FIT - BB(I))**2
C
      ERR = ERR + EPSQ
   20 CONTINUE
C
      ERR = DSQRT(ERR/M)
C
C
C        SAVE ALL DATA FOR WEIGHTED AVERAGES  (WEIGHT = 1.0/CONDITION)
      KNT = KNT + 1
      CON(KNT) = COND
      CN ALL(KNT) = CN LOG
      XPL(KNT) = X(1)
      YPL(KNT) = X(2)
      ZPL(KNT) = X(3)
C
C
C
C        P U B L I S H   O C T A N T   S T A T I S T I C S
C
      DO 19 I=1,8
      ICTANT(I) = 0.5 + 100.0*OCTANT(I)/M
      ICTENT(I) = 0.5 + 100.0*OCTENT(I)/M
   19 CONTINUE
C
C
C     ----- SYMMETRY FACTORS -------------- 87APR03 -------------------
      XPLUS  = OCTANT(1) + OCTANT(4) + OCTANT(8) + OCTANT(5)
      XMINUS = OCTANT(2) + OCTANT(3) + OCTANT(7) + OCTANT(6)
      YPLUS  = OCTANT(1) + OCTANT(2) + OCTANT(6) + OCTANT(5)
      YMINUS = OCTANT(4) + OCTANT(3) + OCTANT(7) + OCTANT(8)
      ZPLUS  = OCTANT(1) + OCTANT(2) + OCTANT(3) + OCTANT(4)
      ZMINUS = OCTANT(5) + OCTANT(6) + OCTANT(7) + OCTANT(8)
 
      SYM X = 100.0 * (1.0 - ABS(XPLUS - XMINUS)/M)
      SYM Y = 100.0 * (1.0 - ABS(YPLUS - YMINUS)/M)
      SYM Z = 100.0 * (1.0 - ABS(ZPLUS - ZMINUS)/M)
C     -----------------------------------------------------------------
C
C
C      E D I T    F O R    A V E R A G E    C O M P U T A T I O N S
C
C     ----- NEW EDIT CRITERIA --------- JAJ 87APR03 -------------------
      MEMO = NO AVG
      IF (ERR/AVG .GT. ERR MAX) GO TO 40
      IF (CN LOG .GT. CON MAX) GO TO 40
      KNT AVG = KNT AVG + 1
      MEMO = IN AVG
C
      IF (SYM X .LT. SYM MIN) GO TO 36
         KNT X = KNT X + 1
         WGT X(KNT X) = SYM X
         X PL EST(KNT X) = X(1)
   36 CONTINUE
C
      IF (SYM Y .LT. SYM MIN) GO TO 37
         KNT Y = KNT Y + 1
         WGT Y(KNT Y) = SYM Y
         Y PL EST(KNT Y) = X(2)
   37 CONTINUE
C
      IF (SYM Z .LT. SYM MIN) GO TO 38
         KNT Z = KNT Z + 1
         WGT Z(KNT Z) = SYM Z
         Z PL EST(KNT Z) = X(3)
   38 CONTINUE
C
C     SAVE CONDITION NUMBERS FOR STARRED ESTIMATES.
      CN STAR(KNT AVG) = CN LOG
   40 CONTINUE
C     -----------------------------------------------------------------
C
C
C     ------------------------------------- 87APR03 -------------------
      WRITE(4,21) KASE, MEMO, X, ERR, (ICTANT(I), I = 1, 4),
     C  SYM X, SYM Y, SYM Z,
     C  AVG, CNLOG,
     C  IYR, ID1, IH1, IM1,
     C                                (ICTANT(I), I = 5, 8)
   21 FORMAT(5X, I5, 1X, A1, 1X, 3F7.3, F8.4, 2X, 4I5,
     C    2X, 3F7.1,
     C    3X, F8.3, F8.2,
     C    4I5,          /  44X, 4I5            /)
C     -----------------------------------------------------------------
C
C
      IF (KPAY .EQ. 1) GO TO 72
C
C        R O T A T E    T O    I N E R T I A L    H E L I O G R A P H I
      XHG = Q11 * X(1)  +  Q21 * X(2)  +  Q31 * X(3)
      YHG = Q12 * X(1)  +  Q22 * X(2)  +  Q32 * X(3)
      ZHG = Q13 * X(1)  +  Q23 * X(2)  +  Q33 * X(3)
C
      GO TO 73
   72 XHG = X(1)
      YHG = X(2)
      ZHG = X(3)
   73 CONTINUE
C
      WRITE(8,51) KASE,MEMO,XHG,YHG,ZHG,Q11,Q21,Q31,IYR,ID1,IH1,IM1,
     C                                  Q12,Q22,Q32,
     C                                  Q13,Q23,Q33
   51 FORMAT(5X, I5, 1X, A1, 1X, 3F7.2, 5X, 3F9.4, 2X, 4I5,
     C     /39X, 3F9.4  /39X, 3F9.4  /)
C
C     ------------------------------------- 87APR09 -------------------
C     (* SAVE ROTATION MATRIX *)
      P11 = Q11
      P12 = Q12
      P13 = Q13
      P21 = Q21
      P22 = Q22
      P23 = Q23
      P31 = Q31
      P32 = Q32
      P33 = Q33
C     -----------------------------------------------------------------
C
C
      IF(MEMO - IN AVG) 1000, 998, 1000
  998 X HG EST(KNT AVG) = X HG
      Y HG EST(KNT AVG) = Y HG
      Z HG EST(KNT AVG) = Z HG
 1000 CONTINUE
C
 1001 CONTINUE
C
C
C
C                     O   U   T
C
C
C        C O M P U T E    A N D    P U B L I S H    A V E R A G E S
C
C
C     ------------------------------------- 87APR08 -------------------
C   ----------   UNWEIGHTED AVERAGES  (* STARRED ESTIMATES ONLY) -------
      X AV HG = 0.0
      Y AV HG = 0.0
      Z AV HG = 0.0
      CN AV ST = 0.0
      IF( KNT AVG .LT. 1) GO TO 45
      DO 55 I=1,KNT AVG
      X AV HG = X AV HG + X HG EST(I)
      Y AV HG = Y AV HG + Y HG EST(I)
      Z AV HG = Z AV HG + Z HG EST(I)
      CN AV ST = CN AV ST + CN STAR(I)
   55 CONTINUE
      X AV HG = X AV HG / KNT AVG
      Y AV HG = Y AV HG / KNT AVG
      Z AV HG = Z AV HG / KNT AVG
      CN AV ST = CN AV ST / KNT AVG
C
      IF (KNT X .GT. 0) THEN
         DO 552 I = 1, KNT X
            WGT X AV = WGT X AV + WGT X(I)
C -->       X AV PL = X AV PL + WGT X(I) * X PL EST(I)
            X AV PL = X AV PL + X PL EST(I)
  552    CONTINUE
C -->    X AV PL = X AV PL / WGT X AV
         X AV PL = X AV PL / KNT X
         WGT X AV = WGT X AV / KNT X
         WRITE (UNIT = PRT X, FMT = '(F7.3)') X AV PL
      ELSE
C        (* KNT X = 0, SO NO X-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT X, FMT = '(A7)') '   ?   '
      END IF
C
      IF (KNT Y .GT. 0) THEN
         DO 553 I = 1, KNT Y
            WGT Y AV = WGT Y AV + WGT Y(I)
C -->       Y AV PL = Y AV PL + WGT Y(I) * Y PL EST(I)
            Y AV PL = Y AV PL + Y PL EST(I)
  553    CONTINUE
C -->    Y AV PL = Y AV PL / WGT Y AV
         Y AV PL = Y AV PL / KNT Y
         WGT Y AV = WGT Y AV / KNT Y
         WRITE (UNIT = PRT Y, FMT = '(F7.3)') Y AV PL
      ELSE
C        (* KNT Y = 0, SO NO Y-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT Y, FMT = '(A7)') '   ?   '
      END IF
C
      IF (KNT Z .GT. 0) THEN
         DO 555 I = 1, KNT Z
            WGT Z AV = WGT Z AV + WGT Z(I)
C -->       Z AV PL = Z AV PL + WGT Z(I) * Z PL EST(I)
            Z AV PL = Z AV PL + Z PL EST(I)
  555    CONTINUE
C -->    Z AV PL = Z AV PL / WGT Z AV
         Z AV PL = Z AV PL / KNT Z
         WGT Z AV = WGT Z AV / KNT Z
         WRITE (UNIT = PRT Z, FMT = '(F7.3)') Z AV PL
      ELSE
C        (* KNT Z = 0, SO NO Z-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT Z, FMT = '(A7)') '   ?   '
      END IF
C     -----------------------------------------------------------------
C
C     ------------------------------------- 87APR03 -------------------
C  -------------  WEIGHTED AVERAGES  (ALL ESTIMATES)  --------------
   45 IF (KNT .LT. 1) GO TO 47
      DEN = 0.0
      XAV = 0.0
      YAV = 0.0
      ZAV = 0.0
      CN AV = 0.0
      DO 58 I=1,KNT
      DEN = DEN + 1.0/CON(I)
      XAV = XAV + XPL(I)/CON(I)
      YAV = YAV + YPL(I)/CON(I)
      ZAV = ZAV + ZPL(I)/CON(I)
      CN AV = CN AV + CN ALL(I)
   58 CONTINUE
      XAV = XAV/DEN
      YAV = YAV/DEN
      ZAV = ZAV/DEN
      CN AV = CN AV/KNT
C     -----------------------------------------------------------------
C
C     ------------------------------------- 87APR08 -------------------
C --> WRITE(4,997) X AV PL, Y AV PL, Z AV PL, XAV, YAV, ZAV,
      WRITE(4,997) PRT X,   PRT Y,   PRT Z,   XAV, YAV, ZAV,
     .             SYM MIN,
     .             KNT X,   KNT Y,   KNT Z,        KNT
  997 FORMAT(
     C//10X,' * UNWEIGHTED AVERAGES            WEIGHTED AVERAGES'
C -->C//10X,' * WEIGHTED AVERAGES              WEIGHTED AVERAGES'
C -->C /10X,'   --BY SYMMETRY FACTOR           --BY CONDITION NUMBER'
     C /10X,' * (COMPONENTS SELECTED           (ALL ESTIMATES)'
     C /10X,'    FROM STARRED ESTIMATES)'
C -->C//13X,  3F7.3, 10X, 3F7.3
     C//13X,  3A7,   10X, 3F7.3
     C//10X,'   NUMBER OF *''D ESTIMATES        NUMBER OF ESTIMATES'
     C /10X,'   WITH SYM FACTOR .GE. ', F5.1
     C//11X,  3I7,   17X, I7 /)
C     -----------------------------------------------------------------
      WRITE(8,999) X AV HG, Y AV HG, Z AV HG
  999 FORMAT(//10X,' * VALUES YIELD FOLLOWING AVERAGES...' //13X, 3F7.2)
C
C        COMPUTE AND PUBLISH 'SIGMAS'  (RPL  24 APR 80)
C
      SIG X PL = 0.0
      SIG Y PL = 0.0
      SIG Z PL = 0.0
      SIG X HG = 0.0
      SIG Y HG = 0.0
      SIG Z HG = 0.0
      IF ( KNT AVG .LT. 1) GO TO 47
      DO 56 I=1,KNT AVG
      SIG X HG = SIG X HG + (X HG EST(I) - X AV HG)**2
      SIG Y HG = SIG Y HG + (Y HG EST(I) - Y AV HG)**2
      SIG Z HG = SIG Z HG + (Z HG EST(I) - Z AV HG)**2
   56 CONTINUE
      SIG X HG = SQRT(SIG X HG) / KNT AVG
      SIG Y HG = SQRT(SIG Y HG) / KNT AVG
      SIG Z HG = SQRT(SIG Z HG) / KNT AVG
C
C     ------------------------------------- 87APR08 -------------------
      IF (KNT X .GE. 1) THEN
         DO 561 I = 1, KNT X
C -->       SIG X PL = SIG X PL + WGT X(I)*(X PL EST(I) - X AV PL)**2
            SIG X PL = SIG X PL + (X PL EST(I) - X AV PL)**2
  561    CONTINUE
C -->    SIG X PL = SQRT(SIG X PL) /(KNT X * WGT X AV)
         SIG X PL = SQRT(SIG X PL) / KNT X
         WRITE (UNIT = PRT X, FMT = '(F7.3)') SIG X PL
      ELSE
C        (* KNT X = 0, SO NO X-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT X, FMT = '(A7)') '   ?   '
      END IF
C
      IF (KNT Y .GT. 0) THEN
         DO 563 I = 1, KNT Y
C -->       SIG Y PL = SIG Y PL + WGT Y(I)*(Y PL EST(I) - Y AV PL)**2
            SIG Y PL = SIG Y PL + (Y PL EST(I) - Y AV PL)**2
  563    CONTINUE
C -->    SIG Y PL = SQRT(SIG Y PL) /(KNT Y * WGT Y AV)
         SIG Y PL = SQRT(SIG Y PL) / KNT Y
         WRITE (UNIT = PRT Y, FMT = '(F7.3)') SIG Y PL
      ELSE
C        (* KNT Y = 0, SO NO Y-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT Y, FMT = '(A7)') '   ?   '
      END IF
C
      IF (KNT Z .GT. 0) THEN
         DO 565 I = 1, KNT Z
C -->       SIG Z PL = SIG Z PL + WGT Z(I)*(Z PL EST(I) - Z AV PL)**2
            SIG Z PL = SIG Z PL + (Z PL EST(I) - Z AV PL)**2
  565    CONTINUE
C -->    SIG Z PL = SQRT(SIG Z PL) /(KNT Z * WGT Z AV)
         SIG Z PL = SQRT(SIG Z PL) / KNT Z
         WRITE (UNIT = PRT Z, FMT = '(F7.3)') SIG Z PL
      ELSE
C        (* KNT Z = 0, SO NO Z-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT Z, FMT = '(A7)') '   ?   '
      END IF
C     -----------------------------------------------------------------
C
C --> WRITE(4,57) SIG X PL, SIG Y PL, SIG Z PL
C     ------------------------------------- 87APR08 -------------------
      WRITE (4, 4057) PRT X,    PRT Y,    PRT Z
 4057 FORMAT(//10X,' * VALUES YIELD FOLLOWING SIGMA/SQRT(N)......'
     C   //13X, 3A7  )
C     -----------------------------------------------------------------
      WRITE(8,57) SIG X HG, SIG Y HG, SIG Z HG
   57 FORMAT(//10X,' * VALUES YIELD FOLLOWING SIGMA/SQRT(N)......'
     C   //13X, 3F7.3)
C
C     ------------------------------------- 87APR09 -------------------
      IF (      (KNT X .NE. 0)
     .    .AND. (KNT Y .NE. 0)
     .    .AND. (KNT Z .NE. 0) ) THEN
C        (* ROTATE AVERAGE OFFSET VECTOR TO HG COORDINATES *)
         X AV HG = P11 * X AV PL  +  P21 * Y AV PL  +  P31 * Z AV PL
         Y AV HG = P12 * X AV PL  +  P22 * Y AV PL  +  P32 * Z AV PL
         Z AV HG = P13 * X AV PL  +  P23 * Y AV PL  +  P33 * Z AV PL
C
         WRITE (8, 8010) X AV HG, Y AV HG, Z AV HG
 8010    FORMAT (//10X,'AVERAGE PAYLOAD OFFSET',
     .                 ', ROTATED INTO HG...'
     .           //13X, 3F7.3//)
      ELSE
C        (* SOME COMPONENTS MISSING -- ROTATION NOT MEANINGFUL *)
         WRITE (8, 8011)
 8011    FORMAT (//10X,'AVERAGE PAYLOAD OFFSET',
     .                 ' CANNOT BE ROTATED INTO HG',
     .            /10X,'BECAUSE SOME COMPONENTS ARE MISSING.'//)
      END IF
C     -----------------------------------------------------------------
C
C     ------------------------------------- 87APR06 -------------------
      WRITE(4,59) CN AV ST, CN AV,  WGT X AV, WGT Y AV, WGT Z AV
   59 FORMAT(//10X,' MEAN LOG CONDITION NUMBER (*''D VALUES) ', F7.3
     C        /10X,' MEAN LOG CONDITION NUMBER (ALL VALUES) ', F7.3
     C      ///10X,' MEAN SYMMETRY FACTORS ', 3F8.2 )
C     -----------------------------------------------------------------
C
C
   47 CONTINUE
C     ------------------------------------- 87APR08 -------------------
      WRITE(4,1008) ERR MAX, CON MAX, SYM MIN
 1008 FORMAT(//10X,' * THE VECTORS MARKED WITH * SATISFY...'
     C//14X,'1.  LEAST SQUARE ERROR/MEAN FIELD  .LT. ',F6.3
     C//14X,'2.  LOG CONDITION  .LT. ',F5.1
     C//10X,' THE COMPONENTS SELECTED FOR AVERAGES ALSO SATISFY...'
     C//14X,'3.  SYMMETRY FACTOR  .GE. ',F5.1  /)
C     -----------------------------------------------------------------
C
C
C
      IF(IDIT 1 .EQ. 1)  WRITE(4,1004) K DIF ED, DIF MIN
 1004 FORMAT(//10X, I5, ' DATA PAIRS REJECTED BECAUSE // B1 - B2 // .LE.
     C ', F5.2 )
C
C
C
      IF(IDIT 2  .EQ.  1) WRITE(4,1006) L DIF ED, BOUND
 1006 FORMAT(//10X,  I5, ' DATA PAIRS REJECTED BECAUSE  ABS(//B1// - //B
     C2//) / (//B1// + //B2//)  .GE. ',F7.3 )
C
C
      IF(IDIT 3  .EQ.  1) WRITE(4,1007) K ANG ED, DEL ANG
 1007 FORMAT(//10X, I5,' DATA PAIRS REJECTED BECAUSE ANGLE(B1,B2)  .LE.'
     C   , F6.1,' DEGREES')
C
C
      WRITE(4,1005) KERR
 1005 FORMAT(//10X, I5,'  OCTANT INDEXING ERRORS'//)
C
      RETURN
      END
C                                                                       00000010
C                                                                       00000020
C                                                                       00000030
C                                                                       00000040
C                                                                       00000050
C     Z E R O    L E V E L    C O M P U T A T I O N S    U S I N G      00000060
C                                                                       00000070
C     3 - D    L I N E A R    M E T H O D    O F     M . H . A C U N A  00000080
C                                                                       00000090
C     A P P L I E D    T O    V O Y A G E R    4 8    S E C    A V G    00000100
C                                                                       00000110
C                                                                       00000120
C                                                                       00000130
      INTEGER*2 YR1, DAY1, OUR1, YR2, DAY2, OUR2                        00000140
      INTEGER*2 HALF(35), IYR, IDA, IHR, MIN, ISC                       00000150
      REAL*8 X1, Y1, Z1, X2, Y2, Z2, DX, DY, DZ                         00000160
      REAL*8  ATA(3,3), E(3), V(3,3), AKI, AKJ, SUM, ERR                00000170
      DIMENSION KP1(3), LP2(3), KKK(3), LLL(3), S(9), TT(9), YY(9)      00000180
      DIMENSION CON(50), XPL(50), YPL(50), ZPL(50)                      00000190
C                                                                       00000200
      DATA PIVMI/1.0E-9/                                                00000210
C                                                                       00000220
      DATA NO AVG/'    '/,  IN AVG/'****'/                              00000230
      DATA PL/'PL  '/                                                   00000240
C                                                                       00000250
C                                                                       00000260
      DIMENSION A(4500), AA(4500), X(3), B(1500), BB(1500)              00000270
C                                                                       00000280
C                                                                       00000290
C                                                                       00000300
      DIMENSION DATA(1100), IDTA(1100)                                  00000310
      EQUIVALENCE (DATA(1), IDTA(1), HALF(1))                           00000320
C                                                                       00000330
      EQUIVALENCE       (IYR,HALF(  7)),(IDA,HALF(  8)),(IHR,HALF(  9)),00000340
     C  (MIN,HALF( 10)),(ISC,HALF( 11)),                                00000350
     C    (X48, DATA(37)), (Y48, DATA(38)), (Z48, DATA(39))             00000360
C                                                                       00000370
C                                                                       00000380
C          MATRIX   Q   ROTATES    HG    TO    PL     Q * HG = PL       00000390
C                                                                       00000400
      EQUIVALENCE (DATA(560),Q11), (DATA(563),Q12), (DATA(566),Q13),    00000410
     C            (DATA(561),Q21), (DATA(564),Q22), (DATA(567),Q23),    00000420
     C            (DATA(562),Q31), (DATA(565),Q32), (DATA(568),Q33)     00000430
C                                                                       00000440
C                                                                       00000450
C        FOLLOWING DIMENSION ESTABLISHES MAXIMUM NKASE = 50             00000460
      DIMENSION X PL EST(50), Y PL EST(50), Z PL EST(50)                00000470
      DIMENSION X HG EST(50), Y HG EST(50), Z HG EST(50)                00000480
C                                                                       00000490
C                                                                       00000500
C                                                                       00000510
      DATA HDR1/'HDR1'/, LFM/'LFM '/                                    00000520
C                                                                       00000530
C                                                                       00000540
C               --- DATA B1 -------   -- DIFF B1-B2  ----               00000550
      DIMENSION OCTANT(8), ICTANT(8), OCTENT(8), ICTENT(8)              00000560
C                                                                       00000570
      KPAY = 0                                                          00000580
      WRITE(3,109)                                                      00000590
  109 FORMAT(   ///2X,'UNIT  3  PRINTOUT' //)                           00000600
C                                                                       00000610
      WRITE(4,110)                                                      00000620
  110 FORMAT(                            //////2X,'UNIT  4  PRINTOUT'//)00000630
C                                                                       00000640
      WRITE(6,49)                                                       00000650
   49 FORMAT(                 ////2X,'UNIT  6  PRINTOUT  TAPE HEADER REC00000660
   49CORD' //)                                                          00000670
      WRITE(8,111)                                                      00000680
  111 FORMAT(                            //////2X,'UNIT  8  PRINTOUT'//)00000690
C                                                                       00000700
C                                                                       00000710
      WRITE(4,52)                                                       00000720
      WRITE(8,52)                                                       00000730
   52 FORMAT(                                                           00000740
     C//10X,'VOYAGER  ZERO  LEVEL  COMPUTATION  USING'                  00000750
     C//10X,'THE  3-D  LINEAR  METHOD  OF'                              00000760
     C//10X,'M. H. ACUNA   (CHORD PERPENDICULAR TO RADIUS)'///)         00000770
C                                                                       00000780
C                                                                       00000790
      M = 500                                                           00000800
      M = 1000                                                          00000810
      M = 1500                                                          00000820
      M = 200                                                           00000830
      M = 400                                                           00000840
C                                                                       00000850
C                                                                       00000860
      WRITE(4,1) M                                                      00000870
    1 FORMAT(/10X,'VOYAGER  48  SECOND  HG  DATA ROTATED INTO PAYLOAD BE00000880
     CFORE PROCESSING'   //8X, I5,' DATA PAIRS PER ESTIMATE'//)         00000890
      WRITE(8,53)                                                       00000900
   53 FORMAT(/10X,'PRECEEDING PAYLOAD ESTIMATES ROTATED BACK INTO HELIOG00000910
     CRAPHIC COORDINATES'    )                                          00000920
C                                                                       00000930
C                                                                       00000940
C                                                                       00000950
C                                                                       00000960
      WRITE(4,50)                                                       00000970
   50 FORMAT(///                                                        00000980
     C/11X,'*',6X,'P A Y L O A D',6X,'LEAST     FIELD DIRECTIONS'       00000990
     C       45X,'B1-B2 DIRECTIONS'                                     00001000
     C/11X,'O    E S T I M A T E S   SQUARES    DISTRIBUTION',          00001010
     C    8X,'AVERAGE     LOG', 26X,'DISTRIBUTION'                      00001020
     C/11X,'K     OX     OY     OZ    ERROR     IN OCTANTS (%)        FI00001030
     CELD    COND   YR   DA   HR   MN      IN OCTANTS (%)' //)          00001040
C                                                                       00001050
      WRITE(8,54)                                                       00001060
   54 FORMAT(///                                                        00001070
     C/11X,'*       HELIOGRAPHIC'                                       00001080
     C/11X,'O    E S T I M A T E S',9X,'MATRICES USED TO ROTATE'        00001090
     C/11X,'K     OX     OY     OZ',9X,'ESTIMATES, PL TO HG',           00001100
     C                         10X,'YR   DA   HR   MN' //)              00001110
C                                                                       00001120
C                                                                       00001130
      KERR = 0                                                          00001140
C                                                                       00001150
C                                                                       00001160
C                                                                       00001170
C                                                                       00001180
C         S K I P    D A T A    B E F O R E    D A Y   1 ,   O U R 1    00001190
C                                                                       00001200
C         E N D   J O B    A F T E R    D A Y 2 ,    O U R 2            00001210
C                                                                       00001220
C                                                                       00001230
C        DAYS  34  THROUGH  37                                          00001240
      YR1 = 78                                                          00001250
      DAY1 = 34                                                         00001260
      OUR1 = 0                                                          00001270
      YR2 = 78                                                          00001280
      DAY2 = 37                                                         00001290
      OUR2 = 24                                                         00001300
C                                                                       00001310
C                                                                       00001320
C                                                                       00001330
C        DAYS  159  THROUGH  183                                        00001340
      YR1 = 78                                                          00001350
      DAY1 = 159                                                        00001360
      OUR1 = 0                                                          00001370
      YR2 = 78                                                          00001380
      DAY2 = 183                                                        00001390
      OUR2 = 24                                                         00001400
C                                                                       00001410
C                                                                       00001420
C        PROCESS ENTIRE   VOL=SER..... NO TIME LIMIT                    00001430
C                                                                       00001440
      YR1 = 0                                                           00001450
      DAY1 = 0                                                          00001460
      OUR1 = 0                                                          00001470
      YR2 = 99                                                          00001480
      DAY2 = 500                                                        00001490
      OUR2 = 50                                                         00001500
C                                                                       00001510
C                                                                       00001520
C                                                                       00001530
C                                                                       00001540
C                                                                       00001550
C                                                                       00001560
C                                                                       00001570
C                                                                       00001580
C                                                                       00001590
   46 CONTINUE                                                          00001600
    5 CALL FREAD(DATA,  20, LENGTH, &1001, &46)                         00001610
C                                                                       00001620
C                                                                       00001630
C                                                                       00001640
      IF(DATA(1) - HDR1) 104, 101, 104                                  00001650
  101 WRITE(  6  ,102) DATA(1),DATA(3),DATA(13),DATA(93),DATA(94),      00001660
     C   DATA(95),DATA(96),DATA(97),DATA(98), DATA(65), DATA(66)        00001670
  102 FORMAT(//                                                         00001680
     C//10X,'    RECORD IDENTIFIER  '  A4                               00001690
     C//10X,'        SPACECRAFT ID  '  A4                               00001700
     C//10X,'    COORDINATE SYSTEM  '  A4                               00001710
     C//10X,'        NAME OF ZEROS  ' 2A4                               00001720
     C//10X,'NAME OF SENSITIVITIES  ' 2A4                               00001730
     C//10X,' NAME OF CALIBRATIONS  ' 2A4                               00001740
     C//10X,'SUMMARY TAPE  VOL=SER  ' 2A4    ////)                      00001750
C                                                                       00001760
      IF (DATA(13) .EQ. PL) KPAY = 1                                    00001770
      GO TO 5                                                           00001780
C                                                                       00001790
C                                                                       00001800
  104 IF(IDTA(1) - LFM) 5,105,5                                         00001810
C                                                                       00001820
C                                                                       00001830
  105 CONTINUE                                                          00001840
C                                                                       00001850
C                                                                       00001860
C                                                                       00001870
      IF(IYR - YR1) 5,43,43                                             00001880
   43 CONTINUE                                                          00001890
C                                                                       00001900
      IF(IDA - DAY 1) 5,6,6                                             00001910
    6 CONTINUE                                                          00001920
C                                                                       00001930
C                                                                       00001940
      IF(IHR - OUR1) 5,41,41                                            00001950
   41 CONTINUE                                                          00001960
C                                                                       00001970
C                                                                       00001980
C        G E T    1 S T    P O I N T    O F    1 S T    D A T A    P A I00001990
C                                                                       00002000
C                                                                       00002010
      X1 = X48                                                          00002020
      Y1 = Y48                                                          00002030
      Z1 = Z48                                                          00002040
C                                                                       00002050
      IF (KPAY .EQ. 1) GO TO 70                                         00002060
C        R O T A T E    T O    P A Y L O A D                            00002070
      X1 = Q11 * X48  +  Q12 * Y48  +  Q13 * Z48                        00002080
      Y1 = Q21 * X48  +  Q22 * Y48  +  Q23 * Z48                        00002090
      Z1 = Q31 * X48  +  Q32 * Y48  +  Q33 * Z48                        00002100
C                                                                       00002110
   70 CONTINUE                                                          00002120
C                                                                       00002130
C                                                                       00002140
C                                                                       00002150
C                                                                       00002160
C                                                                       00002170
C                                                                       00002180
C       G E N E R A T E    A V E R A G E S    O F     Z E R O           00002190
C                                                                       00002200
C        E S T I M A T E S    S A T I S F Y I N G    F O L L O W I N G  00002210
C                                                                       00002220
C    1   LOG CONDITION    .LT.    CON MAX                               00002230
C                                                                       00002240
C    2   N. AND S. HEMISPHERES EACH CONTAIN AT LEAST  MIN PCT  PERCENT  00002250
C        OF THE POINTS.                                                 00002260
C                                                                       00002270
C    3   NO LONGITUDINAL (PHI) QUADRANT HAS MORE THAN  MAX PHI  PERCENT 00002280
C        OF THE POINTS.                                                 00002290
C                                                                       00002300
C                                                                       00002310
      CON MAX = 0.3                                                     00002320
      MIN PCT = 20                                                      00002330
      MAX PHI = 80                                                      00002340
C                                                                       00002350
      MIN PCT = 10                                                      00002360
      MAX PHI = 90                                                      00002370
C                                                                       00002380
      KNT AVG = 0                                                       00002390
C                                                                       00002400
C                                                                       00002410
C                                                                       00002420
C                                                                       00002430
C                                                                       00002440
C                                                                       00002450
C                 E D I T    1                                          00002460
C                                                                       00002470
C         // B 1  -  B 2  //   .GT.   D I F M I N                       00002480
C                                                                       00002490
      DIF MIN = 0.2                                                     00002500
      K DIF ED = 0                                                      00002510
      IDIT 1 = 1                                                        00002520
      IDIT 1 = 0                                                        00002530
C                                                                       00002540
C                                                                       00002550
C                                                                       00002560
C                                                                       00002570
C           E D I T   2                                                 00002580
C                                                                       00002590
C     ABS(//B1// - //B2//) / (//B1// + //B2//)  .LT.  BOUND             00002600
C                                                                       00002610
      BOUND = 0.15                                                      00002620
      BOUND = 0.025                                                     00002630
      BOUND = 0.050                                                     00002640
      BOUND = 0.100                                                     00002650
      BOUND = 0.200                                                     00002660
      L DIF ED = 0                                                      00002670
      IDIT 2 = 0                                                        00002680
      IDIT 2 = 1                                                        00002690
C                                                                       00002700
C                                                                       00002710
C                                                                       00002720
C                                                                       00002730
C             E D I T    3                                              00002740
C                                                                       00002750
C        A N G L E ( B1 , B2 )  . G T .    D E L  A N G                 00002760
C                                                                       00002770
C                                                                       00002780
      DEL ANG = 4.0                                                     00002790
      DEL ANG = 3.0                                                     00002800
      DEL ANG = 2.0                                                     00002810
      K ANG ED = 0                                                      00002820
      IDIT 3 = 0                                                        00002830
      IDIT 3 = 1                                                        00002840
C                                                                       00002850
C                                                                       00002860
C                                                                       00002870
      NKASE = 200                                                       00002880
      NKASE = 50                                                        00002890
      KNT = 0                                                           00002900
      DO 1000 KASE = 1, NKASE                                           00002910
C                                                                       00002920
C                                                                       00002930
      DO 123 I=1,8                                                      00002940
      OCTENT(I) = 0.0                                                   00002950
  123 OCTANT(I) = 0.0                                                   00002960
C                                                                       00002970
C                                                                       00002980
C                                                                       00002990
C                                                                       00003000
      ID1 = IDA                                                         00003010
      IH1 = IHR                                                         00003020
      IM1 = MIN                                                         00003030
C                                                                       00003040
C                                                                       00003050
C                                                                       00003060
C                                                                       00003070
      SUM = 0.0                                                         00003080
C                                                                       00003090
C                                                                       00003100
C                                                                       00003110
C                                                                       00003120
C        E D I T   D A T A   A N D   C R E A T E   M   D A T A   P A I R00003130
C                                                                       00003140
      DO 100 I=1,M                                                      00003150
C                                                                       00003160
C        G E T   2 N D   P O I N T   O F   D A T A   P A I R            00003170
C                                                                       00003180
    3 CONTINUE                                                          00003190
C                                                                       00003200
      CALL FREAD(DATA,  20 , LENGTH, &1001,  &3 )                       00003210
      IF(DATA(1) - HDR1) 107,106,107                                    00003220
  106 WRITE(  6  ,102) DATA(1),DATA(3),DATA(13),DATA(93),DATA(94),      00003230
     C   DATA(95),DATA(96),DATA(97),DATA(98), DATA(65), DATA(66)        00003240
      IF (DATA(13) .EQ. PL) KPAY = 1                                    00003250
      GO TO 3                                                           00003260
C                                                                       00003270
C                                                                       00003280
C                                                                       00003290
  107 IF(IDTA(1) - LFM) 3,108,3                                         00003300
  108 CONTINUE                                                          00003310
C                                                                       00003320
C                                                                       00003330
C                                                                       00003340
C                                                                       00003350
C                                                                       00003360
      IF(IYR - YR 2)  2,44,1001                                         00003370
   44 CONTINUE                                                          00003380
C                                                                       00003390
C                                                                       00003400
      IF(IDA - DAY 2) 2,42,1001                                         00003410
C                                                                       00003420
   42 IF(IHR - OUR2) 2,2,1001                                           00003430
C                                                                       00003440
C                                                                       00003450
C                                                                       00003460
C                                                                       00003470
    2 CONTINUE                                                          00003480
C                                                                       00003490
C                                                                       00003500
      X2 = X48                                                          00003510
      Y2 = Y48                                                          00003520
      Z2 = Z48                                                          00003530
C                                                                       00003540
      IF (KPAY .EQ. 1) GO TO 71                                         00003550
C         R O T A T E    T O    P A Y L O A D                           00003560
      X2 = Q11 * X48  +  Q12 * Y48  +  Q13 * Z48                        00003570
      Y2 = Q21 * X48  +  Q22 * Y48  +  Q23 * Z48                        00003580
      Z2 = Q31 * X48  +  Q32 * Y48  +  Q33 * Z48                        00003590
C                                                                       00003600
   71 CONTINUE                                                          00003610
C                                                                       00003620
      F1 = DSQRT(X1*X1 + Y1*Y1 + Z1*Z1)                                 00003630
      F2 = DSQRT(X2*X2 + Y2*Y2 + Z2*Z2)                                 00003640
C                                                                       00003650
C                                                                       00003660
C     *********** E D I T   P A I R   ********************************* 00003670
C     *********** E D I T   P A I R   ********************************* 00003680
C                                                                       00003690
C      E D I T    P A I R                                               00003700
C                                                                       00003710
C                                                                       00003720
C                                                                       00003730
C                                                                       00003740
C                                                                       00003750
C                                                                       00003760
      IF(IDIT 1) 23,23,25                                               00003770
   25 CONTINUE                                                          00003780
C                 E D I T   1                                           00003790
C     R E Q U I R E   // B 1 - B 2 //  . G T .   D I F M I N            00003800
C                                                                       00003810
      DX = X1 - X2                                                      00003820
      DY = Y1 - Y2                                                      00003830
      DZ = Z1 - Z2                                                      00003840
      DIF = DSQRT(DX*DX + DY*DY + DZ*DZ)                                00003850
C                                                                       00003860
      IF(DIF - DIF MIN) 22,22,23                                        00003870
C                                                                       00003880
   22 K DIF ED = K DIF ED + 1                                           00003890
      IS1 = IS2                                                         00003900
      X 1 = X 2                                                         00003910
      Y 1 = Y 2                                                         00003920
      Z 1 = Z 2                                                         00003930
C                                                                       00003940
      GO TO 3                                                           00003950
C                                                                       00003960
C                                                                       00003970
   23 IF(IDIT 2) 29,29,26                                               00003980
   26 CONTINUE                                                          00003990
C                                                                       00004000
C                                                                       00004010
C            E D I T   2                                                00004020
C                                                                       00004030
C     ABS(//B1// - //B2//) / (//B1// + //B2//)  .LT.  BOUND             00004040
C                                                                       00004050
      IF( ( ABS(F1 - F2) / (F1 + F2) )  -  BOUND) 29,28,28              00004060
   28 L DIF ED = L DIF ED + 1                                           00004070
      IS1 = IS2                                                         00004080
      X 1 = X 2                                                         00004090
      Y 1 = Y 2                                                         00004100
      Z 1 = Z 2                                                         00004110
      GO TO 3                                                           00004120
C                                                                       00004130
C                                                                       00004140
C                                                                       00004150
   29 IF(IDIT 3) 32,32,30                                               00004160
   30 CONTINUE                                                          00004170
C                                                                       00004180
C        E D I T   3                                                    00004190
C                                                                       00004200
C        A N G L E ( B1 , B2 )   . G T .   D E L   A N G                00004210
C                                                                       00004220
      C B1 B2 = (X1*X2 + Y1*Y2 + Z1*Z2)/(F1*F2)                         00004230
      IF( ABS(C B1 B2) - 1.0) 48,48,31                                  00004240
   48 CONTINUE                                                          00004250
      ANGL = ARCOS(C B1 B2)/(1.74533 E-2)                               00004260
      IF(ANGL - DEL ANG) 31,31,32                                       00004270
   31 K ANG ED = K ANG ED + 1                                           00004280
      IS1 = IS2                                                         00004290
      X 1 = X 2                                                         00004300
      Y 1 = Y 2                                                         00004310
      Z 1 = Z 2                                                         00004320
      GO TO 3                                                           00004330
C                                                                       00004340
C                                                                       00004350
   32 CONTINUE                                                          00004360
C                                                                       00004370
C                                                                       00004380
C                                                                       00004390
C                                                                       00004400
C     ******************************************************************00004410
C     ***************************************************************** 00004420
C                                                                       00004430
      SUM = SUM + F1 + F2                                               00004440
C                                                                       00004450
C                                                                       00004460
C                                                                       00004470
C        A D D    C U R R E N T    D A T A    P A I R    T O            00004480
C                                                                       00004490
C        L I N E A R    S Y S T E M    F O R    3 D    M E T H O D      00004500
C                                                                       00004510
C        O F     M .  H .  A C U N A  .                                 00004520
C                                                                       00004530
      IJ = 3*(I - 1)                                                    00004540
C                                                                       00004550
      A(IJ + 1) = 2.0*(X2 - X1)                                         00004560
      A(IJ + 2) = 2.0*(Y2 - Y1)                                         00004570
      A(IJ + 3) = 2.0*(Z2 - Z1)                                         00004580
C                                                                       00004590
      DX = X1*X1 - X2*X2                                                00004600
      DY = Y1*Y1 - Y2*Y2                                                00004610
      DZ = Z1*Z1 - Z2*Z2                                                00004620
C                                                                       00004630
      B(I) = DX + DY + DZ                                               00004640
C                                                                       00004650
C                                                                       00004660
C       M A I N T A I N     O C T A N T    S T A T I S T I C S          00004670
C       F O R    D A T A    B 1                                         00004680
C                                                                       00004690
      EX = X 1                                                          00004700
      WY = Y 1                                                          00004710
      ZE = Z 1                                                          00004720
C                                                                       00004730
      PHI = ANGLE(WY, EX)                                               00004740
      RR = SQRT(EX*EX + WY*WY)                                          00004750
      THETA = ANGLE(RR, ZE)                                             00004760
      INDEX = 1 + PHI/90.0                                              00004770
      IF(THETA - 90.0) 14,14,13                                         00004780
   13 INDEX = INDEX + 4                                                 00004790
   14 IF(INDEX) 16,16,15                                                00004800
   15 IF(INDEX - 8) 17,17,16                                            00004810
   16 KERR = KERR + 1                                                   00004820
      GO TO 18                                                          00004830
   17 OCTANT(INDEX) = OCTANT(INDEX) + 1                                 00004840
   18 CONTINUE                                                          00004850
C                                                                       00004860
C          MAINTAIN  OCTENT  STATISTICS FOR DIFFERENCES  B1 - B2        00004870
C                                                                       00004880
      DX = X1 - X2                                                      00004890
      DY = Y1 - Y2                                                      00004900
      DZ = Z1 - Z2                                                      00004910
C                                                                       00004920
      PHI = ANGLE(DY,DX)                                                00004930
      RR = DSQRT(DX*DX + DY*DY)                                         00004940
      THETA = ANGLE(RR,DZ)                                              00004950
C                                                                       00004960
      INDEX = 1 + PHI/90.0                                              00004970
      IF(THETA - 90.0) 64,64,63                                         00004980
   63 INDEX = INDEX + 4                                                 00004990
   64 IF(INDEX) 66,66,65                                                00005000
   65 IF(INDEX - 8) 67,67,66                                            00005010
   66 KERR = KERR + 1                                                   00005020
      GO TO 68                                                          00005030
   67 OCTENT(INDEX) = OCTENT(INDEX) + 1                                 00005040
   68 CONTINUE                                                          00005050
C                                                                       00005060
C                                                                       00005070
C      R E T A I N   2 N D   P O I N T   F O R   N E X T   D A T A   P A00005080
      IS1 = IS2                                                         00005090
      X 1 = X 2                                                         00005100
      Y 1 = Y 2                                                         00005110
      Z 1 = Z 2                                                         00005120
C                                                                       00005130
C                                                                       00005140
  100 CONTINUE                                                          00005150
C                                                                       00005160
C                                                                       00005170
      AVG = SUM/(2*M)                                                   00005180
C                                                                       00005190
C                                                                       00005200
C        COPY  A ,  B  FOR LEAST SQUARES ERROR COMPUTATION              00005210
      MN = M*3                                                          00005220
      DO 8 I=1,MN                                                       00005230
    8 AA(I) = A(I)                                                      00005240
      DO 9 I=1,M                                                        00005250
    9 BB(I) = B(I)                                                      00005260
C                                                                       00005270
C                                                                       00005280
C                                                                       00005290
C     ******************* BEGIN CONDITION ANALYSIS  ********************00005300
C                                                                       00005310
C        A C C U M U L A T E   U P P E R   T R I A N G L E   O F    A T 00005320
C                                                                       00005330
      DO 11 I=1,3                                                       00005340
      DO 11 J=I,3                                                       00005350
      SUM = 0.0                                                         00005360
      DO 10 K=1,M                                                       00005370
      KK = 3*(K-1)                                                      00005380
      KI = KK + I                                                       00005390
      KJ = KK + J                                                       00005400
      AKI = A(KI)                                                       00005410
      AKJ = A(KJ)                                                       00005420
      SUM = SUM + AKI*AKJ                                               00005430
   10 CONTINUE                                                          00005440
   11 ATA(I,J) = SUM                                                    00005450
C                                                                       00005460
C        F I L L   I N   L O W E R   T R I A N G L E   O F   A T A      00005470
      ATA(2,1) = ATA(1,2)                                               00005480
      ATA(3,1) = ATA(1,3)                                               00005490
      ATA(3,2) = ATA(2,3)                                               00005500
C                                                                       00005510
C                                                                       00005520
C                                                                       00005530
      NVAL = 3                                                          00005540
      NVEC = 0                                                          00005550
C                                                                       00005560
      CALL GIVHO(ATA, E, V, NVAL, NVAL, NVEC)                           00005570
      COND = DSQRT(E(1) / E(NVAL))                                      00005580
      CNLOG = ALOG(COND) / 2.30259                                      00005590
C                                                                       00005600
C                                                                       00005610
C     *******************  END CONDITION ANALYSIS  *********************00005620
C                                                                       00005630
C                                                                       00005640
      N = 3                                                             00005650
      IRANK = 0                                                         00005660
C                                                                       00005670
      CALL SEUDO(A, X, B, M, N, PIVMI,IRANK,KP1,LP2,KKK,LLL,S,TT,YY)    00005680
C                                                                       00005690
C                                                                       00005700
C                                                                       00005710
C      C O M P U T E   L E A S T    S Q U A R E S    E R R O R          00005720
      ERR = 0.0                                                         00005730
      DO 20 I=1,M                                                       00005740
C                                                                       00005750
C                                                                       00005760
      IJ = 3*(I - 1)                                                    00005770
      FIT = AA(IJ+1)*X(1) + AA(IJ+2)*X(2) + AA(IJ+3)*X(3)               00005780
C                                                                       00005790
      EPSQ = (FIT - BB(I))**2                                           00005800
C                                                                       00005810
      ERR = ERR + EPSQ                                                  00005820
   20 CONTINUE                                                          00005830
C                                                                       00005840
      ERR = DSQRT(ERR/M)                                                00005850
C                                                                       00005860
C                                                                       00005870
C        SAVE ALL DATA FOR WEIGHTED AVERAGES  (WEIGHT = 1.0/CONDITION)  00005880
      KNT = KNT + 1                                                     00005890
      CON(KNT) = COND                                                   00005900
      XPL(KNT) = X(1)                                                   00005910
      YPL(KNT) = X(2)                                                   00005920
      ZPL(KNT) = X(3)                                                   00005930
C                                                                       00005940
C                                                                       00005950
C                                                                       00005960
C        P U B L I S H   O C T A N T   S T A T I S T I C S              00005970
C                                                                       00005980
      DO 19 I=1,8                                                       00005990
      ICTANT(I) = 0.5 + 100.0*OCTANT(I)/M                               00006000
      ICTENT(I) = 0.5 + 100.0*OCTENT(I)/M                               00006010
   19 CONTINUE                                                          00006020
C                                                                       00006030
C                                                                       00006040
C                                                                       00006050
C      E D I T    F O R    A V E R A G E    C O M P U T A T I O N S     00006060
C                                                                       00006070
      MEMO = NO AVG                                                     00006080
      NORTH = ICTANT(1) + ICTANT(2) + ICTANT(3) + ICTANT(4)             00006090
      NOUTH = ICTANT(5) + ICTANT(6) + ICTANT(7) + ICTANT(8)             00006100
      IF(NORTH - MIN PCT) 40,33,33                                      00006110
   33 IF(NOUTH - MIN PCT) 40,34,34                                      00006120
   34 IF(CN LOG - CON MAX) 35,35,40                                     00006130
   35 IF(ICTANT(1) + ICTANT(5) - MAX PHI) 36,36,40                      00006140
   36 IF(ICTANT(2) + ICTANT(6) - MAX PHI) 37,37,40                      00006150
   37 IF(ICTANT(3) + ICTANT(7) - MAX PHI) 38,38,40                      00006160
   38 IF(ICTANT(4) + ICTANT(8) - MAX PHI) 39,39,40                      00006170
   39 KNT AVG = KNT AVG + 1                                             00006180
      MEMO = IN AVG                                                     00006190
      X PL EST(KNT AVG) = X(1)                                          00006200
      Y PL EST(KNT AVG) = X(2)                                          00006210
      Z PL EST(KNT AVG) = X(3)                                          00006220
   40 CONTINUE                                                          00006230
C                                                                       00006240
C                                                                       00006250
C                                                                       00006260
      WRITE(4,21) KASE, MEMO, X, ERR, (ICTANT(I), I=1,4), AVG, CNLOG,   00006270
     C  IYR, ID1, IH1, IM1,     (ICTENT(I), I=1,4),                     00006280
     C       (ICTANT(I),I=5,8), (ICTENT(I), I=5,8)                      00006290
   21 FORMAT(5X, I5, 1X, A1, 1X, 3F7.2, F8.3, 2X, 4I5, 2X, F8.2, F8.2,  00006300
     C    4I5, 2X, 4I5  /  44X, 4I5, 40X, 4I5  /)                       00006310
C                                                                       00006320
C                                                                       00006330
      IF (KPAY .EQ. 1) GO TO 72                                         00006340
C                                                                       00006350
C        R O T A T E    T O    I N E R T I A L    H E L I O G R A P H I 00006360
      XHG = Q11 * X(1)  +  Q21 * X(2)  +  Q31 * X(3)                    00006370
      YHG = Q12 * X(1)  +  Q22 * X(2)  +  Q32 * X(3)                    00006380
      ZHG = Q13 * X(1)  +  Q23 * X(2)  +  Q33 * X(3)                    00006390
C                                                                       00006400
      GO TO 73                                                          00006410
   72 XHG = X(1)                                                        00006420
      YHG = X(2)                                                        00006430
      ZHG = X(3)                                                        00006440
   73 CONTINUE                                                          00006450
C                                                                       00006460
      WRITE(8,51) KASE,MEMO,XHG,YHG,ZHG,Q11,Q21,Q31,IYR,ID1,IH1,IM1,    00006470
     C                                  Q12,Q22,Q32,                    00006480
     C                                  Q13,Q23,Q33                     00006490
   51 FORMAT(5X, I5, 1X, A1, 1X, 3F7.2, 5X, 3F9.4, 2X, 4I5,             00006500
     C     /39X, 3F9.4  /39X, 3F9.4  /)                                 00006510
C                                                                       00006520
C                                                                       00006530
      IF(MEMO - IN AVG) 1000, 998, 1000                                 00006540
  998 X HG EST(KNT AVG) = X HG                                          00006550
      Y HG EST(KNT AVG) = Y HG                                          00006560
      Z HG EST(KNT AVG) = Z HG                                          00006570
 1000 CONTINUE                                                          00006580
C                                                                       00006590
 1001 CONTINUE                                                          00006600
C                                                                       00006610
C                                                                       00006620
C                                                                       00006630
C                     O   U   T                                         00006640
C                                                                       00006650
C                                                                       00006660
C        C O M P U T E    A N D    P U B L I S H    A V E R A G E S     00006670
C                                                                       00006680
C                                                                       00006690
C   ----------   UNWEIGHTED AVERAGES  (* STARRED ESTIMATES ONLY) -------00006700
      X AV PL = 0.0                                                     00006710
      Y AV PL = 0.0                                                     00006720
      Z AV PL = 0.0                                                     00006730
      X AV HG = 0.0                                                     00006740
      Y AV HG = 0.0                                                     00006750
      Z AV HG = 0.0                                                     00006760
      IF( KNT AVG .LT. 1) GO TO 45                                      00006770
      DO 55 I=1,KNT AVG                                                 00006780
      X AV PL = X AV PL + X PL EST(I)                                   00006790
      Y AV PL = Y AV PL + Y PL EST(I)                                   00006800
      Z AV PL = Z AV PL + Z PL EST(I)                                   00006810
      X AV HG = X AV HG + X HG EST(I)                                   00006820
      Y AV HG = Y AV HG + Y HG EST(I)                                   00006830
      Z AV HG = Z AV HG + Z HG EST(I)                                   00006840
   55 CONTINUE                                                          00006850
      X AV PL = X AV PL / KNT AVG                                       00006860
      Y AV PL = Y AV PL / KNT AVG                                       00006870
      Z AV PL = Z AV PL / KNT AVG                                       00006880
      X AV HG = X AV HG / KNT AVG                                       00006890
      Y AV HG = Y AV HG / KNT AVG                                       00006900
      Z AV HG = Z AV HG / KNT AVG                                       00006910
C                                                                       00006920
C  -------------  WEIGHTED AVERAGES  (ALL ESTIMATES)  --------------    00006930
   45 IF (KNT .LT. 1) GO TO 47                                          00006940
      DEN = 0.0                                                         00006950
      XAV = 0.0                                                         00006960
      YAV = 0.0                                                         00006970
      ZAV = 0.0                                                         00006980
      DO 58 I=1,KNT                                                     00006990
      DEN = DEN + 1.0/CON(I)                                            00007000
      XAV = XAV + XPL(I)/CON(I)                                         00007010
      YAV = YAV + YPL(I)/CON(I)                                         00007020
      ZAV = ZAV + ZPL(I)/CON(I)                                         00007030
   58 CONTINUE                                                          00007040
      XAV = XAV/DEN                                                     00007050
      YAV = YAV/DEN                                                     00007060
      ZAV = ZAV/DEN                                                     00007070
      WRITE(4,997) X AV PL, Y AV PL, Z AV PL, XAV, YAV, ZAV             00007080
  997 FORMAT(                                                           00007090
     C//10X,' * UNWEIGHTED AVERAGES            WEIGHTED AVERAGES'       00007100
     C /10X,' * (STARRED ESTIMATES)            (ALL ESTIMATES)'         00007110
     C//13X,  3F7.2, 10X, 3F7.2)                                        00007120
      WRITE(8,999) X AV HG, Y AV HG, Z AV HG                            00007130
  999 FORMAT(//10X,' * VALUES YIELD FOLLOWING AVERAGES...' //13X, 3F7.2)00007140
C                                                                       00007150
C        COMPUTE AND PUBLISH 'SIGMAS'  (RPL  24 APR 80)                 00007160
C                                                                       00007170
      SIG X PL = 0.0                                                    00007180
      SIG Y PL = 0.0                                                    00007190
      SIG Z PL = 0.0                                                    00007200
      SIG X HG = 0.0                                                    00007210
      SIG Y HG = 0.0                                                    00007220
      SIG Z HG = 0.0                                                    00007230
      IF ( KNT AVG .LT. 1) GO TO 47                                     00007240
      DO 56 I=1,KNT AVG                                                 00007250
      SIG X PL = SIG X PL + (X PL EST(I) - X AV PL)**2                  00007260
      SIG Y PL = SIG Y PL + (Y PL EST(I) - Y AV PL)**2                  00007270
      SIG Z PL = SIG Z PL + (Z PL EST(I) - Z AV PL)**2                  00007280
      SIG X HG = SIG X HG + (X HG EST(I) - X AV HG)**2                  00007290
      SIG Y HG = SIG Y HG + (Y HG EST(I) - Y AV HG)**2                  00007300
      SIG Z HG = SIG Z HG + (Z HG EST(I) - Z AV HG)**2                  00007310
   56 CONTINUE                                                          00007320
      SIG X PL = SQRT(SIG X PL) / KNT AVG                               00007330
      SIG Y PL = SQRT(SIG Y PL) / KNT AVG                               00007340
      SIG Z PL = SQRT(SIG Z PL) / KNT AVG                               00007350
      SIG X HG = SQRT(SIG X HG) / KNT AVG                               00007360
      SIG Y HG = SQRT(SIG Y HG) / KNT AVG                               00007370
      SIG Z HG = SQRT(SIG Z HG) / KNT AVG                               00007380
      WRITE(4,57) SIG X PL, SIG Y PL, SIG Z PL                          00007390
      WRITE(8,57) SIG X HG, SIG Y HG, SIG Z HG                          00007400
   57 FORMAT(//10X,' * VALUES YIELD FOLLOWING SIGMA/SQRT(N)......'      00007410
     C   //13X, 3F7.3)                                                  00007420
C                                                                       00007430
C                                                                       00007440
   47 CONTINUE                                                          00007450
      WRITE(4,1008) KNT AVG, CON MAX, MIN PCT, MAX PHI                  00007460
 1008 FORMAT(//10X,' * THE 'I4,'  VALUES USED IN AVERAGES SATISFY...'   00007470
     C//14X,'1.  LOG CONDITION  .LT. 'F5.1                              00007480
     C//14X,'2.  N. AND S. HEMISPHERES EACH CONTAIN AT LEAST'I3,        00007490
     C   ' PERCENT OF POINTS'                                           00007500
     C//14X,'3.  NO LONGITUDINAL (PHI) QUADRANT HAS MORE THAN'I4,       00007510
     C   '  PERCENT OF POINTS' / )                                      00007520
C                                                                       00007530
C                                                                       00007540
C                                                                       00007550
      IF(IDIT 1 .EQ. 1)  WRITE(4,1004) K DIF ED, DIF MIN                00007560
 1004 FORMAT(//10X, I5, ' DATA PAIRS REJECTED BECAUSE // B1 - B2 // .LE.00007570
     C '  F5.2 )                                                        00007580
C                                                                       00007590
C                                                                       00007600
C                                                                       00007610
      IF(IDIT 2  .EQ.  1) WRITE(4,1006) L DIF ED, BOUND                 00007620
 1006 FORMAT(//10X,  I5, ' DATA PAIRS REJECTED BECAUSE  ABS(//B1// - //B00007630
     C2//) / (//B1// + //B2//)  .GE. 'F7.3 )                            00007640
C                                                                       00007650
C                                                                       00007660
      IF(IDIT 3  .EQ.  1) WRITE(4,1007) K ANG ED, DEL ANG               00007670
 1007 FORMAT(//10X, I5,' DATA PAIRS REJECTED BECAUSE ANGLE(B1,B2)  .LE.'00007680
     C     F6.1,' DEGREES')                                             00007690
C                                                                       00007700
C                                                                       00007710
      WRITE(4,1005) KERR                                                00007720
 1005 FORMAT(//10X, I5,'  OCTANT INDEXING ERRORS'//)                    00007730
C                                                                       00007740
      RETURN                                                            00007780
      END                                                               00007790
C
C
C
C
C
C     Z E R O    L E V E L    C O M P U T A T I O N S    U S I N G
C
C     3 - D    L I N E A R    M E T H O D    O F     M . H . A C U N A
C
C     A P P L I E D    T O    V O Y A G E R    4 8    S E C    A V G
C
C
C
C     ------------------------------------- 87APR08 -------------------
C     UPDATED TO COMPUTE SYMMETRY FACTORS;
C        WEIGHT AVERAGES BY SYMMETRY FACTORS;
C        AVERAGE CONDITION NUMBERS;
C        READ OPTIONAL OFFSET VALUES.
C     J.A.JONES SAR 1987 APRIL 6
C     RECONSIDERED:
C        DO NOT WEIGHT BY SYMMETRY FACTORS;
C        ROTATE AVERAGE VECTOR INTO HG COORDINATES, IF POSSIBLE;
C        CONVERT TO FORTRAN 77.
C     JAJ 87APR08
C     -----------------------------------------------------------------
C
C
      INTEGER*2 YR1, DAY1, OUR1, YR2, DAY2, OUR2
      INTEGER*2 HALF(35), IYR, IDA, IHR, MIN, ISC
      REAL*8 X1, Y1, Z1, X2, Y2, Z2, DX, DY, DZ
      REAL*8  ATA(3,3), E(3), V(3,3), AKI, AKJ, SUM, ERR
      DIMENSION KP1(3), LP2(3), KKK(3), LLL(3), S(9), TT(9), YY(9)
      DIMENSION CON(50), XPL(50), YPL(50), ZPL(50)
C
C     ------------------------------------- 87APR08 -------------------
C --> DATA PIVMI/1.0E-9/
      REAL PIVMI/1.0E-9/
C
C --> DATA NO AVG/'    '/,  IN AVG/'****'/
C --> DATA PL/'PL  '/
      CHARACTER*4 $NO AVG/'    '/,  $IN AVG/'****'/
      CHARACTER*4 $PL/'PL  '/
      EQUIVALENCE (NOAVG, $NOAVG), (INAVG, $INAVG), (PL, $PL)
C     ----------------------------------------------------------------
C
C
      DIMENSION A(4500), AA(4500), X(3), B(1500), BB(1500)
C
C
C
      DIMENSION DATA(1100), IDTA(1100)
      EQUIVALENCE (DATA(1), IDTA(1), HALF(1))
C
      EQUIVALENCE       (IYR,HALF(  7)),(IDA,HALF(  8)),(IHR,HALF(  9)),
     C  (MIN,HALF( 10)),(ISC,HALF( 11)),
     C    (X48, DATA(37)), (Y48, DATA(38)), (Z48, DATA(39))
C
C
C          MATRIX   Q   ROTATES    HG    TO    PL     Q * HG = PL
C
      EQUIVALENCE (DATA(560),Q11), (DATA(563),Q12), (DATA(566),Q13),
     C            (DATA(561),Q21), (DATA(564),Q22), (DATA(567),Q23),
     C            (DATA(562),Q31), (DATA(565),Q32), (DATA(568),Q33)
C
C
C        FOLLOWING DIMENSION ESTABLISHES MAXIMUM NKASE = 50
      DIMENSION X PL EST(50), Y PL EST(50), Z PL EST(50)
      DIMENSION X HG EST(50), Y HG EST(50), Z HG EST(50)
C     ------------------------------------- 87APR08 -------------------
      DIMENSION WGT X(50), WGT Y(50), WGT Z(50)
      DIMENSION CN STAR(50), CN ALL(50)
      LOGICAL FIXUP
      CHARACTER*7 PRT X, PRT Y, PRT Z
C
C
C
C --> DATA HDR1/'HDR1'/, LFM/'LFM '/
      CHARACTER*4 $HDR1/'HDR1'/, $LFM/'LFM '/
      EQUIVALENCE (HDR1, $HDR1), (LFM, $LFM)
C     -----------------------------------------------------------------
C
C
C               --- DATA B1 -------   -- DIFF B1-B2  ----
      DIMENSION OCTANT(8), ICTANT(8), OCTENT(8), ICTENT(8)
C
      KPAY = 0
      WRITE(3,109)
  109 FORMAT(   ///2X,'UNIT  3  PRINTOUT' //)
C
      WRITE(4,110)
  110 FORMAT(                            //////2X,'UNIT  4  PRINTOUT'//)
C
      WRITE(6,49)
   49 FORMAT(////2X,'UNIT  6  PRINTOUT  TAPE HEADER RECORD' //)
      WRITE(8,111)
  111 FORMAT(                            //////2X,'UNIT  8  PRINTOUT'//)
C
C
      WRITE(4,52)
      WRITE(8,52)
   52 FORMAT(
     C//10X,'VOYAGER  ZERO  LEVEL  COMPUTATION  USING'
     C//10X,'THE  3-D  LINEAR  METHOD  OF'
     C//10X,'M. H. ACUNA   (CHORD PERPENDICULAR TO RADIUS)'///)
C
C
C     ------------------------------------- 87APR06 -------------------
C     READ IN OFFSETS TO "FIXUP" THE INPUT VALUES.
C     IF NO OFFSETS ARE FOUND ON UNIT 5, NO FIXUP WILL BE DONE.
C
      FIXUP = .FALSE.
      READ (5, *, END = 5012) X OFF, Y OFF, Z OFF
         FIXUP = .TRUE.
         WRITE (4, 4010) X OFF, Y OFF, Z OFF
 4010    FORMAT (5X, 12('*****'),
     C           /T6,'*',T65,'*',
     C           /10X,'OFFSETS ADDED TO INPUT VALUES', 3F7.3,
     C            T6,'*',T65,'*',
     C           /T6,'*',T65,'*',
     C           /5X, 12('*****') // )
 5012 CONTINUE
C     -----------------------------------------------------------------
C
C
      M = 500
      M = 1000
      M = 1500
      M = 200
      M = 400
C
C
      WRITE(4,1) M
    1 FORMAT(/10X,'VOYAGER  48  SECOND  HG  DATA ROTATED INTO PAYLOAD BE
     CFORE PROCESSING'   //8X, I5,' DATA PAIRS PER ESTIMATE'//)
      WRITE(8,53)
   53 FORMAT(/10X,'PRECEEDING PAYLOAD ESTIMATES ROTATED BACK INTO HELIOG
     CRAPHIC COORDINATES'    )
C
C
C
C
      WRITE(4,50)
C     ------------------------------------- 87APR03 -------------------
   50 FORMAT(///
     C/11X,'*',6X,'P A Y L O A D',6X,'LEAST     FIELD DIRECTIONS',
     C       7X, 'SYMMETRY FACTORS'
     C/11X,'O    E S T I M A T E S   SQUARES    DISTRIBUTION',
     C    9X, '100 - |%(+) - %(-)|', 4X,'AVERAGE     LOG'
     C/11X,'K     OX     OY     OZ    ERROR     IN OCTANTS (%)',
     C   10X, 'X      Y      Z',
     C    7X, 'FIELD    COND   YR   DA   HR   MN' //)
C     -----------------------------------------------------------------
C
      WRITE(8,54)
   54 FORMAT(///
     C/11X,'*       HELIOGRAPHIC'
     C/11X,'O    E S T I M A T E S',9X,'MATRICES USED TO ROTATE'
     C/11X,'K     OX     OY     OZ',9X,'ESTIMATES, PL TO HG',
     C                         10X,'YR   DA   HR   MN' //)
C
C
      KERR = 0
C
C
C
C
C         S K I P    D A T A    B E F O R E    D A Y   1 ,   O U R 1
C
C         E N D   J O B    A F T E R    D A Y 2 ,    O U R 2
C
C
C        DAYS  34  THROUGH  37
      YR1 = 78
      DAY1 = 34
      OUR1 = 0
      YR2 = 78
      DAY2 = 37
      OUR2 = 24
C
C
C
C        DAYS  159  THROUGH  183
      YR1 = 78
      DAY1 = 159
      OUR1 = 0
      YR2 = 78
      DAY2 = 183
      OUR2 = 24
C
C
C        PROCESS ENTIRE   VOL=SER..... NO TIME LIMIT
C
      YR1 = 0
      DAY1 = 0
      OUR1 = 0
      YR2 = 99
      DAY2 = 500
      OUR2 = 50
C
C
C
C
C
C
C
C
C
   46 CONTINUE
C ->5 CALL FREAD(DATA,  20, LENGTH, &1001, &46)
    5 CALL FREAD(DATA,  20, LENGTH, *1001, *46)
C
C
C
      IF(DATA(1) - HDR1) 104, 101, 104
  101 WRITE(  6  ,102) DATA(1),DATA(3),DATA(13),DATA(93),DATA(94),
     C   DATA(95),DATA(96),DATA(97),DATA(98), DATA(65), DATA(66)
  102 FORMAT(//
     C//10X,'    RECORD IDENTIFIER  ', A4
     C//10X,'        SPACECRAFT ID  ', A4
     C//10X,'    COORDINATE SYSTEM  ', A4
     C//10X,'        NAME OF ZEROS  ',2A4
     C//10X,'NAME OF SENSITIVITIES  ',2A4
     C//10X,' NAME OF CALIBRATIONS  ',2A4
     C//10X,'SUMMARY TAPE  VOL=SER  ',2A4    ////)
C
      IF (DATA(13) .EQ. PL) KPAY = 1
      GO TO 5
C
C
  104 IF(IDTA(1) - LFM) 5,105,5
C
C
  105 CONTINUE
C
C
C
      IF(IYR - YR1) 5,43,43
   43 CONTINUE
C
      IF(IDA - DAY 1) 5,6,6
    6 CONTINUE
C
C
      IF(IHR - OUR1) 5,41,41
   41 CONTINUE
C
C
C        G E T    1 S T    P O I N T    O F    1 S T    D A T A    P A I
C
C
      X1 = X48
      Y1 = Y48
      Z1 = Z48
C
      IF (KPAY .EQ. 1) GO TO 70
C        R O T A T E    T O    P A Y L O A D
      X1 = Q11 * X48  +  Q12 * Y48  +  Q13 * Z48
      Y1 = Q21 * X48  +  Q22 * Y48  +  Q23 * Z48
      Z1 = Q31 * X48  +  Q32 * Y48  +  Q33 * Z48
C
   70 CONTINUE
C
C     ------------------------------------- 87APR06 -------------------
      IF (FIXUP) X1 = X1 + X OFF
      IF (FIXUP) Y1 = Y1 + Y OFF
      IF (FIXUP) Z1 = Z1 + Z OFF
C     -----------------------------------------------------------------
C
C
C     ------------------------------------- 87APR03 -------------------
C
C
C
C       G E N E R A T E    A V E R A G E S    O F     Z E R O
C
C        E S T I M A T E S    S A T I S F Y I N G    F O L L O W I N G
C
C    1   LEAST SQUARE ERROR / AVERAGE FIELD  .LT.  ERR MAX
C
C    2   LOG CONDITION    .LT.    CON MAX
C
C    3   FOR EACH COMPONENT, SYMMETRY FACTOR  .GE.  SYM MIN
C
C
C    NOTE:  THE SYMMETRY FACTOR IS A MEASURE OF THE DISTRIBUTION
C      OF THE VECTORS WRT EACH COORDINATE AXIS.  COMPUTE THE
C      FRACTION OF VECTORS WITH A POSITIVE PROJECTION ON THE AXIS,
C      %(+), AND THE FRACTION WITH NEGATIVE PROJECTION, %(-).
C      THE SYMMETRY FACTOR IS
C           SYM = 100 - ABS(%(+) - %(-)) ,
C           0 .LE. SYM .LE. 100 .
C      THUS, IF THE VECTORS ARE EVENLY DISTRIBUTED BETWEEN THE TWO
C      HEMISPHERES, %(+) = %(-), AND SYM = 100.
C      IF THE VECTORS ARE ALL IN THE SAME HEMISPHERE, SAY %(+) = 100%,
C      AND %(-) = 0%, THEN SYM = 0.
C      A LOW VALUE OF THE SYMMETRY FACTOR IMPLIES AN ASYMMETRICAL
C      DISTRIBUTION, A HIGH VALUE IMPLIES AN EVEN DISTRIBUTION.
C      AS A RULE, A SMALL SYMMETRY FACTOR FOR AN AXIS IS DIAGNOSTIC
C      FOR AN UNRELIABLE ZERO OFFSET ESTIMATE.
C      (JAJ 1987 APRIL 3)
C
C     -----------------------------------------------------------------
      ERR MAX = 0.015
      SYM MIN = 10.0
C
      CON MAX = 0.3
      MIN PCT = 20
      MAX PHI = 80
C
      MIN PCT = 10
      MAX PHI = 90
C
      KNT AVG = 0
C
C
C
C
C
C
C                 E D I T    1
C
C         // B 1  -  B 2  //   .GT.   D I F M I N
C
      DIF MIN = 0.2
      K DIF ED = 0
      IDIT 1 = 1
      IDIT 1 = 0
C
C
C
C
C           E D I T   2
C
C     ABS(//B1// - //B2//) / (//B1// + //B2//)  .LT.  BOUND
C
      BOUND = 0.15
      BOUND = 0.025
      BOUND = 0.050
      BOUND = 0.100
      BOUND = 0.200
      L DIF ED = 0
      IDIT 2 = 0
      IDIT 2 = 1
C
C
C
C
C             E D I T    3
C
C        A N G L E ( B1 , B2 )  . G T .    D E L  A N G
C
C
      DEL ANG = 4.0
      DEL ANG = 3.0
      DEL ANG = 2.0
      K ANG ED = 0
      IDIT 3 = 0
      IDIT 3 = 1
C
C
C
      NKASE = 200
      NKASE = 50
      KNT = 0
      DO 1000 KASE = 1, NKASE
C
C
      DO 123 I=1,8
      OCTENT(I) = 0.0
  123 OCTANT(I) = 0.0
C
C
C
C
      ID1 = IDA
      IH1 = IHR
      IM1 = MIN
C
C
C
C
      SUM = 0.0
C
C
C
C
C        E D I T   D A T A   A N D   C R E A T E   M   D A T A   P A I R
C
      DO 100 I=1,M
C
C        G E T   2 N D   P O I N T   O F   D A T A   P A I R
C
    3 CONTINUE
C
C --> CALL FREAD(DATA,  20 , LENGTH, &1001,  &3 )
      CALL FREAD(DATA,  20 , LENGTH, *1001,  *3 )
      IF(DATA(1) - HDR1) 107,106,107
  106 WRITE(  6  ,102) DATA(1),DATA(3),DATA(13),DATA(93),DATA(94),
     C   DATA(95),DATA(96),DATA(97),DATA(98), DATA(65), DATA(66)
      IF (DATA(13) .EQ. PL) KPAY = 1
      DAT1=DATA(93)
      DAT2=DATA(94)
      DAT3=DATA(95)
      DAT4=DATA(96)
      GO TO 3
C
C
C
  107 IF(IDTA(1) - LFM) 3,108,3
  108 CONTINUE
C
C
C
C
C
      IF(IYR - YR 2)  2,44,1001
   44 CONTINUE
C
C
      IF(IDA - DAY 2) 2,42,1001
C
   42 IF(IHR - OUR2) 2,2,1001
C
C
C
C
    2 CONTINUE
C
C
      X2 = X48
      Y2 = Y48
      Z2 = Z48
C
      IF (KPAY .EQ. 1) GO TO 71
C         R O T A T E    T O    P A Y L O A D
      X2 = Q11 * X48  +  Q12 * Y48  +  Q13 * Z48
      Y2 = Q21 * X48  +  Q22 * Y48  +  Q23 * Z48
      Z2 = Q31 * X48  +  Q32 * Y48  +  Q33 * Z48
C
   71 CONTINUE
C
C     ------------------------------------- 87APR06 -------------------
      IF (FIXUP) X2 = X2 + X OFF
      IF (FIXUP) Y2 = Y2 + Y OFF
      IF (FIXUP) Z2 = Z2 + Z OFF
C     -----------------------------------------------------------------
C
      F1 = DSQRT(X1*X1 + Y1*Y1 + Z1*Z1)
      F2 = DSQRT(X2*X2 + Y2*Y2 + Z2*Z2)
C
C
C     *********** E D I T   P A I R   *********************************
C     *********** E D I T   P A I R   *********************************
C
C      E D I T    P A I R
C
C
C
C
C
C
      IF(IDIT 1) 23,23,25
   25 CONTINUE
C                 E D I T   1
C     R E Q U I R E   // B 1 - B 2 //  . G T .   D I F M I N
C
      DX = X1 - X2
      DY = Y1 - Y2
      DZ = Z1 - Z2
      DIF = DSQRT(DX*DX + DY*DY + DZ*DZ)
C
      IF(DIF - DIF MIN) 22,22,23
C
   22 K DIF ED = K DIF ED + 1
      IS1 = IS2
      X 1 = X 2
      Y 1 = Y 2
      Z 1 = Z 2
C
      GO TO 3
C
C
   23 IF(IDIT 2) 29,29,26
   26 CONTINUE
C
C
C            E D I T   2
C
C     ABS(//B1// - //B2//) / (//B1// + //B2//)  .LT.  BOUND
C
      IF( ( ABS(F1 - F2) / (F1 + F2) )  -  BOUND) 29,28,28
   28 L DIF ED = L DIF ED + 1
      IS1 = IS2
      X 1 = X 2
      Y 1 = Y 2
      Z 1 = Z 2
      GO TO 3
C
C
C
   29 IF(IDIT 3) 32,32,30
   30 CONTINUE
C
C        E D I T   3
C
C        A N G L E ( B1 , B2 )   . G T .   D E L   A N G
C
      C B1 B2 = (X1*X2 + Y1*Y2 + Z1*Z2)/(F1*F2)
      IF( ABS(C B1 B2) - 1.0) 48,48,31
   48 CONTINUE
      ANGL = ARCOS(C B1 B2)/(1.74533 E-2)
      IF(ANGL - DEL ANG) 31,31,32
   31 K ANG ED = K ANG ED + 1
      IS1 = IS2
      X 1 = X 2
      Y 1 = Y 2
      Z 1 = Z 2
      GO TO 3
C
C
   32 CONTINUE
C
C
C
C
C     ******************************************************************
C     ******************************************************************
C
      SUM = SUM + F1 + F2
C
C
C
C        A D D    C U R R E N T    D A T A    P A I R    T O
C
C        L I N E A R    S Y S T E M    F O R    3 D    M E T H O D
C
C        O F     M .  H .  A C U N A  .
C
      IJ = 3*(I - 1)
C
      A(IJ + 1) = 2.0*(X2 - X1)
      A(IJ + 2) = 2.0*(Y2 - Y1)
      A(IJ + 3) = 2.0*(Z2 - Z1)
C
      DX = X1*X1 - X2*X2
      DY = Y1*Y1 - Y2*Y2
      DZ = Z1*Z1 - Z2*Z2
C
      B(I) = DX + DY + DZ
C
C
C       M A I N T A I N     O C T A N T    S T A T I S T I C S
C       F O R    D A T A    B 1
C
      EX = X 1
      WY = Y 1
      ZE = Z 1
C
      PHI = ANGLE(WY, EX)
      RR = SQRT(EX*EX + WY*WY)
      THETA = ANGLE(RR, ZE)
      INDEX = 1 + PHI/90.0
      IF(THETA - 90.0) 14,14,13
   13 INDEX = INDEX + 4
   14 IF(INDEX) 16,16,15
   15 IF(INDEX - 8) 17,17,16
   16 KERR = KERR + 1
      GO TO 18
   17 OCTANT(INDEX) = OCTANT(INDEX) + 1
   18 CONTINUE
C
C          MAINTAIN  OCTENT  STATISTICS FOR DIFFERENCES  B1 - B2
C
      DX = X1 - X2
      DY = Y1 - Y2
      DZ = Z1 - Z2
C
      PHI = ANGLE(DY,DX)
      RR = DSQRT(DX*DX + DY*DY)
      THETA = ANGLE(RR,DZ)
C
      INDEX = 1 + PHI/90.0
      IF(THETA - 90.0) 64,64,63
   63 INDEX = INDEX + 4
   64 IF(INDEX) 66,66,65
   65 IF(INDEX - 8) 67,67,66
   66 KERR = KERR + 1
      GO TO 68
   67 OCTENT(INDEX) = OCTENT(INDEX) + 1
   68 CONTINUE
C
C
C      R E T A I N   2 N D   P O I N T   F O R   N E X T   D A T A   P A
      IS1 = IS2
      X 1 = X 2
      Y 1 = Y 2
      Z 1 = Z 2
C
C
  100 CONTINUE
C
C
      AVG = SUM/(2*M)
C
C
C        COPY  A ,  B  FOR LEAST SQUARES ERROR COMPUTATION
      MN = M*3
      DO 8 I=1,MN
    8 AA(I) = A(I)
      DO 9 I=1,M
    9 BB(I) = B(I)
C
C
C
C     ******************* BEGIN CONDITION ANALYSIS  ********************
C
C        A C C U M U L A T E   U P P E R   T R I A N G L E   O F    A T
C
      DO 11 I=1,3
      DO 11 J=I,3
      SUM = 0.0
      DO 10 K=1,M
      KK = 3*(K-1)
      KI = KK + I
      KJ = KK + J
      AKI = A(KI)
      AKJ = A(KJ)
      SUM = SUM + AKI*AKJ
   10 CONTINUE
   11 ATA(I,J) = SUM
C
C        F I L L   I N   L O W E R   T R I A N G L E   O F   A T A
      ATA(2,1) = ATA(1,2)
      ATA(3,1) = ATA(1,3)
      ATA(3,2) = ATA(2,3)
C
C
C
      NVAL = 3
      NVEC = 0
C
      CALL GIVHO(ATA, E, V, NVAL, NVAL, NVEC)
      COND = DSQRT(E(1) / E(NVAL))
      CNLOG = ALOG(COND) / 2.30259
C
C
C     *******************  END CONDITION ANALYSIS  *********************
C
C
      N = 3
      IRANK = 0
C
      CALL SEUDO(A, X, B, M, N, PIVMI,IRANK,KP1,LP2,KKK,LLL,S,TT,YY)
C
C
C
C      C O M P U T E   L E A S T    S Q U A R E S    E R R O R
      ERR = 0.0
      DO 20 I=1,M
C
C
      IJ = 3*(I - 1)
      FIT = AA(IJ+1)*X(1) + AA(IJ+2)*X(2) + AA(IJ+3)*X(3)
C
      EPSQ = (FIT - BB(I))**2
C
      ERR = ERR + EPSQ
   20 CONTINUE
C
      ERR = DSQRT(ERR/M)
C
C
C        SAVE ALL DATA FOR WEIGHTED AVERAGES  (WEIGHT = 1.0/CONDITION)
      KNT = KNT + 1
      CON(KNT) = COND
      CN ALL(KNT) = CN LOG
      XPL(KNT) = X(1)
      YPL(KNT) = X(2)
      ZPL(KNT) = X(3)
C
C
C
C        P U B L I S H   O C T A N T   S T A T I S T I C S
C
      DO 19 I=1,8
      ICTANT(I) = 0.5 + 100.0*OCTANT(I)/M
      ICTENT(I) = 0.5 + 100.0*OCTENT(I)/M
   19 CONTINUE
C
C
C     ----- SYMMETRY FACTORS -------------- 87APR03 -------------------
      XPLUS  = OCTANT(1) + OCTANT(4) + OCTANT(8) + OCTANT(5)
      XMINUS = OCTANT(2) + OCTANT(3) + OCTANT(7) + OCTANT(6)
      YPLUS  = OCTANT(1) + OCTANT(2) + OCTANT(6) + OCTANT(5)
      YMINUS = OCTANT(4) + OCTANT(3) + OCTANT(7) + OCTANT(8)
      ZPLUS  = OCTANT(1) + OCTANT(2) + OCTANT(3) + OCTANT(4)
      ZMINUS = OCTANT(5) + OCTANT(6) + OCTANT(7) + OCTANT(8)
 
      SYM X = 100.0 * (1.0 - ABS(XPLUS - XMINUS)/M)
      SYM Y = 100.0 * (1.0 - ABS(YPLUS - YMINUS)/M)
      SYM Z = 100.0 * (1.0 - ABS(ZPLUS - ZMINUS)/M)
C     -----------------------------------------------------------------
C
C
C      E D I T    F O R    A V E R A G E    C O M P U T A T I O N S
C
C     ----- NEW EDIT CRITERIA --------- JAJ 87APR03 -------------------
      MEMO = NO AVG
      IF (ERR/AVG .GT. ERR MAX) GO TO 40
      IF (CN LOG .GT. CON MAX) GO TO 40
      KNT AVG = KNT AVG + 1
      MEMO = IN AVG
C
      IF (SYM X .LT. SYM MIN) GO TO 36
         KNT X = KNT X + 1
         WGT X(KNT X) = SYM X
         X PL EST(KNT X) = X(1)
   36 CONTINUE
C
      IF (SYM Y .LT. SYM MIN) GO TO 37
         KNT Y = KNT Y + 1
         WGT Y(KNT Y) = SYM Y
         Y PL EST(KNT Y) = X(2)
   37 CONTINUE
C
      IF (SYM Z .LT. SYM MIN) GO TO 38
         KNT Z = KNT Z + 1
         WGT Z(KNT Z) = SYM Z
         Z PL EST(KNT Z) = X(3)
   38 CONTINUE
C
C     SAVE CONDITION NUMBERS FOR STARRED ESTIMATES.
      CN STAR(KNT AVG) = CN LOG
   40 CONTINUE
C     -----------------------------------------------------------------
C
C
C     ------------------------------------- 87APR03 -------------------
      WRITE(4,21) KASE, MEMO, X, ERR, (ICTANT(I), I = 1, 4),
     C  SYM X, SYM Y, SYM Z,
     C  AVG, CNLOG,
     C  IYR, ID1, IH1, IM1,
     C                                (ICTANT(I), I = 5, 8)
   21 FORMAT(5X, I5, 1X, A1, 1X, 3F7.3, F8.4, 2X, 4I5,
     C    2X, 3F7.1,
     C    3X, F8.3, F8.2,
     C    4I5,          /  44X, 4I5            /)
C     -----------------------------------------------------------------
C
C
      IF (KPAY .EQ. 1) GO TO 72
C
C        R O T A T E    T O    I N E R T I A L    H E L I O G R A P H I
      XHG = Q11 * X(1)  +  Q21 * X(2)  +  Q31 * X(3)
      YHG = Q12 * X(1)  +  Q22 * X(2)  +  Q32 * X(3)
      ZHG = Q13 * X(1)  +  Q23 * X(2)  +  Q33 * X(3)
C
      GO TO 73
   72 XHG = X(1)
      YHG = X(2)
      ZHG = X(3)
   73 CONTINUE
C
      WRITE(8,51) KASE,MEMO,XHG,YHG,ZHG,Q11,Q21,Q31,IYR,ID1,IH1,IM1,
     C                                  Q12,Q22,Q32,
     C                                  Q13,Q23,Q33
   51 FORMAT(5X, I5, 1X, A1, 1X, 3F7.2, 5X, 3F9.4, 2X, 4I5,
     C     /39X, 3F9.4  /39X, 3F9.4  /)
C
C     ------------------------------------- 87APR09 -------------------
C     (* SAVE ROTATION MATRIX *)
      P11 = Q11
      P12 = Q12
      P13 = Q13
      P21 = Q21
      P22 = Q22
      P23 = Q23
      P31 = Q31
      P32 = Q32
      P33 = Q33
C     -----------------------------------------------------------------
C
C
      IF(MEMO - IN AVG) 1000, 998, 1000
  998 X HG EST(KNT AVG) = X HG
      Y HG EST(KNT AVG) = Y HG
      Z HG EST(KNT AVG) = Z HG
 1000 CONTINUE
C
 1001 CONTINUE
C
C
C
C                     O   U   T
C
C
C        C O M P U T E    A N D    P U B L I S H    A V E R A G E S
C
C
C     ------------------------------------- 87APR08 -------------------
C   ----------   UNWEIGHTED AVERAGES  (* STARRED ESTIMATES ONLY) -------
      X AV HG = 0.0
      Y AV HG = 0.0
      Z AV HG = 0.0
      CN AV ST = 0.0
      IF( KNT AVG .LT. 1) GO TO 45
      DO 55 I=1,KNT AVG
      X AV HG = X AV HG + X HG EST(I)
      Y AV HG = Y AV HG + Y HG EST(I)
      Z AV HG = Z AV HG + Z HG EST(I)
      CN AV ST = CN AV ST + CN STAR(I)
   55 CONTINUE
      X AV HG = X AV HG / KNT AVG
      Y AV HG = Y AV HG / KNT AVG
      Z AV HG = Z AV HG / KNT AVG
      CN AV ST = CN AV ST / KNT AVG
C
      IF (KNT X .GT. 0) THEN
         DO 552 I = 1, KNT X
            WGT X AV = WGT X AV + WGT X(I)
C -->       X AV PL = X AV PL + WGT X(I) * X PL EST(I)
            X AV PL = X AV PL + X PL EST(I)
  552    CONTINUE
C -->    X AV PL = X AV PL / WGT X AV
         X AV PL = X AV PL / KNT X
         WGT X AV = WGT X AV / KNT X
         WRITE (UNIT = PRT X, FMT = '(F7.3)') X AV PL
      ELSE
C        (* KNT X = 0, SO NO X-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT X, FMT = '(A7)') '   ?   '
      END IF
C
      IF (KNT Y .GT. 0) THEN
         DO 553 I = 1, KNT Y
            WGT Y AV = WGT Y AV + WGT Y(I)
C -->       Y AV PL = Y AV PL + WGT Y(I) * Y PL EST(I)
            Y AV PL = Y AV PL + Y PL EST(I)
  553    CONTINUE
C -->    Y AV PL = Y AV PL / WGT Y AV
         Y AV PL = Y AV PL / KNT Y
         WGT Y AV = WGT Y AV / KNT Y
         WRITE (UNIT = PRT Y, FMT = '(F7.3)') Y AV PL
      ELSE
C        (* KNT Y = 0, SO NO Y-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT Y, FMT = '(A7)') '   ?   '
      END IF
C
      IF (KNT Z .GT. 0) THEN
         DO 555 I = 1, KNT Z
            WGT Z AV = WGT Z AV + WGT Z(I)
C -->       Z AV PL = Z AV PL + WGT Z(I) * Z PL EST(I)
            Z AV PL = Z AV PL + Z PL EST(I)
  555    CONTINUE
C -->    Z AV PL = Z AV PL / WGT Z AV
         Z AV PL = Z AV PL / KNT Z
         WGT Z AV = WGT Z AV / KNT Z
         WRITE (UNIT = PRT Z, FMT = '(F7.3)') Z AV PL
      ELSE
C        (* KNT Z = 0, SO NO Z-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT Z, FMT = '(A7)') '   ?   '
      END IF
C     -----------------------------------------------------------------
C
C     ------------------------------------- 87APR03 -------------------
C  -------------  WEIGHTED AVERAGES  (ALL ESTIMATES)  --------------
   45 IF (KNT .LT. 1) GO TO 47
      DEN = 0.0
      XAV = 0.0
      YAV = 0.0
      ZAV = 0.0
      CN AV = 0.0
      DO 58 I=1,KNT
      DEN = DEN + 1.0/CON(I)
      XAV = XAV + XPL(I)/CON(I)
      YAV = YAV + YPL(I)/CON(I)
      ZAV = ZAV + ZPL(I)/CON(I)
      CN AV = CN AV + CN ALL(I)
   58 CONTINUE
      XAV = XAV/DEN
      YAV = YAV/DEN
      ZAV = ZAV/DEN
      CN AV = CN AV/KNT
      IF(KNTX.EQ.0.AND.KNTY.EQ.0.AND.KNTZ.EQ.0) GO TO 201
      CALL KTIME(IY,ID)
      IDA=IDA-1
      WRITE(12,200)IYR,IDA,XAVPL,YAVPL,ZAVPL,KNTX,KNTY,KNTZ,DAT1,
     1DAT2,DAT3,DAT4,IY,ID
  200 FORMAT(2I5,3F7.3,3I7,2A4,1X,2A4,2I5)
  201 CONTINUE
C     -----------------------------------------------------------------
C
C     ------------------------------------- 87APR08 -------------------
C --> WRITE(4,997) X AV PL, Y AV PL, Z AV PL, XAV, YAV, ZAV,
      WRITE(4,997) PRT X,   PRT Y,   PRT Z,   XAV, YAV, ZAV,
     .             SYM MIN,
     .             KNT X,   KNT Y,   KNT Z,        KNT
  997 FORMAT(
     C//10X,' * UNWEIGHTED AVERAGES            WEIGHTED AVERAGES'
C -->C//10X,' * WEIGHTED AVERAGES              WEIGHTED AVERAGES'
C -->C /10X,'   --BY SYMMETRY FACTOR           --BY CONDITION NUMBER'
     C /10X,' * (COMPONENTS SELECTED           (ALL ESTIMATES)'
     C /10X,'    FROM STARRED ESTIMATES)'
C -->C//13X,  3F7.3, 10X, 3F7.3
     C//13X,  3A7,   10X, 3F7.3
     C//10X,'   NUMBER OF *''D ESTIMATES        NUMBER OF ESTIMATES'
     C /10X,'   WITH SYM FACTOR .GE. ', F5.1
     C//11X,  3I7,   17X, I7 /)
C     -----------------------------------------------------------------
      WRITE(8,999) X AV HG, Y AV HG, Z AV HG
  999 FORMAT(//10X,' * VALUES YIELD FOLLOWING AVERAGES...' //13X, 3F7.2)
C
C        COMPUTE AND PUBLISH 'SIGMAS'  (RPL  24 APR 80)
C
      SIG X PL = 0.0
      SIG Y PL = 0.0
      SIG Z PL = 0.0
      SIG X HG = 0.0
      SIG Y HG = 0.0
      SIG Z HG = 0.0
      IF ( KNT AVG .LT. 1) GO TO 47
      DO 56 I=1,KNT AVG
      SIG X HG = SIG X HG + (X HG EST(I) - X AV HG)**2
      SIG Y HG = SIG Y HG + (Y HG EST(I) - Y AV HG)**2
      SIG Z HG = SIG Z HG + (Z HG EST(I) - Z AV HG)**2
   56 CONTINUE
      SIG X HG = SQRT(SIG X HG) / KNT AVG
      SIG Y HG = SQRT(SIG Y HG) / KNT AVG
      SIG Z HG = SQRT(SIG Z HG) / KNT AVG
C
C     ------------------------------------- 87APR08 -------------------
      IF (KNT X .GE. 1) THEN
         DO 561 I = 1, KNT X
C -->       SIG X PL = SIG X PL + WGT X(I)*(X PL EST(I) - X AV PL)**2
            SIG X PL = SIG X PL + (X PL EST(I) - X AV PL)**2
  561    CONTINUE
C -->    SIG X PL = SQRT(SIG X PL) /(KNT X * WGT X AV)
         SIG X PL = SQRT(SIG X PL) / KNT X
         WRITE (UNIT = PRT X, FMT = '(F7.3)') SIG X PL
      ELSE
C        (* KNT X = 0, SO NO X-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT X, FMT = '(A7)') '   ?   '
      END IF
C
      IF (KNT Y .GT. 0) THEN
         DO 563 I = 1, KNT Y
C -->       SIG Y PL = SIG Y PL + WGT Y(I)*(Y PL EST(I) - Y AV PL)**2
            SIG Y PL = SIG Y PL + (Y PL EST(I) - Y AV PL)**2
  563    CONTINUE
C -->    SIG Y PL = SQRT(SIG Y PL) /(KNT Y * WGT Y AV)
         SIG Y PL = SQRT(SIG Y PL) / KNT Y
         WRITE (UNIT = PRT Y, FMT = '(F7.3)') SIG Y PL
      ELSE
C        (* KNT Y = 0, SO NO Y-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT Y, FMT = '(A7)') '   ?   '
      END IF
C
      IF (KNT Z .GT. 0) THEN
         DO 565 I = 1, KNT Z
C -->       SIG Z PL = SIG Z PL + WGT Z(I)*(Z PL EST(I) - Z AV PL)**2
            SIG Z PL = SIG Z PL + (Z PL EST(I) - Z AV PL)**2
  565    CONTINUE
C -->    SIG Z PL = SQRT(SIG Z PL) /(KNT Z * WGT Z AV)
         SIG Z PL = SQRT(SIG Z PL) / KNT Z
         WRITE (UNIT = PRT Z, FMT = '(F7.3)') SIG Z PL
      ELSE
C        (* KNT Z = 0, SO NO Z-ESTIMATES ARE RELIABLE *)
         WRITE (UNIT = PRT Z, FMT = '(A7)') '   ?   '
      END IF
C     -----------------------------------------------------------------
C
C --> WRITE(4,57) SIG X PL, SIG Y PL, SIG Z PL
C     ------------------------------------- 87APR08 -------------------
      WRITE (4, 4057) PRT X,    PRT Y,    PRT Z
 4057 FORMAT(//10X,' * VALUES YIELD FOLLOWING SIGMA/SQRT(N)......'
     C   //13X, 3A7  )
C     -----------------------------------------------------------------
      WRITE(8,57) SIG X HG, SIG Y HG, SIG Z HG
   57 FORMAT(//10X,' * VALUES YIELD FOLLOWING SIGMA/SQRT(N)......'
     C   //13X, 3F7.3)
C
C     ------------------------------------- 87APR09 -------------------
      IF (      (KNT X .NE. 0)
     .    .AND. (KNT Y .NE. 0)
     .    .AND. (KNT Z .NE. 0) ) THEN
C        (* ROTATE AVERAGE OFFSET VECTOR TO HG COORDINATES *)
         X AV HG = P11 * X AV PL  +  P21 * Y AV PL  +  P31 * Z AV PL
         Y AV HG = P12 * X AV PL  +  P22 * Y AV PL  +  P32 * Z AV PL
         Z AV HG = P13 * X AV PL  +  P23 * Y AV PL  +  P33 * Z AV PL
C
         WRITE (8, 8010) X AV HG, Y AV HG, Z AV HG
 8010    FORMAT (//10X,'AVERAGE PAYLOAD OFFSET',
     .                 ', ROTATED INTO HG...'
     .           //13X, 3F7.3//)
      ELSE
C        (* SOME COMPONENTS MISSING -- ROTATION NOT MEANINGFUL *)
         WRITE (8, 8011)
 8011    FORMAT (//10X,'AVERAGE PAYLOAD OFFSET',
     .                 ' CANNOT BE ROTATED INTO HG',
     .            /10X,'BECAUSE SOME COMPONENTS ARE MISSING.'//)
      END IF
C     -----------------------------------------------------------------
C
C     ------------------------------------- 87APR06 -------------------
      WRITE(4,59) CN AV ST, CN AV,  WGT X AV, WGT Y AV, WGT Z AV
   59 FORMAT(//10X,' MEAN LOG CONDITION NUMBER (*''D VALUES) ', F7.3
     C        /10X,' MEAN LOG CONDITION NUMBER (ALL VALUES) ', F7.3
     C      ///10X,' MEAN SYMMETRY FACTORS ', 3F8.2 )
C     -----------------------------------------------------------------
C
C
   47 CONTINUE
C     ------------------------------------- 87APR08 -------------------
      WRITE(4,1008) ERR MAX, CON MAX, SYM MIN
 1008 FORMAT(//10X,' * THE VECTORS MARKED WITH * SATISFY...'
     C//14X,'1.  LEAST SQUARE ERROR/MEAN FIELD  .LT. ',F6.3
     C//14X,'2.  LOG CONDITION  .LT. ',F5.1
     C//10X,' THE COMPONENTS SELECTED FOR AVERAGES ALSO SATISFY...'
     C//14X,'3.  SYMMETRY FACTOR  .GE. ',F5.1  /)
C     -----------------------------------------------------------------
C
C
C
      IF(IDIT 1 .EQ. 1)  WRITE(4,1004) K DIF ED, DIF MIN
 1004 FORMAT(//10X, I5, ' DATA PAIRS REJECTED BECAUSE // B1 - B2 // .LE.
     C ', F5.2 )
C
C
C
      IF(IDIT 2  .EQ.  1) WRITE(4,1006) L DIF ED, BOUND
 1006 FORMAT(//10X,  I5, ' DATA PAIRS REJECTED BECAUSE  ABS(//B1// - //B
     C2//) / (//B1// + //B2//)  .GE. ',F7.3 )
C
C
      IF(IDIT 3  .EQ.  1) WRITE(4,1007) K ANG ED, DEL ANG
 1007 FORMAT(//10X, I5,' DATA PAIRS REJECTED BECAUSE ANGLE(B1,B2)  .LE.'
     C   , F6.1,' DEGREES')
C
C
      WRITE(4,1005) KERR
 1005 FORMAT(//10X, I5,'  OCTANT INDEXING ERRORS'//)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C THIS ROUTINE READS A STANDARD VOYAGER SUMMARY TAPE, AND CALCULATES
C HOURLY AVERAGES FOR SPACE CRAFT FIELD (X, Y, Z FIELD COMPONENTS
C AND THE TOTAL FIELD) AND THE RMS FOR THE TOTAL  FIELD,
C FROM 48 SECOND AVERAGES. THESE ARE OUTPUT TO A DISK FILE.
C     THE INTENTION IS TO PROCESS 30
C DAYS OF DATA AT A TIME.  THE OUTPUT FROM THIS PROGRAM WILL BE
C TRANSFERRED TO THE LEP VAX VIA COMBOARD WHERE IT WILL BE PLOTTED.
C
C PDL: READ SUMMARY TAPE RECORD
C      IF THE RECORD IS NOT LFM THEN DISCARD THE RECORD
C      IF THE SPACE CRAFT FIELD IS FILL(999.) THEN DISCARD THE RECORD
C      IF THIS RECORD IS FOR THE HOUR BEING PROCESSED THEN
C          ACCUMULATE THE SPACE CRAFT FIELD VALUES AND INCREMENT THE
C           COUNT
C      ELSE
C          RESET THE CURRENT HOUR BEING PROCESSED
C          IF THERE ARE POINTS ACCUMULATED FOR THIS HOUR THEN
C              CALCULATE AVERAGES AND RMS
C              OUTPUT THE TIME, AVERAGES AND RMS
C          END IF
C          INITIALIZE ACCUMULATORS AND COUNTER FOR NEXT HOUR
C      END IF
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      INTEGER*2 REC, YR, DAY, HR, CURYR, CURDAY,
     1          CURHR
      DATA CURYR/0/, CURDAY/0/, CURHR/0/, LFM/'LFM '/
      DIMENSION REC(2500)
      EQUIVALENCE (REC(1), IDENT),
     1            (REC(7), YR),
     2            (REC(8), DAY),
     3            (REC(9), HR),
     4            (REC(1049), SCX),
     5            (REC(1051), SCY),
     6            (REC(1053), SCZ),
     7            (REC(1055), SCF)
   10 CONTINUE
      CALL FREAD (REC, 10, NBYT, *30, *20)
      IF (IDENT.NE. LFM) GO TO 10
      IF (SCF .EQ. 999.) GO TO 10
      IF ((YR .EQ. CURYR) .AND. (DAY .EQ. CURDAY) .AND. (HR .EQ. CURHR))
     1THEN
          SUMX = SUMX + SCX
          SUMY = SUMY + SCY
          SUMZ = SUMZ + SCZ
          SUMF = SUMF + SCF
          SUMF2 = SUMF2 + SCF**2
          NSC = NSC + 1
      ELSE
          IF (NSC .NE. 0) THEN
              HAVX = SUMX / NSC
              HAVY = SUMY / NSC
              HAVZ = SUMZ / NSC
              HAVF = SUMF / NSC
              RMSF = SQRT((NSC * SUMF2 - SUMF**2)/(NSC * (NSC - 1)))
              WRITE (20,FMT='(3I4,5E12.4)') YR, DAY, HR, HAVX, HAVY,
     1                                      HAVZ, HAVF, RMSF
          END IF
          CURYR = YR
          CURDAY = DAY
          CURHR = HR
          SUMX = SCFX
          SUMY = SCFY
          SUMZ = SCFZ
          SUMF = SCF
          SUMF2 = SCF**2
          NSC = 1
      END IF
      GO TO 10
   20 CONTINUE
      WRITE (6,FMT='('' ERROR READING SUMMARY FILE'')')
      GO TO 10
   30 CONTINUE
C OUTPUT DATA FOR LAST HOUR PROCESSED
      IF (NSC .NE. 0) THEN
          HAVX = SUMX / NSC
          HAVY = SUMY / NSC
          HAVZ = SUMZ / NSC
          HAVF = SUMF / NSC
          RMSF = SQRT((NSC * SUMF2 - SUMF**2)/(NSC * (NSC - 1)))
          WRITE (20,FMT='(3I4,5E12.4)') YR, DAY, HR, HAVX, HAVY,
     1                                  HAVZ, HAVF, RMSF
      END IF
      STOP
      END
      SUBROUTINE SDRGET (ITM,REC,ITYPE)                                 00000100
C-----------------------------------------------------------------------00000110
C  READS STANDARD JPL SEDR TAPE & RETURNS ONE DATA RECORD AT A TIME.    00000120
C-----------------------------------------------------------------------00000130
C ---- BY ADS                                                           00000140
C  VAR     I/O      TYPE     DESCRIPTION                                00000150
C  ---    ------   -------   -------------------------------            00000160
C  ITM    OUTPUT   6(I*4)    TIME (YR DY HR MN SC MS)                   00000170
C  REC    OUTPUT   "ARRAY"   DATA RECORD                                00000180
C  ITYPE  OUTPUT      I*4    DATA RECORD DESCRIPTOR                     00000190
C                                                                       00000200
C  ITYPE  DESCRIPTION                    RETURNS TO CALLING PROGRAM     00000210
C  -----  -----------                    ------- -- ------- -------     00000220
C    1    JUPITER NAVIGATION RECORD      TIME RETURNED IN ITM           00000230
C                                        RECORD RETURNED IN REC(1008 B.)00000240
C    2    NON-JUPITER NAVIGATION RECORD  TIME RETURNED IN ITM           00000250
C                                        RECORD RETURNED IN REC(504 B.) 00000260
C    3    POINTING VECTOR RECORD         TIME RETURNED IN ITM           00000270
C                                        RECORD RETURNED IN REC(504 B.) 00000280
C    4    HEADER RECORD                  RECORD RETURNED IN REC(180 B.) 00000290
C    5    HEADER RECORD(OUT OF ORDER)    RECORD RETURNED IN REC(180 B.) 00000300
C    6    BAD RECORD                     ---------------                00000310
C    7    I/O ERROR                      ---------------                00000320
C    8    END OF FILE                    ---------------                00000330
C    9    BEYOND END OF TIME INTERVAL    ---------------                00000340
C                                                                       00000350
C  NOTE: ITYPE=9 IS FLAGGED ONLY WHEN BOTH A NAVIGATION RECORD (IF      00000360
C        EITHER TYPE HAS BEEN REQUESTED) AND A POINTING VECTOR          00000370
C        RECORD (IF REQUESTED) HAVE BEEN FOUND BEYOND THE END OF THE    00000380
C        TIME INTERVAL. THEREAFTER, NO TAPE READ IS PERFORMED AND THIS  00000390
C        ITYPE IS RETURNED UNTIL SDRRST IS CALLED AGAIN.                00000400
C  NOTE: IF AN EXCESSIVELY LARGE RECORD IS ENCOUNTERED ON THE TAPE      00000410
C        THIS IS A FATAL ERROR.                                         00000420
C  NOTE: NO CHECKS ARE MADE ON THE SEDR EXCEPT FOR RECORD SIZE AND      00000430
C        POINTING VECTOR CONTINUATION WORD.                             00000440
C-----------------------------------------------------------------------00000450
      LOGICAL*1 REC(1)                                                  00000460
      LOGICAL*4 LTYPE(1),LEOF/.FALSE./,LTMS(2)/2*.FALSE./               00000470
      LOGICAL*4 LDOE(7)/7*.TRUE./                                       00000480
      INTEGER*4 ITM(6),NPTR/4/,NSEC/0/,ICB/0/,IBUF(126,3)               00000490
      INTEGER*4 LIM1(6),LIM2(6),JREC/0/                                 00000500
      REAL*8 TIME1/-5.D75/,TIME2/+5.D75/,TIME,TIMS                      00000510
      IF (LEOF) GO TO 8                                                 00000520
C**** GET A NEW DATA RECORD.                                            00000530
  501 IF (LTMS(1).AND.LTMS(2)) GO TO 9                                  00000540
      IF (NPTR.LE.NSEC.AND.(NPTR.EQ.1.OR.ICB.EQ.1)) GO TO 1             00000550
C**** GET A NEW LOGICAL RECORD.                                         00000560
      CALL FREAD(IBUF,12,IBYT,&8,&7)                                    00000570
      JREC = JREC + 1                                                   00000580
      NPTR = 1                                                          00000590
      NSEC = 0                                                          00000600
      IF (IBYT.GT.1512) GO TO 503                                       00000610
      IF (IBYT.EQ.180) GO TO 4                                          00000620
      IF (IBYT.NE.1008.AND.IBYT.NE.1512) GO TO 6                        00000630
C**** DATA BLOCK. ITYPE = 1,2,3.                                        00000640
    1 NSEC = IBYT/504                                                   00000650
      IF (ICB.EQ.0) ITYPE = 4 - NSEC                                    00000660
      IF (ICB.EQ.1) ITYPE = 3                                           00000670
      MCB = ICB                                                         00000680
      IF (MCB.EQ.0) ICB = 1                                             00000690
      IF (MCB.EQ.1) ICB = IBUF(101,NPTR)                                00000700
      IF (ICB.NE.0.AND.ICB.NE.1) GO TO 6                                00000710
      MPTR = NPTR                                                       00000720
      NPTR = NPTR + 1                                                   00000730
      IF (ITYPE.EQ.1) NPTR = NPTR + 1                                   00000740
      IF (.NOT.LDOE(ITYPE)) GO TO 501                                   00000750
      MTM = 1 + ITYPE/3                                                 00000760
      IF (LTMS(MTM)) GO TO 501                                          00000770
C**** CHECK TIME INTERVAL.                                              00000780
      TIME = TIMS(IBUF(1,MPTR))                                         00000790
      IF (TIME.LT.TIME1) GO TO 501                                      00000800
      IF (TIME.GT.TIME2) GO TO 502                                      00000810
      MBYT = 504                                                        00000820
      IF (ITYPE.EQ.1) MBYT = 1008                                       00000830
      CALL FMOVE(ITM,24,IBUF(1,MPTR))                                   00000840
      CALL FMOVE(REC,MBYT,IBUF(1,MPTR))                                 00000850
      RETURN                                                            00000860
  502 LTMS(MTM) = .TRUE.                                                00000870
      GO TO 501                                                         00000880
C**** HEADER RECORD. ITYPE = 4,5.                                       00000890
    4 ITYPE = 4 + ICB                                                   00000900
      ICB = 0                                                           00000910
      IF (.NOT.LDOE(ITYPE)) GO TO 501                                   00000920
      CALL FMOVE(REC,180,IBUF)                                          00000930
      RETURN                                                            00000940
C**** BAD RECORD. ITYPE = 6.                                            00000950
    6 ITYPE = 6                                                         00000960
      ICB = 0                                                           00000970
      NPTR = 4                                                          00000980
      IF (LDOE(ITYPE)) RETURN                                           00000990
      GO TO 501                                                         00001000
C**** I/O ERROR. ITYPE = 7.                                             00001010
    7 ITYPE = 7                                                         00001020
      IF (LDOE(ITYPE)) RETURN                                           00001030
      GO TO 501                                                         00001040
C**** END OF FILE. ITYPE = 8.                                           00001050
    8 ITYPE = 8                                                         00001060
      LEOF = .TRUE.                                                     00001070
      RETURN                                                            00001080
C**** BEYOND END OF TIME INTERVAL. ITYPE = 9.                           00001090
    9 ITYPE = 9                                                         00001100
      RETURN                                                            00001110
C**** RECORD TOO LARGE. FATAL ERROR.                                    00001120
  503 WRITE (6,2001) IBYT                                               00001130
 2001 FORMAT (' SDRGET: RECORD READ WITH ',I5,' BYTES')                 00001140
      STOP                                                              00001150
      ENTRY SDRLGL (LTYPE)                                              00001160
C-----------------------------------------------------------------------00001170
C  THE SEVEN LOGICAL*4 SWITCHES LTYPE ARE INPUT TO INDICATE WHETHER OR  00001180
C  NOT SDRGET RETURNS WITH THE CORRESPONDING ITYPE. THE ITYPES 8 & 9    00001190
C  ARE ALWAYS RETURNED.                                                 00001200
C-----------------------------------------------------------------------00001210
      CALL FMOVE(LDOE,28,LTYPE)                                         00001220
      RETURN                                                            00001230
      ENTRY SDRRST (LIM1,LIM2)                                          00001240
C-----------------------------------------------------------------------00001250
C  LIM1 AND LIM2 (BOTH ARE SIX INTEGER*4 WORDS) SET THE TIME INTERVAL   00001260
C  FOR NAVIGATION AND POINTING VECTOR RECORDS (IF THESE RECORDS ARE     00001270
C  REQUESTED). IF THE YEAR IS ZERO, THEN THE CORRESPONDING TIME         00001280
C  LIMIT IS IGNORED.                                                    00001290
C-----------------------------------------------------------------------00001300
      LTMS(1) = .FALSE.                                                 00001310
      LTMS(2) = .FALSE.                                                 00001320
      TIME1 = - 5.D75                                                   00001330
      IF (LIM1(1).NE.0) TIME1 = TIMS(LIM1)                              00001340
      TIME2 = + 5.D75                                                   00001350
      IF (LIM2(1).NE.0) TIME2 = TIMS(LIM2)                              00001360
      IF (TIME1.LT.TIME2) RETURN                                        00001370
      WRITE (6,2002) LIM1,LIM2                                          00001380
 2002 FORMAT (' SDRRST: BAD LIMITS ',12I5)                              00001390
      STOP                                                              00001400
      ENTRY SDRLRN (LREC)                                               00001410
C-----------------------------------------------------------------------00001420
C  OUTPUT IS LREC, THE NUMBER OF THE LATEST LOGICAL SEDR RECORD READ.   00001430
C-----------------------------------------------------------------------00001440
      LREC = JREC                                                       00001450
      RETURN                                                            00001460
      END                                                               00001470
      REAL FUNCTION TIMS*8 (ITM)                                        00001480
C-----------------------------------------------------------------------00001490
C  INPUT:  ITM(1) = YEAR                                                00001500
C          ITM(2) = DAY OF YEAR                                         00001510
C          ITM(3) = HOUR OF DAY                                         00001520
C          ITM(4) = MINUTE OF HOUR                                      00001530
C          ITM(5) = SECOND OF MINUTE                                    00001540
C          ITM(6) = MILLISECOND OF SECOND                               00001550
C  OUTPUT: TIMS = DAYS SINCE 1977 DAY 0 (REAL*8)                        00001560
C-----------------------------------------------------------------------00001570
      INTEGER*4 ITM(6)                                                  00001580
      IYR = ITM(1)                                                      00001590
      IYR = MOD(IYR,1900) - 77                                          00001600
      LYR = IYR/4                                                       00001610
      TIMS = IYR*365.D0 + (ITM(2) + (ITM(3) + (ITM(4) + (ITM(5) +       00001620
     X .001D0*ITM(6))/60.D0)/60.D0)/24.D0) + LYR                        00001630
      RETURN                                                            00001640
      END                                                               00001650
      SUBROUTINE HEAD (SEDREC)                                          00010017
      INTEGER*4 SEDREC(1), CRUISE/'CRUI'/, LAUNCH/'LAUN'/               00020017
      COMMON PROCES                                                     00030017
      LOGICAL*4 PROCES                                                  00040017
      IF ((SEDREC(14) .EQ. CRUISE) .OR. (SEDREC(14) .EQ. LAUNCH))       00050017
     1  GOTO 10                                                         00060017
C NON-CRUISE/LAUNCH HEADER -- NOT TO BE PROCESSED                       00070017
      PROCES = .FALSE.                                                  00080017
      GOTO 20                                                           00090017
   10 CONTINUE                                                          00100017
C CRUISE/LAUNCH HEADER -- PROCESS ALL NAVIGATION RECORDS                00110017
      PROCES = .TRUE.                                                   00120017
   20 CONTINUE                                                          00130017
      RETURN                                                            00140017
      END                                                               00150017
      SUBROUTINE NAV (SEDREC, NAVBYT)                                   00160017
      INTEGER*4 SEDREC(1), OLDDAY, ENCR, ENCR0                          00170027
      COMMON PROCES                                                     00180017
      LOGICAL*4 PROCES, FIRST/.TRUE./                                   00190017
      IF (.NOT. PROCES) GOTO 30                                         00200017
      IF (.NOT. FIRST) GOTO 20                                          00210017
C FIRST RECORD TO BE PROCESSED. INITIALIZE DAY, READ PARAMETERS         00220017
C AND CALL ROUTINE TO CALCULATE CARRINGTON NUMBERS FOR THIS NAV RECORD. 00230017
      OLDDAY = SEDREC(2)                                                00240017
      READ (5, 10) NCR, NCREF0, ENCR0                                   00250026
   10 FORMAT (I11, /, I11, /, I11)                                      00260027
      WRITE (6,15) NCR, NCREF0, ENCR0                                   00270026
   15 FORMAT ('1INITIAL VALUES:',/,                                     00280017
     1        '     NCR = ', I5, /,'  NCREF0 = ', I5, /,                00290030
     2        '   ENCR0 = ', I5)                                        00300030
      CLELST = 360.                                                     00301017
      ECLLST = 360.                                                     00302035
      NFLG = 0                                                          00303035
      IFL = 0                                                           00304017
      IFLG = 0                                                          00305017
      NCREF = NCREF0                                                    00306027
      ENCR = ENCR0                                                      00307027
      SDR51 = .729739E09                                                00307145
      SDR98 = 228.48                                                    00307240
      SDR100 = 203.46                                                   00307340
      SEDREC(3) = 0                                                     00307444
      SEDREC(4) = 1                                                     00307544
      SEDREC(5) = 23                                                    00307644
      SEDREC(6) = 743                                                   00307744
      DO 100 IDAY = 1,64                                                00308040
          SEDREC(2) = IDAY                                              00308140
          SDR51 = SDR51 + 960800.                                       00309040
          SDR98 = SDR98 + .0510937                                      00309140
          SDR100 = SDR100 + 1.0097                                      00309240
          CALL CARING (SDR51, SDR98, SDR100,                            00310041
     1                 SEDREC, NCR, CLELST, NCREF,                      00310140
     2                 ENCR, IFL, IFLG, ECLLST, NFLG)                   00311040
  100 CONTINUE                                                          00312040
      DO 200 IDAY = 65,99                                               00313040
          SEDREC(2) = IDAY                                              00313140
          SDR51 = SDR51 + 960800.                                       00314040
          SDR98 = SDR98 + .0510937                                      00315040
          SDR100 = SDR100 + 1.0097                                      00316040
          CALL CARING (SDR51, SDR98, SDR100,                            00317041
     1                 SEDREC, NCR, CLELST, NCREF,                      00318040
     2                 ENCR, IFL, IFLG, ECLLST, NFLG)                   00319040
  200 CONTINUE                                                          00319140
      FIRST = .FALSE.                                                   00320017
      GOTO 30                                                           00330017
   20 CONTINUE                                                          00340017
C PROCESS ONE NAVIGATION RECORD PER DAY                                 00341017
      IF (SEDREC(2) .EQ. OLDDAY) GOTO 30                                00350017
      OLDDAY = SEDREC(2)                                                00360017
      CALL CARING (SEDREC(51), SEDREC(98), SEDREC(100),                 00370040
     1             SEDREC, NCR, CLELST, NCREF,                          00370140
     2             ENCR, IFL, IFLG, ECLLST, NFLG)                       00371040
   30 CONTINUE                                                          00380017
      RETURN                                                            00390017
      END                                                               00400017
      SUBROUTINE PV                                                     00410017
C POINTING VECTORS ARE BYPASSED                                         00420017
      RETURN                                                            00430017
      END                                                               00440017
      SUBROUTINE CARING (SDR51, SDR98, SDR100,                          00450048
     1                   ITM, NCR, CLELST, NCREF,                       00460048
     2                   ENCR, IFL, IFLG, ECLLST, NFLG)                 00470048
      INTEGER*2 SDRYR                                                   00480048
      INTEGER*4 ITM(6), ENCR                                            00490048
      REAL*4 DNUS/14.184/, HNUS/.591/, DNUE/13.198/,                    00500048
     1       VH/1548000./, CL0/177./, ALF0/87.6/                        00510048
      REAL*8 DDAY, YR, DAY, HR, MIN, SEC, MSEC, EPICDY                  00520048
      SDRYR = ITM(1) - 1900                                             00530048
C CALCULATE DECIMAL DAY (DAY + FRACTION)                                00540048
      YR = ITM(1)                                                       00550048
      DAY = ITM(2)                                                      00560048
      HR = ITM(3)                                                       00570048
      MIN = ITM(4)                                                      00580048
      SEC = ITM(5)                                                      00590048
      MSEC = ITM(6)                                                     00600048
      DDAY = (DAY - 1.) + (HR + (MIN + (SEC + (MSEC / 1000.)) /         00610048
     1       60.) / 60.) /24.                                           00620048
C CALCULATE DAYS + FRACTION SINCE 8/20/77                               00630048
      CALL EPIC (SDRYR, DDAY, EPICDY)                                   00640048
      DALF = SDR98 - ALF0                                               00650048
      DALFE = SDR100 - ALF0                                             00660048
      ROT = DNUS * EPICDY                                               00670048
      BETA = CL0 - ROT                                                  00680048
      AB = ABS(BETA)                                                    00690048
      ABETA = AMOD(AB, 360.)                                            00700048
      IF (BETA .LT. 0) GOTO 3                                           00710048
      BETA = ABETA                                                      00720048
      GOTO 7                                                            00730048
    3 CONTINUE                                                          00740048
      BETA = -ABETA                                                     00750048
    7 CONTINUE                                                          00760048
      CL = DALF + BETA                                                  00770048
      IF (CL .LE. 0) GOTO 10                                            00780048
      IFL = 1                                                           00790048
      GOTO 20                                                           00800048
   10 CONTINUE                                                          00810048
      CL = CL + 360.                                                    00820048
      IF (IFL .EQ.0) GOTO 20                                            00830048
      NCR = NCR + 1                                                     00840048
      IFL = 0                                                           00850048
   20 CONTINUE                                                          00860048
      DT = SDR51 / VH                                                   00870048
      DCL = DT * HNUS                                                   00880048
      CLEF = CL + DCL                                                   00890048
      NCREFL = NCREF                                                    00900048
      IF (CLEF .LT. 360.) GOTO 30                                       00910048
      NCREF = NCR - 1                                                   00920048
      CLEF = CLEF - 360.                                                00930048
      IF (CLEF .LT. 360.) GOTO 30                                       00940048
      NCREF = NCREF - 1                                                 00950048
      CLEF = CLEF - 360.                                                00960048
   30 CONTINUE                                                          00970048
      CLEDIF = CLELST - CLEF                                            00980048
      IF (CLEDIF .GE. 0) GO TO 35                                       00990048
      NCREF = NCREF + 1                                                 01000048
   35 CONTINUE                                                          01001048
      NCDIF = NCREF - NCREFL                                            01002048
      IF (NCDIF .LE. 1) GO TO 36                                        01003048
      NCREF = NCREF - 1                                                 01004048
   36 CONTINUE                                                          01005048
      CLELST = CLEF                                                     01006048
      BETAE = CL0 - ROT                                                 01007048
      ABE = ABS(BETAE)                                                  01008048
      ABTAE = AMOD(ABE,360.)                                            01009048
      IF (BETAE .LT. 0.) GO TO 37                                       01009148
      BETAE = ABTAE                                                     01009248
      GO TO 38                                                          01009348
   37 CONTINUE                                                          01009448
      BETAE = -ABTAE                                                    01009548
   38 CONTINUE                                                          01009648
      ECL = DALFE + BETAE                                               01009748
C      WRITE (6,10000) SEDREC(51), SEDREC(98), SEDREC(100),             01009848
C     1                DALFE, BETAE, EPICDY                             01009948
C10000 FORMAT (10X,'SEDREC(51,98,100) =',F15.2,2F10.2,/,                01010048
C     1        10X,'DALFE =',F6.1,' BETAE =',F6.1,' EPICDY =',F8.3)     01010148
      IF (ECL .LE. 0) GO TO 40                                          01010248
      IFLG = 1                                                          01010348
      GO TO 50                                                          01010448
   40 CONTINUE                                                          01010548
      ECL = ECL + 360.                                                  01010648
      IF (ECL .LE. 0) GO TO 40                                          01010748
      IF (IFLG .EQ. 0) GO TO 50                                         01010848
      ENCR = ENCR + 1                                                   01010948
      IFLG = 0                                                          01011048
      NFLG = 1                                                          01011148
   50 CONTINUE                                                          01011248
      IF (NFLG .EQ. 1) GO TO 60                                         01011348
      ECLDIF = ECLLST - ECL                                             01011448
      IF (ECLDIF .GE. 0) GO TO 60                                       01011548
      ENCR = ENCR + 1                                                   01011648
   60 CONTINUE                                                          01011748
      ECLLST = ECL                                                      01011848
      NFLG = 0                                                          01011948
      CALL WRITE (ITM, ECL, ENCR, CL, NCR, DT, DCL, CLEF, NCREF)        01012048
      RETURN                                                            01012148
      END                                                               01012248
      SUBROUTINE WRITE (SDRTIM, ECL, ENCR, CL, NCR, DT, DCL, CLEF,      01012317
     1                  NCREF)                                          01013017
      INTEGER*4 SDRTIM(6), NLINES/99/, ENCR                             01020017
      IF (NLINES .LT. 60) GOTO 20                                       01030017
C WRITE PAGE HEADER                                                     01040017
      WRITE (6, 10)                                                     01050017
   10 FORMAT (1H1, T27, 'VGR', T37, 'VGR', T47, 'EARTH', T57, 'EARTH',/,01051043
     1 T27, 'CARR.', T37, 'CARR.', T47, 'CARR.', T57, 'CARR.', T67,     01060043
     2 'DELAY', T77, 'DELTA', T87, 'EFFEC', T98,'EFFEC', /, T11,'TIME', 01070043
     3 T27, 'LONG.', T37, 'ROT #', T47, 'LONG.', T57, 'ROT #', T67,     01090043
     4 'TIME', T78, 'CL', T88, 'CL', T98, 'NCR', /, T27, '(CL)', T37,   01100043
     5 '(NCR)', T47,'(ECL)', T57, '(ENCR)', T67, '(DT)', T77,           01110043
     6 '(DCL)', T87, '(CLEF)', T97, '(NCREF)',                          01120043
     7 /, 1X, 21('_'), T27, 5('_'), T37, 5('_'), T47, 5('_'), T57,      01130043
     8 6('_'), T67, 5('_'), T77, 5('_'), T87, 6('_'), T97, 7('_'))      01140043
      NLINES = 6                                                        01150018
   20 CONTINUE                                                          01160017
C WRITE DETAIL LINE                                                     01170017
      WRITE (6, 30) SDRTIM, CL, NCR, ECL, ENCR, DT, DCL, CLEF, NCREF    01190024
   30 FORMAT (' ', I4, '/', I3, ':', I2, ':', I2, ':', I2, '.', I3,     01200043
     1        T27, F5.1, T37, I5, T47, F5.1, T57, I5, T67, F5.1, T77,   01210043
     2        F5.1, T87,F5.1, T97, I5)                                  01220043
      NLINES = NLINES + 1                                               01230017
      RETURN                                                            01240017
      END                                                               01250017
C-----------------------------------------------------------------------00001000
C  LISTS SEDR TAPES ----- BY ADS                                        00001100
C     LDET=TRUE PRODUCES DETAIL(HG) PRINTOUT.                           00001200
C     LIST=TRUE PRODUCES FULL LISTING.                                  00001300
C-----------------------------------------------------------------------00001400
C  ICB=0 NO PV CONTINUATION     ICB=1 PV CONTINUATION                   00001500
C-----------------------------------------------------------------------00001600
      REAL*8 VOLSER,SUMTAP,TIMS,TIME1/-5.D75/,TIME2/+5.D75/,TIME        00001700
      INTEGER*4 ILUN/12/,JLUN/6/,IREC(378),NREC/0/,ICB/0/               00001800
      INTEGER*4 JREC(126,3),NHDC/0/,ITM(6,2)/12*0/                      00001900
      LOGICAL LDET /.FALSE./,LIST/.FALSE./,FIRST/.TRUE./                00002000
      LOGICAL LOUT/.FALSE./                                             00002100
      EQUIVALENCE (IREC(1),JREC(1,1))                                   00002200
C**** READ SWITCHES AND TIME INTERVAL.                                  00002300
      READ (4,1001,END=11) LDET,LIST                                    00002400
 1001 FORMAT (2L1)                                                      00002500
   11 WRITE (6,2012) LDET,LIST                                          00002600
 2012 FORMAT('0SPECIAL REQUEST SWITCHES: ',2L1)                         00002700
      READ (5,1002,END=10) (ITM(I,1),I=1,5),(ITM(I,2),I=1,5)            00002800
 1002 FORMAT(10I4)                                                      00002900
      WRITE (6,2005) (ITM(I,1),I=1,5),(ITM(I,2),I=1,5)                  00003000
 2005 FORMAT('0TIME INTERVAL IS ',2I4,3(':',I2),5X,                     00003100
     X   2I4,3(':',I2))                                                 00003200
      TIME1 = TIMS(ITM(1,1))                                            00003300
      TIME2 = TIMS(ITM(1,2))                                            00003400
C**** READ A PHYSICAL RECORD.                                           00003500
   10 CALL FREAD (IREC,ILUN,IBYT,&50,&60)                               00003600
      NREC = NREC + 1                                                   00003700
      IF (IBYT.EQ.180)  GO TO 20                                        00003800
      IF (IBYT.EQ.1008.OR.IBYT.EQ.1512) GO TO 30                        00003900
      WRITE (JLUN,2002) IBYT                                            00004000
 2002 FORMAT ('0RECORD READ WITH ',I5,' BYTES')                         00004100
      GO TO 10                                                          00004200
C**** HEADER RECORD.                                                    00004300
   20 IF (ICB.EQ.1.AND.LOUT)  WRITE (JLUN,2009)                         00004400
 2009 FORMAT ('0HEADER RECORD FOUND WHEN PV CONTINUATION EXPECTED')     00004500
      NHDC = NHDC + 1                                                   00004600
      WRITE (JLUN,2003) NHDC,(IREC(I), I = 1,5),IREC(6),NREC,           00004700
     X  IREC(8),IREC(9),IREC(10),(IREC(I),I=12,27)                      00004800
 2003 FORMAT ('0',97('*')/                                              00004900
     X ' ** HEADER RECORD # ',I3,1X,2A6,I3,2A6,I7,' REC# ',I8,26X,' **'/00005000
     X ' ** ',2A4,I7,4(2X,2A4,1X,2A4),' **'/                            00005100
     X 1X,97('*')/)                                                     00005200
      FIRST = .TRUE.                                                    00005300
      ICB = 0                                                           00005400
      GO TO 10                                                          00005500
C**** DATA RECORD.                                                      00005600
   30 NKC = IBYT/504                                                    00005700
      TIME = TIMS(JREC)                                                 00005800
      IF (TIME.GE.TIME1) LOUT=.TRUE.                                    00005900
      IF (TIME.GT.TIME2) GO TO 90                                       00006000
      IF (ICB.EQ.1)  GO TO 40                                           00006100
C**** DATA RECORD (CN/PV).                                              00006200
      IF ((FIRST.OR.LIST).AND.LOUT)                                     00006300
     X    WRITE (JLUN,2013) NREC,(JREC(I,1),  I = 1,6)                  00006400
 2013 FORMAT (' REC#',I8,' NAVIGATION TIME: ',I4,'(',I3,')',I2,':',     00006500
     X       I2,':',I2,'.',I3)                                          00006600
      FIRST = .FALSE.                                                   00006700
      IF (JREC(1,1).EQ.0.AND.LOUT) WRITE (6,2020) NREC                  00006800
 2020 FORMAT (' BAD NAVIGATION TIME IN RECORD # ',I8)                   00006900
      IF (LDET.AND.LOUT) CALL HGOUT(JLUN,JREC,NKC,1)                    00007000
      IF (LIST.AND.LOUT)                                                00007100
     X  WRITE (JLUN,2014) NREC,(JREC(I,NKC),  I = 1,8),JREC(101,NKC)    00007200
 2014 FORMAT (' REC#',I8,' POINTING VECTOR TIME: ',I4,'(',I3,')',I2,    00007300
     X       ':',I2,':',I2,'.',I3,'  FDSC=',I5,'.',                     00007400
     X     I2,'  CONT. WORD=',I4)                                       00007500
      IF (JREC(1,NKC).EQ.0.AND.LOUT) WRITE (6,2023) NREC,               00007600
     X  (JREC(I,1),I=1,6)                                               00007700
 2023 FORMAT (' BAD POINTING VECTOR TIME IN RECORD # ',I8,              00007800
     X ' NAV TIME= ',I4,'(',I3,')',I2,':',I2,':',I2,'.',I3)             00007900
      IF (JREC(101,NKC).NE.0.AND.JREC(101,NKC).NE.1.AND.LOUT)           00008000
     X    WRITE (6,2022) NREC                                           00008100
 2022 FORMAT (' BAD POINTING VECTOR CONTINUATION WORD IN RECORD # ',    00008200
     X  I8)                                                             00008300
      IF (LDET.AND.LOUT) CALL HGOUT(JLUN,JREC,NKC,2)                    00008400
      ICB = JREC(101,NKC)                                               00008500
      GO TO 10                                                          00008600
C**** DATA RECORD (PV/PV).                                              00008700
   40 DO 41  N = 1,NKC                                                  00008800
      IF (LIST.AND.LOUT) WRITE (JLUN,2014) NREC,(JREC(I,N),  I = 1,8),  00008900
     X   JREC(101,N)                                                    00009000
      IF (JREC(1,N).EQ.0.AND.LOUT)  WRITE (6,2021) NREC                 00009100
 2021 FORMAT (' BAD POINTING VECTOR TIME IN RECORD # ',I8)              00009200
      IF (JREC(101,N).NE.0.AND.JREC(101,N).NE.1.AND.LOUT)               00009300
     X    WRITE (6,2022) NREC                                           00009400
      IF (LDET.AND.LOUT) CALL HGOUT(JLUN,JREC,N,2)                      00009500
      ICB = JREC(101,N)                                                 00009600
      IF (ICB.EQ.0)  GO TO 10                                           00009700
   41 CONTINUE                                                          00009800
      GO TO 10                                                          00009900
C**** END OF FILE.                                                      00010000
   50 WRITE (JLUN,2007)                                                 00010100
 2007 FORMAT ('0END OF FILE')                                           00010200
      GO TO 90                                                          00010300
C**** I/O ERROR.                                                        00010400
   60 WRITE (JLUN,2008)                                                 00010500
 2008 FORMAT ('0I/O ERROR')                                             00010600
      GO TO 90                                                          00010700
C**** VOLUME SERIAL NUMBER.                                             00010800
   90 SUMTAP = VOLSER('FT12F001')                                       00010900
      IF (.NOT.LIST) WRITE (6,2013) NREC,(JREC(I,1),I=1,6)              00011000
      WRITE (6,2017) SUMTAP                                             00011100
 2017 FORMAT ('0LISTING OF VOLUME ',A8)                                 00011200
      WRITE (6,2018) NHDC                                               00011300
 2018 FORMAT ('0NUMBER OF HEADER RECORDS = ',I3)                        00011400
      WRITE (6,2019) NREC                                               00011500
 2019 FORMAT ('0TOTAL NUMBER OF RECORDS = ',I8)                         00011600
      STOP                                                              00011700
      END                                                               00011800
      SUBROUTINE HGOUT (JLUN,JREC,NKC,NPAS)                             00011900
C-----------------------------------------------------------------------00012000
C    HG CALCULATIONS.                                                   00012100
C-----------------------------------------------------------------------00012200
      REAL*4 CN(6),TPEZ(3,3),TTB(3,3),TTB5(3,3),THG(3,3)                00012300
      REAL*4 ANG(2),SPV(6)                                              00012400
      INTEGER*4 JREC(126,3)                                             00012500
      IF (NPAS.EQ.2)  GO TO 60                                          00012600
      CALL FMOVE (CN,24,JREC(13,1))                                     00012700
      CALL SEDRCN (JREC(1,1),TTB,TTB5,ANG,RANGE,SPV)                    00012800
      WRITE (JLUN,2004) CN,RANGE                                        00012900
 2004 FORMAT (' ',5X,'S/C POS,VEL,RANGE: ',1P3E11.3,3X,3E11.3,3X,E11.3) 00013000
      WRITE (JLUN,2016) SPV                                             00013100
 2016 FORMAT (' ',5X,'S/C NORM IHG POS & IHG VEL:',1P6E14.6)            00013200
      WRITE (JLUN,2015) ANG(1),ANG(2)                                   00013300
 2015 FORMAT (' ',5X,'PROBE LONGITUDE & LATITUDE: ',2F8.2)              00013400
      WRITE (JLUN,2010) TTB                                             00013500
 2010 FORMAT (' ',5X,'TTB: ',1P3E11.3/(11X,3E11.3))                     00013600
      WRITE (JLUN,2011) TTB5                                            00013700
 2011 FORMAT (' ',5X,'TTB5 INVERSE: ',1P3E11.3/(20X,3E11.3))            00013800
      RETURN                                                            00013900
   60 CALL FMOVE (TPEZ,36,JREC(12,NKC))                                 00014000
      WRITE (JLUN,2005) TPEZ                                            00014100
 2005 FORMAT (' ',5X,'S/C ATTITUDE: ',1P3E11.3/(20X,3E11.3))            00014200
      CALL SEDRPV (JREC(12,NKC),TTB,TTB5,THG)                           00014300
      WRITE (JLUN,2012) THG                                             00014400
 2012 FORMAT (' ',5X,'THG: ',1P3E11.3/(11X,3E11.3))                     00014500
      RETURN                                                            00014600
      END                                                               00014700
      REAL FUNCTION TIMS*8 (ITM)                                        00014800
C-----------------------------------------------------------------------00014900
C  INPUT:  ITM(1) = YEAR                                                00015000
C          ITM(2) = DAY OF YEAR                                         00015100
C          ITM(3) = HOUR OF DAY                                         00015200
C          ITM(4) = MINUTE OF HOUR                                      00015300
C          ITM(5) = SECOND OF MINUTE                                    00015400
C          ITM(6) = MILLISECOND OF SECOND                               00015500
C  OUTPUT: TIMS = DAYS SINCE 1977 DAY 0 (REAL*8)                        00015600
C-----------------------------------------------------------------------00015700
      INTEGER*4 ITM(6)                                                  00015800
      IYR = ITM(1)                                                      00015900
      IYR = MOD(IYR,1900) - 77                                          00016000
      LYR = IYR/4                                                       00016100
      TIMS = IYR*365.D0 + (ITM(2) + (ITM(3) + (ITM(4) + (ITM(5) +       00016200
     X .001D0*ITM(6))/60.D0)/60.D0)/24.D0) + LYR                        00016300
      RETURN                                                            00016400
      END                                                               00016500
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00000010
C                                                                       00000020
C PROGRAM: SEDRDUMP                                                     00000030
C                                                                       00000040
C PROGRAMMER: T. W. VOLLMER (GSFC) - 9/16/83                            00000050
C                                                                       00000060
C DESCRIPTION: THIS ROUTINE READS ANY NON-JUPITER SEDR.  IF THE RECORD  00000070
C              READ IS WITHIN THE TIME BOUNDARIES INPUT, THE ENTIRE     00000080
C              RECORD IS DUMPED IN HEX.                                 00000090
C                                                                       00000100
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00000110
      INTEGER*4 SDREC(126,3), YRBEG, DAYBEG, HRBEG, MINBEG,             00000410
     1                        YREND, DAYEND, HREND, MINEND              00000420
C READ LIMITS OF TIMES TO BE PROCESSED                                  00000430
      READ (5,10) YRBEG, DAYBEG, HRBEG, MINBEG,                         00000440
     1            YREND, DAYEND, HREND, MINEND                          00000450
      WRITE (6,10000) YRBEG,DAYBEG,HRBEG,MINBEG,                        00000460
     1                YREND,DAYEND,HREND,MINEND                         00000470
10000 FORMAT (' TIME LIMITS ',8I5)                                      00000480
   10 FORMAT (8I5)                                                      00000490
      NREC = 0                                                          00000500
   20 CONTINUE                                                          00000510
C READ AN SEDR RECORD                                                   00000520
      CALL FREAD (SDREC, 10, NBYT, &150, &130)                          00000530
C CHECK FOR AND BYPASS HEADER RECORDS                                   00000540
      IF (NBYT .EQ. 180) GO TO 20                                       00000550
C CHECK THAT RECORD IS WITHIN TIME LIMIT REQUISTED                      00000610
      IF (SDREC(1,1) .LT.  YRBEG) GO TO 20                              00000620
      IF (SDREC(1,1) .GT.  YRBEG) GO TO 40                              00000630
      IF (SDREC(2,1) .LT. DAYBEG) GO TO 20                              00000640
      IF (SDREC(2,1) .GT. DAYBEG) GO TO 40                              00000650
      IF (SDREC(3,1) .LT.  HRBEG) GO TO 20                              00000660
      IF (SDREC(3,1) .GT.  HRBEG) GO TO 40                              00000670
      IF (SDREC(4,1) .LT. MINBEG) GO TO 20                              00000680
      IF (SDREC(4,1) .GT. MINBEG) GO TO 40                              00000690
      GO TO 50                                                          00000695
   40 CONTINUE                                                          00000730
      IF (SDREC(1,1) .LT.  YREND) GO TO 50                              00000740
      IF (SDREC(1,1) .GT.  YREND) GO TO 150                             00000750
      IF (SDREC(2,1) .LT. DAYEND) GO TO 50                              00000760
      IF (SDREC(2,1) .GT. DAYEND) GO TO 150                             00000770
      IF (SDREC(3,1) .LT.  HREND) GO TO 50                              00000780
      IF (SDREC(3,1) .GT.  HREND) GO TO 150                             00000790
      IF (SDREC(4,1) .LT. MINEND) GO TO 50                              00000800
      IF (SDREC(4,1) .GT. MINEND) GO TO 150                             00000810
   50 CONTINUE                                                          00000820
C     WRITE (6,10010) NBYT                                              00000830
C0010 FORMAT (//' NBYTE =',I5)                                          00000840
C     DO 10070 J=1,3                                                    00000870
C     WRITE (6,10030)  (SDREC(I,J),I=1,126)                             00000880
C0070 CONTINUE                                                          00000890
C0030 FORMAT (13(1X,10(Z8,2X)/))                                        00000900
      GO TO 20                                                          00000910
  130 CONTINUE                                                          00001360
C ERROR READING SEDR TAPE                                               00001370
      WRITE (6,140) NREC                                                00001380
  140 FORMAT (' ERROR READING RECORD',I5)                               00001390
      GO TO 20                                                          00001400
  150 CONTINUE                                                          00001410
C     WRITE (6,10020)                                                   00001420
C0020 FORMAT (' END OF SEDR')                                           00001430
      STOP                                                              00001440
      END                                                               00001450
      SUBROUTINE HEAD (SEDREC)                                          00010017
      INTEGER*4 SEDREC(1), CRUISE/'CRUI'/, LAUNCH/'LAUN'/               00020017
      COMMON PROCES                                                     00030017
      LOGICAL*4 PROCES                                                  00040017
      IF ((SEDREC(14) .EQ. CRUISE) .OR. (SEDREC(14) .EQ. LAUNCH))       00050017
     1  GOTO 10                                                         00060017
C NON-CRUISE/LAUNCH HEADER -- NOT TO BE PROCESSED                       00070017
      PROCES = .FALSE.                                                  00080017
      GOTO 20                                                           00090017
   10 CONTINUE                                                          00100017
C CRUISE/LAUNCH HEADER -- PROCESS ALL NAVIGATION RECORDS                00110017
      PROCES = .TRUE.                                                   00120017
   20 CONTINUE                                                          00130017
      RETURN                                                            00140017
      END                                                               00150017
      SUBROUTINE NAV (SEDREC, NAVBYT)                                   00160017
      INTEGER*4 SEDREC(1), OLDDAY, ENCR, ENCR0                          00170027
      COMMON PROCES                                                     00180017
      LOGICAL*4 PROCES, FIRST/.TRUE./                                   00190017
      IF (.NOT. PROCES) GOTO 30                                         00200017
      IF (.NOT. FIRST) GOTO 20                                          00210017
C FIRST RECORD TO BE PROCESSED. INITIALIZE DAY, READ PARAMETERS         00220017
C AND CALL ROUTINE TO CALCULATE CARRINGTON NUMBERS FOR THIS NAV RECORD. 00230017
      OLDDAY = SEDREC(2)                                                00240017
      READ (5, 10) NCR, NCREF0, ENCR0                                   00250026
   10 FORMAT (I11, /, I11, /, I11)                                      00260027
      WRITE (6,15) NCR, NCREF0, ENCR0                                   00270026
   15 FORMAT ('1INITIAL VALUES:',/,                                     00280017
     1        '     NCR = ', I5, /,'  NCREF0 = ', I5, /,                00290030
     2        '   ENCR0 = ', I5)                                        00300030
      CLELST = 360.                                                     00301017
      ECLLST = 360.                                                     00302035
      NFLG = 0                                                          00303035
      IFL = 0                                                           00304017
      IFLG = 0                                                          00305017
      NCREF = NCREF0                                                    00306027
      ENCR = ENCR0                                                      00307027
      CALL CARING (SEDREC, SEDREC, NCR, CLELST, NCREF,                  00310027
     1             ENCR, IFL, IFLG, ECLLST, NFLG)                       00311035
      FIRST = .FALSE.                                                   00320017
      GOTO 30                                                           00330017
   20 CONTINUE                                                          00340017
C PROCESS ONE NAVIGATION RECORD PER DAY                                 00341017
      IF (SEDREC(2) .EQ. OLDDAY) GOTO 30                                00350017
      OLDDAY = SEDREC(2)                                                00360017
      CALL CARING (SEDREC, SEDREC, NCR, CLELST, NCREF,                  00370027
     1             ENCR, IFL, IFLG, ECLLST, NFLG)                       00371035
   30 CONTINUE                                                          00380017
      RETURN                                                            00390017
      END                                                               00400017
      SUBROUTINE PV                                                     00410017
C POINTING VECTORS ARE BYPASSED                                         00420017
      RETURN                                                            00430017
      END                                                               00440017
      SUBROUTINE CARING (SEDREC, ITM, NCR, CLELST, NCREF,               00450026
     1                   ENCR, IFL, IFLG, ECLLST, NFLG)                 00451035
      INTEGER*2 SDRYR                                                   00460017
      INTEGER*4 ITM(6), ENCR                                            00470017
      REAL*4 SEDREC(1), DNUS/14.184/, HNUS/.591/, DNUE/13.198/,         00480017
     1       VH/1548000./, CL0/177./, ALF0/87.6/                        00490026
      REAL*8 DDAY, YR, DAY, HR, MIN, SEC, MSEC, EPICDY                  00500017
      SDRYR = ITM(1) - 1900                                             00510017
C CALCULATE DECIMAL DAY (DAY + FRACTION)                                00520017
      YR = ITM(1)                                                       00530017
      DAY = ITM(2)                                                      00540017
      HR = ITM(3)                                                       00550017
      MIN = ITM(4)                                                      00560017
      SEC = ITM(5)                                                      00570017
      MSEC = ITM(6)                                                     00580017
      DDAY = (DAY - 1.) + (HR + (MIN + (SEC + (MSEC / 1000.)) /         00590017
     1       60.) / 60.) /24.                                           00600017
C CALCULATE DAYS + FRACTION SINCE 8/20/77                               00610017
      CALL EPIC (SDRYR, DDAY, EPICDY)                                   00640017
      DALF = SEDREC(98) - ALF0                                          00670017
      DALFE = SEDREC(100) - ALF0                                        00671025
      ROT = DNUS * EPICDY                                               00680017
      BETA = CL0 - ROT                                                  00690017
      AB = ABS(BETA)                                                    00700017
      ABETA = AMOD(AB, 360.)                                            00710017
      IF (BETA .LT. 0) GOTO 3                                           00720017
      BETA = ABETA                                                      00730017
      GOTO 7                                                            00740017
    3 CONTINUE                                                          00750017
      BETA = -ABETA                                                     00760017
    7 CONTINUE                                                          00770017
      CL = DALF + BETA                                                  00780017
      IF (CL .LE. 0) GOTO 10                                            00790017
      IFL = 1                                                           00800017
      GOTO 20                                                           00810017
   10 CONTINUE                                                          00820017
      CL = CL + 360.                                                    00830017
      IF (IFL .EQ.0) GOTO 20                                            00840017
      NCR = NCR + 1                                                     00850017
      IFL = 0                                                           00860017
   20 CONTINUE                                                          00870017
      DT = SEDREC(51) / VH                                              00880017
      DCL = DT * HNUS                                                   00890017
      CLEF = CL + DCL                                                   00900017
      NCREFL = NCREF                                                    00901042
      IF (CLEF .LT. 360.) GOTO 30                                       00910017
      NCREF = NCR - 1                                                   00920017
      CLEF = CLEF - 360.                                                00930017
      IF (CLEF .LT. 360.) GOTO 30                                       00940017
      NCREF = NCREF - 1                                                 00950017
      CLEF = CLEF - 360.                                                00960041
   30 CONTINUE                                                          00970017
      CLEDIF = CLELST - CLEF                                            00971017
      IF (CLEDIF .GE. 0) GO TO 35                                       00972017
      NCREF = NCREF + 1                                                 00973017
   35 CONTINUE                                                          00973117
      NCDIF = NCREF - NCREFL                                            00973242
      IF (NCDIF .LE. 1) GO TO 36                                        00973342
      NCREF = NCREF - 1                                                 00973442
   36 CONTINUE                                                          00973542
      CLELST = CLEF                                                     00974017
      BETAE = CL0 - ROT                                                 00974129
      ABE = ABS(BETAE)                                                  00974225
      ABTAE = AMOD(ABE,360.)                                            00974325
      IF (BETAE .LT. 0.) GO TO 37                                       00974425
      BETAE = ABTAE                                                     00974525
      GO TO 38                                                          00974625
   37 CONTINUE                                                          00974725
      BETAE = -ABTAE                                                    00974825
   38 CONTINUE                                                          00974925
      ECL = DALFE + BETAE                                               00975025
C     WRITE (6,10000) SEDREC(51), SEDREC(98), SEDREC(100),              00975140
C    1                DALFE, BETAE, EPICDY                              00975240
C0000 FORMAT (10X,'SEDREC(51,98,100) =',F15.2,2F10.2,/,                 00975340
C    1        10X,'DALFE =',F6.1,' BETAE =',F6.1,' EPICDY =',F8.3)      00975440
      IF (ECL .LE. 0) GO TO 40                                          00975517
      IFLG = 1                                                          00976017
      GO TO 50                                                          00977017
   40 CONTINUE                                                          00978017
      ECL = ECL + 360.                                                  00979017
      IF (ECL .LE. 0) GO TO 40                                          00979133
      IF (IFLG .EQ. 0) GO TO 50                                         00979217
      ENCR = ENCR + 1                                                   00979317
      IFLG = 0                                                          00979417
      NFLG = 1                                                          00979535
   50 CONTINUE                                                          00979617
      IF (NFLG .EQ. 1) GO TO 60                                         00979735
      ECLDIF = ECLLST - ECL                                             00979835
      IF (ECLDIF .GE. 0) GO TO 60                                       00979935
      ENCR = ENCR + 1                                                   00980035
   60 CONTINUE                                                          00980235
      ECLLST = ECL                                                      00980337
      NFLG = 0                                                          00980435
      CALL WRITE (SEDREC, ECL, ENCR, CL, NCR, DT, DCL, CLEF, NCREF)     00981017
      RETURN                                                            00990017
      END                                                               01000017
      SUBROUTINE WRITE (SDRTIM, ECL, ENCR, CL, NCR, DT, DCL, CLEF,      01010017
     1                  NCREF)                                          01011017
      INTEGER*4 SDRTIM(6), NLINES/99/, ENCR                             01020017
      IF (NLINES .LT. 60) GOTO 20                                       01030017
C WRITE PAGE HEADER                                                     01040017
      WRITE (6, 10)                                                     01050017
   10 FORMAT (1H1, T25, 'VGR', T35, 'VGR', T45, 'EARTH', T55, 'EARTH',/,01051023
     1 T25, 'CARR.', T35, 'CARR.', T45, 'CARR.', T55, 'CARR.', T65,     01060019
     2 'DELAY', T75, 'DELTA', T85, 'EFFEC', T96,'EFFEC', /, T9, 'TIME', 01070023
     3 T25, 'LONG.', T35, 'ROT #', T45, 'LONG.', T55, 'ROT #', T65,     01090018
     4 'TIME', T76, 'CL', T87, 'CL', T97, 'NCR', /, T25, '(CL)', T35,   01100023
     5 '(NCR)', T45,'(ECL)', T55, '(ENCR)', T65, '(DT)', T75,           01110022
     6 '(DCL)', T85, '(CLEF)', T95, '(NCREF)',                          01120018
     7 /, 1X, 19('_'), T25, 5('_'), T35, 5('_'), T45, 5('_'), T55,      01130018
     8 6('_'), T65, 5('_'), T75, 5('_'), T85, 6('_'), T95, 7('_'))      01140018
      NLINES = 6                                                        01150018
   20 CONTINUE                                                          01160017
C WRITE DETAIL LINE                                                     01170017
      SDRTIM(1) = SDRTIM(1) - 1900                                      01180017
      WRITE (6, 30) SDRTIM, CL, NCR, ECL, ENCR, DT, DCL, CLEF, NCREF    01190024
   30 FORMAT (' ', I2, '/', I3, ':', I2, ':', I2, ':', I2, '.', I3,     01200017
     1        T25, F5.1, T35, I5, T45, F5.1, T55, I5, T65, F5.1, T75,   01210023
     2        F5.1, T85,F5.1, T95, I5)                                  01220023
      NLINES = NLINES + 1                                               01230017
      RETURN                                                            01240017
      END                                                               01250017
C-----------------------------------------------------------------------00000100
C  COMPUTES L1 COORDINATE SYSTEM INFORMATION FROM SATURN SEDR TAPE      00000110
C     ---- BY ADS                                                       00000115
C-----------------------------------------------------------------------00000120
      COMMON /CCA/WORK(500)                                             00000130
      REAL*8 VOLSER,SUMTAP,TIMS,TIME1/-5.D75/,TIME2/+5.D75/,TIME        00000140
      REAL*8 TIMEF,ROTP/.4440277D0/                                     00000150
      INTEGER*4 IREC(378),NREC/0/,ICB/0/,MAXOUT/1200/                   00000160
      INTEGER*4 JREC(126,3),ITM(6,2)/12*0/,JOUT/1/                      00000170
      LOGICAL LOUT/.FALSE./,FIRST/.TRUE./                               00000180
      EQUIVALENCE (IREC(1),JREC(1,1))                                   00000190
      EQUIVALENCE (WORK(61),ICOORD)                                     00000200
      ICOORD = 3                                                        00000210
C**** READ TIME INTERVAL FROM FT05F001.                                 00000220
      READ (5,1002,END=10) (ITM(I,1),I=1,5),(ITM(I,2),I=1,5)            00000230
      WRITE (6,2005) (ITM(I,1),I=1,5),(ITM(I,2),I=1,5)                  00000240
      TIME1 = TIMS(ITM(1,1))                                            00000250
      TIME2 = TIMS(ITM(1,2))                                            00000260
C**** READ A PHYSICAL RECORD FROM FT12F001.                             00000270
   10 CALL FREAD (IREC,12,IBYT,&50,&60)                                 00000280
      NREC = NREC + 1                                                   00000290
      IF (IBYT.EQ.180)  GO TO 20                                        00000300
      IF (IBYT.EQ.1008) GO TO 30                                        00000310
      WRITE (6,2002) IBYT                                               00000320
      GO TO 10                                                          00000330
C**** HEADER RECORD.                                                    00000340
   20 IF (ICB.EQ.1.AND.LOUT)  WRITE (6,2009)                            00000350
      ICB = 0                                                           00000360
      GO TO 10                                                          00000370
C**** DATA RECORD.                                                      00000380
   30 TIME = TIMS(JREC)                                                 00000390
      IF (TIME.GE.TIME1.AND.ICB.EQ.0) LOUT=.TRUE.                       00000400
      IF (TIME.GT.TIME2) GO TO 90                                       00000410
      IF (ICB.EQ.1)  GO TO 40                                           00000420
C**** DATA RECORD (CN/PV).                                              00000430
      IF (.NOT.LOUT) GO TO 35                                           00000440
      IF (JREC(1,1).EQ.0) WRITE (6,2020) NREC                           00000450
      CALL L1OUT(JREC,0,1)                                              00000460
      IF (JREC(1,2).EQ.0) WRITE (6,2023) NREC,(JREC(I,1),I=1,6)         00000470
      IF (JREC(101,2).NE.0.AND.JREC(101,2).NE.1) WRITE(6,2022) NREC     00000480
      N = 2                                                             00000490
      CALL L1OUT(JREC,N,2)                                              00000500
      IF (FIRST) WRITE (6,2014) NREC,(JREC(I,N),  I = 1,6)              00000510
      IF (FIRST) TIMEF = TIMS(JREC(1,N))                                00000520
      FIRST = .FALSE.                                                   00000530
      IF (JOUT.GE.MAXOUT) GO TO 90                                      00000540
      IF (TIMS(JREC(1,N))-TIMEF.GE.ROTP) GO TO 90                       00000550
      JOUT = JOUT + 1                                                   00000560
   35 ICB = JREC(101,2)                                                 00000570
      GO TO 10                                                          00000580
C**** DATA RECORD (PV/PV).                                              00000590
   40 DO 41  N = 1,2                                                    00000600
      IF (.NOT.LOUT) GO TO 42                                           00000610
      IF (JREC(1,N).EQ.0)  WRITE (6,2021) NREC                          00000620
      IF (JREC(101,N).NE.0.AND.JREC(101,N).NE.1) WRITE(6,2022) NREC     00000630
      CALL L1OUT(JREC,N,2)                                              00000640
      IF (JOUT.GE.MAXOUT) GO TO 90                                      00000650
      IF (TIMS(JREC(1,N))-TIMEF.GE.ROTP) GO TO 90                       00000660
      JOUT = JOUT + 1                                                   00000670
   42 ICB = JREC(101,N)                                                 00000680
      IF (ICB.EQ.0)  GO TO 10                                           00000690
   41 CONTINUE                                                          00000700
      GO TO 10                                                          00000710
C**** END OF FILE.                                                      00000720
   50 WRITE (6,2007)                                                    00000730
      GO TO 90                                                          00000740
C**** I/O ERROR.                                                        00000750
   60 WRITE (6,2008)                                                    00000760
      GO TO 90                                                          00000770
C**** VOLUME SERIAL NUMBER.                                             00000780
   90 SUMTAP = VOLSER('FT12F001')                                       00000790
      WRITE (6,2017) SUMTAP                                             00000800
      WRITE (6,2019) JOUT                                               00000810
      CALL AVERAG                                                       00000820
      WRITE (6,2014) NREC,(JREC(I,N),  I = 1,6)                         00000830
      STOP                                                              00000840
 1002 FORMAT(10I4)                                                      00000850
 2002 FORMAT ('0RECORD READ WITH ',I5,' BYTES')                         00000860
 2005 FORMAT('0TIME INTERVAL IS ',2I4,3(':',I2),5X,2I4,3(':',I2))       00000870
 2007 FORMAT ('0END OF FILE')                                           00000880
 2008 FORMAT ('0I/O ERROR')                                             00000890
 2009 FORMAT ('0HEADER RECORD FOUND WHEN PV CONTINUATION EXPECTED')     00000900
 2014 FORMAT (' REC#',I5,' POINTING VECTOR TIME: ',I4,'(',I3,')',I2,    00000910
     X       ':',I2,':',I2,'.',I3)                                      00000920
 2017 FORMAT ('0LISTING OF VOLUME ',A8)                                 00000930
 2019 FORMAT ('0NUMBER OF RECORDS USED  = ',I5)                         00000940
 2020 FORMAT (' BAD NAVIGATION TIME IN RECORD # ',I5)                   00000950
 2021 FORMAT (' BAD POINTING VECTOR TIME IN RECORD # ',I5)              00000960
 2022 FORMAT (' BAD POINTING VECTOR CONTINUATION WORD IN RECORD # ',I5) 00000970
 2023 FORMAT (' BAD POINTING VECTOR TIME IN RECORD # ',I5,              00000980
     X ' NAV TIME= ',I4,'(',I3,')',I2,':',I2,':',I2,'.',I3)             00000990
      END                                                               00001000
      SUBROUTINE L1OUT (JREC,NKC,NPAS)                                  00001010
C-----------------------------------------------------------------------00001020
C    L1 CALCULATIONS.                                                   00001030
C-----------------------------------------------------------------------00001040
      REAL*4 AUXM(3,3),BUXM(3,3),TL1(3,3)                               00001050
      REAL*4 ANG(2),SPV(6),FINAL(3,3)/9*0.E0/                           00001060
      INTEGER*4 JREC(126,3),NPTS/0/                                     00001070
      IF (NPAS.EQ.2)  GO TO 60                                          00001080
      CALL SEDRCJ (JREC,0,PSI,OMG,ANG,RANGE,SPV)                        00001090
      RETURN                                                            00001120
   60 CALL SEDRPJ (JREC(12,NKC),PSI,OMG,ANG(2),AUXM,BUXM,TL1)           00001130
      WRITE (6,3002) OMG,ANG(2),SPV(1),SPV(2),SPV(3),AUXM,BUXM,TL1      00001140
 3002 FORMAT (1X,1P11E11.3)                                             00001150
      NPTS = NPTS + 1                                                   00001160
      DO 70  I = 1,3                                                    00001170
      DO 70  J = 1,3                                                    00001180
   70 FINAL(I,J) = FINAL(I,J) + BUXM(I,J)                               00001190
      RETURN                                                            00001200
      ENTRY AVERAG                                                      00001210
      DO 80 I = 1,3                                                     00001220
      DO 80 J = 1,3                                                     00001230
   80 FINAL(I,J) = FINAL(I,J)/NPTS                                      00001240
      WRITE (6,2001) NPTS,FINAL                                         00001250
 2001 FORMAT (' AVERAGE (',I5,' PTS)',1P9E11.3)                         00001260
      RETURN                                                            00001270
      END                                                               00001280
      REAL FUNCTION TIMS*8 (ITM)                                        00001290
C-----------------------------------------------------------------------00001300
C  INPUT:  ITM(1) = YEAR                                                00001310
C          ITM(2) = DAY OF YEAR                                         00001320
C          ITM(3) = HOUR OF DAY                                         00001330
C          ITM(4) = MINUTE OF HOUR                                      00001340
C          ITM(5) = SECOND OF MINUTE                                    00001350
C          ITM(6) = MILLISECOND OF SECOND                               00001360
C  OUTPUT: TIMS = DAYS SINCE 1977 DAY 0 (REAL*8)                        00001370
C-----------------------------------------------------------------------00001380
      INTEGER*4 ITM(6)                                                  00001390
      IYR = ITM(1)                                                      00001400
      IYR = MOD(IYR,1900) - 77                                          00001410
      TIMS = IYR*365.D0 + (ITM(2) + (ITM(3) + (ITM(4) + (ITM(5) +       00001420
     X .001D0*ITM(6))/60.D0)/60.D0)/24.D0) + MOD(IYR,4)                 00001430
      RETURN                                                            00001440
      END                                                               00001450
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00010000
C                                                                       00020000
C PROGRAM: SEDRMRG                                                      00030005
C                                                                       00040000
C PROGRAMMER: T. W. VOLLMER (GSFC)                                      00050004
C                                                                       00051004
C DATE: AUGUST 21, 1986                                                 00052005
C                                                                       00060000
C DESCRIPTION: THIS ROUTINE READS AN SEDR IN ANY FORMAT (LAUNCH,        00070000
C              CRUISE, JUPITER, ETC.).  RECORDS BETWEEN THE TIMES THAT  00080005
C              ARE INPUT ARE COPIED TO THE OUTPUT FILE. (ALL TIMES ARE  00090005
C              FOR NAVIGATION BLOCKS.  ALL ASSOCIATED POINTING VECTORS  00180005
C              ARE COPIED WITH THE NAV BLOCK.)  THIS ROUTINE IS A       00181006
C              MODIFICATION OF SEDRREAD                                 00182006
C                                                                       00183006
C PDL:                                                                  00190000
C READ THE SEDR TIMES TO BE PROCESSED                                   00200000
C READ THE SEDR RECORD                                                  00210000
C IF THIS IS A HEADER RECORD THEN WRITE TO OUTPUT TAPE AND              00220007
C  READ ANOTHER RECORD                                                  00221007
C     ELSE                                                              00230000
C     IF THE RECORD DOES NOT HAVE THE CORRECT LENGTH THEN DISCARD       00240003
C     IF THIS IS A NAVIGATION RECORD                                    00250000
C         THEN IF RECORD IS WITHIN TIMES TO BE PROCESSED                00260000
C                  THEN SET FLAG INDICATING RECORD IS TO BE PROCESSED   00270000
C                  WRITE RECORD TO OUTPUT FILE                          00271006
C              IF THIS IS A JUPITER FORMAT RECORD                       00280000
C                  THEN SET NAV BLOCK LENGTH TO 1008                    00290000
C                       SET POINTING VECTOR POSITION TO 3               00300000
C                  ELSE SET NAV BLOCK LENGTH TO 504                     00310000
C                       SET POINTING VECTOR POSITION TO 2               00320000
C              IF THIS IS THE LAST POINTING VECTOR                      00360000
C                  THEN SET SET FLAG INDICATING A NAVIGATION BLOCK NEXT 00370000
C                  ELSE TURN OFF FLAG INDICATING A NAVIGATION BLOCK NEXT00380000
C         ELSE DO FOR EACH POINTING VECTOR                              00390000
C                  IF THIS RECORD IS TO BE PROCESSED                    00400000
C                      THEN WRITE RECORD TO THE OUTPUT FILE.            00410006
C                  IF THIS IS THE LAST POINTING                         00420000
C                      THEN SET FLAG INDICATING A NAVIGATION BLOCK      00430000
C                           GO BACK AND READ A NEW SEDR RECORD          00440000
C              END DO                                                   00450000
C                                                                       00460000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00470000
      LOGICAL*1 LNAV/.TRUE./, PROC/.TRUE./                              00480008
      INTEGER*4 SDREC(126,3), YRBEG, DAYBEG, HRBEG, MINBEG,             00490000
     1                        YREND, DAYEND, HREND, MINEND              00500000
C READ LIMITS OF TIMES TO BE PROCESSED                                  00510000
      READ (5,10) YRBEG, DAYBEG, HRBEG, MINBEG,                         00520000
     1            YREND, DAYEND, HREND, MINEND                          00530000
      WRITE (6,10000) YRBEG,DAYBEG,HRBEG,MINBEG,                        00540000
     1                YREND,DAYEND,HREND,MINEND                         00550000
10000 FORMAT (' TIME LIMITS ',8I5)                                      00560000
   10 FORMAT (8I5)                                                      00570000
      NREC = 0                                                          00580000
      NHDR = 0                                                          00581009
   20 CONTINUE                                                          00590000
C READ AN SEDR RECORD                                                   00600000
      CALL FREAD (SDREC, 10, NBYT, &150, &130)                          00610000
      NREC = NREC + 1                                                   00610109
C PROCESS HEADER RECORD                                                 00611007
      IF (NBYT .NE. 180) GO TO 25                                       00620007
          NHDR = NHDR + 1                                               00621009
C         IF (NHDR .GE. 10) CALL FWRITE (SDREC, 20, NBYT)               00630014
C         CALL FWRITE (SDREC, 20, NBYT)                                 00631015
   25 CONTINUE                                                          00640007
C IF SEDR RECORD IS NOT A VALID LENGTH THEN DISCARD                     00660003
      IF ((NBYT .NE. 1008) .AND. (NBYT .NE.1512)) GO TO 20              00670003
      IF (.NOT. LNAV) GO TO 100                                         00680000
C NAVIGATION BLOCK                                                      00690000
C CHECK THAT RECORD IS WITHIN TIME LIMIT REQUISTED                      00700000
      IF (SDREC(1,1) .LT.  YRBEG) GO TO 30                              00710003
      IF (SDREC(1,1) .GT.  YRBEG) GO TO 40                              00720003
      IF (SDREC(2,1) .LT. DAYBEG) GO TO 30                              00730003
      IF (SDREC(2,1) .GT. DAYBEG) GO TO 40                              00740003
      IF (SDREC(3,1) .LT.  HRBEG) GO TO 30                              00750003
      IF (SDREC(3,1) .GT.  HRBEG) GO TO 40                              00760003
      IF (SDREC(4,1) .LT. MINBEG) GO TO 30                              00770003
      IF (SDREC(4,1) .GT. MINBEG) GO TO 40                              00780003
      GO TO 50                                                          00790003
   30 CONTINUE                                                          00800003
      PROC = .FALSE.                                                    00810000
      GO TO 60                                                          00820003
   40 CONTINUE                                                          00830003
      IF (SDREC(1,1) .LT.  YREND) GO TO 50                              00840003
      IF (SDREC(1,1) .GT.  YREND) GO TO 150                             00850003
      IF (SDREC(2,1) .LT. DAYEND) GO TO 50                              00860003
      IF (SDREC(2,1) .GT. DAYEND) GO TO 150                             00870003
      IF (SDREC(3,1) .LT.  HREND) GO TO 50                              00880003
      IF (SDREC(3,1) .GT.  HREND) GO TO 150                             00890003
      IF (SDREC(4,1) .LT. MINEND) GO TO 50                              00900003
      IF (SDREC(4,1) .GT. MINEND) GO TO 150                             00910000
   50 CONTINUE                                                          00920003
      PROC = .TRUE.                                                     00930003
      CALL FWRITE (SDREC, 20, NBYT)                                     00931005
   60 CONTINUE                                                          00940000
      IF (NBYT .EQ. 1512) GO TO 70                                      00950000
C NON-JUPITER NAVIGATION BLOCK                                          00960000
      NAVBYT = 504                                                      00970000
      IPV = 2                                                           00980000
      GO TO 80                                                          00990000
   70 CONTINUE                                                          01000000
C JUPITER NAVIGATION BLOCK                                              01010000
      NAVBYT = 1008                                                     01020000
      IPV = 3                                                           01030000
   80 CONTINUE                                                          01040000
      LNAV = .FALSE.                                                    01100000
      IF (SDREC(101,IPV) .EQ. 0) LNAV = .TRUE.                          01110000
      GO TO 20                                                          01120000
  100 CONTINUE                                                          01130000
C POINTING VECTOR                                                       01140000
      LIM = NBYT / 504                                                  01150000
      IF (PROC) CALL FWRITE (SDREC, 20, NBYT)                           01151005
      DO 120 IPV = 1, LIM                                               01160000
      IF (SDREC(101,IPV) .EQ. 1) GO TO 120                              01200000
      LNAV = .TRUE.                                                     01210000
      GO TO 20                                                          01220000
  120 CONTINUE                                                          01230000
      GO TO 20                                                          01240000
  130 CONTINUE                                                          01250000
C ERROR READING SEDR TAPE                                               01260000
      WRITE (6,140) NREC                                                01270000
  140 FORMAT (' ERROR READING RECORD',I5)                               01280000
      GO TO 20                                                          01290000
  150 CONTINUE                                                          01300000
C     WRITE (6,10020)                                                   01310000
C0020 FORMAT (' END OF SEDR')                                           01320000
      STOP                                                              01330000
      END                                                               01340000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00010000
C                                                                       00020000
C PROGRAM: SEDRREAD                                                     00030000
C                                                                       00040000
C PROGRAMMER: T. W. VOLLMER (GSFC)                                      00050004
C                                                                       00051004
C DATE: FEBRUARY 8, 1984                                                00052004
C                                                                       00060000
C DESCRIPTION: THIS ROUTINE READS AN SEDR IN ANY FORMAT (LAUNCH,        00070000
C              CRUISE, JUPITER, ETC.), BREAKING THE RECORDS INTO        00080000
C              HEADER RECORDS,  NAVIGATION BLOCKS AND POINTING VECTORS. 00090000
C              THESE ARE THEN PASSED TO SUBROUTINES (HEAD, NAV & PV)    00100000
C              WHERE THEY ARE PROCESSED.  IT IS ASSUMED THAT THE        00110000
C              SUBROUTINES 'HEAD', 'NAV' AND 'PV' WILL CHANGE FOR       00120000
C              DIFFERENT APPLICATIONS.  NOTE THAT ONLY THE NAVAGATION   00130000
C              BLOCK IS CHECKED AGAINST THE INPUT TIME LIMITS.  POINTING00140000
C              VECTORS ARE PROCESSED IF AND ONLY IF THE PRECEEDING NAV  00150000
C              IS PROCESSED.  THIS IS TO ACCOUNT FOR THE FACT THAT A PV 00160000
C              CAN HAVE AN EARLIER TIME THAN THE NAV.                   00170000
C                                                                       00180000
C PDL:                                                                  00190000
C READ THE SEDR TIMES TO BE PROCESSED                                   00200000
C READ THE SEDR RECORD                                                  00210000
C IF THIS IS A HEADER RECORD THEN CALL HEAD                             00220000
C     ELSE                                                              00230000
C     IF THE RECORD DOES NOT HAVE THE CORRECT LENGTH THEN DISCARD       00240003
C     IF THIS IS A NAVIGATION RECORD                                    00250000
C         THEN IF RECORD IS WITHIN TIMES TO BE PROCESSED                00260000
C                  THEN SET FLAG INDICATING RECORD IS TO BE PROCESSED   00270000
C              IF THIS IS A JUPITER FORMAT RECORD                       00280000
C                  THEN SET NAV BLOCK LENGTH TO 1008                    00290000
C                       SET POINTING VECTOR POSITION TO 3               00300000
C                  ELSE SET NAV BLOCK LENGTH TO 504                     00310000
C                       SET POINTING VECTOR POSITION TO 2               00320000
C              IF THIS RECORD IS TO BE PROCESSED                        00330000
C                  THEN CALL NAV TO PROCESS NAVIGATION BLOCK            00340000
C                       CALL PV TO PROCESS POINTING VECTOR              00350000
C              IF THIS IS THE LAST POINTING VECTOR                      00360000
C                  THEN SET SET FLAG INDICATING A NAVIGATION BLOCK NEXT 00370000
C                  ELSE TURN OFF FLAG INDICATING A NAVIGATION BLOCK NEXT00380000
C         ELSE DO FOR EACH POINTING VECTOR                              00390000
C                  IF THIS RECORD IS TO BE PROCESSED                    00400000
C                      THEN CALL PV TO PROCESS THE POINTING VECTOR      00410000
C                  IF THIS IS THE LAST POINTING                         00420000
C                      THEN SET FLAG INDICATING A NAVIGATION BLOCK      00430000
C                           GO BACK AND READ A NEW SEDR RECORD          00440000
C              END DO                                                   00450000
C                                                                       00460000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00470000
      LOGICAL*1 LNAV/.TRUE./, PROC                                      00480000
      INTEGER*4 SDREC(126,3), YRBEG, DAYBEG, HRBEG, MINBEG,             00490000
     1                        YREND, DAYEND, HREND, MINEND              00500000
C READ LIMITS OF TIMES TO BE PROCESSED                                  00510000
      READ (5,10) YRBEG, DAYBEG, HRBEG, MINBEG,                         00520000
     1            YREND, DAYEND, HREND, MINEND                          00530000
      WRITE (6,10000) YRBEG,DAYBEG,HRBEG,MINBEG,                        00540000
     1                YREND,DAYEND,HREND,MINEND                         00550000
10000 FORMAT (' TIME LIMITS ',8I5)                                      00560000
   10 FORMAT (8I5)                                                      00570000
      NREC = 0                                                          00580000
   20 CONTINUE                                                          00590000
C READ AN SEDR RECORD                                                   00600000
      CALL FREAD (SDREC, 10, NBYT, &150, &130)                          00610000
       WRITE (6,22) NBYT                                                00611013
   22 FORMAT (' READ SEDR RECORD NBYTE = ',I5)                          00612013
C     IF (NBYT .NE. 180) GO TO 25                                       00620011
C PROCESS HEADER RECORD                                                 00630003
      CALL HEAD (SDREC)                                                 00640003
   25 CONTINUE                                                          00650003
C IF SEDR RECORD IS NOT A VALID LENGTH THEN DISCARD                     00660003
      IF ((NBYT .NE. 1008) .AND. (NBYT .NE.1512)) GO TO 20              00670014
      IF (.NOT. LNAV) GO TO 100                                         00680014
C NAVIGATION BLOCK                                                      00690000
C CHECK THAT RECORD IS WITHIN TIME LIMIT REQUISTED                      00700000
C     WRITE (6,*) SDREC(1,1),SDREC(2,1),SDREC(3,1)                      00701011
      IF (SDREC(1,1) .LT.  YRBEG) GO TO 30                              00710003
      IF (SDREC(1,1) .GT.  YRBEG) GO TO 40                              00720003
      IF (SDREC(2,1) .LT. DAYBEG) GO TO 30                              00730003
      IF (SDREC(2,1) .GT. DAYBEG) GO TO 40                              00740003
      IF (SDREC(3,1) .LT.  HRBEG) GO TO 30                              00750003
      IF (SDREC(3,1) .GT.  HRBEG) GO TO 40                              00760003
      IF (SDREC(4,1) .LT. MINBEG) GO TO 30                              00770003
      IF (SDREC(4,1) .GT. MINBEG) GO TO 40                              00780003
      GO TO 50                                                          00790003
   30 CONTINUE                                                          00800003
      PROC = .FALSE.                                                    00810000
      GO TO 60                                                          00820003
   40 CONTINUE                                                          00830003
      IF (SDREC(1,1) .LT.  YREND) GO TO 50                              00840003
      IF (SDREC(1,1) .GT.  YREND) GO TO 150                             00850003
      IF (SDREC(2,1) .LT. DAYEND) GO TO 50                              00860003
      IF (SDREC(2,1) .GT. DAYEND) GO TO 150                             00870003
      IF (SDREC(3,1) .LT.  HREND) GO TO 50                              00880003
      IF (SDREC(3,1) .GT.  HREND) GO TO 150                             00890003
      IF (SDREC(4,1) .LT. MINEND) GO TO 50                              00900003
      IF (SDREC(4,1) .GT. MINEND) GO TO 150                             00910000
   50 CONTINUE                                                          00920003
      PROC = .TRUE.                                                     00930003
   60 CONTINUE                                                          00940000
      IF (NBYT .EQ. 1512) GO TO 70                                      00950000
C NON-JUPITER NAVIGATION BLOCK                                          00960000
      NAVBYT = 504                                                      00970000
      IPV = 2                                                           00980000
      GO TO 80                                                          00990000
   70 CONTINUE                                                          01000000
C JUPITER NAVIGATION BLOCK                                              01010000
      NAVBYT = 1008                                                     01020000
      IPV = 3                                                           01030000
   80 CONTINUE                                                          01040000
      IF (.NOT. PROC) GO TO 90                                          01050000
C PROCESS NAV AND PV                                                    01060000
      WRITE(6,*) ' PROCESSING NAV BLOCK &&&&&'                          01061013
      CALL NAV (SDREC(1,1), SDREC(1,1), NAVBYT)                         01070005
      WRITE(6,*) ' PROCESSING PV BLOCK ?????'                           01071013
      CALL PV (SDREC(1,IPV), SDREC(1,IPV))                              01080005
      WRITE(6,*) ' AFTER PV'                                            01081013
   90 CONTINUE                                                          01090000
      WRITE(6,*) ' AFTER 90 '                                           01091013
      LNAV = .FALSE.                                                    01100000
      IF (SDREC(101,IPV) .EQ. 0) LNAV = .TRUE.                          01110000
      GO TO 20                                                          01120000
  100 CONTINUE                                                          01130000
C POINTING VECTOR                                                       01140000
      LIM = NBYT / 504                                                  01150000
      DO 120 IPV = 1, LIM                                               01160000
      IF (.NOT. PROC) GO TO 110                                         01170000
      CALL PV (SDREC(1,IPV), SDREC(1,IPV))                              01180005
  110 CONTINUE                                                          01190000
      IF (SDREC(101,IPV) .EQ. 1) GO TO 120                              01200000
      LNAV = .TRUE.                                                     01210000
      GO TO 20                                                          01220000
  120 CONTINUE                                                          01230000
      GO TO 20                                                          01240000
  130 CONTINUE                                                          01250000
C ERROR READING SEDR TAPE                                               01260000
      WRITE (6,140) NREC                                                01270000
  140 FORMAT (' ERROR READING RECORD',I5)                               01280000
      GO TO 20                                                          01290000
  150 CONTINUE                                                          01300000
C     WRITE (6,10020)                                                   01310000
C0020 FORMAT (' END OF SEDR')                                           01320000
      STOP                                                              01330000
      END                                                               01340000
C-----------------------------------------------------------------------00000100
C  A. SILVER    U2ADS.LIB.FORT(SEDRTAB2)    01-MAY-80                   00000110
C  ITYP=1  S/C   POSITION    EARTH CENTERED                             00000120
C  ITYP=2  S/C   POSITION    SUN   CENTERED                             00000130
C  ITYP=3  EARTH POSITION    SUN   CENTERED                             00000140
C  ICOORD=1    ISE COORDINATE SYSTEM                                    00000150
C  ICOORD=2    IHG COORDINATE SYSTEM                                    00000160
C-----------------------------------------------------------------------00000170
      REAL*8 TIME,PTIM/-1.D60/                                          00000180
      INTEGER*4 ILUN/12/,IREC(378),ICB/0/,IER/0/                        00000190
      INTEGER*4 ICOORD/0/,ITYP/0/,JREC(126,3),NBAD/0/,NMIS/0/           00000200
      REAL*4 DTIM/0./                                                   00000210
      EQUIVALENCE (IREC(1),JREC(1,1))                                   00000220
      EQUIVALENCE (IDY,JREC(2,1)),(IHR,JREC(3,1)),(IMN,JREC(4,1)),      00000230
     X  (ISC,JREC(5,1)),(IMS,JREC(6,1))                                 00000240
      NAMELIST /INPUT/ ICOORD,ITYP,DTIM                                 00000250
C**** READ IN INPUT AND PRINT IT.                                       00000260
      READ (5,INPUT)                                                    00000270
      IF (DTIM.LE.0.E0.OR.ITYP.LE.0.OR.ICOORD.LE.0) STOP                00000280
      CALL HEAD(6,ICOORD,ITYP,DTIM)                                     00000290
C**** READ A PHYSICAL RECORD.                                           00000300
   10 CALL FREAD (IREC,ILUN,IBYT,&50,&60)                               00000310
      IF (IBYT.EQ.180)  GO TO 20                                        00000320
      IF (IBYT.EQ.1008.OR.IBYT.EQ.1512) GO TO 30                        00000330
      NBAD = NBAD + 1                                                   00000340
      GO TO 10                                                          00000350
C**** HEADER RECORD.                                                    00000360
   20 IF (ICB.EQ.1) NMIS = NMIS + 1                                     00000370
      ICB = 0                                                           00000380
      GO TO 10                                                          00000390
C**** DATA RECORD.                                                      00000400
   30 NKC = IBYT/504                                                    00000410
      IF (ICB.EQ.1)  GO TO 40                                           00000420
C**** DATA RECORD (CN/PV).                                              00000430
C**** COMPUTE TIME IN HOURS. ASSUME YEAR IS CONSTANT.                   00000440
C**** PRINT RECORDS GE DTIM HOURS APART.                                00000450
      TIME = 24.D0*IDY + IHR +(IMN + (ISC + .001D0*IMS)/60.D0)/60.D0    00000460
      IF (TIME-PTIM.LT.DTIM)  GO TO 25                                  00000470
      PTIM = TIME                                                       00000480
      CALL BODY(6,ICOORD,ITYP,IREC,NKC)                                 00000490
   25 ICB = JREC(101,NKC)                                               00000500
      GO TO 10                                                          00000510
C**** DATA RECORD (PV/PV).                                              00000520
   40 DO 41  N = 1,NKC                                                  00000530
      ICB = JREC(101,N)                                                 00000540
      IF (ICB.EQ.0)  GO TO 10                                           00000550
   41 CONTINUE                                                          00000560
      GO TO 10                                                          00000570
C**** END OF FILE.                                                      00000580
   50 IER = 1                                                           00000590
      GO TO 90                                                          00000600
C**** I/O ERROR.                                                        00000610
   60 IER = 2                                                           00000620
C**** FINAL PRINTOUT                                                    00000630
   90 CALL FOOT(6,IER,NBAD,NMIS)                                        00000640
      STOP                                                              00000650
      END                                                               00000660
      SUBROUTINE BODY (JLUN,ICOORD,ITYP,IREC,NKC)                       00000670
      INTEGER*4 IFN(3,2)/7,13,31,7,13,49/,IGN(3,2)/49,51,50,172,173,174/00000680
      INTEGER*4 IREC(1)                                                 00000690
      REAL*4 CN(6),SPV(6)                                               00000700
      REAL*4 T5(3,3) /+0.2576  ,+0.9662  ,+0.      ,                    00000710
     X                -0.9585  ,+0.2555  ,+0.1262  ,                    00000720
     X                +0.1219  ,-0.0325  ,+0.9920  /                    00000730
      CALL FMOVE(CN,24,IREC(IFN(ITYP,NKC-1)))                           00000740
      CALL FMOVE(RANGE,4,IREC(IGN(ITYP,NKC-1)))                         00000750
      IF (ICOORD.NE.2)  GO TO 23                                        00000760
      DO 21  I = 1,3                                                    00000770
      SPV(I) =  T5(1,I)*CN(1) + T5(2,I)*CN(2) + T5(3,I)*CN(3)           00000780
   21 SPV(I+3) = T5(1,I)*CN(4) + T5(2,I)*CN(5) + T5(3,I)*CN(6)          00000790
      GO TO 24                                                          00000800
   23 CALL FMOVE(SPV,24,CN)                                             00000810
   24 WRITE (JLUN,2001) (IREC(I),I=1,6),SPV,RANGE                       00000820
 2001 FORMAT (1X,I4,'(',I3,')',I2,':',I2,':',I2,'.',I3,                 00000830
     X   1P7E15.7)                                                      00000840
      RETURN                                                            00000850
      END                                                               00000860
      SUBROUTINE HEAD (JLUN,ICOORD,ITYP,DTIM)                           00000870
      IF (ITYP.EQ.1)  WRITE (JLUN,2021)                                 00000880
 2021 FORMAT ('0S/C POSITION   EARTH CENTERED'//)                       00000890
      IF (ITYP.EQ.2)  WRITE (JLUN,2022)                                 00000900
 2022 FORMAT ('0S/C POSITION   SUN CENTERED'//)                         00000910
      IF (ITYP.EQ.3)  WRITE (JLUN,2023)                                 00000920
 2023 FORMAT ('0EARTH POSITION   SUN CENTERED'//)                       00000930
      IF (ICOORD.EQ.1)  WRITE (JLUN,2031)                               00000940
 2031 FORMAT ('0ISE COORDINATE SYSTEM'//)                               00000950
      IF (ICOORD.EQ.2)  WRITE (JLUN,2032)                               00000960
 2032 FORMAT ('0IHG COORDINATE SYSTEM'//)                               00000970
      WRITE (JLUN,2003) DTIM                                            00000980
 2003 FORMAT ('0PRINT RECORDS AT LEAST ',1PE9.1,' HOURS APART'//)       00000990
      RETURN                                                            00001000
      END                                                               00001010
      SUBROUTINE FOOT (JLUN,IER,NBAD,NMIS)                              00001020
      REAL*8 VOLSER,SUMTAP                                              00001030
C**** END OF FILE.                                                      00001040
      IF (IER.EQ.1) WRITE (JLUN,2007)                                   00001050
 2007 FORMAT ('0END OF FILE')                                           00001060
C**** I/O ERROR.                                                        00001070
      IF (IER.EQ.2) WRITE (JLUN,2008)                                   00001080
 2008 FORMAT ('0I/O ERROR')                                             00001090
C**** VOLUME SERIAL NUMBER.                                             00001100
      IF (NBAD.GT.0)  WRITE (JLUN,2006) NBAD                            00001110
 2006 FORMAT ('0',I5,' RECORDS READ WITH WRONG # OF BYTES')             00001120
      IF (NMIS.GT.0) WRITE (JLUN,2009) NMIS                             00001130
 2009 FORMAT ('0',I5,' MISSING RECORDS')                                00001140
      SUMTAP = VOLSER('FT12F001')                                       00001150
      WRITE (JLUN,2017) SUMTAP                                          00001160
 2017 FORMAT ('0LISTING OF VOLUME ',A8)                                 00001170
      RETURN                                                            00001180
      END                                                               00001190
C  PROGRAM: SUMBLOCK                                                    00001033
C  PROGRAMMER: T. MCCLANAHAN  12/20/92                                  00002069
C  THIS PROGRAM WILL REBLOCK VOYAGER SUMMARY DATA RETRIEVED FROM        00003069
C  UNITTREE.                                                            00004069
       INTEGER*4 I4REC(63),INUNIT/10/,OUTUNIT/20/,NBYTS,LFM/'LFM '/     00010070
       INTEGER*4 OUT4(5000),TBYTS,INCNT,OCNT,IWRDS,TREC,ENG/'ENG '/     00011071
       INTEGER*2 I2REC(126),OUT2REC(10000)                              00020068
       EQUIVALENCE (I4REC(1),I2REC(1))                                  00030065
C  INITIALIZE COUNTERS. TREC  = TOTAL RECORDS PROCESSED                 00030169
C                       INCNT = CURRENT WORD IN INPUT ARRAY             00030269
C                       OCNT  = CURRENT WORD IN OUTPUT ARRAY            00030369
C                       IWRDS = VALUE READ FROM 64TH I*2 IN RECORD      00030469
C                               ( NUMBER OF WORDS LEFT IN LOGICAL REC)  00030569
       TREC = 0                                                         00031024
       NBYTS = 0                                                        00031168
       IWRDS = -2                                                       00032067
       OCNT = 1                                                         00040067
       INCNT = 1                                                        00040167
       WRITE (6,*)'BEGINNING PROCESSING......'                          00041025
       DO WHILE (.TRUE.)                                                00042052
         IF (INCNT .GT. NBYTS/4) THEN                                   00050065
           CALL FREAD(I4REC,INUNIT,NBYTS,&50,&50)                       00060065
           INCNT = 1                                                    00070065
         ENDIF                                                          00080468
           IF (OCNT .EQ. 32) IWRDS = I2REC(INCNT*2)                     00090068
           IF (IWRDS .EQ. -1) THEN                                      00120068
             TBYTS = (OCNT-1)*4                                         00121068
             IF ((OUT4(1).NE.LFM).AND.(OUT4(1).NE.ENG))                 00122072
     1        CALL FWRITE(OUT4,OUTUNIT,TBYTS)                           00130070
             TREC = TREC + 1                                            00130368
             OCNT = 1                                                   00130468
           END IF                                                       00151068
           OUT4(OCNT) = I4REC(INCNT)                                    00160067
           INCNT = INCNT + 1                                            00170067
           IWRDS = IWRDS - 1                                            00171067
           OCNT = OCNT + 1                                              00172067
       END DO                                                           00180065
 50    CONTINUE                                                         00341800
       TBYTS = (OCNT-1)*4                                               00342068
       CALL FWRITE(OUT4,OUTUNIT,TBYTS)                                  00342218
       TREC = TREC + 1                                                  00342361
       WRITE(6,*) 'TOTAL RECORDS PROCESSED = ',TREC                     00342424
       STOP                                                             00343000
       END                                                              00350000
C  PROGRAM: SUMBLOCK                                                    00001033
C  PROGRAMMER: T. MCCLANAHAN  12/20/92                                  00002069
C  THIS PROGRAM WILL REBLOCK VOYAGER SUMMARY DATA RETRIEVED FROM        00003069
C  UNITTREE.                                                            00004069
       INTEGER*4 I4REC(63),INUNIT/10/,OUTUNIT/20/,NBYTS                 00010044
       INTEGER*4 OUT4(5000),TBYTS,INCNT,OCNT,IWRDS,TREC                 00011068
       INTEGER*2 I2REC(126),OUT2REC(10000)                              00020068
       EQUIVALENCE (I4REC(1),I2REC(1))                                  00030065
C  INITIALIZE COUNTERS. TREC  = TOTAL RECORDS PROCESSED                 00030169
C                       INCNT = CURRENT WORD IN INPUT ARRAY             00030269
C                       OCNT  = CURRENT WORD IN OUTPUT ARRAY            00030369
C                       IWRDS = VALUE READ FROM 64TH I*2 IN RECORD      00030469
C                               ( NUMBER OF WORDS LEFT IN LOGICAL REC)  00030569
       TREC = 0                                                         00031024
       NBYTS = 0                                                        00031168
       IWRDS = -2                                                       00032067
       OCNT = 1                                                         00040067
       INCNT = 1                                                        00040167
       WRITE (6,*)'BEGINNING PROCESSING......'                          00041025
       DO WHILE (.TRUE.)                                                00042052
         IF (INCNT .GT. NBYTS/4) THEN                                   00050065
           CALL FREAD(I4REC,INUNIT,NBYTS,&50,&50)                       00060065
           INCNT = 1                                                    00070065
         ENDIF                                                          00080468
           IF (OCNT .EQ. 32) IWRDS = I2REC(INCNT*2)                     00090068
           IF (IWRDS .EQ. -1) THEN                                      00120068
             TBYTS = (OCNT-1)*4                                         00121068
             CALL FWRITE(OUT4,OUTUNIT,TBYTS)                            00130068
             TREC = TREC + 1                                            00130368
             OCNT = 1                                                   00130468
           END IF                                                       00151068
           OUT4(OCNT) = I4REC(INCNT)                                    00160067
           INCNT = INCNT + 1                                            00170067
           IWRDS = IWRDS - 1                                            00171067
           OCNT = OCNT + 1                                              00172067
       END DO                                                           00180065
 50    CONTINUE                                                         00341800
       TBYTS = (OCNT-1)*4                                               00342068
       CALL FWRITE(OUT4,OUTUNIT,TBYTS)                                  00342218
       TREC = TREC + 1                                                  00342361
       WRITE(6,*) 'TOTAL RECORDS PROCESSED = ',TREC                     00342424
       STOP                                                             00343000
       END                                                              00350000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C THIS ROUTINE READS LFM (MAG) RECORDS FROM A STANDARD VOYAGER
C SUMMARY TAPE.  EACH 1.92 SECOND FIELD (F1) AVERAGE IS COMPARED TO
C THE PREVIOUS 48 SECOND FIELD AVERAGE.  IF IT DIFFERS BY MORE THAN A
C CERTAIN PERCENTAGE, IT IS DELETED.  NEW 9.6 AND 48 SECOND AVERAGES
C ARE COMPUTED AND THE RECORD (ALTERED OR NOT) IS WRITTEN TO AN OUTPUT
C SUMMARY TAPE.  LIMITS OF PROCESSING ARE ENTERED VIA RECORD
C NUMBER LIMITS.  ONLY RECORDS BETWEEN THESE LIMITS ARE PROCESSED
C AND WRITTEN TO THE OUTPUT FILE
C
C PROGRAMMER: T.W.VOLLMER (GSFC) 10/1/86
C
C SUBROUTINES USED (THESE ARE MODIFICATIONS OF ONES
C GENEROUSLY SUPPLIED BY LWK):
C     ELIM - DELETES FLAGGED 1.92 SECOND AVERAGES FROM RECORD
C     CORR96 - (A MODIFICATION OF CORR48) CALCULATE NEW 9.6
C              SECOND AVERAGES FROM THE REMAINING 1.92 SECOND
C              AVERAGES
C     CORR48 - CALCULATE NEW 48 SECOND AVERAGES FROM REMAINING
C              9.6 SEC AVGS.
C
C PDL:
C DO FOR EACH RECORD ON TAPE
C    READ SUMMARY TAPE RECORD
C    IF RECORD WITHIN REQUESTED RECORD NUMBER LIMITS THEN
C        IF LFM (MAG) RECORD THEN
C            IF THIS IS THE FIRST LFM RECORD PROCESSED
C            THEN
C                SAVE 48SECOND FIELD AVERAGE
C            ELSE
C                DO FOR EACH 1.92 SECOND AVERAGE THAT IS NOT FILL
C                    IF THE PERCENTAGE DIFFERENCE FROM PREVIOUS 48 SEC
C                     AVERAGE THEN FLAG IT FOR DELETION
C                END DO
C                CALL ELIM TO DELETE FLAGGED 1.92 SEC AVGS
C                CALL CORR96 TO CALCULATE NEW 9.6 SEC AVG
C                CALL CORR48 TO CALCULATE NEW 48 SEC AVG
C            END IF
C        END IF
C    END IF
C    WRITE RECORD TO OUTPUT TAPE
C END DO 
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      INTEGER*2 I2REC(10000), BEGREC, ENDREC                            00000010
      INTEGER*4 I4REC(5000),LFM/'LFM '/,I4MAG(1),IDFLG(25)              00000020
      REAL*4 PTOT/0./, PDEL/0./
C DELIM = .09 FOR V2 86/24:8 - 86/26:7
      REAL*4 R4REC(5000), R4MAG(1)                                      00000040
      REAL*8 R8REC(2500), R8MAG(1)                                      00000050
      LOGICAL*4 FIRST/.TRUE./
      EQUIVALENCE (I4REC(1),I2REC(1),R8REC(1),R4REC(1))                 00000060
      EQUIVALENCE (I4REC(33),I4MAG(1),R4MAG(1),R8MAG(1))
      NREC = 0                                                          00000070
      READ (5,10) BEGREC, ENDREC                                        00000080
   10 FORMAT (2I10)                                                     00000090
      WRITE(6,10) BEGREC, ENDREC                                        00000080
      READ (5, 13) DELIM
   13 FORMAT (8X, F10.0)
      READ (5, 17) METHOD
   17 FORMAT (8X, I1)
   20 CONTINUE                                                          00000100
      CALL FREAD (I4REC,10,NBYT,&100,&80)                               00000110
      NREC = NREC + 1                                                   00000120
      IF (I2REC(63).LT.BEGREC) GO TO 20                                 00000200
      IF (I2REC(63).GT.ENDREC) GO TO 100                                00000210
      IF (I4REC(1) .NE. LFM) GO TO 70                                   00000115
      IF (.NOT. FIRST) GO TO 50
          IF (R4MAG(1) .EQ. 999.) GO TO 70
          AVG48 = R4MAG(1)
          FIRST = .FALSE.
          GO TO 70
   50 CONTINUE
          DO 60 I = 1, 25
              IDFLG(I) = 1
              IF (ABS(R4MAG(66+I) - 999.) .LT. 1.0) GO TO 60
              PTOT = PTOT + 1.
              IF (METHOD .EQ. 1) GO TO 53
                  DEL =  ABS((AVG48 - R4MAG(66+I)) / AVG48)
                  GO TO 57
   53         CONTINUE
                  DEL = ABS(AVG48 - R4MAG(66+I))
   57         CONTINUE
              IF (DEL .LE. DELIM) GO TO 60
                  IDFLG(I) =  0
                  PDEL = PDEL + 1.
   60     CONTINUE
          CALL ELIM (IDFLG, R4MAG)
          CALL CORR96 (R4MAG)
          CALL CORR48 (R4MAG)
          IF (R4MAG(1) .NE. 999.) AVG48 = R4MAG(1)
   70 CONTINUE
      CALL FWRITE (R4REC, 20, NBYT)
      GO TO 20
   80 CONTINUE
      WRITE (6, 90) NREC
   90 FORMAT (' ERROR READING RECORD ', I7)
      GO TO 20
  100 CONTINUE
      IF (PDEL .EQ.0) GO TO 110
          DAVG = (PDEL / PTOT) * 100.
          GO TO 120
  110 CONTINUE
          DAVG = 0.
  120 CONTINUE
          WRITE (6, 900) PDEL, DAVG, DELIM, METHOD
  900 FORMAT (1X, F10.0, ' POINTS DELETED -', F5.1, ' PERCENT OF DATA',
     1 ' (DELIM = ', F5.3, ' METHOD = ', I1, ')')
      STOP
      END
      SUBROUTINE ELIM(ICORR, MAG)                                       00000400
C                                                                       00000410
C    ELIMINATE 1.92 SECOND DATA VIA MASK :ICORR                         00000420
C                                                                       00000430
       REAL*4 MAG(1)                                                    00000440
       INTEGER*4 ICORR(1)                                               00000450
C                                                                       00000460
       DO 10 I = 1, 25                                                  00000470
       IF( ICORR(I) .NE. 0    ) GO TO 10                                00000480
       MAG(66+I) = 999.                                                 00000490
       MAG(91+I) = 999.                                                 00000500
       MAG(116+I) = 90.                                                 00000510
       MAG(141+I) = 45.                                                 00000520
       MAG(166+I) = 999.                                                00000530
       MAG(191+I) = 999.                                                00000540
       MAG(216+I) = 999.                                                00000550
       MAG(242+3*(I-1)) = 999.
       MAG(243+3*(I-1)) = 999.
       MAG(244+3*(I-1)) = 999.
       CALL FMOVE (MAG(316+I), 4, 0)
  10   CONTINUE                                                         00000590
       RETURN                                                           00000600
       END                                                              00000610
       SUBROUTINE CORR96(MAG)                                           00000620
C                                                                       00000630
C    RE-AVERAGE 1.92 SECOND DATA                                        00000640
C                                                                       00000650
       REAL*4 MAG(1)                                                    00000660
C                                                                       00000680
       REAL*8 F1,B1,B2,B3,SIGX,SIGY,SIGZ                                00000690
C                                                                       00000700
       DO 40 J=1, 5
           F1 = 0.                                                      00000710
           B1 = 0.                                                      00000720
           B2 = 0.                                                      00000730
           B3 = 0.                                                      00000740
           SIGX = 0.                                                    00000750
           SIGY = 0.                                                    00000760
           SIGZ = 0.                                                    00000770
           N = 0                                                        00000780
           DO 10 I = 1,5                                                00000800
               IJ = ((J - 1) * 5) + (I - 1)
               IF( ABS(MAG(67+IJ)-999.) .LT. 1.0 ) GO TO 10             00000811
                   N = N + 1                                            00000820
                   F1 = F1 + SQRT(MAG(167+IJ)**2 + MAG(192+IJ)**2       00000830
     1                            + MAG(217+IJ)**2)
                   B1 = B1 + MAG(167+IJ)                                00000840
                   B2 = B2 + MAG(192+IJ)                                00000850
                   B3 = B3 + MAG(217+IJ)                                00000860
  10       CONTINUE                                                     00000870
           IF( N .LT. 1 ) GO TO 30                                      00000871
               F1 = F1/N                                                00000880
               B1 = B1/N                                                00000890
               B2 = B2/N                                                00000900
               B3 = B3/N                                                00000910
               DO 20 I = 1,5                                            00000930
                   IJ = ((J - 1) * 5) + (I - 1)
                   IF( ABS(MAG(67+IJ)-999.) .LT. 1.0 ) GO TO 20         00000945
                       SIGX = SIGX + (B1-MAG(167+IJ))*(B1-MAG(167+IJ))  00000950
                       SIGY = SIGY + (B2-MAG(192+IJ))*(B2-MAG(192+IJ))  00000960
                       SIGZ = SIGZ + (B3-MAG(217+IJ))*(B3-MAG(217+IJ))  00000970
  20           CONTINUE                                                 00000990
               MAG(11+J) = F1                                           00001000
               MAG(16+J) =DSQRT(B1*B1 + B2*B2 + B3*B3)                  00001010
               MAG(21+J) = DARSIN(B3/MAG(16+J)) * 180./3.14159          00001020
               MAG(26+J) =DATAN2(B2,B1)*180./3.14159                    00001030
               IF( MAG(26+J) .LT. 0 ) MAG(26+J) = 360. + MAG(26+J)      00001040
               MAG(31+J) = B1                                           00001050
               MAG(36+J) = B2                                           00001060
               MAG(41+J) = B3                                           00001070
               MAG(47+(J-1)*3) =DSQRT(SIGX/N)                           00001080
               MAG(48+(J-1)*3) =DSQRT(SIGY/N)                           00001090
               MAG(49+(J-1)*3) =DSQRT(SIGZ/N)                           00001100
               CALL FMOVE (MAG(61+J), 4, N)
               GO TO 40                                                 00001120
  30       CONTINUE                                                     00001121
               MAG(11+J) = 999.                                         00001000
               MAG(16+J) = 999.                                         00001010
               MAG(21+J) = 90.                                          00001020
               MAG(26+J) = 45.                                          00001030
               MAG(31+J) = 999.                                         00001050
               MAG(36+J) = 999.                                         00001060
               MAG(41+J) = 999.                                         00001070
               MAG(47+(J-1)*3) = 999.                                   00001080
               MAG(48+(J-1)*3) = 999.                                   00001090
               MAG(49+(J-1)*3) = 999.                                   00001100
               CALL FMOVE (MAG(61+J), 4, N)
   40  CONTINUE
       RETURN
       END                                                              00001160
       SUBROUTINE CORR48(MAG)                                           00000620
C                                                                       00000630
C    RE-AVERAGE 9.6 SECOND DATA                                         00000640
C                                                                       00000650
       REAL*4 MAG(1)                                                    00000660
C                                                                       00000680
       REAL*8 F1,B1,B2,B3,SIGX,SIGY,SIGZ                                00000690
C                                                                       00000700
       F1 = 0.                                                          00000710
       B1 = 0.                                                          00000720
       B2 = 0.                                                          00000730
       B3 = 0.                                                          00000740
       SIGX = 0.                                                        00000750
       SIGY = 0.                                                        00000760
       SIGZ = 0.                                                        00000770
      N = 0                                                             00000780
       DO 10 I = 1,5                                                    00000800
       IF( ABS(MAG(11+I)-999.) .LT. 1.0 ) GO TO 10                      00000811
       N = N + 1                                                        00000820
       F1 = F1 + SQRT(MAG(31+I)**2 + MAG(36+I)**2 + MAG(41+I)**2)       00000830
       B1 = B1 + MAG(31+I)                                              00000840
       B2 = B2 + MAG(36+I)                                              00000850
       B3 = B3 + MAG(41+I)                                              00000860
  10   CONTINUE                                                         00000870
       IF( N .LT. 1 ) GO TO 30                                          00000871
       F1 = F1/N                                                        00000880
       B1 = B1/N                                                        00000890
       B2 = B2/N                                                        00000900
       B3 = B3/N                                                        00000910
       DO 20 I = 1,5                                                    00000930
       IF( ABS(MAG(11+I)-999.) .LT. 1.0 ) GO TO 20                      00000945
       SIGX = SIGX + (B1-MAG(31+I))*(B1-MAG(31+I))                      00000950
       SIGY = SIGY + (B2-MAG(36+I))*(B2-MAG(36+I))                      00000960
       SIGZ = SIGZ + (B3-MAG(41+I))*(B3-MAG(41+I))                      00000970
  20   CONTINUE                                                         00000990
       MAG(1) = F1                                                      00001000
       MAG(2) =DSQRT(B1*B1 + B2*B2 + B3*B3)                             00001010
       MAG(3) = DARSIN(B3/MAG(2)) * 180./3.14159                        00001020
       MAG(4) =DATAN2(B2,B1)*180./3.14159                               00001030
      IF( MAG(4) .LT. 0 ) MAG(4) = 360. + MAG(4)                        00001040
       MAG(5) = B1                                                      00001050
       MAG(6) = B2                                                      00001060
       MAG(7) = B3                                                      00001070
       MAG(8) =DSQRT(SIGX/N)                                            00001080
       MAG(9) =DSQRT(SIGY/N)                                            00001090
       MAG(10) =DSQRT(SIGZ/N)                                           00001100
       CALL FMOVE (MAG(11), 4, N)
       RETURN                                                           00001120
  30   CONTINUE                                                         00001121
       DO 40 K = 1,10                                                   00001122
       MAG(K) = 999.                                                    00001123
  40   CONTINUE                                                         00001124
       MAG(3) = 90.
       MAG(4) = 45.
       CALL FMOVE (MAG(11), 4, N)
       RETURN                                                           00001125
       END                                                              00001160
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C THIS ROUTINE UPDATED BY TWV TO BEGIN CLEANUP AT THE FIRST
C SPECIFIED RECORD AND TO CONTINUE TO THE END OF FILE
C
C THIS ROUTINE READS LFM (MAG) RECORDS FROM A STANDARD VOYAGER
C SUMMARY TAPE.  EACH 1.92 SECOND FIELD (F1) AVERAGE IS COMPARED TO
C THE PREVIOUS 48 SECOND FIELD AVERAGE.  IF IT DIFFERS BY MORE THAN A
C CERTAIN PERCENTAGE, IT IS DELETED.  NEW 9.6 AND 48 SECOND AVERAGES
C ARE COMPUTED AND THE RECORD (ALTERED OR NOT) IS WRITTEN TO AN OUTPUT
C SUMMARY TAPE.  LIMITS OF PROCESSING ARE ENTERED VIA RECORD
C NUMBER LIMITS.  ONLY RECORDS BETWEEN THESE LIMITS ARE PROCESSED
C AND WRITTEN TO THE OUTPUT FILE
C
C PROGRAMMER: T.W.VOLLMER (GSFC) 10/1/86
C
C SUBROUTINES USED (THESE ARE MODIFICATIONS OF ONES
C GENEROUSLY SUPPLIED BY LWK):
C     ELIM - DELETES FLAGGED 1.92 SECOND AVERAGES FROM RECORD
C     CORR96 - (A MODIFICATION OF CORR48) CALCULATE NEW 9.6
C              SECOND AVERAGES FROM THE REMAINING 1.92 SECOND
C              AVERAGES
C     CORR48 - CALCULATE NEW 48 SECOND AVERAGES FROM REMAINING
C              9.6 SEC AVGS.
C
C PDL:
C DO FOR EACH RECORD ON TAPE
C    READ SUMMARY TAPE RECORD
C    IF RECORD WITHIN REQUESTED RECORD NUMBER LIMITS THEN
C        IF LFM (MAG) RECORD THEN
C            IF THIS IS THE FIRST LFM RECORD PROCESSED
C            THEN
C                SAVE 48SECOND FIELD AVERAGE
C            ELSE
C                DO FOR EACH 1.92 SECOND AVERAGE THAT IS NOT FILL
C                    IF THE PERCENTAGE DIFFERENCE FROM PREVIOUS 48 SEC
C                     AVERAGE THEN FLAG IT FOR DELETION
C                END DO
C                CALL ELIM TO DELETE FLAGGED 1.92 SEC AVGS
C                CALL CORR96 TO CALCULATE NEW 9.6 SEC AVG
C                CALL CORR48 TO CALCULATE NEW 48 SEC AVG
C            END IF
C        END IF
C    END IF
C    WRITE RECORD TO OUTPUT TAPE
C END DO 
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      INTEGER*2 I2REC(10000), BEGREC, ENDREC                            00000010
      INTEGER*4 I4REC(5000),LFM/'LFM '/,I4MAG(1),IDFLG(25)              00000020
      REAL*4 PTOT/0./, PDEL/0./
C DELIM = .09 FOR V2 86/24:8 - 86/26:7
      REAL*4 R4REC(5000), R4MAG(1)                                      00000040
      REAL*8 R8REC(2500), R8MAG(1)                                      00000050
      LOGICAL*4 FIRST/.TRUE./
      EQUIVALENCE (I4REC(1),I2REC(1),R8REC(1),R4REC(1))                 00000060
      EQUIVALENCE (I4REC(33),I4MAG(1),R4MAG(1),R8MAG(1))
      NREC = 0                                                          00000070
      READ (5,10) BEGREC                                                00000080
   10 FORMAT (2I10)                                                     00000090
      WRITE(6,10) BEGREC                                                00000080
      READ (5, 13) DELIM
   13 FORMAT (8X, F10.0)
      READ (5, 17) METHOD
   17 FORMAT (8X, I1)
   20 CONTINUE                                                          00000100
      CALL FREAD (I4REC,10,NBYT,&100,&80)                               00000110
      NREC = NREC + 1                                                   00000120
      IF (.NOT. FIRST) GO TO 1000
      IF (I2REC(63).LT.BEGREC) GO TO 20                                 00000200
 1000 CONTINUE
      IF (I4REC(1) .NE. LFM) GO TO 70                                   00000115
      IF (.NOT. FIRST) GO TO 50
          IF (R4MAG(1) .EQ. 999.) GO TO 70
          AVG48 = R4MAG(1)
          FIRST = .FALSE.
          GO TO 70
   50 CONTINUE
          DO 60 I = 1, 25
              IDFLG(I) = 1
              IF (ABS(R4MAG(66+I) - 999.) .LT. 1.0) GO TO 60
              PTOT = PTOT + 1.
              IF (METHOD .EQ. 1) GO TO 53
                  DEL =  ABS((AVG48 - R4MAG(66+I)) / AVG48)
                  GO TO 57
   53         CONTINUE
                  DEL = ABS(AVG48 - R4MAG(66+I))
   57         CONTINUE
              IF (DEL .LE. DELIM) GO TO 60
                  IDFLG(I) =  0
                  PDEL = PDEL + 1.
   60     CONTINUE
          CALL ELIM (IDFLG, R4MAG)
          CALL CORR96 (R4MAG)
          CALL CORR48 (R4MAG)
          IF (R4MAG(1) .NE. 999.) AVG48 = R4MAG(1)
   70 CONTINUE
      CALL FWRITE (R4REC, 20, NBYT)
      GO TO 20
   80 CONTINUE
      WRITE (6, 90) NREC
   90 FORMAT (' ERROR READING RECORD ', I7)
      GO TO 20
  100 CONTINUE
      IF (PDEL .EQ.0) GO TO 110
          DAVG = (PDEL / PTOT) * 100.
          GO TO 120
  110 CONTINUE
          DAVG = 0.
  120 CONTINUE
          WRITE (6, 900) PDEL, DAVG, DELIM, METHOD
  900 FORMAT (1X, F10.0, ' POINTS DELETED -', F5.1, ' PERCENT OF DATA',
     1 ' (DELIM = ', F5.3, ' METHOD = ', I1, ')')
      STOP
      END
      SUBROUTINE ELIM(ICORR, MAG)                                       00000400
C                                                                       00000410
C    ELIMINATE 1.92 SECOND DATA VIA MASK :ICORR                         00000420
C                                                                       00000430
       REAL*4 MAG(1)                                                    00000440
       INTEGER*4 ICORR(1)                                               00000450
C                                                                       00000460
       DO 10 I = 1, 25                                                  00000470
       IF( ICORR(I) .NE. 0    ) GO TO 10                                00000480
       MAG(66+I) = 999.                                                 00000490
       MAG(91+I) = 999.                                                 00000500
       MAG(116+I) = 90.                                                 00000510
       MAG(141+I) = 45.                                                 00000520
       MAG(166+I) = 999.                                                00000530
       MAG(191+I) = 999.                                                00000540
       MAG(216+I) = 999.                                                00000550
       MAG(242+3*(I-1)) = 999.
       MAG(243+3*(I-1)) = 999.
       MAG(244+3*(I-1)) = 999.
       CALL FMOVE (MAG(316+I), 4, 0)
  10   CONTINUE                                                         00000590
       RETURN                                                           00000600
       END                                                              00000610
       SUBROUTINE CORR96(MAG)                                           00000620
C                                                                       00000630
C    RE-AVERAGE 1.92 SECOND DATA                                        00000640
C                                                                       00000650
       REAL*4 MAG(1)                                                    00000660
C                                                                       00000680
       REAL*8 F1,B1,B2,B3,SIGX,SIGY,SIGZ                                00000690
C                                                                       00000700
       DO 40 J=1, 5
           F1 = 0.                                                      00000710
           B1 = 0.                                                      00000720
           B2 = 0.                                                      00000730
           B3 = 0.                                                      00000740
           SIGX = 0.                                                    00000750
           SIGY = 0.                                                    00000760
           SIGZ = 0.                                                    00000770
           N = 0                                                        00000780
           DO 10 I = 1,5                                                00000800
               IJ = ((J - 1) * 5) + (I - 1)
               IF( ABS(MAG(67+IJ)-999.) .LT. 1.0 ) GO TO 10             00000811
                   N = N + 1                                            00000820
                   F1 = F1 + SQRT(MAG(167+IJ)**2 + MAG(192+IJ)**2       00000830
     1                            + MAG(217+IJ)**2)
                   B1 = B1 + MAG(167+IJ)                                00000840
                   B2 = B2 + MAG(192+IJ)                                00000850
                   B3 = B3 + MAG(217+IJ)                                00000860
  10       CONTINUE                                                     00000870
           IF( N .LT. 1 ) GO TO 30                                      00000871
               F1 = F1/N                                                00000880
               B1 = B1/N                                                00000890
               B2 = B2/N                                                00000900
               B3 = B3/N                                                00000910
               DO 20 I = 1,5                                            00000930
                   IJ = ((J - 1) * 5) + (I - 1)
                   IF( ABS(MAG(67+IJ)-999.) .LT. 1.0 ) GO TO 20         00000945
                       SIGX = SIGX + (B1-MAG(167+IJ))*(B1-MAG(167+IJ))  00000950
                       SIGY = SIGY + (B2-MAG(192+IJ))*(B2-MAG(192+IJ))  00000960
                       SIGZ = SIGZ + (B3-MAG(217+IJ))*(B3-MAG(217+IJ))  00000970
  20           CONTINUE                                                 00000990
               MAG(11+J) = F1                                           00001000
               MAG(16+J) =DSQRT(B1*B1 + B2*B2 + B3*B3)                  00001010
               MAG(21+J) = DARSIN(B3/MAG(16+J)) * 180./3.14159          00001020
               MAG(26+J) =DATAN2(B2,B1)*180./3.14159                    00001030
               IF( MAG(26+J) .LT. 0 ) MAG(26+J) = 360. + MAG(26+J)      00001040
               MAG(31+J) = B1                                           00001050
               MAG(36+J) = B2                                           00001060
               MAG(41+J) = B3                                           00001070
               MAG(47+(J-1)*3) =DSQRT(SIGX/N)                           00001080
               MAG(48+(J-1)*3) =DSQRT(SIGY/N)                           00001090
               MAG(49+(J-1)*3) =DSQRT(SIGZ/N)                           00001100
               CALL FMOVE (MAG(61+J), 4, N)
               GO TO 40                                                 00001120
  30       CONTINUE                                                     00001121
               MAG(11+J) = 999.                                         00001000
               MAG(16+J) = 999.                                         00001010
               MAG(21+J) = 90.                                          00001020
               MAG(26+J) = 45.                                          00001030
               MAG(31+J) = 999.                                         00001050
               MAG(36+J) = 999.                                         00001060
               MAG(41+J) = 999.                                         00001070
               MAG(47+(J-1)*3) = 999.                                   00001080
               MAG(48+(J-1)*3) = 999.                                   00001090
               MAG(49+(J-1)*3) = 999.                                   00001100
               CALL FMOVE (MAG(61+J), 4, N)
   40  CONTINUE
       RETURN
       END                                                              00001160
       SUBROUTINE CORR48(MAG)                                           00000620
C                                                                       00000630
C    RE-AVERAGE 9.6 SECOND DATA                                         00000640
C                                                                       00000650
       REAL*4 MAG(1)                                                    00000660
C                                                                       00000680
       REAL*8 F1,B1,B2,B3,SIGX,SIGY,SIGZ                                00000690
C                                                                       00000700
       F1 = 0.                                                          00000710
       B1 = 0.                                                          00000720
       B2 = 0.                                                          00000730
       B3 = 0.                                                          00000740
       SIGX = 0.                                                        00000750
       SIGY = 0.                                                        00000760
       SIGZ = 0.                                                        00000770
      N = 0                                                             00000780
       DO 10 I = 1,5                                                    00000800
       IF( ABS(MAG(11+I)-999.) .LT. 1.0 ) GO TO 10                      00000811
       N = N + 1                                                        00000820
       F1 = F1 + SQRT(MAG(31+I)**2 + MAG(36+I)**2 + MAG(41+I)**2)       00000830
       B1 = B1 + MAG(31+I)                                              00000840
       B2 = B2 + MAG(36+I)                                              00000850
       B3 = B3 + MAG(41+I)                                              00000860
  10   CONTINUE                                                         00000870
       IF( N .LT. 1 ) GO TO 30                                          00000871
       F1 = F1/N                                                        00000880
       B1 = B1/N                                                        00000890
       B2 = B2/N                                                        00000900
       B3 = B3/N                                                        00000910
       DO 20 I = 1,5                                                    00000930
       IF( ABS(MAG(11+I)-999.) .LT. 1.0 ) GO TO 20                      00000945
       SIGX = SIGX + (B1-MAG(31+I))*(B1-MAG(31+I))                      00000950
       SIGY = SIGY + (B2-MAG(36+I))*(B2-MAG(36+I))                      00000960
       SIGZ = SIGZ + (B3-MAG(41+I))*(B3-MAG(41+I))                      00000970
  20   CONTINUE                                                         00000990
       MAG(1) = F1                                                      00001000
       MAG(2) =DSQRT(B1*B1 + B2*B2 + B3*B3)                             00001010
       MAG(3) = DARSIN(B3/MAG(2)) * 180./3.14159                        00001020
       MAG(4) =DATAN2(B2,B1)*180./3.14159                               00001030
      IF( MAG(4) .LT. 0 ) MAG(4) = 360. + MAG(4)                        00001040
       MAG(5) = B1                                                      00001050
       MAG(6) = B2                                                      00001060
       MAG(7) = B3                                                      00001070
       MAG(8) =DSQRT(SIGX/N)                                            00001080
       MAG(9) =DSQRT(SIGY/N)                                            00001090
       MAG(10) =DSQRT(SIGZ/N)                                           00001100
       CALL FMOVE (MAG(11), 4, N)
       RETURN                                                           00001120
  30   CONTINUE                                                         00001121
       DO 40 K = 1,10                                                   00001122
       MAG(K) = 999.                                                    00001123
  40   CONTINUE                                                         00001124
       MAG(3) = 90.
       MAG(4) = 45.
       CALL FMOVE (MAG(11), 4, N)
       RETURN                                                           00001125
       END                                                              00001160
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C THIS ROUTINE READS LFM (MAG) RECORDS FROM A STANDARD VOYAGER
C SUMMARY TAPE.
C NEW 9.6 AND 48 SECOND AVERAGES
C ARE COMPUTED AND THE RECORD (ALTERED OR NOT) IS WRITTEN TO AN OUTPUT
C SUMMARY TAPE.  LIMITS OF PROCESSING ARE ENTERED VIA RECORD
C NUMBER LIMITS.  ONLY RECORDS BETWEEN THESE LIMITS ARE PROCESSED
C AND WRITTEN TO THE OUTPUT FILE
C
C PROGRAMMER: T.W.VOLLMER (GSFC) 10/1/86
C
C SUBROUTINES USED (THESE ARE MODIFICATIONS OF ONES
C GENEROUSLY SUPPLIED BY LWK):
C     ELIM - DELETES FLAGGED 1.92 SECOND AVERAGES FROM RECORD
C     CORR96 - (A MODIFICATION OF CORR48) CALCULATE NEW 9.6
C              SECOND AVERAGES FROM THE REMAINING 1.92 SECOND
C              AVERAGES
C     CORR48 - CALCULATE NEW 48 SECOND AVERAGES FROM REMAINING
C              9.6 SEC AVGS.
C
C PDL:
C DO FOR EACH RECORD ON TAPE
C    READ SUMMARY TAPE RECORD
C    IF RECORD WITHIN REQUESTED RECORD NUMBER LIMITS THEN
C        IF LFM (MAG) RECORD THEN
C            IF THIS IS THE FIRST LFM RECORD PROCESSED
C            THEN
C                SAVE 48SECOND FIELD AVERAGE
C            ELSE
C                DO FOR EACH 1.92 SECOND AVERAGE THAT IS NOT FILL
C                    IF THE PERCENTAGE DIFFERENCE FROM PREVIOUS 48 SEC
C                     AVERAGE THEN FLAG IT FOR DELETION
C                END DO
C                CALL ELIM TO DELETE FLAGGED 1.92 SEC AVGS
C                CALL CORR96 TO CALCULATE NEW 9.6 SEC AVG
C                CALL CORR48 TO CALCULATE NEW 48 SEC AVG
C            END IF
C        END IF
C    END IF
C    WRITE RECORD TO OUTPUT TAPE
C END DO 
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      INTEGER*2 I2REC(10000), BEGREC, ENDREC                            00000010
      INTEGER*4 I4REC(5000),LFM/'LFM '/,I4MAG(1),IDFLG(25)              00000020
      REAL*4 PTOT/0./, PDEL/0./
C DELIM = .09 FOR V2 86/24:8 - 86/26:7
      REAL*4 R4REC(5000), R4MAG(1)                                      00000040
      REAL*8 R8REC(2500), R8MAG(1)                                      00000050
      LOGICAL*4 FIRST/.TRUE./
      EQUIVALENCE (I4REC(1),I2REC(1),R8REC(1),R4REC(1))                 00000060
      EQUIVALENCE (I4REC(33),I4MAG(1),R4MAG(1),R8MAG(1))
      NREC = 0                                                          00000070
      READ (5,10) BEGREC, ENDREC                                        00000080
   10 FORMAT (2I10)                                                     00000090
      WRITE(6,10) BEGREC, ENDREC                                        00000080
C     READ (5, 13) DELIM
C  13 FORMAT (8X, F10.0)
C     READ (5, 17) METHOD
C  17 FORMAT (8X, I1)
   20 CONTINUE                                                          00000100
      CALL FREAD (I4REC,10,NBYT,&100,&80)                               00000110
      NREC = NREC + 1                                                   00000120
      IF (I2REC(63).LT.BEGREC) GO TO 20                                 00000200
      IF ((I2REC(63).GT.ENDREC) .AND. (ENDREC .GT. 0)) GO TO 100        00000210
      IF (I4REC(1) .NE. LFM) GO TO 70                                   00000115
C     IF (.NOT. FIRST) GO TO 50
C         IF (R4MAG(1) .EQ. 999.) GO TO 70
C         AVG48 = R4MAG(1)
C         FIRST = .FALSE.
C         GO TO 70
C  50 CONTINUE
          DO 60 I = 1, 25
              IDFLG(I) = 1
C             IF (ABS(R4MAG(66+I) - 999.) .LT. 1.0) GO TO 60
C             PTOT = PTOT + 1.
C             IF (METHOD .EQ. 1) GO TO 53
C                 DEL =  ABS((AVG48 - R4MAG(66+I)) / AVG48)
C                 GO TO 57
C  53         CONTINUE
C                 DEL = ABS(AVG48 - R4MAG(66+I))
C  57         CONTINUE
C             IF (DEL .LE. DELIM) GO TO 60
C                 IDFLG(I) =  0
C                 PDEL = PDEL + 1.
   60     CONTINUE
          CALL ELIM (IDFLG, R4MAG)
          CALL CORR96 (R4MAG)
          CALL CORR48 (R4MAG)
          IF (R4MAG(1) .NE. 999.) AVG48 = R4MAG(1)
   70 CONTINUE
      CALL FWRITE (R4REC, 20, NBYT)
      GO TO 20
   80 CONTINUE
      WRITE (6, 90) NREC
   90 FORMAT (' ERROR READING RECORD ', I7)
      GO TO 20
  100 CONTINUE
      IF (PDEL .EQ.0) GO TO 110
          DAVG = (PDEL / PTOT) * 100.
          GO TO 120
  110 CONTINUE
          DAVG = 0.
  120 CONTINUE
          WRITE (6, 900) PDEL, DAVG, DELIM, METHOD
  900 FORMAT (1X, F10.0, ' POINTS DELETED -', F5.1, ' PERCENT OF DATA',
     1 ' (DELIM = ', F5.3, ' METHOD = ', I1, ')')
      STOP
      END
      SUBROUTINE ELIM(ICORR, MAG)                                       00000400
C                                                                       00000410
C    ELIMINATE 1.92 SECOND DATA VIA MASK :ICORR                         00000420
C                                                                       00000430
       REAL*4 MAG(1)                                                    00000440
       INTEGER*4 ICORR(1)                                               00000450
C                                                                       00000460
       DO 10 I = 1, 25                                                  00000470
       IF( ICORR(I) .NE. 0    ) GO TO 10                                00000480
       MAG(66+I) = 999.                                                 00000490
       MAG(91+I) = 999.                                                 00000500
       MAG(116+I) = 90.                                                 00000510
       MAG(141+I) = 45.                                                 00000520
       MAG(166+I) = 999.                                                00000530
       MAG(191+I) = 999.                                                00000540
       MAG(216+I) = 999.                                                00000550
       MAG(242+3*(I-1)) = 999.
       MAG(243+3*(I-1)) = 999.
       MAG(244+3*(I-1)) = 999.
       CALL FMOVE (MAG(316+I), 4, 0)
  10   CONTINUE                                                         00000590
       RETURN                                                           00000600
       END                                                              00000610
       SUBROUTINE CORR96(MAG)                                           00000620
C                                                                       00000630
C    RE-AVERAGE 1.92 SECOND DATA                                        00000640
C                                                                       00000650
       REAL*4 MAG(1)                                                    00000660
C                                                                       00000680
       REAL*8 F1,B1,B2,B3,SIGX,SIGY,SIGZ                                00000690
C                                                                       00000700
       DO 40 J=1, 5
           F1 = 0.                                                      00000710
           B1 = 0.                                                      00000720
           B2 = 0.                                                      00000730
           B3 = 0.                                                      00000740
           SIGX = 0.                                                    00000750
           SIGY = 0.                                                    00000760
           SIGZ = 0.                                                    00000770
           N = 0                                                        00000780
           DO 10 I = 1,5                                                00000800
               IJ = ((J - 1) * 5) + (I - 1)
               IF( ABS(MAG(67+IJ)-999.) .LT. 1.0 ) GO TO 10             00000811
                   N = N + 1                                            00000820
                   F1 = F1 + SQRT(MAG(167+IJ)**2 + MAG(192+IJ)**2       00000830
     1                            + MAG(217+IJ)**2)
                   B1 = B1 + MAG(167+IJ)                                00000840
                   B2 = B2 + MAG(192+IJ)                                00000850
                   B3 = B3 + MAG(217+IJ)                                00000860
  10       CONTINUE                                                     00000870
           IF( N .LT. 1 ) GO TO 30                                      00000871
               F1 = F1/N                                                00000880
               B1 = B1/N                                                00000890
               B2 = B2/N                                                00000900
               B3 = B3/N                                                00000910
               DO 20 I = 1,5                                            00000930
                   IJ = ((J - 1) * 5) + (I - 1)
                   IF( ABS(MAG(67+IJ)-999.) .LT. 1.0 ) GO TO 20         00000945
                       SIGX = SIGX + (B1-MAG(167+IJ))*(B1-MAG(167+IJ))  00000950
                       SIGY = SIGY + (B2-MAG(192+IJ))*(B2-MAG(192+IJ))  00000960
                       SIGZ = SIGZ + (B3-MAG(217+IJ))*(B3-MAG(217+IJ))  00000970
  20           CONTINUE                                                 00000990
               MAG(11+J) = F1                                           00001000
               MAG(16+J) =DSQRT(B1*B1 + B2*B2 + B3*B3)                  00001010
               MAG(21+J) = DARSIN(B3/MAG(16+J)) * 180./3.14159          00001020
               MAG(26+J) =DATAN2(B2,B1)*180./3.14159                    00001030
               IF( MAG(26+J) .LT. 0 ) MAG(26+J) = 360. + MAG(26+J)      00001040
               MAG(31+J) = B1                                           00001050
               MAG(36+J) = B2                                           00001060
               MAG(41+J) = B3                                           00001070
               MAG(47+(J-1)*3) =DSQRT(SIGX/N)                           00001080
               MAG(48+(J-1)*3) =DSQRT(SIGY/N)                           00001090
               MAG(49+(J-1)*3) =DSQRT(SIGZ/N)                           00001100
               CALL FMOVE (MAG(61+J), 4, N)
               GO TO 40                                                 00001120
  30       CONTINUE                                                     00001121
               MAG(11+J) = 999.                                         00001000
               MAG(16+J) = 999.                                         00001010
               MAG(21+J) = 90.                                          00001020
               MAG(26+J) = 45.                                          00001030
               MAG(31+J) = 999.                                         00001050
               MAG(36+J) = 999.                                         00001060
               MAG(41+J) = 999.                                         00001070
               MAG(47+(J-1)*3) = 999.                                   00001080
               MAG(48+(J-1)*3) = 999.                                   00001090
               MAG(49+(J-1)*3) = 999.                                   00001100
               CALL FMOVE (MAG(61+J), 4, N)
   40  CONTINUE
       RETURN
       END                                                              00001160
       SUBROUTINE CORR48(MAG)                                           00000620
C                                                                       00000630
C    RE-AVERAGE 9.6 SECOND DATA                                         00000640
C                                                                       00000650
       REAL*4 MAG(1)                                                    00000660
C                                                                       00000680
       REAL*8 F1,B1,B2,B3,SIGX,SIGY,SIGZ                                00000690
C                                                                       00000700
       F1 = 0.                                                          00000710
       B1 = 0.                                                          00000720
       B2 = 0.                                                          00000730
       B3 = 0.                                                          00000740
       SIGX = 0.                                                        00000750
       SIGY = 0.                                                        00000760
       SIGZ = 0.                                                        00000770
      N = 0                                                             00000780
       DO 10 I = 1,5                                                    00000800
       IF( ABS(MAG(11+I)-999.) .LT. 1.0 ) GO TO 10                      00000811
       N = N + 1                                                        00000820
       F1 = F1 + SQRT(MAG(31+I)**2 + MAG(36+I)**2 + MAG(41+I)**2)       00000830
       B1 = B1 + MAG(31+I)                                              00000840
       B2 = B2 + MAG(36+I)                                              00000850
       B3 = B3 + MAG(41+I)                                              00000860
  10   CONTINUE                                                         00000870
       IF( N .LT. 1 ) GO TO 30                                          00000871
       F1 = F1/N                                                        00000880
       B1 = B1/N                                                        00000890
       B2 = B2/N                                                        00000900
       B3 = B3/N                                                        00000910
       DO 20 I = 1,5                                                    00000930
       IF( ABS(MAG(11+I)-999.) .LT. 1.0 ) GO TO 20                      00000945
       SIGX = SIGX + (B1-MAG(31+I))*(B1-MAG(31+I))                      00000950
       SIGY = SIGY + (B2-MAG(36+I))*(B2-MAG(36+I))                      00000960
       SIGZ = SIGZ + (B3-MAG(41+I))*(B3-MAG(41+I))                      00000970
  20   CONTINUE                                                         00000990
       MAG(1) = F1                                                      00001000
       MAG(2) =DSQRT(B1*B1 + B2*B2 + B3*B3)                             00001010
       MAG(3) = DARSIN(B3/MAG(2)) * 180./3.14159                        00001020
       MAG(4) =DATAN2(B2,B1)*180./3.14159                               00001030
      IF( MAG(4) .LT. 0 ) MAG(4) = 360. + MAG(4)                        00001040
       MAG(5) = B1                                                      00001050
       MAG(6) = B2                                                      00001060
       MAG(7) = B3                                                      00001070
       MAG(8) =DSQRT(SIGX/N)                                            00001080
       MAG(9) =DSQRT(SIGY/N)                                            00001090
       MAG(10) =DSQRT(SIGZ/N)                                           00001100
       CALL FMOVE (MAG(11), 4, N)
       RETURN                                                           00001120
  30   CONTINUE                                                         00001121
       DO 40 K = 1,10                                                   00001122
       MAG(K) = 999.                                                    00001123
  40   CONTINUE                                                         00001124
       MAG(3) = 90.
       MAG(4) = 45.
       CALL FMOVE (MAG(11), 4, N)
       RETURN                                                           00001125
       END                                                              00001160
************************************************************************00010000
*                                                                       00011011
* PROGRAMMER: T. W. VOLLMER (GSFC)                                      00012011
*                                                                       00013011
* DATE: JUNE 27, 1984                                                   00014011
*                                                                       00020000
* THIS ROUTINE READS A REQUEST FOR A VOYAGER SPACECRAFT, TIME PERIOD,   00030000
* AND COORDINATE SYSTEM AND RETURNS A LIST OF ALL VOYAGER SUMMARY       00040000
* TAPES COVERING THAT PERIOD.                                           00050000
*                                                                       00060000
************************************************************************00070000
*                                                                       00080000
* FORMAT OF REQUEST (FT05F001) VARIABLE NAME (REQEST)                   00090000
*     COLUMN    FIELD (VARIABLE NAME)                                   00100000
*      1        SPACECRAFT   (SCR)                                      00110000
*      2- 3     BEGIN YEAR|                                             00120000
*      4- 6     BEGIN DAY |-(BEGR)                                      00130000
*      7- 8     BEGIN HOUR|                                             00140000
*      9-10     END YEAR|                                               00160000
*     11-13     END DAY |-(ENDR)                                        00170000
*     14-15     END HOUR|                                               00180000
*     16-17     COORDINATE SYSTEM (CORDR)                               00190000
*                                                                       00200000
************************************************************************00210000
*                                                                       00220000
* FORMAT OF SUMMARY INDEX FILE (FT10F001) VARIABLE NAME (INDEX)         00230000
*     COLUMN    FIELD (VARIABLE NAME)                                   00240000
*      1        "V"                                                     00250000
*      2        SPACECRAFT (SCI)                                        00260000
*      3        " "                                                     00270000
*      4- 5     BEGIN YEAR |                                            00280000
*      6        "/"        |                                            00290010
*      7- 9     BEGIN DAY  |-(BEGI)                                     00300000
*     10        ":"        |                                            00310010
*     11-12     BEGIN HOUR |                                            00320000
*     13-16     " TO "                                                  00330000
*     17-18     END YEAR |                                              00340000
*     19        "/"      |                                              00350010
*     20-22     END DAY  |-(ENDI)                                       00360000
*     23        ":"      |                                              00370010
*     24-25     END HOUR |                                              00380000
*     26        " "                                                     00390000
*     27-28     COORDINATE SYSTEM (CORDI)                               00400000
*     29        " "                                                     00410000
*     30-35     SUMMARY TAPE NUMBER                                     00420000
*     36        " "                                                     00430000
*     37-72     COMMENT                                                 00440000
*                                                                       00450000
************************************************************************00460000
      CHARACTER*1  SCR, SCI                                             00480000
      CHARACTER*2  CORDR, CORDI                                         00490000
      CHARACTER*7  BEGR, ENDR, BEGI, ENDI                               00500000
      CHARACTER*16 SORT, OSORT                                          00501001
      CHARACTER*17 REQEST                                               00510000
      CHARACTER*72 INDEX, OINDEX                                        00520001
      LOGICAL SELECT                                                    00580000
      INTEGER NINDEX                                                    00590001
      EQUIVALENCE (SCR, REQEST(1:1)),                                   00590102
     1            (BEGR, REQEST(2:8)),                                  00590202
     2            (ENDR, REQEST(9:15)),                                 00590302
     3            (CORDR, REQEST(16:17))                                00590402
      EQUIVALENCE (SCI, INDEX(2:2)), (CORDI, INDEX(27:28))              00590502
      DATA OSORT/' '/                                                   00590602
      DATA OINDEX/' '/                                                  00590702
      DATA NINDEX/0/                                                    00591001
* READ THE REQUEST DATA AND CHECK ITS VALIDITY                          00600000
      CALL PARM (NBYT, REQEST)                                          00610009
      IF (NBYT .EQ. 17) GOTO 10                                         00620009
      WRITE (6,5)                                                       00621009
    5 FORMAT (' REQUEST HAS WRONG LENGTH')                              00622009
      STOP                                                              00623009
   10 CONTINUE                                                          00624009
      IF ((SCR .EQ. '1') .OR. (SCR .EQ. '2')) GOTO 30                   00630000
      WRITE (6,20) SCR                                                  00640000
   20 FORMAT (' INVALID SPACECRAFT REQUESTED ',A1)                      00650007
      STOP                                                              00660000
   30 CONTINUE                                                          00670000
      IF (BEGR .LT. ENDR) GOTO 50                                       00680000
      WRITE (6,40)                                                      00690000
   40 FORMAT (' INVALID BEGIN AND/OR END TIMES REQUESTED')              00700000
      STOP                                                              00710000
   50 CONTINUE                                                          00720000
      IF ((CORDR .EQ. 'HG') .OR.                                        00730000
     1    (CORDR .EQ. 'S3') .OR.                                        00740000
     2    (CORDR .EQ. 'L1') .OR.                                        00750012
     3    (CORDR .EQ. 'U1') .OR.                                        00751013
     4    (CORDR .EQ. 'N1')) GOTO 75                                    00752013
      WRITE (6, 60) CORDR                                               00760000
   60 FORMAT (' INVALID COORDINATE SYSTEM REQUESTED ',A2)               00770000
      STOP                                                              00780000
* READ SUMMARY TAPE INDEX RECORD AND CHECK FOR ASCENDING SEQUENCE       00781000
   70 CONTINUE                                                          00790000
      OINDEX = INDEX                                                    00800000
      OSORT = SORT                                                      00810000
   75 CONTINUE                                                          00820000
      READ (10, 80, END=100, ERR=120) INDEX                             00830000
   80 FORMAT (A72)                                                      00840000
      SORT = INDEX(2:2)//INDEX(4:5)//INDEX(7:9)//INDEX(11:12)//         00850003
     1       INDEX(27:28)//INDEX(30:35)                                 00860003
      IF (SORT .LE. OSORT) WRITE (6,90) OINDEX, INDEX                   00870000
      BEGI = INDEX(4:5)//INDEX(7:9)//INDEX(11:12)                       00871005
      ENDI = INDEX(17:18)//INDEX(20:22)//INDEX(24:25)                   00872005
   90 FORMAT (' SEQUENCE ERROR IN SUMMARY INDEX FILE:'/A72/A72///)      00880000
      IF (SCR .GT. SCI) GOTO 70                                         00890000
      IF (SCR .LT. SCI) GOTO 100                                        00900000
      SELECT = .FALSE.                                                  00910000
      IF ((BEGR .GE. BEGI) .AND. (BEGR .LE. ENDI)) SELECT = .TRUE.      00920000
      IF ((ENDR .GE. BEGI) .AND. (ENDR .LE. ENDI)) SELECT = .TRUE.      00930000
      IF ((BEGI .GE. BEGR) .AND. (BEGI .LE. ENDR)) SELECT = .TRUE.      00940000
      IF ((.NOT. SELECT) .OR. (CORDR .NE. CORDI)) GOTO 70               00950000
* WRITE SELECTED SUMMARY TAPE INDEX RECORD TO SCREEN                    00960010
      WRITE (6, 95) INDEX                                               00970007
   95 FORMAT (1X,A72)                                                   00971007
      NINDEX = NINDEX + 1                                               00980000
* WRITE SELECTED MSS DATASET NAME TO DISK DATASET                       00980110
      WRITE (20,98) INDEX(30:35)                                        00981010
   98 FORMAT ('U0#16.VOYAGER.SUMMARY.',A6)                              00982010
      GOTO 70                                                           00990000
  100 CONTINUE                                                          01000000
      WRITE (6, 110) NINDEX                                             01010000
  110 FORMAT (1X,I2,' TAPE(S) FOUND COVERING THE REQUESTED PERIOD')     01020010
      STOP                                                              01030000
  120 CONTINUE                                                          01040000
      WRITE (6,130)                                                     01050000
  130 FORMAT (' ERROR READING SUMMARY TAPE INDEX FILE')                 01060000
      GOTO 70                                                           01070000
      END                                                               01080000
C  PROGRAM: SUMLIST                                                     00001034
C  THIS PROGRAM IS A REPLACEMENT FOR THE SUMMARY LISTING PROGRAM        00002040
C  ON THE IBM 9021.                                                     00003040
       INTEGER*4 I4REC(5000),INUNIT/20/,NBYTS ,ICT,RECNT                00010051
       INTEGER*2 I2REC(10000)                                           00011054
       REAL*4 FLTMP,TPS                                                 00012057
       REAL*8 DDAY,DDAYCT,F8REC(2500)                                   00013059
       CHARACTER*4 RECTYP,TLMFT,SPCCFT,TYPTIM                           00020057
       CHARACTER*8 CONFID,EDRS(4),ZEROS,SEDR(4)                         00020162
       CHARACTER CLN/':'/                                               00021058
       CHARACTER MAG(32),SYS(32),PLS(32)                                00022060
       EQUIVALENCE (I4REC(1),I2REC(1)),(I4REC(1),RECTYP),               00030034
     1 (I4REC(2),TLMFT),(I4REC(3),SPCCFT),(I4REC(33),FLTMP),            00030157
     2 (I4REC(7),DDAY),(I4REC(9),DDAYCT),(I4REC(11),TYPTIM),            00030258
     3 (I4REC(19),CONFID),(I4REC(33),EDRS(1)),(I4REC(101),SYS(32)),     00030362
     4 (I4REC(109),MAG(1)),(I4REC(117),PLS(1)),(I4REC(125),ZEROS),      00030459
     5 (I4REC(1),F8REC(1)),(SEDR(1),I4REC(53))                          00030564
       TREC = 0                                                         00031024
       ICT = 1                                                          00040034
       WRITE (6,*)'BEGINNING READING......'                             00041034
       DO WHILE(.TRUE.)                                                 00042034
       CALL FREAD(I4REC,INUNIT,NBYTS,&50,&50)                           00050034
       WRITE(6,*) ' '                                                   00050258
       WRITE(6,*) '****************************'                        00050358
       WRITE(6,*) ' HEADER BLOCK:'                                      00050458
C      WRITE(6,*) ' ICNT, NBYTS = ',ICT,NBYTS                           00050542
C      IF (FLTMP.GT.0.1) THEN                                           00050654
        WRITE(6,*)ICT,RECTYP,TLMFT,SPCCFT,I2REC(7),CLN,                 00051057
     1     I2REC(8),CLN,I2REC(9),CLN,I2REC(10),I2REC(11),F8REC(6),      00052060
     2     DDAY,DDAYCNT,TYPTIM,I4REC(25),I4REC(26),I2REC(27),           00052157
     3     I2REC(28),I2REC(33),I2REC(34),CONFID,I2REC(59),I2REC(60),    00052258
     4     I2REC(61),I2REC(62),I2REC(63),I2REC(64)                      00052358
C       WRITE(6,101) 'I4REC(33),FLTMP = ',I4REC(33),FLTMP               00052551
        IF (RECTYP .EQ. 'LFM ') THEN                                    00052658
        WRITE(6,*) '*** SCIENCE BLOCK WDS 33 TO 44 ***'                 00052758
        WRITE(6,102) I4REC(33),I4REC(34),I4REC(35),I4REC(36),           00052858
     1             I4REC(37),I4REC(38),I4REC(39),I4REC(40),             00052958
     2             I4REC(41),I4REC(42),I4REC(43)                        00053058
         WRITE(6,*) '--- SEDR BLOCK ---'                                00053160
         WRITE(6,*) 'R*8 W92 ',F8REC(265)                               00053261
         WRITE(6,*) 'R*8 W93 ',F8REC(266)                               00053361
         WRITE(6,*) 'W533-538 '                                         00053461
         WRITE(6,121) I4REC(533),I4REC(534),I4REC(535),I4REC(536),      00053561
     1     I4REC(537),I4REC(538)                                        00053661
         WRITE(6,131) 'I4REC(542) FLT =',I4REC(542)                     00053761
         WRITE(6,131) 'I4REC(543) FLT =',I4REC(543)                     00053861
         WRITE(6,131) 'I4REC(544) FLT =',I4REC(544)                     00053961
         WRITE(6,131) 'I4REC(545) FLT =',I4REC(545)                     00054061
        END IF                                                          00054258
        IF (RECTYP .EQ. 'HDR1') THEN                                    00054358
        WRITE(6,*) '*** HDR1 DATA BLOCK ***'                            00054458
        WRITE(6,103) EDRS(1),EDRS(2),EDRS(3),EDRS(4)                    00054558
        WRITE(6,*) 'SEDR =',SEDR(1)                                     00054664
        WRITE(6,*) ' SYS SWITCHES:'                                     00054758
        WRITE(6,105) SYS                                                00054858
        WRITE(6,*) ' MAG SWITCHES:'                                     00054958
        WRITE(6,105) MAG                                                00055058
        WRITE(6,*) ' PLS SWITCHES:'                                     00055158
        WRITE(6,105) PLS                                                00055258
        WRITE(6,104) ZEROS                                              00055358
        END IF                                                          00055458
        IF ((RECTYP .EQ. 'E1  ').OR.(RECTYP .EQ. 'E2  ')) THEN          00055559
         WRITE(6,*) '*** E1 OR E2 DATA BLOCK'                           00055659
         WRITE(6,*) 'I2REC(65) =',I2REC(65)                             00055759
         WRITE(6,*) 'I2REC(66) =',I2REC(66)                             00055859
         WRITE(6,*) 'FLOAT I4REC(36 TO 44) ='                           00055959
         WRITE(6,111) I4REC(36),I4REC(37),I4REC(38),I4REC(39),          00056059
     1    I4REC(40),I4REC(41),I4REC(42),I4REC(43),I4REC(44)             00056159
 111     FORMAT (9(1X,F10.5))                                           00056259
        END IF                                                          00056359
        IF (RECTYP .EQ. 'ENG ') THEN                                    00056459
         WRITE(6,*)' *** ENG BLOCK ***'                                 00056559
         WRITE(6,*) 'I2REC(65) =',I2REC(65)                             00056659
         WRITE(6,*) 'I2REC(66) =',I2REC(66)                             00056759
         WRITE(6,112) 'I4REC(34) FLT =',I4REC(34)                       00056859
 112     FORMAT(1X,A15,F10.5)                                           00056959
        END IF                                                          00057059
        IF ((RECTYP .EQ. 'M   ').OR.(RECTYP .EQ. 'L   ')) THEN          00057159
         WRITE(6,*) '*** M OR L MODE ***'                               00057259
         WRITE(6,*) 'I2REC(65 - 70) =',I2REC(65),I2REC(66),I2REC(67),   00057359
     1   I2REC(68),I2REC(69),I2REC(70)                                  00057459
         WRITE(6,*) ' I4REC(36-44)  ='                                  00057559
         WRITE(6,111) I4REC(36),I4REC(37),I4REC(38),I4REC(39),          00057659
     1    I4REC(40),I4REC(41),I4REC(42),I4REC(43),I4REC(44)             00057759
         WRITE(6,112) 'I4REC(28) FLT =',I4REC(60)                       00057862
         WRITE(6,112) 'I4REC(63) FLT =',I4REC(95)                       00057962
         WRITE(6,*) 'I4REC(163 - 164) ='                                00058062
         WRITE(6,113) I4REC(163),I4REC(164),I4REC(165)                  00058162
         WRITE(6,*) 'SEDR BLOCK'                                        00058259
         WRITE(6,*) 'R*8 W92 ',F8REC(92)                                00058359
         WRITE(6,*) 'R*8 W93 ',F8REC(93)                                00058459
         WRITE(6,*) 'W187-192 '                                         00058559
         WRITE(6,121) I4REC(187),I4REC(188),I4REC(189),I4REC(190),      00058659
     1     I4REC(191),I4REC(192)                                        00058759
         WRITE(6,131) 'I4REC(214) FLT =',I4REC(214)                     00058860
         WRITE(6,131) 'I4REC(222) FLT =',I4REC(222)                     00058960
 131     FORMAT(1X,A16,F10.5)                                           00059060
 121     FORMAT (6(1X,F10.5))                                           00059159
 113     FORMAT(3(2X,F10.5))                                            00059259
        END IF                                                          00059359
        RECNT = RECNT + 1                                               00059451
       ICT = ICT + 1                                                    00059534
       ENDDO                                                            00060034
 50    WRITE(6,*)'TOTAL RECORDS PROCESSED =',ICT                        00070035
C      WRITE(6,*)'TOTAL RECORDS WITH BMAG >0.1',RECNT                   00071058
C100   FORMAT(1X,I5,1X,3A4,I2,A,I3,2(A,I2),1X,I4,1X,5(F9.5,1X))         00080058
 100   FORMAT(1X,I5,1X,3A4,I2,A,I3,2(A,I2),2(1X,I4),2(1X,F16.6),        00081058
     1   A4,1X,F9.5,5(1X,I4),1X,A8,6(1X,I4))                            00082058
 102   FORMAT(1X,10(F9.5,1X),2X,I5)                                     00083058
 103   FORMAT(4(1X,A8))                                                 00083158
 104   FORMAT(1X,A8)                                                    00084058
 105   FORMAT(1X,32(I2,1X))                                             00085058
 101   FORMAT(1X,A17,1X,F12.5,1X,F12.5)                                 00090044
       CONTINUE                                                         00335835
       STOP                                                             00340000
       END                                                              00350000
C  PROGRAM: SUMLIST                                                     00001034
C  THIS PROGRAM IS A REPLACEMENT FOR THE SUMMARY LISTING PROGRAM        00002040
C  ON THE IBM 9021.                                                     00003040
       INTEGER*4 I4REC(5000),INUNIT/20/,NBYTS ,ICT,RECNT                00010051
       INTEGER*2 I2REC(10000)                                           00011034
       REAL*4 FLTMP                                                     00012044
       CHARACTER*4 RECTYP,TLMFT,SPCCFT                                  00020034
       CHARACTER CLN/':'/                                               00021036
       EQUIVALENCE (I4REC(1),I2REC(1)),(I4REC(1),RECTYP),               00030034
     1 (I4REC(2),TLMFT),(I4REC(3),SPCCFT),(I4REC(33),FLTMP)             00030144
       TREC = 0                                                         00031024
       ICT = 1                                                          00040034
       WRITE (6,*)'BEGINNING READING......'                             00041034
       DO WHILE(.TRUE.)                                                 00042034
       CALL FREAD(I4REC,INUNIT,NBYTS,&50,&50)                           00050034
C      WRITE(6,*) ' ICNT, NBYTS = ',ICT,NBYTS                           00050154
C      IF (FLTMP.GT.0.1) THEN                                           00050354
C       WRITE(6,100) ICT,RECTYP,TLMFT,SPCCFT,I2REC(7),CLN,              00051054
C    1     I2REC(8),CLN,I2REC(9),CLN,I2REC(10),I2REC(64),I4REC(33),     00052054
C    2     I4REC(34),I4REC(37),I4REC(38),I4REC(39)                      00052154
C       WRITE(6,101) 'I4REC(33),FLTMP = ',I4REC(33),FLTMP               00052251
        RECNT = RECNT + 1                                               00052351
       ENDIF                                                            00052750
       ICT = ICT + 1                                                    00053034
       ENDDO                                                            00060034
 50    WRITE(6,*)'TOTAL RECORDS PROCESSED =',ICT                        00070035
       WRITE(6,*)'TOTAL RECORDS WITH BMAG >0.1',RECNT                   00071053
 100   FORMAT(1X,I5,1X,3A4,I2,A,I3,2(A,I2),1X,I4,1X,5(F9.5,1X))         00080041
 101   FORMAT(1X,A17,1X,F12.5,1X,F12.5)                                 00090044
       CONTINUE                                                         00335835
       STOP                                                             00340000
       END                                                              00350000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   00010000
C                                                                       00020000
C PROGRAM: XTRCTZRO                                                     00021024
C                                                                       00022000
C                                                                       00060000
C WRITTEN BY T. MCCLANAHAN 12/28/93                                     00061024
C                                                                       00062000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC  00070000
      INTEGER*4 ADDR(2), ISW/0/,                                        00071055
     1    IYR1, IDAY1, IHOUR1,COUNT,                                    00072041
     3     ZERON(10,3,2)                                                00074055
      REAL*4 ZERO1(10,3,2)                                              00080055
      REAL*8 NAME1, NAME(2)/2*'NONAME  '/                               00100035
      CHARACTER*60 LINE                                                 00100135
      CHARACTER*8 V2SINGLE/'A898TST2'/                                  00100258
      CHARACTER*4 NUMBER,ONE/'   1'/,BDCHK/' 235'/                      00100335
      CHARACTER*8 TBLENAME,SANDY/'G85286Z1'/                            00100435
      CHARACTER*10 TIME                                                 00100535
      EQUIVALENCE (TBLENAME,NAME1)                                      00100635
      EXTERNAL ZEROLD                                                   00101042
C READ NAMES AND TIMES OF ZERO TABLES (TIMES ARE THE TIMES              00102000
C OF THE ROLL/MANEUVER FROM WHICH THIS TABLE WAS DERIVED)               00103000
      NUMBER = '    '                                                   00105126
      TBLENAME = '        '                                             00105247
      COUNT = 1                                                         00105341
      DO WHILE (TBLENAME.NE.'A898TST2')                                 00105458
C     DO WHILE (NUMBER.NE.ONE)                                          00105558
        READ(10,21,END=200) LINE                                        00105630
        NUMBER = LINE(3:6)                                              00105734
        TBLENAME = LINE(10:17)                                          00105847
        WRITE(6,*)  TBLENAME                                            00105948
      END DO                                                            00106026
      DO WHILE (.TRUE.)                                                 00106134
        TBLENAME = LINE(10:17)                                          00106334
        WRITE(6,*) 'IN 2ND WHILE, TBLE = ',TBLENAME                     00106454
        IF (TBLENAME .EQ. '        ') GO TO 300                         00106550
        WRITE(6,*) 'CONTINUING...'                                      00106654
        TIME = LINE(21:30)                                              00106724
        NUMBER = LINE(3:6)                                              00106834
  21    FORMAT(A60)                                                     00107534
  22    FORMAT(2X,A4,4X,2(A8),4X,A10)                                   00107635
   10 FORMAT(I1)                                                        00121023
   11 FORMAT (A8,3I4)                                                   00130023
   20 FORMAT (' SC = ',I1,1X, A8, 5X, 3I4)                              00160033
      WRITE(6,*) 'BEFORE CALL TO LOADER'                                00161055
      CALL LOADER (NAME1, NAME(1), ADDR(1))                             00170044
      ADDR(1) = ADDR(1) + 8                                             00171012
      CALL LINK (ADDR(1), ZERO1, ZEROLD)                                00172012
      WRITE(6,*) ' AFTER LINK CALL'                                     00173055
      DO 60 I = 1, 2                                                    00182155
      DO 60 J = 1, 3                                                    00182255
      DO 60 K = 1,10                                                    00182355
          ZERON(K,J,I) = INT(ZERO1(K,J,I))                              00182456
   60 CONTINUE                                                          00182524
      WRITE(11,*) '#'                                                   00184246
      WRITE(11,*) ' VOYAGER 2 ZEROTABLE ',COUNT                         00184356
      WRITE(11,*) ' TIME = ',TIME,' TABLE = ',TBLENAME                  00184445
      WRITE(11,*) ' MAGNETOMETER = IBLFM'                               00184545
      WRITE(11,*) '      X       Y       Z'                             00184645
      DO K = 1,10                                                       00184755
       WRITE(11,55) K,'.',ZERON(K,1,1),'    ',ZERON(K,2,1),'    ',      00184855
     1       ZERON(K,3,1)                                               00184955
      END DO                                                            00185036
      WRITE(11,*) ' MAGNETOMETER = OBLFM'                               00185145
      WRITE(11,*) '      X       Y       Z'                             00185245
      DO K = 1,10                                                       00185355
       WRITE(11,55) K,'.',ZERON(K,1,2),'    ',ZERON(K,2,2),'    ',      00185455
     1       ZERON(K,3,2)                                               00185555
      END DO                                                            00185836
 55   FORMAT(3X,I2,A1,1X,3(I4,A4))                                      00185939
  200 CONTINUE                                                          00186034
      COUNT = COUNT + 1                                                 00186141
      READ(10,21,END=200) LINE                                          00186242
      END DO                                                            00187034
      GO TO 400                                                         00201000
  300 CONTINUE                                                          00210000
      WRITE (6, 310) NAME2                                              00220023
  310 FORMAT (' ERROR READING ', A8)                                    00230000
  400 CONTINUE                                                          00240000
      STOP                                                              00250000
      END                                                               00260000
      SUBROUTINE ZEROLD (TABIN, TABOUT)                                 00270001
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00280000
C                                                                       00290000
C THIS SUBROUTINE MOVES THE 0 TABLE VALUES INTO                         00300001
C A LOCAL ARRAY FROM THE CALLING PROGRAM                                00310000
C                                                                       00320000
C                                                                       00380000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00390000
      REAL*4 TABIN(10,6), TABOUT(10,6)                                  00400015
      DO 20 IRNG=1, 10                                                  00420001
          DO 10 ICOORD=1, 6                                             00430001
              TABOUT(IRNG, ICOORD) = TABIN(IRNG, ICOORD)                00450001
   10     CONTINUE                                                      00460000
   20 CONTINUE                                                          00470000
      RETURN                                                            00480000
      END                                                               00490000
      SUBROUTINE DELDAY (IYR1, IDAY1, IHOUR1,                           00500002
     1                   IYR2, IDAY2, IHOUR2, DAYS)                     00510002
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC    00520002
C                                                                       00530002
C PURPOSE: THIS SUBROUTINE CALCULATES THE NUMBER OF DAYS (INCLUDING     00540002
C     FRACTION) BETWEEN TIMES 1 AND 2.                                  00550002
C                                                                       00560002
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC   00570002
      IF(MOD(IYR1,4).EQ.0) LPYR=1                                       00580002
      IF(IYR1.NE.IYR2)ISW=1                                             00590002
      DAY1 = FLOAT(IDAY1) + FLOAT(IHOUR1) / 24.                         00600003
      DAY2 = FLOAT(IDAY2) + FLOAT(IHOUR2) / 24.                         00610003
      IF (IYR1.NE.IYR2) DAY2 = DAY2 + 365. + LPYR                       00620002
      DAYS = DAY2 - DAY1                                                00630002
      RETURN                                                            00640002
      END                                                               00650002
      SUBROUTINE ZDATE(ID,IE)                                           00010000
C-----------------------------------------------------------------------00020000
C     CHOOSE MAG ZEROS AND SENSITIVITIES BY DATE                        00030000
C     TABLE NAMES AND ASSOCIATED START TIMES ARE READ FROM UNIT 30      00031004
C-----------------------------------------------------------------------00040000
C       ID = 1 FOR FLT1          IE = 1 FOR ZEROS                       00050000
C       ID = 2 FOR FLT2          IE = 2 FOR SENSITIVITIES               00060000
C-----------------------------------------------------------------------00070000
C**** FLIGHT 1 ZEROS                                                    00080004
      INTEGER*4 NZ1, ITIMZ1(3,200)                                      00090004
      REAL*8 ZERO1(200)                                                 00100004
C**** FLIGHT 1 SENSITIVITIES                                            00110004
      INTEGER*4 NS1, ITIMS1(3,20)                                       00120004
      REAL*8 SENS1(20)                                                  00130004
C**** FLIGHT 2 ZEROS                                                    00140004
      INTEGER*4 NZ2, ITIMZ2(3,200)                                      00150004
      REAL*8 ZERO2(200)                                                 00160004
C**** FLIGHT 2 SENSITIVITES                                             00170004
      INTEGER*4 NS2,ITIMS2(3,20)                                        00180004
      REAL*8 SENS2(20)                                                  00190004
      LOGICAL*1 FIRST/.TRUE./                                           00190104
      IF (.NOT. FIRST) GO TO 400                                        00190204
C-----------------------------------------------------------------------00191004
C READ TABLES AND TIMES                                                 00192004
C-----------------------------------------------------------------------00193004
C READ VOYAGER1 ZERO TABLES NAMES AND APPLICABLE START TIMES            00200004
      READ (30,100) NZ1                                                 00210004
  100 FORMAT (41X, I4)                                                  00220004
      READ (30, 200) (ZERO1(I), (ITIMZ1(J,I),J=1,3),I=1,NZ1)            00230004
  200 FORMAT (///, (T10, A8, T21, I2, 1X, I3, 1X, I2))                  00240004
C READ VOYAGER1 SENSITIVITY TABLES NAMES AND APPLICABLE START TIMES     00250004
      READ (30,300) NS1                                                 00260004
  300 FORMAT (//, 41X, I4)                                              00270004
      READ (30, 200) (SENS1(I), (ITIMS1(J,I),J=1,3),I=1,NS1)            00280004
C READ VOYAGER2 ZERO TABLES NAMES AND APPLICABLE START TIMES            00300004
      READ (30,300) NZ2                                                 00310004
      READ (30, 200) (ZERO2(I), (ITIMZ2(J,I),J=1,3),I=1,NZ2)            00330004
C READ VOYAGER2 SENSITIVITY TABLES NAMES AND APPLICABLE START TIMES     00350004
      READ (30,300) NS2                                                 00360004
      READ (30, 200) (SENS2(I), (ITIMS2(J,I),J=1,3),I=1,NS2)            00380004
      FIRST = .FALSE.                                                   00390004
  400 CONTINUE                                                          00393004
C-----------------------------------------------------------------------00400004
C CHOOSE APPLICABLE ZERO OR SENSITIVITY TABLE AS SPECIFIED              00410004
C BY ID AND IE                                                          00420004
C-----------------------------------------------------------------------00430004
C**** ID=1  IE=1  FLIGHT 1 ZEROS                                        01170000
      IF (ID.EQ.1.AND.IE.EQ.1) CALL ZDATEF(NZ1,ITIMZ1,ZERO1,1,1)        01180000
C**** ID=2  IE=1  FLIGHT 2 ZEROS                                        01190000
      IF (ID.EQ.2.AND.IE.EQ.1) CALL ZDATEF(NZ2,ITIMZ2,ZERO2,2,1)        01200000
C**** ID=1  IE=2  FLIGHT 1 SENSITIVITIES                                01210000
      IF (ID.EQ.1.AND.IE.EQ.2) CALL ZDATEF(NS1,ITIMS1,SENS1,1,2)        01220000
C**** ID=2  IE=2  FLIGHT 2 SENSITIVITIES                                01230000
      IF (ID.EQ.2.AND.IE.EQ.2) CALL ZDATEF(NS2,ITIMS2,SENS2,2,2)        01240000
      RETURN                                                            01250000
      END                                                               01260000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC     00010000
C                                                                       00020000
C PURPOSE:  TO CONVERT THE ESTIMATED ERROR IN ZEROS BASED ON            00030000
C           ONE TABLE TO ERROR ESTIMATES BASED ON ANOTHER.              00040000
C                                                                       00050000
C METHOD:  EACH RECORD READ CONTAINS A ZERO ERROR BASED ON A GIVEN      00060000
C          ZERO TABLE.  ALL SUBSEQUENT ERROR ESTIMATES WILL BE          00070000
C          CONVERTED TO ERROR ESTIMATES BASED ON THIS FORST TABLE.      00080000
C                                                                       00090000
C PDL:                                                                  00100000
C     READ FIRST DATA RECORD                                            00110000
C     READ ZEROS AND SENSITIVITIES ASSOCIATED WITH THIS ESTIMATE        00120000
C     DO FOR EACH ADDITIONAL RECORD                                     00130000
C         READ RECORD                                                   00140000
C         IF THIS ZERO TABLE IS THE SAME AS THE FIRST                   00150000
C         THEN                                                          00160000
C             OUTPUT THE RECORD UNCHANGED                               00170000
C         ELSE                                                          00180000
C             IF ZEROS AND SENSITIVITIES HAVE NOT BEEN READ FOR         00190000
C              THIS TABLE THEN READ THEM                                00200000
C             DO FOR EACH COORDINATE (X, Y, Z)                          00230000
C                 IF THE ERROR ESTIMATE IS NOT BASED ON ZERO SAMPLES    00240000
C                 THEN CONVERT THE ERROR ESTIMATE  TO THE ALTERNATE     00250000
C                       ZEROTABLE                                       00260000
C                 ENDIF                                                 00270000
C             END DO                                                    00280000
C             OUTPUT THE ALTERED RECORD                                 00290000
C         END IF                                                        00300000
C     END DO                                                            00310000
C                                                                       00320000
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 00330000
      INTEGER*4 YR, DAY, NERR(3), YRRUN,                                00340005
     1          DAYRUN, ADDR(2)                                         00341001
      REAL*4 SENS1(3,2), SENS2(3,2), ZERO1(3,2), ERRXYZ(3),             00350007
     1       ZERO2(3,2), DELDEL(3)                                      00351018
      REAL*8 ZRONM(2), SNSNM(2),                                        00360012
     1       NAME(2)/2*'NONAME  '/, NAMEIN                              00361001
      EXTERNAL ZEROLD                                                   00362011
      READ (10,10) YR, DAY, ERRXYZ, NERR, ZRONM(1), SNSNM(1),           00370012
     1             YRRUN, DAYRUN,BAV,CLOG                               00371016
   10 FORMAT (2I5, 3F7.3, 3I3, A8,1X,A8,2I5,2F6.3)                      00380016
      WRITE (20,10) YR, DAY, ERRXYZ, NERR, ZRONM(1), SNSNM(1),          00390012
     1             YRRUN, DAYRUN,BAV,CLOG                               00391016
      WRITE (6,10) YR, DAY, ERRXYZ, NERR, ZRONM(1), SNSNM(1),           00391612
     1             YRRUN, DAYRUN,BAV,CLOG                               00391716
      I = 1                                                             00392002
      CALL LOADER (ZRONM(1), NAME(1), ADDR(1), &200, &200)              00400002
      WRITE (6, 1000)                                                   00401010
1000  FORMAT (' LOADER')                                                00402010
      ADDR(1) = ADDR(1) + 8                                             00410001
      CALL LINK (ADDR(1), ZERO1, ZEROLD)                                00420002
      WRITE (6, 1010)                                                   00420110
1010  FORMAT (' LINK')                                                  00420210
      CALL LOADER (SNSNM(1), NAME(2), ADDR(2), &300, &300)              00421008
      ADDR(2) = ADDR(2) + 8                                             00422002
      CALL LINK (ADDR(2), SENS1, ZEROLD)                                00423002
      I = 2                                                             00423102
   20 CONTINUE                                                          00424002
C          READ (10, 10, END=400) YR, DAY, ERRXYZ, NERR, ZRONM(2),      00425009
C     1                  SNSNM(2), YRRUN, DAYRUN                        00426009
          READ (10, 10, END=400) YR, DAY, ERRXYZ, NERR, ZRONM(2),       00426109
     1        SNSNM(2), YRRUN, DAYRUN,BAV,CLOG                          00426216
          IF ((ZRONM(1) .EQ. ZRONM(2)) .AND. (SNSNM(1) .EQ. SNSNM(2)))  00427002
     2     GO TO 100                                                    00428002
              IF (ZRONM(1) .EQ. ZRONM(2)) GO TO 30                      00428103
                  CALL LOADER (ZRONM(2), NAME(1), ADDR(1), &200, &200)  00428203
                  ADDR(1) = ADDR(1) + 8                                 00428303
                  CALL LINK (ADDR(1), ZERO2, ZEROLD)                    00428403
                  GO TO 37                                              00428506
   30         CONTINUE                                                  00428603
                  DO 33 IXYZ=1,3                                        00428706
                      ZERO2(IXYZ,2) = ZERO1(IXYZ,2)                     00428806
   33             CONTINUE                                              00428906
   37         CONTINUE                                                  00429006
              IF (SNSNM(1) .EQ. SNSNM(2)) GO TO 40                      00429106
                  CALL LOADER (SNSNM(2), NAME(2), ADDR(2), &200, &200)  00429206
                  ADDR(2) = ADDR(2) + 8                                 00429306
                  CALL LINK (ADDR(2), SENS2, ZEROLD)                    00429406
                  GO TO 47                                              00429506
   40         CONTINUE                                                  00429603
                  DO 43 IXYZ=1,3                                        00429706
                      SENS2(IXYZ,1) = SENS1(IXYZ,1)                     00429826
   43             CONTINUE                                              00429906
   47         CONTINUE                                                  00430006
              DO 50 IXYZ=1,3                                            00430105
                  IF (NERR(IXYZ) .EQ. 0) GOTO 50                        00430205
C                     ERRXYZ(IXYZ) = SENS2(IXYZ,2) *                    00430317
C    1                 ((ERRXYZ(IXYZ) / SENS1(IXYZ,2)) +                00430417
C    2                 ZERO2(IXYZ,2) - ZERO1(IXYZ,2))                   00430517
                      ERRXYZ(IXYZ) = SENS1(IXYZ,1) *                    00430625
     1                 ((ERRXYZ(IXYZ) / SENS2(IXYZ,1)) +                00430725
     2                 ZERO1(IXYZ,1) - ZERO2(IXYZ,1))                   00430825
   50         CONTINUE                                                  00430905
  100     CONTINUE                                                      00431002
          WRITE (20,10) YR, DAY, ERRXYZ, NERR,                          00431114
     1     ZRONM(1), SNSNM(1), YRRUN, DAYRUN,BAV,CLOG                   00431216
C         WRITE (20,10) YR, DAY, ERRXYZ, NERR,                          00431314
C    1     ZRONM(1), YRRUN, DAYRUN                                      00431414
          GO TO 20                                                      00431502
  200 CONTINUE                                                          00431602
      WRITE (6, 210) ZRONM(I)                                           00431702
  210 FORMAT (' ERROR READING ', A8)                                    00431802
      GO TO 400                                                         00431902
  300 WRITE (6, 210) SNSNM(I)                                           00432002
  400 CONTINUE                                                          00432102
C CALCULATE THE CHANGE IN THE DIFFERENCE IN ZEROS BETWEEN INNER(1)      00432218
C AND OUTER(2) MAGS FOR THE FIRST AND LAST ZERO TABLES PROCESSED        00432318
      DO 410 IXYZ=1,3                                                   00432418
          DELDEL(IXYZ) = (ZERO2(IXYZ,2) - ZERO2(IXYZ,1)) -              00432518
     1                   (ZERO1(IXYZ,2) - ZERO1(IXYZ,1))                00432618
  410 CONTINUE                                                          00432718
      WRITE (20, 420) DELDEL                                            00432818
  420 FORMAT (80(' '),/,3F8.0)                                          00432924
      STOP                                                              00433002
      END                                                               00433102
      SUBROUTINE ZEROLD (TABLE, RANGE0)                                 00434002
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00440002
C                                                                       00450002
C THIS SUBROUTINE MOVES THE RANGE 0 TABLE VALUES(ZERO OR SENSITIVITIES) 00460002
C A LOCAL ARRAY FROM THE CALLING PROGRAM                                00470002
C                                                                       00480002
C VARIABLES:                                                            00490002
C    RANGE0: ARRAY IN THE CALLING WHERE RANGE 0 VALUES FROM THE ZERO OR 00500002
C        SENSITIVITIES TABLE ARE TO BE PLACED.                          00510002
C        DIMENSIONS: (1) COORDINATE (X=1,Y=2,Z=3)                       00520002
C                    (2) MAGNETOMETER (IB=1,OB=2)                       00530002
C                                                                       00540002
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00550002
      REAL*4 TABLE(10,6), RANGE0(3,2)                                   00560002
      ICO = 0                                                           00570002
      DO 20 IMAG=1, 2                                                   00580002
          DO 10 ICOORD=1, 3                                             00590002
              ICO = ICO + 1                                             00600002
              RANGE0(ICOORD, IMAG) = TABLE(1,ICO)                       00610002
   10     CONTINUE                                                      00620002
   20 CONTINUE                                                          00630002
      RETURN                                                            00640002
      END                                                               00650002
      END                                                               00010062
      READ (5, 80) ZERNAM, SENNAM                                       00600036
   80 FORMAT (A8, 1X, A8)                                               00600136
C                                                                       00600236
C READ ZERO AND SENSITIVITY TABLES                                      00600336
C                                                                       00600436
      CALL LOADER (ZERNAM, NAME(1), ADDR(1), &400, &400)                00601043
      ADDR(1) = ADDR(1) + 8                                             00604036
      CALL LINK (ADDR(1), ZERO, ZEROLD)                                 00605036
      DO 87 IMAG=1,2                                                    00605143
          DO 85 ICRD=1,3                                                00605243
             DO 83 IRNG=1,10                                            00605343
                 ZERON(IRNG,ICRD,IMAG) = INT(ZERO(IRNG,ICRD,IMAG))      00605443
   83        CONTINUE                                                   00605543
   85     CONTINUE                                                      00605643
   87 CONTINUE                                                          00605743
      WRITE ( 6,111) ZERNAM, ZERON                                      00606046
      CALL LOADER (SENNAM, NAME(2), ADDR(2), &500, &500)                00608043
      ADDR(2) = ADDR(2) + 8                                             00609036
      CALL LINK (ADDR(2), SENS, ZEROLD)                                 00609136
C                                                                       00609236
C CORRECT THE ZERO TABLE                                                00609336
C                                                                       00609459
C IMAG = 1,1 APPLIES THE OFFSETS TO THE SECONDARY MAG ONLY. INBOARD     00609560
C TIM MCCLANAHAN 11/30/92. FOR SINGLE MAG ONLY (FILTER) V2              00609659
C                                                                       00609736
      DO 100 IMAG = 1,1                                                 00609860
          DO 90 IRNG = 1,8                                              00609936
              ZERON(IRNG, 3, IMAG) = INT(ZERO(IRNG, 3, IMAG)            00610043
     1              + (BZAVG / SENS(IRNG, 3, IMAG)) + .5)               00610136
   90     CONTINUE                                                      00610236
  100 CONTINUE                                                          00610336
      LETTER = B                                                        00611037
      WRITE (06,111) ZERNAM, ZERON                                      00612046
      WRITE (20,110) ZERNAM, ZERON                                      00620043
  110 FORMAT(A8, ' CSECT',                                              00630039
     1          /,9X,'GENDATE'/,                                        00640037
     2        'XI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00650037
     3             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00660037
     4        'YI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00670037
     5             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00680037
     6        'ZI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00690037
     7             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00691037
     8        'XO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00692037
     9             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00693037
     A        'YO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00694037
     B             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00695037
     C        'ZO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00696037
     D             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00697037
     E             T10,'END')                                           00698037
  111 FORMAT(1X,A8, ' CSECT',                                           00698146
     1          /,9X,'GENDATE'/,                                        00698246
     2        ' XI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698347
     3             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00698446
     4        ' YI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698547
     5             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00698646
     6        ' ZI',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698747
     7             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00698846
     8        ' XO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00698947
     9             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00699046
     A        ' YO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00699147
     B             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00699246
     C        ' ZO',T10,'DC',T16,'E''',4(I4,','),I4,'''',/,             00699347
     D             T10,'DC',T16,'E''',4(I4,','),I4,'''',/,              00699446
     E             T10,'END')                                           00699546
      GO TO 1000                                                        00699639
  200 CONTINUE                                                          00699739
      WRITE (6, 210)                                                    00699839
  210 FORMAT (' ***** HOUR AVERAGE IS NOT HG OR PL *****')              00699941
      GO TO 1000                                                        00700039
  300 CONTINUE                                                          00700139
      WRITE (6, 310)                                                    00700239
  310 FORMAT (' ***** NO HOUR AVERAGES IN REQUESTED PERIOD *****')      00700339
      GO TO 1000                                                        00700443
  400 CONTINUE                                                          00700543
      WRITE (6, 410) ZERNAM                                             00700643
  410 FORMAT (' ERROR READING ', A8)                                    00700743
      GO TO 1000                                                        00700843
  500 CONTINUE                                                          00700943
      WRITE (6, 410) SENNAM                                             00701043
 1000 STOP                                                              00701139
      END                                                               00701242
      SUBROUTINE ZEROLD (TABIN, TABOUT)                                 00701336
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00702036
C                                                                       00703036
C THIS SUBROUTINE MOVES THE 0 TABLE VALUES INTO                         00704036
C A LOCAL ARRAY FROM THE CALLING PROGRAM                                00705036
C                                                                       00706036
C                                                                       00707036
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC00708036
      REAL*4 TABIN(10,6), TABOUT(10,6)                                  00709036
      DO 20 IRNG=1, 10                                                  00709136
          DO 10 ICOORD=1, 6                                             00709236
              TABOUT(IRNG, ICOORD) = TABIN(IRNG, ICOORD)                00709336
   10     CONTINUE                                                      00709436
   20 CONTINUE                                                          00709536
      RETURN                                                            00709636
      END                                                               00710011
