PROGRAM QL14
C-----READ AND PRINT MST3
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      .01C. SL     85/01/25.  REVISED COMMENTS.
C     ------------------------------------------------------------------
C
C     ===1=========2=========3========4=========5=========6=========7==
      IMPLICIT INTEGER(A-E,G-Z)
C
      PARAMETER(MAX=60,RPTOFF=1,FMISS=-9999.,INDEXCK=5,BPR=3712,ID=0
     +,BPW=60,DIM BUF=(1006*64-1)/BPW+1,DIM PK=(BPR-1)/BPW+1,DIM UN=271)
C
      COMMON /MST3/FUNITS(271),FBASE(271),BITS(271),OFFSET(271)
C
      DIMENSION BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN)
C
C-----2 DIMENSIONAL FTRUE
      DIMENSION FTRUE2(19,14)
      EQUIVALENCE (FTRUE(6),FTRUE2)
C
      DATA LEVEL/4H.01C/,BUF/DIM BUF*0/
C
      CALL DATE(DTE)
      CALL TIME(TME)
      PRINT 1,LEVEL,DTE,TME
1     FORMAT('1QL14',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(I),I=1,5)
300   FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0
     +,' BOX10 ',F4.0,' CHECKSUM ',F6.0/
     +9X,7X,'D',7X,'H',7X,'X',7X,'Y',7X,'N',7X,'M',7X,'S'
     +  ,7X,'0',7X,'1',7X,'2',7X,'3',7X,'4',7X,'5',7X,'6')
      PRINT 301,((FTRUE2(I,J),J=1,14),I=1,19)
301   FORMAT(1X,'S       ',F8.1,3F8.2,F8.0,9F8.2/
     +1X,'A       ',F8.1,3F8.2,F8.0,9F8.2/
     +1X,'W       ',F8.1,3F8.2,F8.0,9F8.2/
     +1X,'U       ',F8.1,3F8.2,F8.0,9F8.2/
     +1X,'V       ',F8.1,3F8.2,F8.0,9F8.2/
     +1X,'P       ',F8.1,3F8.2,F8.0,9F8.2/
     +1X,'C       ',F8.1,3F8.2,F8.0,9F8.1/
     +1X,'Q       ',F8.1,3F8.2,F8.0,9F8.2/
     +1X,'R       ',F8.1,3F8.2,F8.0,9F8.1/
     +1X,'S-A     ',F8.1,3F8.2,F8.0,9F8.2/
     +1X,'(S-A)*W ',F8.1,3F8.2,F8.0,9F8.1/
     +1X,'QS-Q    ',F8.1,3F8.2,F8.0,9F8.2/
     +1X,'(QS-Q)*W',F8.1,3F8.2,F8.0,9F8.1/
     +1X,'W*U     ',F8.1,3F8.2,F8.0,9F8.1/
     +1X,'W*V     ',F8.1,3F8.2,F8.0,9F8.1/
     +1X,'U*A     ',F8.1,3F8.2,F8.0,9F8.1/
     +1X,'V*A     ',F8.1,3F8.2,F8.0,9F8.1/
     +1X,'U*Q     ',F8.1,3F8.2,F8.0,9F8.1/
     +1X,'V*Q     ',F8.1,3F8.2,F8.0,9F8.1)
      IF(BUF(2).LT.MAX)GOTO 100
C
900   PRINT *,' REPORTS ',BUF(2),', EOF ',JEOF
      END
C=======================================================================
      BLOCK DATA MST3
      IMPLICIT INTEGER(A-E,G-Z)
C
      COMMON /MST3/FUNITS(271),FBASE(271),BITS(271),OFFSET(271)
C
      DATA FUNITS/5*1.
     +,19*.2,57*.01,19*1.
     +,6*.01,.1,.01,.1,.01,.1,.01,7*.1
     +,6*.01,.1,.01,.1,.01,.1,.01,7*.1
     +,6*.01,.1,.01,.1,.01,.1,.01,7*.1
     +,6*.01,.1,.01,.1,.01,.1,.01,7*.1
     +,6*.01,.1,.01,.1,.01,.1,.01,7*.1
     +,6*.01,.1,.01,.1,.01,.1,.01,7*.1
     +,6*.01,.1,.01,.1,.01,.1,.01,7*.1
     +,6*.01,.1,.01,.1,.01,.1,.01,7*.1
     +,6*.01,.1,.01,.1,.01,.1,.01,7*.1/
C
      DATA FBASE/1799,4*0
     +,19*4,57*-1,19*0
     +,-501,-8801,-1,2*-10221,86999,3*-1
     +,-6301,-10001,-4001,-10001,2*-30001,2*-20001,2*-10001
     +,19*-1
     +,-501,-8801,-1,2*-10221,86999,3*-1
     +,-6301,-10001,-4001,-10001,2*-30001,2*-20001,2*-10001
     +,-501,-8801,-1,2*-10221,86999,3*-1
     +,-6301,-10001,-4001,-10001,2*-30001,2*-20001,2*-10001
     +,-501,-8801,-1,2*-10221,86999,3*-1
     +,-6301,-10001,-4001,-10001,2*-30001,2*-20001,2*-10001
     +,-501,-8801,-1,2*-10221,86999,3*-1
     +,-6301,-10001,-4001,-10001,2*-30001,2*-20001,2*-10001
     +,-501,-8801,-1,2*-10221,86999,3*-1
     +,-6301,-10001,-4001,-10001,2*-30001,2*-20001,2*-10001
     +,-501,-8801,-1,2*-10221,86999,3*-1
     +,-6301,-10001,-4001,-10001,2*-30001,2*-20001,2*-10001
     +,-501,-8801,-1,2*-10221,86999,3*-1
     +,-6301,-10001,-4001,-10001,2*-30001,2*-20001,2*-10001/
C
      DATA BITS/8,4,14,10,12,76*8,190*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
     +,328,336,344,352,360,368,376,384,392,400,408,416,424,432,440,448
     +,456,464,472,480,488,496,504,512,520,528,536,544,552,560,568,576
     +,584,592,600,608,616,624,632,640,648,656,664,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,1600,1616
     +,1632,1648,1664,1680,1696,1712,1728,1744,1760,1776,1792,1808,1824
     +,1840,1856,1872,1888,1904,1920,1936,1952,1968,1984,2000,2016,2032
     +,2048,2064,2080,2096,2112,2128,2144,2160,2176,2192,2208,2224,2240
     +,2256,2272,2288,2304,2320,2336,2352,2368,2384,2400,2416,2432,2448
     +,2464,2480,2496,2512,2528,2544,2560,2576,2592,2608,2624,2640,2656
     +,2672,2688,2704,2720,2736,2752,2768,2784,2800,2816,2832,2848,2864
     +,2880,2896,2912,2928,2944,2960,2976,2992,3008,3024,3040,3056,3072
     +,3088,3104,3120,3136,3152,3168,3184,3200,3216,3232,3248,3264,3280
     +,3296,3312,3328,3344,3360,3376,3392,3408,3424,3440,3456,3472,3488
     +,3504,3520,3536,3552,3568,3584,3600,3616,3632,3648,3664,3680,3696/
      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