PROGRAM QI9
C-----READ AND PRINT MSU2
C
C-----RPTIN, BUFFER IN, UNIT, LENGTH, GBYTE/S, DATE AND TIME ARE
C     MACHINE-DEPENDENT ROUTINES AND FUNCTIONS.  SEE COADS RELEASE 1
C     SUPPLEMENT H FOR A DESCRIPTION OF THEIR BEHAVIOR.  BPW IS A
C     PARAMETER WHICH MUST BE SET TO THE NUMBER OF BITS PER MACHINE
C     WORD.
C     ===1=========2=========3========4=========5=========6=========7==
C
C     -----------REVISION HISTORY---------------------------------------
C      LEVEL AUTHOR DATE       DESCRIPTION
C      ===== ====== ========== ====================
C      .01G. SL     85/01/24.  REVISED COMMENTS.
C     ------------------------------------------------------------------
C
C     ===1=========2=========3========4=========5=========6=========7==
      IMPLICIT INTEGER(A-E,G-Z)
C
      PARAMETER(MAX=100,RPTOFF=1,FMISS=-9999.,INDEXCK=5,BPR=1600,ID=0
     +,BPW=60,DIM BUF=(1006*64-1)/BPW+1,DIM PK=(BPR-1)/BPW+1,DIM UN=117)
C
      COMMON /MSU2/FUNITS(117),FBASE(117),BITS(117),OFFSET(117)
C
      DIMENSION BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN)
C
C-----2 DIMENSIONAL FTRUE
      DIMENSION FTRUE2(8,14)
      EQUIVALENCE (FTRUE(6),FTRUE2)
C
      DATA LEVEL/4H.01G/,BUF/DIM BUF*0/
C
      CALL DATE(DTE)
      CALL TIME(TME)
      PRINT 1,LEVEL,DTE,TME
1     FORMAT('1QI9',A4,2A9)
C
100   CALL GETRPT(1,FMISS,FUNITS,FBASE,BITS,OFFSET,INDEXCK,ID
     +,BPR,BPW,RPTOFF,BUF,DIM BUF,PK,DIM PK,UN,DIM UN,FTRUE,JEOF)
      IF(JEOF.NE.0)GOTO 900
C
      PRINT 300,FTRUE
300   FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0,' BOX10 ',F4.0
     +,' CHECKSUM ',F6.0/
     +8X,'S',7X,'A',7X,'W',7X,'U',7X,'V',7X,'P',7X,'C',7X,'Q'/
     +1X,'D',8F8.1/
     +1X,'H',8F8.1/
     +1X,'X',8F8.2/
     +1X,'Y',8F8.2/
     +1X,'N',8F8.0/
     +1X,'M',6F8.2,F8.1,F8.2/
     +1X,'S',6F8.2,F8.1,F8.2/
     +1X,'0',6F8.2,F8.1,F8.2/
     +1X,'1',6F8.2,F8.1,F8.2/
     +1X,'2',6F8.2,F8.1,F8.2/
     +1X,'3',6F8.2,F8.1,F8.2/
     +1X,'4',6F8.2,F8.1,F8.2/
     +1X,'5',6F8.2,F8.1,F8.2/
     +1X,'6',6F8.2,F8.1,F8.2)
      IF(BUF(2).LT.MAX)GOTO 100
C
900   PRINT *,' REPORTS ',BUF(2),', EOF ',JEOF
      END
C=======================================================================
      BLOCK DATA MSU2
      IMPLICIT INTEGER(A-E,G-Z)
      COMMON /MSU2/FUNITS(117),FBASE(117),BITS(117),OFFSET(117)
C
      DATA FUNITS/5*1.
     +,8*.2,8*.1,16*.01,8*1.
     +,6*.01,.1,.01
     +,6*.01,.1,.01
     +,6*.01,.1,.01
     +,6*.01,.1,.01
     +,6*.01,.1,.01
     +,6*.01,.1,.01
     +,6*.01,.1,.01
     +,6*.01,.1,.01
     +,6*.01,.1,.01/
C
      DATA FBASE/1799,4*0
     +,8*4,24*-1,8*0,-501,-8801,-1,2*-10221,86999,2*-1,8*-1
     +,-501,-8801,-1,2*-10221,86999,2*-1
     +,-501,-8801,-1,2*-10221,86999,2*-1
     +,-501,-8801,-1,2*-10221,86999,2*-1
     +,-501,-8801,-1,2*-10221,86999,2*-1
     +,-501,-8801,-1,2*-10221,86999,2*-1
     +,-501,-8801,-1,2*-10221,86999,2*-1
     +,-501,-8801,-1,2*-10221,86999,2*-1/
C
      DATA BITS/8,4,14,10,12,32*8,80*16/
C
      DATA OFFSET/
     +   16,  24,  28,  42,  52,  64,  72,  80,  88,  96, 104, 112, 120
     +, 128, 136, 144, 152, 160, 168, 176, 184, 192, 200, 208, 216, 224
     +, 232, 240, 248, 256, 264, 272, 280, 288, 296, 304, 312, 320, 336
     +, 352, 368, 384, 400, 416, 432, 448, 464, 480, 496, 512, 528, 544
     +, 560, 576, 592, 608, 624, 640, 656, 672, 688, 704, 720, 736, 752
     +, 768, 784, 800, 816, 832, 848, 864, 880, 896, 912, 928, 944, 960
     +, 976, 992,1008,1024,1040,1056,1072,1088,1104,1120,1136,1152,1168
     +,1184,1200,1216,1232,1248,1264,1280,1296,1312,1328,1344,1360,1376
     +,1392,1408,1424,1440,1456,1472,1488,1504,1520,1536,1552,1568,1584/
      END
C=======================================================================
      SUBROUTINE GETRPT(TAPE,FMISS,FUNITS,FBASE,BITS,OFFSET,INDEXCK,ID
     +,BPR,BPW,RPTOFF,BUF,DIM BUF,PK,DIM PK,UN,DIM UN,FTRUE,JEOF)
C
C-----RETURN FLOATING POINT VALUES IN FTRUE
C
C     INPUT
C         TAPE - RPTIN/RCDIN UNIT
C         FMISS - MISSING VALUE
C         FUNITS(DIM UN) - UNITS FOR UNCODING
C         FBASE(DIM UN) - BASE FOR UNCODING
C         BITS(DIM UN) - BITS FOR UNPACKING
C         OFFSET(DIM UN) - OFFSET FOR UNPACKING
C         INDEXCK - UN(INDEXCK) = CHECKSUM
C         ID - GROUP NUMBER FOR IDENTIFICATION CHECKSUM
C         BPR - BITS PER REPORT
C         BPW - BITS PER WORD
C         RPTOFF - 0=FALSE 1=TRUE
C     OUTPUT
C         BUF(DIM BUF) - RPTIN/RCDIN BUFFER
C         PK(DIM PK) - PACKED REPORT
C         UN(DIM UN) - UNPACKED REPORT
C         FTRUE(DIM UN) - TRUE VALUES
C         JEOF - 0=FALSE 1=TRUE
C
      IMPLICIT INTEGER(A-E,G-Z)
      DIMENSION FUNITS(DIM UN),FBASE(DIM UN),BITS(DIM UN),OFFSET(DIM UN)
     +,BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN)
C
C-----RPTIN/RCDIN
      IF(RPTOFF.NE.0)GOTO 100
      CALL RPTIN(TAPE,BUF,PK,KWDS,1,DIM PK,JEOF)
      GOTO 110
100   CALL RCDIN(TAPE,BUF,DIM BUF,PK,DIM PK,BPR,BPW,JEOF)
110   IF(JEOF-1)200,900,800
C
C-----GBYTE AND CONVERT TO TRUE
200   CK=ID
      DO 230 I=1,DIM UN
      CALL GBYTE(PK(OFFSET(I)/BPW+1),UN(I),MOD(OFFSET(I),BPW),BITS(I))
      IF(I.EQ.INDEXCK)GOTO 210
      IF(UN(I).EQ.0)GOTO 220
      FTRUE(I)=(UN(I)+FBASE(I))*FUNITS(I)
      CK=CK+UN(I)
      GOTO 230
210   FTRUE(INDEXCK)=UN(INDEXCK)
      GOTO 230
220   FTRUE(I)=FMISS
230   CONTINUE
      IF(MOD(CK,2**BITS(INDEXCK)-1).EQ.UN(INDEXCK))RETURN
C
C-----ERROR
      PRINT *,' SUBROUTINE GETRPT  --  CHECKSUM ERROR, TAPE = ',TAPE
     +,', REPORT = ',BUF(2)
      PRINT *,' FTRUE = ',FTRUE
800   STOP
C
900   END
C=======================================================================
      SUBROUTINE RCDIN(TAPE,BUF,DIM BUF,RCD,DIM RCD,BPR,BPW,JEOF)
C
C-----RETURN ONE LOGICAL RECORD IN RCD
C
C     INPUT
C         TAPE - BUFFER IN UNIT
C         BPR - BITS PER RECORD
C         BPW - BITS PER WORD
C     OUTPUT
C         BUF(DIM BUF) - PHYSICAL RECORD
C         RCD(DIM RCD) - LOGICAL RECORD
C         JEOF - 0=FALSE 1=TRUE
C
C     BUF(1) = GBYTE OFFSET
C     BUF(2) = LOGICAL RECORD COUNT
C     BUF(3) = PHYSICAL RECORD COUNT
C     BUF(4) =
C     BUF(5) = BLOCK LENGTH IN BITS
C     BUF(6) =
C
      IMPLICIT INTEGER(A-E,G-Z)
      REAL UNIT
      DIMENSION BUF(DIM BUF),RCD(DIM RCD)
C
      IF(BUF(1)+BPR.LE.BUF(5))GOTO 200
C-----BUFFER IN
10    BUFFER IN(TAPE,1)(BUF(7),BUF(DIM BUF))
      JEOF=UNIT(TAPE)+1
      IF(JEOF-1)100,100,800
100   BUF(1)=0
      BUF(5)=LENGTH(TAPE)*BPW
      IF(JEOF.EQ.1)RETURN
      BUF(3)=BUF(3)+1
C
C-----GBYTE
200   CALL GBYTES
     +(BUF(6+BUF(1)/BPW+1) ,RCD ,MOD(BUF(1),BPW) ,BPW ,0 ,DIM RCD)
      IF(RCD(1).EQ.0.AND.RCD(2).EQ.0)GOTO 10
      BUF(1)=BUF(1)+BPR
      BUF(2)=BUF(2)+1
      RETURN
C
C-----ERROR
800   PRINT *,' SUBROUTINE RCDIN  --  BUFFER IN ERROR, TAPE = ',TAPE
     +,', BLOCK = ',BUF(3)+1
      STOP
      END