PROGRAM QI24 C-----READ AND PRINT DSU2 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=250,RPTOFF=1,FMISS=-9999.,INDEXCK=5,BPR=960,ID=0 +,BPW=60,DIM BUF=(1006*64-1)/BPW+1,DIM PK=(BPR-1)/BPW+1,DIM UN=58) C COMMON /DSU2/FUNITS(58),FBASE(58),BITS(58),OFFSET(58) C DIMENSION BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN) C C-----2 DIMENSIONAL FTRUE DIMENSION FTRUE2(8,6) 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('1QI24',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(/' DECADE ',F4.0,' MONTH ',F3.0,' BOX2 ',F6.0,' BOX10 ' +,F4.0,' CHECKSUM ',F6.0/ +8X,'0',7X,'1',7X,'2',7X,'3',7X,'4',7X,'5',7X,'6',7X,'N'/ +1X,'S',7F8.2,F8.0/ +1X,'A',7F8.2,F8.0/ +1X,'U',7F8.2,F8.0/ +1X,'V',7F8.2,F8.0/ +1X,'P',7F8.2,F8.0/ +1X,'R',7F8.1,F8.0/ +1X,' U ',F8.2,' V ',F8.2,' UV ',F8.2,' UU ',F8.2,' VV ',F8.2) IF(BUF(2).LT.MAX)GOTO 100 C 900 PRINT *,' REPORTS ',BUF(2),', EOF ',JEOF END C======================================================================= BLOCK DATA DSU2 IMPLICIT INTEGER(A-E,G-Z) COMMON /DSU2/FUNITS(58),FBASE(58),BITS(58),OFFSET(58) C DATA FUNITS/5*1. +,7*.01,1. ,7*.01,1. ,7*.01,1. ,7*.01,1. ,7*.01,1. ,7*.1,1. +,5*.01/ C +,FBASE/179,4*0 +,7*-501,0 ,7*-8801,0 ,7*-10221,0 ,7*-10221,0 ,7*86999,0 ,7*-1,0 +,2*-10221,-522243,2*-1/ C +,BITS/8,4,14,10,12,50*16,3*32/ C +,OFFSET/ + 16, 24, 28, 42, 52, 64, 80, 96,112,128,144,160,176,192,208,224 +,240,256,272,288,304,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,896,928/ 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