cat > p.f <<\EOR PROGRAM QL8 C-----READ AND PRINT DSUL1 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 .01B. SL 85/01/25. REVISED COMMENTS. C .01C. SL 85/10/15. RECOGNIZES LAND. C .01D. SL 92/05/14. DIRECT ACCESS, UNFORMATTED READ. C .01E. SL 12/04/23. GFORTRAN. C ------------------------------------------------------------------ C C ===1=========2=========3========4=========5=========6=========7== IMPLICIT INTEGER(A-E,G-Z) C PARAMETER(MAX=200,RPTOFF=1,FMISS=-9999.,INDEXCK=5,BPR=384,ID=0 +,BPW=32,DIM BUF=6,DIM PK=(BPR-1)/BPW+1,DIM UN=23 +,FLAND=-8888.) C CHARACTER*8 DTE,TME C COMMON /DSUL1/FTRUEL(23),FTRUEU(23),FUNITS(23),FBASE(23) +,BITS(23),OFFSET(23) C DIMENSION BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN) C C-----2 DIMENSIONAL FTRUE DIMENSION FTRUE2(3,6) EQUIVALENCE (FTRUE(6),FTRUE2) C DATA LEVEL/4H.01E/,BUF/DIM BUF*0/ C CALL DATE(DTE) CALL CLOCK(TME) PRINT 1,LEVEL,DTE,TME 1 FORMAT('1QL8',A4,2A9) OPEN(1,FORM='UNFORMATTED',ACCESS='DIRECT',RECL=48) 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 +,FLAND) IF(JEOF.NE.0)GOTO 900 C PRINT 300,(FTRUE(I),I=1,5),((FTRUE2(I,J),J=1,6),I=1,3) 300 FORMAT(/' BOX10 ',F4.0,' MONTH ',F3.0,' BOX2 ',F6.0 +,' PERIOD ',F5.0,' CHECKSUM ',F6.0/ +2X,7X,'S',7X,'A',7X,'U',7X,'V',7X,'P',7X,'R'/ +1X,'L',5F8.2,F8.1/ +1X,'G',5F8.2,F8.1/ +1X,'U',5F8.2,F8.1) GOTO 100 IF(BUF(2).LT.MAX)GOTO 100 C 900 PRINT *,' REPORTS ',BUF(2),', EOF ',JEOF END C======================================================================= BLOCK DATA IMPLICIT INTEGER(A-E,G-Z) C COMMON /DSUL1/FTRUEL(23),FTRUEU(23),FUNITS(23),FBASE(23) +,BITS(23),OFFSET(23) C DATA FTRUEL/3*1.,1800.,0. +,3*-5.,3*-88.,6*-102.2,3*870.,3*0./ C DATA FTRUEU/648.,12.,16202.,2054.,4094. +,3*40.,3*58.,6*102.2,3*1074.6,3*100./ C DATA FUNITS/5*1. +,15*.01,3*.1/ C DATA FBASE/3*0,1799,0 +,3*-501,3*-8801,6*-10221,3*86999,3*-1/ C DATA BITS/10,4,14,8,12 +,18*16/ C DATA OFFSET/ 16, 26, 30, 44, 52 +, 64, 80, 96,112,128,144,160,176,192,208 +,224,240,256,272,288,304,320,336/ 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 +,FLAND) 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 C 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 CK=CK+UN(I) IF(UN(I).EQ.65534)GOTO 225 FTRUE(I)=(UN(I)+FBASE(I))*FUNITS(I) GOTO 230 210 FTRUE(INDEXCK)=UN(INDEXCK) GOTO 230 220 FTRUE(I)=FMISS GOTO 230 225 FTRUE(I)=FLAND 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 - FORTRAN UNIT C BPR - BITS PER RECORD C BPW - BITS PER WORD C OUTPUT C BUF(DIM BUF) - COUNTS C RCD(DIM RCD) - LOGICAL RECORD C JEOF - 0=FALSE 1=TRUE C C BUF(1) = READ(,REC= COUNT C BUF(2) = LOGICAL RECORD COUNT C BUF(3) = C BUF(4) = C BUF(5) = BLOCK LENGTH IN BITS C BUF(6) = C IMPLICIT INTEGER(A-E,G-Z) CHARACTER RCD*48 DIMENSION BUF(DIM BUF) C 100 READ(TAPE,REC=BUF(1)+1,IOSTAT=IOS)RCD IF(IOS.NE.0)GOTO 900 BUF(1)=BUF(1)+1 IF(RCD(1:8).EQ.CHAR(0)//CHAR(0)//CHAR(0)//CHAR(0) +//CHAR(0)//CHAR(0)//CHAR(0)//CHAR(0))GOTO 100 BUF(2)=BUF(2)+1 JEOF=0 RETURN 900 JEOF=1 END EOR rm fort.1 a.out #ln -s ZKT1 fort.1 ln -s ZKT2 fort.1 #ln -s ZKU1 fort.1 gfortran p.f date.f gsbytes.f ./a.out