      PROGRAM DPU57PLT
      INTEGER*2 IFLAG,INEW,JNEW,MINST,ICONV,IOPEN2,IOPEN3,IFLX,PRSCR,JNK
      INTEGER*2 IFRST,IYR
      INTEGER*2 PRFLE,HD,JPAUZ,LINLOG,NDET,IALX,IFLUX,IPA,INMAG,IOPEN12
      INTEGER*4 KTIM1,KTIM2,VTCW,SCRATCH(480),FLE$N
      LOGICAL*1 IRCD(480),ISUB(120),DATOUT(192),EXIS$T,OPENE$D

C     IRCD HOLDS ONE SECOND OF DPU57 DATA; ISUB HOLDS ONE SECOND OF
C     TIME/SUBCOM INFORMATION FROM THE AGENCY DATA FILE

C     CHARACTER*4 IHDR(30),EPHEM(60)
C     IHDR HOLDS THE HEADER RECORD FROM ONE ORBIT OF DATA, EPHEM HOLDS 
C     ONE SET OF PACKED EPHEMERIS DATA (1 OR 5 MINUTE INTERVALS)
C     WE DON'T REALLY NEED THESE FOR THE DPU57 STRIPOUT

      CHARACTER*30 OUTFILE,FILNAM
      CHARACTER*1 ANS,SUF(3)
C      CHARACTER EPHFIL*30
      DATA SUF/'C','S','V'/
      DATA INEW,JNEW,JNK,HD,IALX,IFRST/0,0,0,0,0,0/
      DATA INMAG/12/
      CALL TIMER(KTIM1)                      !FOR TIMING PURPOSES


      VER=1.0
      WRITE(*,1000)VER
1000  FORMAT(1X,'CRRES DPU57 PROGRAM VER. ',F3.1)

C     OPEN THE FILES
C     GET THE INPUT DATA FILE NAME
1     IF(INEW.EQ.0)GOTO2
      IF(UT.GT.86400.)UT=UT-86400.
      WRITE(*,1001)
1001  FORMAT(1X,' DO YOU WANT TO USE THE SAME FILE?',/)
      CALL PAUZ(ANS)
      IF(ANS.EQ.'N'.OR.ANS.EQ.'n')GOTO3334
      WRITE(*,3335)
3335  FORMAT(' DO YOU WANT TO USE THE SAME TIMES? (Y,N)',/)
      CALL PAUZ(ANS)
      IF(ANS.EQ.'y'.OR.ANS.EQ.'Y')GOTO3336
      PRINT*,' The last time processed was UT=',UT
      GO TO 3
3334  CLOSE(UNIT=3)
      IOPEN3=0
      JNK=0
      IFRST=0
2     TYMOLD=-100.
      WRITE(*,1003)
1003  FORMAT(' INPUT FILE NAME?',/)
      READ(*,1004)FILNAM
1004  FORMAT(A)
      INQUIRE(FILE=FILNAM,EXIST=EXIS$T,OPENED=OPENE$D)
      IF(EXIS$T)GOTO222
      WRITE(*,221)CHARNB(FILNAM)
221   FORMAT(' FILE ',A,' DOES NOT EXIST')
      GO TO 2
222   IF(OPENE$D)GO TO 223
      OPEN (UNIT=3,FILE=FILNAM,STATUS='OLD',ACCESS='TRANSPARENT',
     1 FORM='UNFORMATTED')
      IOPEN3=1
      IALX=0
C      GET THE FILE LENGTH IN BYTES
223   INQUIRE(FILE=FILNAM,FLEN=FLE$N)
      NLEN=FLE$N/512
      WRITE(*,2252)CHARNB(FILNAM),NLEN
2252  FORMAT(' FILE ',A,' IS ',I8,' SECTORS LONG')
      INEW=1
      CLOSE(UNIT=3)
      OPEN (UNIT=3,FILE=FILNAM,STATUS='OLD',ACCESS='TRANSPARENT',
     1 FORM='UNFORMATTED')
      IALX=0

C     GET THE UT AND VTCW AT THE START OF THE DATA AND RETURN IT
      CALL CRESSUB(ISUB,VTCW,UT,IFLAG,IOPEN3,IALX,IFRST)
      IF(IFLAG.NE.0.)GOTO400
C     IF IFLAG IS SET, WE'VE REALLY GOT A PROBLEM: JUST OPENED A
C     FILE WITH NO DATA IN IT!
      IDAY=206+(VTCW+348928)/675000
      IF(UT.LT.1000.AND.VTCW.GT.100000)IDAY=IDAY+1
      IF(UT.GT.80000.AND.VTCW.LT.100000)IDAY=IDAY+1
      IYR=1990
      IF(IDAY.GT.365)IYR=IYR+1
      IF(IDAY.GT.365)IDAY=IDAY-365
      WRITE(*,1005)IYR,IDAY,UT,VTCW
1005  FORMAT(1X,I4,' DAY ',I4,' UT=',F9.3,3X,' VTCW HEX = ',Z8)
      CLOSE(UNIT=3)
      IALX=0
      OPEN (UNIT=3,FILE=FILNAM,STATUS='OLD',ACCESS='TRANSPARENT',
     1 FORM='UNFORMATTED')
C     GET THE START AND STOP TIMES
3     WRITE(*,1025)
1025  FORMAT(' START AND STOP TIMES? (2F7.0)',/,
     1 ' (STOP LT START ABORTS RUN)',/,3X)
      READ(*,1006)ATIME,BTIME
1006  FORMAT(2F7.0)
      IF(BTIME.LT.ATIME)GOTO60
3336  WRITE(*,1007)ATIME,BTIME
1007  FORMAT(' REQUEST IS FOR UT= ',F6.0,' TO ',F6.0)
C     POSITION THE DATA TO THE PROPER INPUT RECORD
      IF(JNK.EQ.1)READ(UNIT=3,END=410)SCRATCH
      IF(ATIME.GE.(TYMOLD+9.))GOTO4
      CLOSE(UNIT=3)
      IALX=0
      JNK=0
      OPEN (UNIT=3,FILE=FILNAM,STATUS='OLD',ACCESS='TRANSPARENT',
     1 FORM='UNFORMATTED')
4     CALL POSITN(ISUB,ATIME,UT,IFLAG,IOPEN3,IALX)
      IF(IFLAG.EQ.1)GOTO410
      WRITE(*,1008)UT
1008  FORMAT(' DATA POSITIONED AT UT=',F9.3,/)

C     GET THE OUTPUT DATA FILE NAME
150   WRITE(*,1016)
1016  FORMAT(' WRITE OUTPUT TO THE SCREEN (1), FILE (2), OR BOTH '
     1 '(3)?',/)
      READ(*,1011)ICONV
      PRSCR=0
      PRFLE=0
      JPAUZ=1
      IF(ICONV.LT.1.OR.ICONV.GT.3.)GO TO 150
      IF(ICONV.EQ.1)PRSCR=1
      IF(ICONV.EQ.2)PRFLE=1
      IF(ICONV.EQ.3)PRSCR=1
      IF(ICONV.EQ.3)PRFLE=1
      IF(PRSCR.EQ.1)WRITE(*,1027)
1027  FORMAT(1X,' PAUSE DISPLAY BETWEEN FRAMES? (1=YES, 2=NO) ',/)
      IF(PRSCR.EQ.1)READ(*,1011)JPAUZ
      IF(PRFLE.EQ.0)GOTO6
      PRINT*,' DO YOU WANT THE PLOT FORMAT FILE? (Y,N)'
      CALL PAUZ(ANS)
      IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')PRFLE=2
      IF(JNEW.EQ.0)GO TO 5
      WRITE(*,1017)
1017  FORMAT(' CONTINUE WRITING ON THE SAME OUTPUT FILE? (Y,N)',/)
      CALL PAUZ (ANS)
      IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GO TO 6
      CLOSE(UNIT=2)
      IOPEN2=0
5     WRITE(*,1009)
1009  FORMAT(' OUTPUT FILE NAME?',/)
      READ(*,1004)OUTFILE
      IF(PRFLE.EQ.2)CALLSUFIX(OUTFILE,SUF)
      OPEN(UNIT=2,FILE=OUTFILE,STATUS='NEW',FORM='FORMATTED')
      IOPEN2=1

C     NOW WE DETERMINE WHAT DATA IS WANTED
6     WRITE(*,1010)
1010  FORMAT(' GET WHAT DATA? MEA=1, MEB e-=2, p+=3, VEH SUBCOMS=4,',
     1 /,' RP=5, PS,DPU FLAGS=6, QUIT=7',/)
      READ(*,1011)NUMINST
1011  FORMAT(I1)
      IF(NUMINST.EQ.7)GOTO80
      IF(NUMINST.NE.2)GOTO7
      WRITE(*,1018)
1018  FORMAT(' INTEGRAL OR DIFFERENTIAL ELECTRON FLUXES? (I,D)',/)
      CALL PAUZ(ANS)
      MINST=1
      IF(ANS.EQ.'I'.OR.ANS.EQ.'i')GOTO7
      MINST=2
      IF(ANS.NE.'D'.AND.ANS.NE.'d')GOTO6
      PRINT*,' DETECTOR NUMBER? (0-9, 10=ALL)'
      READ(*,1011)NDET
7     IF(NUMINST.EQ.4)GO TO 88
      IF(NUMINST.EQ.3)PRINT*,' DETECTOR NUMBER? (0-3, 4=ALL)'
      IF(NUMINST.EQ.3)READ(*,1011)NDET

      WRITE(*,1019)
1019  FORMAT(' COUNTS (1) OR FLUXES(2)?',/)
      READ(*,1011)IFLX
      IF(IFLX.LT.1.OR.IFLX.GT.2)GO TO 7
      IF(IFLX.EQ.2.AND.NUMINST.EQ.5)PRINT*,' NO FLUXES AVAILABLE FOR RP'
      IF(NUMINST.EQ.5)IFLX=1
      IFLUX=IFLX-1
      PRINT*,' Linear (1) or Log(2)?'
      READ (*,1011)LINLOG
      IF(LINLOG.EQ.2)IFLUX=IFLUX+5
      IF(NUMINST.NE.1)GO TO 88
      PRINT*,' DO YOU WANT A CRUDE BACKGROUND CORRECTION? (Y,N)'
      CALL PAUZ(ANS)
      IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')IFLUX=IFLUX+2
      IPA=0
      PRINT*,' DO YOU WANT PITCH ANGLES? (Y,N)'
      CALL PAUZ(ANS)
      IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
        IPA=1
        CALL PITCHNGL(FILNAM,INMAG,IOPEN12,IFLAG)
        IF(IFLAG.EQ.1)IPA=0
        IOPEN12=1
      ENDIF
      GO TO 88
C     AT THIS POINT WE CAN START PROCESSING DATA.  WE ENTER THE LOOP
C     AFTER THE SUBCOM DATA CALL BECAUSE THAT DATA WAS JUST READ IN
C     WHEN POSITIONING THE FILE

8     CALL CRESSUB(ISUB,VTCW,UT,IFLAG,IOPEN3,IALX,IFRST)
      print*,' UT= ',ut
      IF(IFLAG.EQ.1)GOTO400
      IF(ICONV.EQ.2)GOTO88
      IF(JPAUZ.EQ.1)CALL PAUZ(ANS)
88    IF(BTIME.GT.86400..AND.UT.LT.2000.)UT=UT+86400.
      IF(UT.GT.(BTIME+1.024))GOTO50
      IF(NUMINST.NE.4)GOTO9
C***********************************************************************
C     VEHICLE SUBCOM STRIPOUT

      CALL DSPHSKP(ISUB,PRSCR,PRFLE,VTCW,UT,HD)
      READ(UNIT=3,END=410)SCRATCH
      GO TO 8

9     DO 20 IDA=1,4
      CALL CRSFLX(IRCD,DATOUT,IFLAG,IOPEN)
      IF(IFLAG.EQ.1)GOTO400
      IF(NUMINST.NE.1)GOTO10

C**************************   MEA STRIPOUT   ***************************
      CALLMEASTRP(DATOUT,PRSCR,PRFLE,IFLUX,UT,HD,IPA,INMAG)
      GO TO 20

10    IF(NUMINST.NE.2)GOTO12
C***************************   MEB e- STRIPOUT   ***********************
      IF(MINST.NE.2)GOTO11
C     DIFFERENTIAL ELECTRON CHANNEL STRIPOUT
      CALL MEBEDIF(DATOUT,PRSCR,PRFLE,IFLUX,UT,HD,NDET)
      GO TO 20

C     INTEGRAL ELECTRON CHANNEL STRIPOUT
11    CALLMEBEINT(DATOUT,PRSCR,PRFLE,IFLUX,UT,HD)
      GO TO 20

C***************************   MEB p+ STRIPOUT   ***********************
12    IF(NUMINST.NE.3)GOTO13
      CALLMEBPROT(DATOUT,PRSCR,PRFLE,IFLUX,UT,HD,NDET)
      GO TO 20

C***************************   RP  STRIPOUT   **************************
13    IF(NUMINST.NE.5) GO TO 14
      
      CALL RPSTRIP(DATOUT,PRSCR,PRFLE,IFLUX,UT,VTCW,HD)
      VTCW=VTCW+8
      GO TO 20
C************************  PS, SUBCOM  STRIPOUT  ***********************

14    IF(NUMINST.NE.6)GO TO 40
      CALL PSUB(DATOUT,PRSCR,PRFLE,IFLUX,UT,VTCW,HD)
      VTCW=VTCW+8
20    UT=UT+1.024

      GO TO 8

40    PRINT*,' ERROR IN SENSOR SELECTION.   WE HAVE TO START OVER.'
      GO TO 60

50    WRITE(*,1012)
1012  FORMAT(' JOB COMPLETED')
      TYMOLD=BTIME
      JNK=1
      HD=0
60    WRITE(*,1020)
1020  FORMAT(' DO YOU WANT TO CONTINUE? (Y,N)',/)
      CALL PAUZ(ANS)
      IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GO TO 1

70    CALL TIMER(KTIM2)
      TME=.01*FLOAT(KTIM2-KTIM1)
      PRINT*,' ELAPSED TIME = ',TME
      IF(IOPEN3.EQ.1)CLOSE(UNIT=3)
      IF(IOPEN2.EQ.1)CLOSE(UNIT=2)
      IF(IOPEN12.EQ.1)CLOSE(UNIT=12)
      STOP

80    WRITE(*,1013)
1013  FORMAT(' PROGRAM ENDED BY KEYBOARD COMMAND')
      GO TO 70

400   PRINT*,' END OF DATA, PROCESSING STOPPED'
      GO TO 70

410   WRITE(*,1014)
1014  FORMAT(' ERROR DURING POSITIONING OF DATA',/,' JOB ABORTED')
      GO TO 70
      END



      SUBROUTINE MEBEINT(DATOUT,PRSCR,PRFLE,IFLUX,UT,HD)
      LOGICAL*1 DATOUT(192)
      INTEGER*4 IDE06A(2),IDE06B(2),IDE(8)
      INTEGER*2 PRSCR,PRFLE,IFLUX,IDBE,HD,HD1
      DIMENSION COEF(10),E06A(2),E06B(2),EDE(8)
      DATA COEF/1.6E4,1.6E4,1.7E4,1.9E4,4.0E4,4.8E4,2.1E4,1.5E4,1.5E4,
     1 2.0E4/
      DATA HD1/0/
C
C
      IDBE=21
      UT1=UT
      UT2=UT+.256
      DO 100 ITYM=1,2
      CALL XPAND8(DATOUT(IDBE),IDE06A,2)
      CALL XPAND8(DATOUT(IDBE+48),IDE06B,2)
      CALL XPAND8(DATOUT(IDBE+64),IDE,8)
      IF(IFLUX.NE.0)GOTO9
      E06A(1)=FLOAT(IDE06A(1))
      E06A(2)=FLOAT(IDE06A(2))
      E06B(1)=FLOAT(IDE06B(1))
      E06B(2)=FLOAT(IDE06B(2))
      DO 7 I=1,8
7     EDE(I)=FLOAT(IDE(I))
      GO TO 20

C     CONVERT TO APPROXIMATE FLUXES HERE
9     E06A(1)=IDE06A(1)*COEF(1)
      E06A(2)=IDE06A(2)*COEF(7)
      E06B(1)=IDE06B(1)*COEF(1)
      E06B(2)=IDE06B(2)*COEF(7)
      DO 10 I=1,5
10    EDE(I)=IDE(I)*COEF(I+1)
      DO 11 I=6,8
11    EDE(I)=IDE(I)*COEF(I+2)
      IF(IFLUX.EQ.1)GO TO 20
      IF(E06A(1).LE.0)E06A(1)=.1
      E06A(1)=ALOG10(E06A(1))
      IF(E06A(2).LE.0)E06A(2)=.1
      E06A(2)=ALOG10(E06A(2))
      IF(E06B(1).LE.0)E06B(1)=.1
      E06B(1)=ALOG10(E06B(1))
      IF(E06B(2).LE.0)E06B(2)=.1
      E06B(2)=ALOG10(E06B(2))
      DO 62 I=1,8
      IF(EDE(I).LE.0)EDE(I)=.1
62    EDE(I)=ALOG10(EDE(I))

20    IF(PRSCR.EQ.0)GOTO30
      HD1=I2MOD(HD1+1,4)
      IF(HD1.NE.1)GO TO 25
      IF(IFLUX.EQ.0)WRITE(*,4)
      IF(IFLUX.EQ.1)WRITE(*,5)
      WRITE(*,1)
25    WRITE(*,3)UT1,IDE06A
      WRITE(*,2)UT2,IDE06B(1),(IDE(J),J=1,5),IDE06B(2),(IDE(K),K=6,8)
30    IF(PRFLE.EQ.0)GOTO40
      IF(PRFLE.EQ.2)GO TO 37
      HD=I2MOD(HD+1,48)
      IF(HD.NE.1)GOTO35
      IF(IFLUX.EQ.0)WRITE(2,4)
      IF(IFLUX.EQ.1)WRITE(2,5)
      WRITE(2,1)
35    WRITE(2,3)UT1,IDE06A
      WRITE(2,2)UT2,IDE06B(1),(IDE(J),J=1,5),IDE06B(2),(IDE(K),K=6,8)
      GO TO 40
37    WRITE(2,12)UT2,E06B,EDE
40    UT1=UT1+.512
      UT2=UT2+.512
100   IDBE=IDBE+96
      RETURN
1     FORMAT(4X,'UT'8X,'IDE0  IDE1  IDE2  IDE3  IDE4  IDE5  IDE6  ',
     1 'IDE7  IDE8  IDE9')
2     FORMAT(1X,F9.3,2X,10I6)
3     FORMAT(1X,F9.3,2X,I6,30X,I6)
4     FORMAT(' RAW NUMBERS')
5     FORMAT(' APPROXIMATE INTEGRAL FLUXES')
12    FORMAT(F8.2,10(',',F9.1))
      END



      SUBROUTINE MEBEDIF(DATOUT,PRSCR,PRFLE,IFLUX,UT,HD,NDET)
      LOGICAL*1 DATOUT(192)
      INTEGER*2 DSE,PRSCR,PRFLE,IFLUX,HD,IDBE,HD1,I,J,NDET,NST
      INTEGER*4 E0E13(14)
      DIMENSION COEF(14,10),E013(14),ENGIES(15)
      DATA HD1/0/, NST/0/
      DATA COEF/
     1 6.4,7.9,9.6,10.1,10.3,9.2,7.1,6.2,5.6,5.1,4.5,3.4,2.6,2.1,
     2 5.6,6.7,7.8,8.5,8.6,7.7,6.8,6.4,5.3,4.6,4.1,3.3,2.9,2.2,
     3 5.6,6.0,6.5,7.2,7.3,6.9,6.5,6.2,5.9,4.7,4.6,3.9,3.6,2.4,
     4 4.9,5.2,5.5,6.5,6.2,6.1,6.0,5.6,5.3,4.9,4.3,3.9,3.9,3.5,
     5 0.9,2.0,3.5,4.3,4.5,4.6,4.4,4.4,4.4,3.9,3.4,2.9,2.4,2.4,
     6 0.8,1.4,2.9,3.5,3.8,4.1,3.6,3.2,2.8,2.0,1.9,1.6,1.3,1.3,
     7 2.8,4.2,4.7,4.8,5.2,5.7,5.8,6.0,6.5,6.9,6.5,5.7,5.2,4.6,
     8 3.3,6.1,6.6,7.4,8.2,9.8,10.0,11.0,11.0,9.8,9.0,7.9,7.1,6.4,
     9 5.5,7.9,8.6,8.8,8.8,8.8,9.0,11.2,13.1,11.7,11.3,10.1,9.2,8.1,
     1 7.4,9.8,10.8,11.2,11.3,11.5,11.6,11.2,11.1,10.4,9.8,8.3,7.6,6.6/
      DATA ENGIES/21.5,31.5,40.,49.5,59.5,69.,81.,94.5,112.,129.5,151.,
     1 177.5, 208.,242.5,285./

      IF(NST.EQ.1)GO TO 100
      NST=1
      DO 99 ISTRT=1,10
      AFAC=1./(.256*.00001*(ENGIES(ISTRT+1)-ENGIES(ISTRT)))
      DO 99 ILEV=1,14
99    COEF(ILEV,ISTRT)=AFAC*COEF(ILEV,ISTRT)

100   IDBE=20
      UT2=UT
      DO 40 IDB=1,4
      CALL XPAND8(DATOUT(IDBE+3),E0E13,14)
      CALLDECCODE(DATOUT(IDBE),DSE)
      IF(NDET.EQ.10)GO TO 5
      IF(DSE.NE.NDET)RETURN
5     IF(IFLUX.NE.0)GO TO 9
      DO 66 I=1,14
66    E013(I)=FLOAT(E0E13(I))
      GO TO 20


C     CONVERT TO FLUX
9     J=DSE+1
      DO 10 I=1,14
10    E013(I)=E0E13(I)*COEF(I,J)
      IF(IFLUX.EQ.1)GO TO 20
      DO 62 I=1,14
      IF(E013(I).LE.0)E013(I)=.1
62    E013(I)=ALOG10(E013(I))

20    IF(PRSCR.EQ.0)GOTO30
      HD1=I2MOD(HD1+1,4)
      IF(HD1.NE.1)GO TO 25
      IF(IFLUX.EQ.0)WRITE(*,6)
      IF(IFLUX.EQ.1)WRITE(*,7)
      WRITE(*,1)
25    IF(IFLUX.EQ.1.OR.IFLUX.EQ.6)WRITE(*,2)UT2,DSE,E013
      IF(IFLUX.EQ.0.OR.IFLUX.EQ.5)WRITE(*,8)UT2,DSE,E0E13
30    IF(PRFLE.EQ.0)GO TO 38
      IF(PRFLE.EQ.2)GO TO 37
      HD=I2MOD(HD+1,50)
      IF(HD.NE.1)GO TO 35
      IF(IFLUX.EQ.0.OR.IFLUX.EQ.5)WRITE(2,6)
      IF(IFLUX.EQ.1.OR.IFLUX.EQ.6)WRITE(2,7)
      WRITE(2,1)
35    IF(IFLUX.EQ.1.OR.IFLUX.EQ.6)WRITE(2,2)UT2,DSE,E013
      IF(IFLUX.EQ.0.OR.IFLUX.EQ.5)WRITE(2,8)UT2,DSE,E0E13
      GO TO 38
37    WRITE(2,12)UT2,E013
38    UT2=UT+.256
40    IDBE=IDBE+48
      RETURN
1     FORMAT(4X,'UT',6X,'DSE   E0     E1     E2     E3     E4     ',
     1 'E5     E6     E7     E8     E9     E10    E11    E12    E13')
2     FORMAT(1X,F9.3,3X,I1,2X,14F7.0)
12    FORMAT(F8.2,14(',',F9.1))
6     FORMAT(' MEB DIFFERENTIAL ELECTRON NUMBER')
7     FORMAT(' MEB DIFFERENTIAL ELECTRON FLUX')
8     FORMAT(1X,F9.3,2X,I1,1X,14I7)
      END



      SUBROUTINE DECCODE(J,K)
      INTEGER*2 J,K,MSK
      DATA MSK/Z'000F'/
      K=IAND(J,MSK)
      RETURN
      END



      SUBROUTINE MEBPROT(DATOUT,PRSCR,PRFLE,IFLUX,UT,HD,NDET)
      LOGICAL*1 DATOUT(192)
      INTEGER*2 DSPA,DSPB,PRSCR,PRFLE,IFLUX,HD,HD1,NDET
      INTEGER*4 PCOINA,PCOINB,PBKA,PBKB,IDPA(4),IDPB(4),P0A(12),P0B(12)
      INTEGER*4 COEFINT
      DIMENSION COEF(12),A(12),B(12),PA(4),PB(4)
      DATA COEF/574.,651.,610.,349.,287.,212.,160.,121.,87.2,63.0,
     1 48.1,4.08/
      DATA COEFINT,HD1/5000,0/
      CALL XPAND8(DATOUT(93),IDPA,4)
      CALL XPAND8(DATOUT(189),IDPB,4)
      CALL XPAND8(DATOUT(37),P0A,12)
      CALL XPAND8(DATOUT(133),P0B,12)
      CALL XPAND8(DATOUT(1),PCOINA,1)
      CALL XPAND8(DATOUT(97),PCOINB,1)
      CALL XPAND8(DATOUT(2),PBKA,1)
      CALL XPAND8(DATOUT(98),PBKB,1)
      CALL DEBCODE(DATOUT(3),DSPA)
      CALL DEBCODE(DATOUT(99),DSPB)
      IF(IFLUX.EQ.0)GOTO20

C     CONVERT TO FLUXES
      DO 10 I=1,12
      A(I)=P0A(I)*COEF(I)
10    B(I)=P0B(I)*COEF(I)
      DO 11 I=1,4
      PA(I)=IDPA(I)*COEFINT
11    PB(I)=IDPB(I)*COEFINT
      IF(IFLUX.EQ.1)GOTO20

      DO 13 I=1,12
      IF(A(I).LE.0)A(I)=.1
      A(I)=ALOG10(A(I))
      IF(B(I).LE.0)B(I)=.1
13    B(I)=ALOG10(B(I))
      DO 14 I=1,4
      IF(PA(I).LE.0)PA(I)=.1
      PA(I)=ALOG10(PA(I))
      IF(PB(I).LE.0)PB(I)=.1
14    PB(I)=ALOG10(PB(I))
      IF(PBKA.EQ.0)PBKA=1
      AK=ALOG10(PBKA)
      IF(PBKB.EQ.0)PBKB=1
      BK=ALOG10(PBKB)
      IF(PCOINA.EQ.0)PCOINA=1
      COINA=ALOG10(PCOINA)
      IF(PCOINB.EQ.0)PCOINB=1
      COINB=ALOG10(PCOINB)

C     HERE WE HAVE TO PRINT IT
20    UT2=UT+.512
      IF(PRSCR.EQ.0)GOTO30
      HD1=HD1+1
      HD1=I2MOD(HD1,4)
      IF(HD1.NE.1)GOTO25
      IF(IFLUX.EQ.0)WRITE(*,4)
      IF(IFLUX.EQ.1)WRITE(*,5)
      WRITE(*,1)
1     FORMAT(4X,'UT',6X,'DSP PCOINC  PBKGD    IDP0   IDP1   IDP2   ',
     1 'IDP3     P0     P1     P2     P3     P4     P5    P6     P7  ',
     2 '   P8     P9    P10    P11')
25    WRITE(*,2)UT,DSPA,PCOINA,PBKA,IDPA,P0A
2     FORMAT(1X,F9.3,3X,I1,2X,I6,1X,I6,1X,16E7.1E1)
      WRITE(*,2)UT2,DSPB,PCOINB,PBKB,IDPB,P0B
30    IF(PRFLE.EQ.0)RETURN
      IF(PRFLE.EQ.2)GO TO 37
      IF(HD.NE.1)GOTO35
      IF(IFLUX.EQ.0)WRITE(2,4)
      IF(IFLUX.EQ.1)WRITE(2,5)
      WRITE(*,1)
35    WRITE(2,2)UT,DSPA,PCOINA,PBKA,IDPA,P0A
      WRITE(2,2)UT2,DSPB,PCOINB,PBKB,IDPB,P0B
      RETURN
37    IF(DSPA.EQ.NDET.OR.NDET.EQ.4)WRITE(2,12)UT,COINA,AK,A,PA
      IF(DSPB.EQ.NDET.OR.NDET.EQ.4)WRITE(2,12)UT2,COINB,BK,B,PB
      RETURN
4     FORMAT(' MEB RAW NUMBERS')
5     FORMAT(' DIFFERNTIAL FLUXES (P0-11), INTEGRAL FLUXES (IDP0-3)')
12    FORMAT(F8.2,18(',',F9.2))
      END



      SUBROUTINE DEBCODE(I,J)
      INTEGER*2 I,J,MSK
      DATA MSK/Z'0003'/
      J=I2MOD(IAND(I,MSK)+2,4)
      RETURN
      END



      SUBROUTINE POSITN(ISUB,ATIME,UT,IFLAG,IOPEN,IALX)
      INTEGER*4 ISUB(30),VTCW,BREC(480)
      INTEGER*2 IFLAG,IOPEN,IALX
      IFLAG=0
      ENDTM=ATIME-2.
      DO1 I=1,64000
      CALL CRESSUB(ISUB,VTCW,UT,IFLAG,IOPEN,IALX,IFRST)
      IF(IFLAG.EQ.1)RETURN
      IF(UT.GE.ENDTM)RETURN
C     THROW AWAY THESE 4 SECONDS OF DATA
      READ(UNIT=3,END=1000)BREC
1     CONTINUE
1000  PRINT *,' END-OF-FILE ON INPUT DATA'
      CLOSE (UNIT=3)
      IFLAG=1
      IOPEN=0
      RETURN
      END



      SUBROUTINE MEASTRP(DATOUT,PRSCR,PRFLE,IFLUX,UT,HD1,IPA,INUNIT)
C     HERE WE HAVE THE ARRAYS FOR ONE SECOND OF MEA DATA
      LOGICAL*1 MEATMP(56),DATOUT(192)
      INTEGER*2 PRSCR,PRFLE,IFLUX,IDT,JDT,HD1,HD,IPA,INUNIT,NTYM
      DIMENSION AMEA(36),COEF(18)
C     CONVERSION COEFFICIENTS (CH9-17, THEN CH0-8)
      DATA COEF/.634,.676,.734,.784,.824,.876,.913,1.953,.962,
     1 .332,.344,.379,.404,.426,.466,.502,.546,.592/
      DATAHD,NTYM/0,0/
      DATA AMEA/36*0./
      IF(NTYM.EQ.1)GO TO 100
      IF(PRFLE.EQ.2)WRITE(2,14)
      NTYM=1

C     FILL THE MEA (-5A) ARRAY WITH 1 SECOND OF UNPROCESSED DATA
100   UT2=UT+.512
      UT3=UT+1.024
      IDT=0
      JDT=6
      DO 2 I=1,4
      DO 1 J=1,14
1     MEATMP(J+IDT)=DATOUT(J+JDT)
      IDT=IDT+14
      JDT=JDT+48
2     CONTINUE
C
      IF(IPA.EQ.0)GO TO 11
      UTPA=UT-.256
      UTPB=UTPA+.512
      UTPC=UTPB+.512
      CALL GETPA(INUNIT,UTPA,APA1,IFLAG)
      CALL GETPA(INUNIT,UTPB,APA2,IFLAG)
      CALL GETPA(INUNIT,UTPC,APA3,IFLAG)

C     CONVERT RAW DATA TO COUNTS AND PUT IN MEA ARRAY
11    CALL MEACVRT(MEATMP,AMEA)
      IF(IFLUX.LT.2)GOTO20

C     SUBTRACT BACKGROUND CHANNEL FROM OTHER CHANNELS
      BKGD=AMEA(8)
      DO 10 IDT=1,18
10    AMEA(IDT)=AMEA(IDT)-BKGD
      AMEA(8)=BKGD
20    IF(IFLUX.EQ.0.OR.IFLUX.EQ.2)GOTO40

C     CONVERT COUNTS TO FLUX
      DO 30 IDT=1,18
      AMEA(IDT)=AMEA(IDT)*COEF(IDT)
30    AMEA(IDT+18)=AMEA(IDT+18)*COEF(IDT)
      IF(IFLUX.LT.4)GO TO 40
      DO 31 IDT=1,40
      IF(AMEA(IDT).LE.0)AMEA(IDT)=.1
31    AMEA(IDT)=ALOG10(AMEA(IDT))
40    IF(PRSCR.EQ.0)GOTO4
      HD=I2MOD(HD+1,4)
      IF(HD.NE.1)GO TO 50
      IF(IFLUX.EQ.0)WRITE(*,6)
      IF(IFLUX.EQ.1)WRITE(*,7)
      IF(IFLUX.EQ.2)WRITE(*,8)
      IF(IFLUX.EQ.3)WRITE(*,9)
      WRITE(*,5)
50    WRITE(*,3)UT,APA1,(AMEA(J),J=1,9),UT2,APA2,(AMEA(K),K=10,18)
3     FORMAT(1X,F8.1,1X,F5.1,1X,9F7.1,/,3X,F8.1,1X,F5.1,1X,9F7.1)
      WRITE(*,3)UT2,APA2,(AMEA(J),J=19,27),UT3,APA3,(AMEA(K),K=28,36)
4     IF(PRFLE.EQ.0)RETURN
      IF(PRFLE.EQ.2)GO TO 65
      HD1=I2MOD(HD1+1,50)
      IF(HD.NE.1)GO TO 60
      IF(HD.NE.1)GO TO 60
      IF(IFLUX.EQ.0)WRITE(2,6)
      IF(IFLUX.EQ.1)WRITE(2,7)
      IF(IFLUX.EQ.2)WRITE(2,8)
      IF(IFLUX.EQ.3)WRITE(2,9)
      WRITE(2,5)
60    WRITE(2,3)UT,APA1,(AMEA(J),J=1,9),UT2,APA2,(AMEA(K),K=10,18)
      WRITE(2,3)UT2,APA2,(AMEA(J),J=19,27),UT3,APA3,(AMEA(K),K=28,36)
65    WRITE(2,13)UT,APA1,(AMEA(J),J=1,9),UT2,APA2,(AMEA(K),K=10,18)
      WRITE(2,13)UT2,APA2,(AMEA(J),J=19,27),UT3,APA3,(AMEA(K),K=28,36)
      RETURN
5     FORMAT(3X,'UT',3X,'PA',7X,'153    214    271    340    418    510'
     1 '    604    693    782',/,22X,'876    976   1090   1178   1287  '
     2 ' 1370   1470   BKGD   1582')
6     FORMAT(' RAW COUNTS')
7     FORMAT(' FLUX, NO BACKGROUND CORRECTION')
8     FORMAT(' RAW COUNTS, BACKGROUND CORRECTED')
9     FORMAT(' FLUX, BACKGROUND CORRECTED')
13    FORMAT(F8.1,',',F6.2,9(',',F8.2),',',F8.1,',',F6.2,9(',',F8.2))
14    FORMAT('UT   PA   876   976   1090   1178   1287   1370   1470   B
     1KGD   1582   UT   PA   153   214   271   340   418   510   604   6
     293   782')
      END



      SUBROUTINE MEACVRT(MEATMP,AMEA)
      LOGICAL*1 MEATMP(56)
      INTEGER*2 MTMP,IFLG
      DIMENSION T(0:4095),AMEA(36)
      DATAIFLG/0/
      IF(IFLG.NE.1)GOTO100
10    CONTINUE
      J=0
      I=0
      DO20 II=1,4
      CALLMEVEN(MEATMP(I+1),MTMP)
      AMEA(J+1)=T(MTMP)
      CALLMEAODD(MEATMP(I+2),MTMP)
      AMEA(J+2)=T(MTMP)
      CALLMEVEN(MEATMP(I+4),MTMP)
      AMEA(J+3)=T(MTMP)
      CALLMEAODD(MEATMP(I+5),MTMP)
      AMEA(J+4)=T(MTMP)
      CALLMEVEN(MEATMP(I+7),MTMP)
      AMEA(J+5)=T(MTMP)
      CALLMEAODD(MEATMP(I+8),MTMP)
      AMEA(J+6)=T(MTMP)
      CALLMEVEN(MEATMP(I+10),MTMP)
      AMEA(J+7)=T(MTMP)
      CALLMEAODD(MEATMP(I+11),MTMP)
      AMEA(J+8)=T(MTMP)
      CALLMEVEN(MEATMP(I+13),MTMP)
      AMEA(J+9)=T(MTMP)
      J=J+9
      I=I+14
20    CONTINUE
      RETURN

100   DO 1 I=0,511
      A=FLOAT(I)
      T(I)=A
      T(I+512)=A+512.
      T(I+1024)=2.*A+1025.
      T(I+1536)=4.*A+2050.
      T(I+2048)=8.*A+4100.
      T(I+2560)=16.*A+8200.
      T(I+3072)=32.*A+16400.
1     T(I+3584)=64.*A+32800.
      IFLG=1
      GOTO10
      END



      SUBROUTINE MEVEN(MEATMP,MTMP)
      INTEGER*2 MEATMP,MTMP,MSK
      DATAMSK/Z'0FFF'/
      CALLSWAP2(MEATMP,MTMP)
      MTMP=ISHFT(MTMP,-4)
      MTMP=IAND(MTMP,MSK)
      IF(MTMP.GE.0.AND.MTMP.LE.4095)RETURN
      WRITE(*,10)MEATMP,MTMP
10    FORMAT(1X,' ERROR: MEATMP= ',Z4,' AND MTMP= ',Z4)
      RETURN
      END



      SUBROUTINE MEAODD(MEATMP,MTMP)
      INTEGER*2 MEATMP,MTMP,IMSK,NTMP
      DATA IMSK/Z'FF0F'/
      NTMP=IAND(MEATMP,IMSK)
      CALLSWAP2(NTMP,MTMP)
      RETURN
      END



      SUBROUTINE CRSFLX(IRCD,DATOUT,IFLAG,IOPEN)
C     A SUBROUTINE TO READ IN 1 SECOND OF CRRES DATA FROM THE
C     AEROSPACE AGENCY TAPE.  IT ASSUMES THAT THE FILE IS PROPERLY
C     POSITIONED AT THE START OF THE DATA.  IT TRANSFERS THE DPU57
C     DATA INTO THE 'DATOUT' ARRAY.
C     IFLAG = 1 IF REACHED END OF FILE.
      LOGICAL*1 IRCD(480),DATOUT(192)
      INTEGER*2 IFLAG,IOPEN
      IFLAG=0
      READ(UNIT=3,END=1000)IRCD
C     TRANSFER DPU57 DATA INTO OUTPUT ARRAY
      IDX=1
      JDX=1
      DO 1 J=1,8
      DATOUT(JDX)=IRCD(IDX+5)
      DATOUT(JDX+1)=IRCD(IDX+6)
      DATOUT(JDX+2)=IRCD(IDX+7)
      DATOUT(JDX+3)=IRCD(IDX+12)
      DATOUT(JDX+4)=IRCD(IDX+13)
      DATOUT(JDX+5)=IRCD(IDX+14)
      DATOUT(JDX+6)=IRCD(IDX+20)
      DATOUT(JDX+7)=IRCD(IDX+21)
      DATOUT(JDX+8)=IRCD(IDX+22)
      DATOUT(JDX+9)=IRCD(IDX+27)
      DATOUT(JDX+10)=IRCD(IDX+28)
      DATOUT(JDX+11)=IRCD(IDX+29)
      DATOUT(JDX+12)=IRCD(IDX+35)
      DATOUT(JDX+13)=IRCD(IDX+36)
      DATOUT(JDX+14)=IRCD(IDX+37)
      DATOUT(JDX+15)=IRCD(IDX+42)
      DATOUT(JDX+16)=IRCD(IDX+43)
      DATOUT(JDX+17)=IRCD(IDX+44)
      DATOUT(JDX+18)=IRCD(IDX+50)
      DATOUT(JDX+19)=IRCD(IDX+51)
      DATOUT(JDX+20)=IRCD(IDX+52)
      DATOUT(JDX+21)=IRCD(IDX+57)
      DATOUT(JDX+22)=IRCD(IDX+58)
      DATOUT(JDX+23)=IRCD(IDX+59)
      IDX=IDX+60
      JDX=JDX+24
1     CONTINUE
      RETURN
1000  IFLAG=1
      PRINT *,' END-OF-FILE ON INPUT DATA'
      CLOSE(UNIT=3)
      IOPEN=0
      RETURN
      END



      SUBROUTINE CRESSUB(ISUB,VTCW,UT,IFLAG,IOPEN,IALX,IFRST)
C     A SUBROUTINE TO READ THE 120 BYTE SUBCOM DATA FROM THE AEROSPACE
C     CRRES AGENCY TAPE. IT RETURNS THE VTCW AND UT IN PROPER FORMAT
C     IFLAG = 1 IF REACHED END OF FILE.
      LOGICAL*1 ISUB(120)
      INTEGER*2 IFLAG,IOPEN,IALX,JREC,KREC,IDPU,JDPU,JFRST,IFRST
      INTEGER*4 VTCW,ITMP,MASK
      DATA KREC,MASK,JDPU/Z'0A0D',Z'0FFFFFFF',Z'00C5'/
      IFLAG=0
100   IF(IALX.NE.4)GO TO 200
101   READ(UNIT=3,END=1000)JREC
      IF(JREC.EQ.KREC)GO TO 200
      WRITE(*,3232)JREC,KREC
3232  FORMAT(1X,'Lost sync on Alphatronix file: read ',Z4,
     1 ', should be ',Z4)
120   DO 150 ILOP=1,10000
      READ(UNIT=3,END=1000)JREC
150   IF(JREC.EQ.KREC)GO TO 200
200   READ(UNIT=3,END=1000)ISUB
C     TRANSFER DPU57 DATA INTO OUTPUT ARRAY
      CALL SWAP4(ISUB(24),VTCW)
C     IF THE VTCW IS FLAGGED, SKIP OVER THE DATA FRAMES
      IF(VTCW.GT.0)GO TO 220
C     THE DATA FRAMES TOTAL 1920 BYTES. USE ISUB AS A BUFFER (120 BYTES
      DO 210 IBD=1,16
210   READ(UNIT=3,END=1000)ISUB
      GO TO 120
220   VTCW=IAND(VTCW,MASK)
      CALL SWAP4(ISUB(1),ITMP)
      CALLREALTM(ITMP,UT)
      IALX=I2MOD(IALX,4)+1
      IF(IFRST.EQ.1)RETURN
C    ENSURE THAT VALID DPU57 DATA IS PRESENT
C
C     NOTE THAT WE THROW AWAY THE FIRST 4 SECONDS OF DATA BECAUSE WE
C     ARE CHECKING FOR THE Z'C5' DPU57 SYNC CODE.  TO RECOVER IT, START 
C     DATA PROCESSING 4 SECONDS EARLIER
      READ(UNIT=3,END=1000)ISUB
      READ(UNIT=3,END=1000)ISUB
      CALL MAKINT2(ISUB(6),IDPU)
      IF(IDPU.EQ.JDPU)IFRST=1
      IF(IFRST.EQ.1)write(*,9393)idpu,jdpu
9393  format(' SYNC code was ',z4,' should be ',z4)
      do 245 i=1,14
245   READ(UNIT=3,END=1000)ISUB
      GO TO 100
1000  IFLAG=1
      PRINT *,' END-OF-FILE ON INPUT DATA'
      CLOSE (UNIT=3)
      IOPEN=0
      RETURN
      END



      SUBROUTINE CHTOINT(I,J)
      INTEGER*2 I,J
      J=I
      RETURN
      END



      SUBROUTINE REALTM(IN,UT)
      INTEGER*4 IN
      UT=.001*FLOAT(IN)
      RETURN
      END



      SUBROUTINE SWAP4(IN,IOUT)
      LOGICAL*1 IN(4),IOUT(4)
      IOUT(1)=IN(4)
      IOUT(2)=IN(3)
      IOUT(3)=IN(2)
      IOUT(4)=IN(1)
      RETURN
      ENTRY SWAP2
      IOUT(1)=IN(2)
      IOUT(2)=IN(1)
      RETURN
      END



      SUBROUTINE DMPIT2(M,N)
      INTEGER*2 N,M(N),MM(16),K,ITEMP,IRYT
      ITEMP=N
      K=0
1     IRYT=16
      IF(ITEMP.LT.16)IRYT=ITEMP
      DO100 I=1,IRYT
100   CALLSWAP2(M(I+K),MM(I))
      WRITE(*,2)(MM(IK),IK=1,IRYT)
2     FORMAT(16(1X,Z4))
      K=K+16
      ITEMP=ITEMP-16
      IF(ITEMP.GT.0)GOTO1
      RETURN
      END



      SUBROUTINE PAUZ(ANS)
      CHARACTER*1 ANS
      READ(*,1)ANS
1     FORMAT(A)
      RETURN
      END



      SUBROUTINE XPAND8(IN,OUT,NUM)
      LOGICAL*1 IN(192)
      INTEGER*2 NUM,IRTN,IFLG,I,J,NADD
      INTEGER*4 OUT(192),ITABL(0:255),ICOF
      DATAIFLG/0/
      IF(IFLG.NE.1)GOTO100
10    CONTINUE
      DO20 I = 1,NUM
      CALL MAKINT2(IN(I),IRTN)
      OUT(I)=ITABL(IRTN)
20    CONTINUE
      RETURN
100   DO101 I=0,31
101   ITABL(I)=I
      ICOF=1
      DO 102 J=1,14
      ICOF=2*ICOF
      DO 102 I=0,15
      NADD=I+16*(J+1)
102   ITABL(NADD)=ICOF*(16+I)
      IFLG=1
      GO TO 10
      END



      SUBROUTINE MAKINT2(IN,OUT)
      INTEGER*2 IN,OUT,MASK
      DATA MASK/Z'00FF'/
      OUT=IAND(IN,MASK)
      RETURN
      END



      SUBROUTINE DSPHSKP(ISUB,PRSCR,PRFLE,VTCW,UT,HD)
      LOGICAL*1 ISUB(120)
      INTEGER*2 SUBOUT(19),PRSCR,PRFLE,HD,I,HD1
      INTEGER*4 VTCW
      DATA HD1/0/
      DO 1 I=1,19
1     CALL MAKINT2(ISUB(I+4),SUBOUT(I))
      IF(PRSCR.EQ.0)GOTO4
      HD1=I2MOD(HD1+1,4)
      IF(HD1.EQ.1)WRITE(*,2)
2     FORMAT(4X,'UT',7X,'VTCW SC14: SF16 SF18 SF28 SF25 SF26  ',
     1 'SC11: SF3 SF4 SF5 SF6 SF7  SC6: SF3 SF4 SF5 SF21  SC7   SC3:',
     2 ' SF7 SF15 SF23 SF31')
      WRITE(*,3)UT,VTCW,(ISUB(J),J=5,9),(SUBOUT(K),K=6,19)
3     FORMAT(1X,F9.3,1X,Z8,6X,Z2,3X,Z2,3X,Z2,3X,Z2,3X,Z2,9X,I3,1X,I3,1X,
     1 I3,1X,I3,1X,I3,7X,I3,1X,I3,1X,I3,1X,I3,3X,I3,8X,I3,1X,I3,2X,I3,
     2 2X,I3,/)
4     IF(PRFLE.EQ.0)RETURN
      HD=I2MOD(HD+1,50)
      IF(HD.EQ.1)WRITE(2,2)
      WRITE(2,3)UT,VTCW,SUBOUT
      RETURN
      END


      SUBROUTINE PSUB(DATOUT,PRSCR,PRFLE,IFLUX,UT,VTCW,HD)
      INTEGER*2 FMT2,DPUHSK,KWTC,SUN(2),IFLUX,HD,SYNCWD,CMDV
      INTEGER*2 PRFLE,PRSCR,HD1,IDNT,ITEMP,ntimz
      INTEGER*4 PSUL,VTCW,JSCRA(3)
      LOGICAL*1 DATOUT(192),CMDVER(2)
      CHARACTER*6 PSID(4),PSTEM(4)
      DIMENSION COEF(4),PFLX(4)
      DATA PSID/'50-75 ','20-50 ','50-105','20-83 '/
      DATA PSTEM/'75-105','50-83 ','50-105','20-83 '/
      DATA COEF/.0306,.0344,.0192,.0266/
      DATA SAVE3,SAVE4/-1.E7,-1.E7/
      DATA HD1,ntimz/0,0/
      PSID(3)=PSTEM(3)
      PSID(4)=PSTEM(4)
      CMDVER(1)=DATOUT(146)
      CMDVER(2)=DATOUT(145)
      CALL MAKINT2(DATOUT(49),SYNCWD)
      CALLCHTOINT(CMDVER,CMDV)
      CALLDEECOD(DATOUT(50),DATOUT(99),FMT2,KWTC,SUN)
      CALLMAKINT2(DATOUT(51),DPUHSK)
      CALL XPAND8(DATOUT(147),PSUL,1)
      UPS=PSUL
      ITEMP=FMT2/2
      IDNT=I2MOD(ITEMP,4)+1
      PFLX(IDNT)=UPS
      IF(IFLUX.EQ.0)GO TO 20
C     CONVERSION TO FLUX
      PSID(3)=PSTEM(1)
      PSID(4)=PSTEM(2)
      GO TO (15,15,11,12)IDNT
11    UPS=PSUL-SAVE3
      GO TO 15
12    UPS=PSUL-SAVE4
15    UPS=UPS*COEF(IDNT)
      PFLX(IDNT)=UPS
20    IF(PRSCR.EQ.0)GOTO40
      HD1=HD1+1
      HD1=I2MOD(HD1,16)
      IF(HD1.NE.1)GOTO25
      IF(IFLUX.EQ.1)WRITE(*,7)
      IF(IFLUX.EQ.0)WRITE(*,8)
      WRITE(*,2)
25    IF(IFLUX.EQ.0)GOTO27
      WRITE(*,3)UT,VTCW,SYNCWD,FMT2,DPUHSK,KWTC,SUN,UPS,PSID(IDNT),CMDV
      GO TO 40
27    WRITE(*,9)UT,VTCW,SYNCWD,FMT2,DPUHSK,KWTC,SUN,PSUL,PSID(IDNT),CMDV
40    IF(PRFLE.EQ.0)GO TO 50
      IF(PRFLE.EQ.2)GO TO 48
      HD=I2MOD(HD+1,50)
      IF(HD.NE.1)GO TO 45
      IF(IFLUX.EQ.1)WRITE(2,7)
      IF(IFLUX.EQ.0)WRITE(2,8)
      WRITE(2,2)
45    IF(IFLUX.EQ.0)GOTO47
      WRITE(2,3)UT,VTCW,SYNCWD,FMT2,DPUHSK,KWTC,SUN,UPS,PSID(IDNT),CMDV
      GO TO 50
47    WRITE(2,9)UT,VTCW,SYNCWD,FMT2,DPUHSK,KWTC,SUN,PSUL,PSID(IDNT),CMDV
      GO TO 50
48    ntimz=ntimz+1
      if(ntimz.ne.4)go to 50
      ntimz=0
      WRITE(2,13)UT,PFLX
13    FORMAT(F8.2,4(',',F7.2))
50    IF(IFLUX.EQ.0)RETURN
      IF(IDNT.EQ.1)SAVE3=PSUL
      IF(IDNT.EQ.2)SAVE4=PSUL
      RETURN
2     FORMAT(5X,'UT',6X,'VTCW',2X,'SYNC FMT2 DPHSK KWTC SUN  PSUL12 ',
     2'CHANNEL CMD')
3     FORMAT(1X,F9.3,1X,Z8,2X,Z2,1X,I3,3X,I3,3X,Z1,3X,I1,1X,I1,1X,
     1 F7.3,1X,A6,1X,Z4)
7     FORMAT(' DIFFERENTIAL PROTON SWITCH FLUXES (/CM2-SEC-STER-MEV)')
8     FORMAT(' PROTON SWITCH RAW COUNTS')
9     FORMAT(1X,F9.3,1X,Z8,2X,Z2,1X,I3,3X,I3,3X,Z1,3X,I1,1X,I1,
     1 1X,I7,1X,A6,1X,Z4)
      END



      SUBROUTINE DEECOD(I1,I2,FMT2,KWTC,SUN)
      INTEGER*2 SUN(2),FMT2,KWTC,I1,I2(50),MSK1,MSK2,MSK3
      DATA MSK1,MSK2,MSK3/Z'007F',Z'00F8',Z'0004'/
      FMT2=IAND(I1,MSK1)
      KWTC=IAND(I2(1),MSK2)
      SUN(1)=ISHFT(IAND(I2(1),MSK3),-2)
      SUN(2)=ISHFT(IAND(I2(49),MSK3),-2)
      RETURN
      END



      SUBROUTINE RPSTRIP(DATOUT,PRSCR,PRFLE,IFLUX,UT,VTCW,HD)
      INTEGER*2 FMT2,KWTC,SUN(2),IFLUX,HD
      INTEGER*2 PRFLE,PRSCR,HD0,I,IEAD
      INTEGER*4 CA03(4),CS03(4),RERM(8),VTCW,JSCRA(3)
      LOGICAL*1 DATOUT(192)
      DATA HD0,I/0,0/
      CALL MAKINT2(DATOUT(49),SYNCWD)
      CALLDEECOD(DATOUT(50),DATOUT(99),FMT2,KWTC,SUN)
      I=I+1
      IF(I.EQ.3)I=1
      IEAD=4*I2MOD(FMT2/2,2)
      CALL XPAND8(DATOUT(4),JSCRA,3)
      CA03(4)=JSCRA(1)
      CS03(4)=JSCRA(2)
      RERM(1+IEAD)=JSCRA(3)
      CALL XPAND8(DATOUT(52),JSCRA,3)
      CA03(1)=JSCRA(1)
      CS03(1)=JSCRA(2)
      RERM(2+IEAD)=JSCRA(3)
      CALL XPAND8(DATOUT(100),JSCRA,3)
      CA03(2)=JSCRA(1)
      CS03(2)=JSCRA(2)
      RERM(3+IEAD)=JSCRA(3)
      CALL XPAND8(DATOUT(148),JSCRA,3)
      CA03(3)=JSCRA(1)
      CS03(3)=JSCRA(2)
      RERM(4+IEAD)=JSCRA(3)
C     IF(IFLUX.EQ.0)GO TO 20
C     CONVERSION TO FLUX
C     NOT IMPLIMENTED YET
20    IF(PRSCR.EQ.0)GOTO40
      HD0=I2MOD(HD0+1,4)
      IF(HD0.NE.1)GOTO25
      IF(IFLUX.EQ.1)WRITE(*,7)
      IF(IFLUX.EQ.0)WRITE(*,8)
      WRITE(*,2)
25    WRITE(*,3)UT,VTCW,FMT2,CA03,CS03
      IF(I.EQ.2)WRITE(*,203)RERM(1),RERM(3),RERM(5),RERM(7),
     1 RERM(2),RERM(4),RERM(6),RERM(8)
40    IF(PRFLE.EQ.0)RETURN
      IF(PRFLE.EQ.2)GO TO 50
      HD=I2MOD(HD+1,50)
      IF(HD.NE.1)GO TO 45
      IF(IFLUX.EQ.1)WRITE(2,7)
      IF(IFLUX.EQ.0)WRITE(2,8)
      WRITE(2,2)
45    WRITE(2,3)UT,VTCW,FMT2,CA03,CS03
      IF(I.EQ.2)WRITE(2,203)RERM(1),RERM(3),RERM(5),RERM(7),
     1 RERM(2),RERM(4),RERM(6),RERM(8)
      RETURN
50    WRITE(2,13)UT,CA03,CS03,RERM(1),RERM(3),RERM(5),RERM(7),
     1 RERM(2),RERM(4),RERM(6),RERM(8)
      RETURN
2     FORMAT(5X,'UT',6X,'VTCW  FMT2     CA0    CA1    CA2    CA3    CS0',
     1 '    CS1    CS2    CS3',/,29X,'RE0    RE1    RE2    RE3    RM0',
     2 '    RM1    RM2    RM3')
3     FORMAT(1X,F9.3,1X,Z8,1X,I3,1X,8I7)
103   FORMAT(1X,F9.3,10X,I3,1X,8I7)
203   FORMAT(25X,8I7)
7     FORMAT(' DIFFERENTIAL PROTON FLUXES (/CM2-SEC-STER-MEV)')
8     FORMAT(' RP RAW COUNTS')
13    FORMAT(F8.2,16(',',I7))
113   FORMAT(F8.2,8(',',I7))
      END
C
C
      SUBROUTINE GETPA(INUNIT,UT,APA,IFLAG)
      DIMENSION ARRAY(4,33),DCS(3),BCMP(3)
      INTEGER*2 INDX,IFLAG,NDX
c      DATA DCS/.1736482,.2537579,1./ !80., 75.3, AND 0 DEGREES
      DATA DCS/-.819152,.5735764,0./ ! 145., 55, AND 90 DEGREES
1     NDX=INDX
      DO 100 J=NDX,33
      IF(UT.GT.ARRAY(1,J))GOTO100
      TDEL=ARRAY(1,J)-ARRAY(1,J-1)
      TPART1=(UT-ARRAY(1,J-1))/TDEL
      BCMP(1)=TPART1*(ARRAY(2,J)-ARRAY(2,J-1))+ARRAY(2,J-1)
      BCMP(2)=TPART1*(ARRAY(3,J)-ARRAY(3,J-1))+ARRAY(3,J-1)
      BCMP(3)=TPART1*(ARRAY(4,J)-ARRAY(4,J-1))+ARRAY(4,J-1)
      DD=DOT(BCMP,BCMP)
      IF(DD.LE.0.)GO TO 100
      B=SQRT(DD)
      BMP=DOT(BCMP,DCS)/B
      IF (BMP.GT.1.)BMP=1.
      IF (BMP.LT.-1.)BMP=-1.
      APA=57.29572*ACOS(BMP)
      IF(APA.LT.0.)APA=-APA
      IF(APA.GT.180.)APA=360.-APA
      RETURN
100   INDX=INDX+1
      DO 110 IJ=1,4
110   ARRAY(IJ,1)=ARRAY(IJ,33)
      CALL GETSECT(INUNIT,ARRAY(1,2),IFLAG)
      IF(IFLAG.EQ.1)THEN
         PRINT*,' MAGNETIC FIELD FILE EXHAUSTED'
         RETURN
      ENDIF
      INDX=2
      GO TO 1
      ENTRY FIRSTPA
      CALL GETSECT(INUNIT,ARRAY(1,2),IFLAG)
        IF(IFLAG.EQ.1)THEN
           PRINT*,' MAGNETIC FIELD FILE CAN NOT BE READ'
           RETURN
        ENDIF
      ARRAY(1,1)=ARRAY(1,2)-0.128
      DO 120 IJ=2,4
120   ARRAY(IJ,1)=ARRAY(IJ,2)
      INDX=2
      UT=ARRAY(1,2)
      RETURN
      END


      SUBROUTINE GETSECT(INUNIT,BREC,IFLAG)
C     A subroutine to read sectors from disk.
C     IFLAG = 1 if reached end of file.
      LOGICAL*1 BREC(512)
      INTEGER*2 INUNIT,IFLAG
      IFLAG=0
      READ(UNIT=INUNIT,END=1000)BREC
      RETURN
1000  IFLAG=1
      PRINT *,' END OF DATA ON INPUT FILE'
      CLOSE (UNIT=INUNIT)
      RETURN
      END


      SUBROUTINE SUFIX(NAME,SUF)
      CHARACTER*1 NAME(51),SUF(3),SUF1
      DATA SUF1/'.'/
      DO 1 I=1,51
      IF(NAME(I).EQ.'.')GOTO4
1     IF(NAME(I).EQ.' ')GOTO3
      WRITE(*,2)NAME
2     FORMAT(' ***** ERROR ***** ERROR ***** ERROR *****',//,
     1 A,//,' exceeds the limit on file names (50 characters)')
      STOP
3     NAME(I)=SUF1
4     NAME(I+1)=SUF(1)
      NAME(I+2)=SUF(2)
      NAME(I+3)=SUF(3)
      RETURN
      END

      FUNCTION DOT(A,B)
      DIMENSION A(3),B(3)
      DOT=A(1)*B(1)+A(2)*B(2)+A(3)*B(3)
      RETURN
      END
C
C
      SUBROUTINE PITCHNGL(INFILE,INUNIT,IOPEN,IFLAG)
      INTEGER*2 IFLAG,INUNIT,IOPEN,ISTRT
      CHARACTER*50 INFILE
      CHARACTER*1 ANS
      DATA ISTRT/0/
      IF (ISTRT.EQ.1)RETURN
      ISTRT=1
      WRITE(*,1008)
1008  FORMAT(' PITCH-ANGLES HAVE BEEN REQUESTED.  A PROCESSED MAG FILE',/,
     1 ' (WITH UT,BX,BY,BZ IN FLOATING POINT IN THAT ORDER)',/,
     2 ' IS REQUIRED. THE SUFFIX MUST BE "FPM"',/)
C
      CALL SUFIX(INFILE,'FPM')
      CALLOPENOLD(INFILE,INUNIT,IOPEN)
C
      CALL FIRSTPA(INUNIT,UT,APA,IFLAG)
      IF(IFLAG.EQ.1)THEN
        PRINT*,' CAN NOT GET PITCH-ANGLES --- CONTINUE? (Y,N)   '
      READ(*,1111)ANS
1111  FORMAT(A)
      IF(ANS.EQ.'N'.OR.ANS.EQ.'n')STOP
      RETURN
      ENDIF
      WRITE(*,1002)UT
1002  FORMAT(' THE FIRST UT IN THE MAG FILE IS ',F10.3,/)
      RETURN
      END
C
C
      SUBROUTINE OPENOLD(FILNAM,NUNIT,NOPEN)
      CHARACTER*30 FILNAM
      CHARACTER*1 ANS
      INTEGER*2 NUNIT,NOPEN
      INTEGER*4 LEN,NLEN
      LOGICAL OPEND,EXST
1     INQUIRE(FILE=FILNAM,EXIST=EXST,OPENED=OPEND)
      IF(EXST)GOTO5
      NOPEN=0
      WRITE(*,2)CHARNB(FILNAM)
2     FORMAT(' FILE ',A,' DOES NOT EXIST',/,' DO YOU NEED IT? (Y,N)')
      CALL PAUZ(ANS)
      IF(ANS.EQ.'N'.OR.ANS.EQ.'n')RETURN
      WRITE(*,3)
3     FORMAT(' ENTER FILE NAME, INCLUDING FULL PATH',/)
      READ(*,4)FILNAM
4     FORMAT(A)
      GO TO 1
5     IF(OPEND)GO TO 6
      OPEN (UNIT=NUNIT,FILE=FILNAM,STATUS='OLD',ACCESS='TRANSPARENT',
     1 FORM='UNFORMATTED')
      NOPEN=1
C     GET THE FILE LENGTH IN BYTES
6     INQUIRE(FILE=FILNAM,FLEN=LEN)
      NLEN=LEN/512
      WRITE(*,7)CHARNB(FILNAM),LEN,NLEN
7     FORMAT(' FILE ',A,' IS ',I8,' BYTES (',I5,'+ SECTORS) LONG')
      RETURN
      END

