PROGRAM QL21 C-----READ AND PRINT CMR5 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=300,RPTOFF=1,FMISS=-999.9,INDEXCK=35,BPR=192,ID=0 +,BPW=60,DIM BUF=(1006*64-1)/BPW+1,DIM PK=(BPR-1)/BPW+1,DIM UN=35) C COMMON /CMR5/FIELD(35),FTRUEL(35),FTRUEU(35),FUNITS(35) +,FBASE(35),BITS(35),OFFSET(35) C DIMENSION BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN) C DATA LEVEL/4H.01C/,BUF/DIM BUF*0/ C CALL DATE(DTE) CALL TIME(TME) PRINT 1,LEVEL,DTE,TME 1 FORMAT('1QL21',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,(FIELD(I),FTRUE(I),I=1,DIM UN) 300 FORMAT(6(1X,A5,F7.1)) IF(BUF(2).LT.MAX)GOTO 100 C 900 PRINT *,' REPORTS ',BUF(2),', EOF ',JEOF END C======================================================================= BLOCK DATA CMR5 IMPLICIT INTEGER(A-E,G-Z) C COMMON /CMR5/FIELD(35),FTRUEL(35),FTRUEU(35),FUNITS(35) +,FBASE(35),BITS(35),OFFSET(35) C DATA FIELD/8HBOX10 ,8HMONTH ,8HBOX2 ,8HYEAR ,8HDAY , +8HHOUR ,8HX ,8HY ,8HS ,8HBI ,8HA , +8HDP ,8HTI ,8HU ,8HV ,8HDI ,8HWI , +8HP ,8HC ,8HNH ,8HCL ,8HH ,8HHI , +8HCM ,8HCH ,8HST ,8HPW ,8HCD ,8HLF , +8HSF ,8HAF ,8HRF ,8HWF ,8HPF ,8HCK / C DATA FTRUEL/3*1.,1800.,1.,3*0.,-5.,0.,-88.,2*0.,2*-102.2,2*0.,870. +,17*0./ C DATA FTRUEU/648.,12.,16202.,2054.,31.,23.,2*2.,40.,2.,58.,70.,5. +,2*102.2,5.,1.,1074.6,2*9.,2*10.,1.,2*10.,7.,99.,999.,0.,5*2.,30./ C DATA FUNITS/6*1.,3*.1,1.,2*.1,1.,2*.1,2*1.,.1,17*1./ C DATA FBASE/3*0,1799,0,3*-1,-51,-1,-881,2*-1,2*-1023,2*-1,8699 +,16*-1,0/ C DATA BITS/10,4,14,8,4*5,9,2,11,10,3,2*11,3,2,11,4*4,2,3*4,7,10 +,1,5*2,5/ C C RPTOFF 0 C DATA OFFSET/ C + 64, 74, 78, 92,100,105,110,115,120,129,131,142,152,155,166,177 C +,180,182,193,197,201,205,209,211,215,219,223,230,240,241,243,245 C +,247,249,251/ C C RPTOFF 1 DATA OFFSET/ + 0, 10, 14, 28, 36, 41, 46, 51, 56, 65, 67, 78, 88, 91,102,113 +,116,118,129,133,137,141,145,147,151,155,159,166,176,177,179,181 +,183,185,187/ 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