PROGRAM QI22 C-----READ AND PRINT MSUG1 GROUP 2 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 .01D. 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=400,RPTOFF=1,FMISS=-9999.,INDEXCK=5,BPR=384,ID=2 +,BPW=60,DIM BUF=(1006*64-1)/BPW+1,DIM PK=(BPR-1)/BPW+1,DIM UN=37) C COMMON /MSUG1/FUNITS(37),FBASE(37),BITS(37),OFFSET(37) C DIMENSION BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN) C C-----2 DIMENSIONAL FTRUE DIMENSION FTRUE2(4,8) EQUIVALENCE (FTRUE(6),FTRUE2) C DATA LEVEL/4H.01D/,BUF/DIM BUF*0/ C CALL DATE(DTE) CALL TIME(TME) PRINT 1,LEVEL,DTE,TME 1 FORMAT('1QI22',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 CALL WRMSUG1(FTRUE) IF(BUF(2).LT.MAX)GOTO 100 C 900 PRINT *,' REPORTS ',BUF(2),', EOF ',JEOF END C======================================================================= SUBROUTINE WRMSUG1(FTRUE) IMPLICIT INTEGER(A-E,G-Z) DIMENSION FTRUE(37) PRINT 100,(FTRUE(I),I=1,5) +,((FTRUE(5+(J-1)*4+I),J=1,8),I=1,4) 100 FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0 +,' BOX10 ',F4.0,' CHECKSUM ',F6.0/ +8X,'3',7X,'M',7X,'N',7X,'E',7X,'D',7X,'H',7X,'X',7X,'Y'/ +1X,'W',2F8.2,F8.0,F8.2,2F8.0,2F8.1/ +1X,'U',2F8.2,F8.0,F8.2,2F8.0,2F8.1/ +1X,'V',2F8.2,F8.0,F8.2,2F8.0,2F8.1/ +1X,'C',2F8.1,F8.0,F8.1,2F8.0,2F8.1) END C======================GROUP 2========================================== BLOCK DATA MSUG1 IMPLICIT INTEGER(A-E,G-Z) C COMMON /MSUG1/FUNITS(37),FBASE(37),BITS(37),OFFSET(37) C DATA FUNITS/5*1. +,3*.01,.1 +,3*.01,.1 +,4*1. +,3*.01,.1 +,4*2. +,4*2. +,4*.2 +,4*.2/ C DATA FBASE/1799,4*0 +,-1.,2*-10221.,-1. +,-1.,2*-10221.,-1. +,4*0. +,4*-1. +,4*0. +,4*-.5 +,4*-.5 +,4*-.5/ C DATA BITS/8,4,14,10,12,16*16,16*4/ C DATA OFFSET +/ 16, 24, 28, 42, 52, 64, 80, 96,112,128 +,144,160,176,192,208,224,240,256,272,288 +,304,320,324,328,332,336,340,344,348,352 +,356,360,364,368,372,376,380/ 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