PROGRAM READON C SAMPLE READ DRIVER FOR ON84 READ OF IDMXJDM GRIDS. C C SET WORD SIZE OF READING MACHINE (IN BITS) PARAMETER (IWSZ=32) C C SET DIMENSIONS OF GRID TO BE READ PARAMETER (IDM=41,JDM=38) C PARAMETER (IJDM=IDM*JDM,IBD64=(384+IJDM*16+63)/64) PARAMETER (IBDM=(64*IBD64+IWSZ-1)/IWSZ,IBYT=8*IBD64) C COMMON /CON84/NQ(1),NS1,NF1,NTM,NC1,NE1,NMA,NEM,NS2,NF2, 2 NNM,NC2,NE2,NCD,NCH,NKS,NK,NUN,NRN,NNW,NYY,NMM,NDD,NII, 3 NRM,NGP,NJJ,NBB,NCSM,NBSN,NBEX,NBFR,NUN1,NUN2,NSCL,BASE, 4 SFC1,SFC2,NIDIM,NJDIM DIMENSION NBF(IBDM),VAL(IDM,JDM),DATA(IJDM),NDATA(IJDM) EQUIVALENCE(VAL,DATA) EQUIVALENCE(NDATA,DATA) IUN=1 CALL GOPEN (IUN,IBYT,FLNM) MXB=IBDM NPREC=0 NREC=0 10 CALL RON84(IUN,NBF,MXB,IST) IF(IST .NE. 0) GO TO 90 NREC=NREC+1 C NSFC1=SFC1+.5 NSFC2=SFC2+.5 PRINT 1007 1007 FORMAT('0 REC YEAR MONTH DAY HOUR K J Q', 2 ' S1 C1E1 S2 C2E2 F1 F2') PRINT 1003,NREC,NYY,NMM,NDD,NII,NK,NJJ,NQ,NS1,NSFC1,NS2,NSFC2, 2 NF1,NF2 1003 FORMAT(1X,20I6) CALL UON84(NBF,NDATA,DATA,NERR) IF(NERR .NE. 0) GO TO 10 C SCALE VALUES FOR PRINTING SCL=1. IF(NQ(1).EQ.90) SCL=1000. DATA(1)=DATA(1)*SCL XMAX=DATA(1) XMIN=DATA(1) XAVE=DATA(1) DO 21 I=2,NJJ DATA(I)=DATA(I)*SCL IF (DATA(I) .GT. XMAX) XMAX=DATA(I) IF (DATA(I) .LT. XMIN) XMIN=DATA(I) XAVE=XAVE+DATA(I) 21 CONTINUE XAVE=XAVE/NJJ NIJK=NJJ/2 PRINT 1008 1008 FORMAT(1X,' A DATA(1) DATA(J) AVERAGE', 2 ' MINIMUM MAXIMUM') PRINT 1001,BASE,DATA(1),DATA(NJJ),XAVE,XMIN,XMAX 1001 FORMAT(1X,8F12.3) IF(NPREC.GT. 2) GO TO 10 C PRINT GRID NPREC=NPREC+1 DO 40 IS=1,IDM,14 IE=IS+13 IF(IE.GT.IDM) IE=IDM PRINT 1005,(I,I=IS,IE) 1005 FORMAT(1H0,9X,14I8) DO 22 JJ=1,JDM J=JDM+1-JJ PRINT 1006,J,(VAL(I,J),I=IS,IE) 1006 FORMAT(2X,I6,2X,14F8.1) 22 CONTINUE 40 CONTINUE GO TO 10 90 CONTINUE PRINT 1004,IST,NREC 1004 FORMAT('0EXIT,STATUS,RECS ',I8,I9) END SUBROUTINE RON84(IUN,NBF,MXB,IST) DIMENSION NBF(MXB) C C READS NMC OFFICE NOTE 84 FORMAT. C C READ STATEMENT MUST BE APPROPRIATE TO READING SYSTEM C C IUN= TAPE UNIT. NBF = TAPE READ BUFFER DIMENSIONED BY MXB. C IST = READ STATUS WHERE 0=OK, 1=EOF, AND 2 = ERROR. C C ALL PARAMETERS IN CON84 ARE RETURNED AND THEIR MEANINGS ARE EXPLAINED C IN NMC ON84. THEIR VALUES MUST NOT BE MODIFIED BY THE CALLING PROGRAM. C VALUES FOR BASE, SFC1, AND SFC2 ARE DERIVED FROM THEIR COMPONENTS IN C ID SECTION OF THE FORMAT. C NIDIM AND NJDIM ARE I AND J DIMENSIONS OF GRID WHICH HAS BEEN READ. C COMMON /CON84/NQ(1),NS1,NF1,NTM,NC1,NE1,NMA,NEM,NS2,NF2, 2 NNM,NC2,NE2,NCD,NCH,NKS,NK,NUN,NRN,NNW,NYY,NMM,NDD,NII, 3 NRM,NGP,NJJ,NBB,NCSM,NBSN,NBEX,NBFR,NUN1,NUN2,NSCL,BASE, 4 SFC1,SFC2,NIDIM,NJDIM DIMENSION ISZ(40) DIMENSION IDIM(70),JDIM(70) DATA ISZ/12,12,8,4,20,8,4,8,12,8,4,20,8,8,8,8,8,4,12,16,8, 2 8,8,8,8,8,16,16,16,1,7,24,8,8,16,5*0/ DATA IDIM/47,73,73,53,17,53,47,0,116,143, 1 216,286,74,36,108,40,39,17,0,47, 2 45,73,73,29,31,53,53,65,65,145, 3 145,327,31,181,181,228,41,145,145,181, 4 181,34,0,65,65,97,97,113,0,129, 5 129,257,257,117,35,87,87,15,1,79, 6 10*0/ DATA JDIM/51,23,24,57,30,57,51,0,44,1, 1 1,1,23,16,1,1,40,13,0,51, 2 59,19,19,27,21,57,45,65,65,37, 3 37,1,24,46,46,1,38,37,37,46, 4 46,25,0,65,65,25,25,89,0,129, 5 129,257,257,51,30,71,71,16,1,67, 6 10*0/ CALL GREAD(IUN,NBF,MXB,IBYT,IST) IF(IST .EQ. 0) GO TO 10 IF(IST .EQ. 1) RETURN PRINT 1001,IST,MXB 1001 FORMAT(' ERROR IN RON84 - IST,MXB ',2I8) RETURN 10 I=1 IOFF=0 20 CALL GBYTES(NBF,NQ(I),IOFF,ISZ(I),0,1) IOFF=IOFF+ISZ(I) I=I+1 IF(ISZ(I) .GT. 0) GO TO 20 IF(NC2 .GT. 524288) NC2=524288-NC2 IF(NC1 .GT. 524288) NC1=524288-NC1 IF(NE1 .GT. 128) NE1=128-NE1 IF(NE2 .GT. 128) NE2=128-NE2 SFC1=FLOAT(NC1)*10.**NE1 SFC2=FLOAT(NC2)*10.**NE2 BASE=FLOAT(NBFR)*16.**(NBEX-70) IF(NSCL .GE. 32768) NSCL=NSCL-65536 IF(NBSN .NE. 0) BASE=-BASE NIDIM=IDIM(NK+1) NJDIM=JDIM(NK+1) RETURN END SUBROUTINE UON84(NBF,NDATA,DATA,NERR) C C UNPACKS ON84 DATA WHICH HAS BEEN READ BY RON84. C NBF IS UNMODIFIED BUFFER AS READ BY RDON84. DATA IS ARRAY TO CONTAIN C DATA WHICH MUST BE DIMENSION APPROPRIATE TO THE GRID BEING UNPACKED. C NERR IS STATUS RETURN WHERE NONZERO VALUE INDICATES THAT NBF HAS C BEEN CHANGED BY USER AFTER READ OR THEIR WAS A BAD READ. C DIMENSION NBF(1),NDATA(1),DATA(1) COMMON /CON84/NQ(1),NS1,NF1,NTM,NC1,NE1,NMA,NEM,NS2,NF2, 2 NNM,NC2,NE2,NCD,NCH,NKS,NK,NUN,NRN,NNW,NYY,NMM,NDD,NII, 3 NRM,NGP,NJJ,NBB,NCSM,NBSN,NBEX,NBFR,NUN1,NUN2,NSCL,BASE, 4 SFC1,SFC2,NIDIM,NJDIM NERR=0 IF(NK .NE. 32 .AND. NK .NE. 36) GO TO 8 C CHANGE FROM COLUMN TO ROW ORDERING IOFF=384 IK=NIDIM JK=NJDIM ISKP=16*(JK-1) DO 6 I=1,JK II=IK*(I-1)+1 CALL GBYTES(NBF,NDATA(II),IOFF,16,ISKP,IK) 6 IOFF=IOFF+16 GO TO 9 8 CALL GBYTES(NBF,NDATA,384,16,0,NJJ) 9 CONTINUE SCL2=2.**(NSCL-15) DO 10 I =1,NJJ IDT= NDATA(I) IF(IDT .GE. 32768) IDT=IDT-65536 DATA(I)=FLOAT(IDT)*SCL2+BASE 10 CONTINUE RETURN END SUBROUTINE GREAD(IUN,NBF,MXB,IBYT,IST) CHARACTER NFLNM*64 DIMENSION NBF(MXB) C APPROPRIATE SYSTEM READ MUST BE USED IN THIS SUBROUTINE C C INPUT ARGS C IUN - FORTRAN LOGICAL UNIT C NBF - BUFFER DIMENSION LARGE ENOUGH TO CONTAIN DATA RECORD C MXB - DIMENSION OF NBF C C OUTPUT ARGS C NBF - BUFFER CONTAINS RECORD READ C IBYT - NUMBER OF BYTES ACTUALLY READ C IST - STATUS OF READ 0 = GOOD READ, 1 = EOF, 2 = ERROR, 3= END OF DATA NRPT=NRPT+1 READ(IUN,ERR=90,REC=NRPT,IOSTAT=ISTAT)(NBF(I),I=1,MXB) IF(ISTAT.EQ.-1) GO TO 95 IF(ISTAT.NE.0) GO TO 90 CALL SWAP4(NBF,NBF,NRECL) IBYT=8*MXB RETURN 90 CONTINUE PRINT 1001,ISTAT 1001 FORMAT(' ERROR IN GREAD - ISTAT = ',I12) IST=2 RETURN 95 IST=1 RETURN C ENTRY GOPEN(IUN,IBYT,FLNM) C ENTRY TO ALLOW OPEN OF FILE IF NECESSARY C NRECL=IBYT PRINT 1000 1000 FORMAT(' ENTER FILE NAME - ') READ(5,'(A)')NFLNM OPEN(IUN,FILE=NFLNM,ACCESS='DIRECT',RECL=NRECL,FORM='UNFORMATTED') NRPT=0 RETURN END SUBROUTINE GBYTE(IN,IOUT,ISKIP,NBYTE) CALL GBYTES(IN,IOUT,ISKIP,NBYTE,0,1) RETURN END SUBROUTINE SBYTE(IOUT,IN,ISKIP,NBYTE) CALL SBYTES(IOUT,IN,ISKIP,NBYTE,0,1) RETURN END SUBROUTINE GBYTES(IN,IOUT,ISKIP,NBYTE,NSKIP,N) C THIS PROGRAM WRITTEN BY..... C DR. ROBERT C. GAMMILL, CONSULTANT C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH C MAY 1972 C THIS IS THE FORTRAN VERSION OF GBYTES. COMMON/MACHIN/NBITSW,NBITSC,MASK0,MASKS(32) DIMENSION IN(1),IOUT(1) C THE STATEMENTS BETWEEN ASTERISK LINES GIVE ALL NECESSARY MACHINE C DEPENDENT INFORMATION C*********************************************************************** C THIS SPECIFICATION IS FOR IBM PC USING MICROSOFT FORTRAN INTEGER RGHTSH,OR,AND LEFTSH(M,N)=ISHFT(M,N) RGHTSH(M,N)=ISHFT(M,-N) OR(M,N)=IOR(M,N) AND(M,N)=IAND(M,N) DATA NBITSW/32/ DATA MASK0/16#0/ DATA MASKS/16#1,16#3,16#7,16#F,16#1F,16#3F,16#7F,16#FF, 2 16#1FF,16#3FF,16#7FF,16#FFF,16#1FFF,16#3FFF,16#7FFF,16#FFFF, 3 16#1FFFF,16#3FFFF,16#7FFFF,16#FFFFF,16#1FFFFF,16#3FFFFF, 4 16#7FFFFF,16#FFFFFF,16#1FFFFFF,16#3FFFFFF,16#7FFFFFF,16#FFFFFFF, 5 16#1FFFFFFF,16#3FFFFFFF,16#7FFFFFFF,16#FFFFFFFF/ C*********************************************************************** C NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW ICON=NBITSW-NBYTE IF(ICON.LT.0) RETURN MASK=MASKS(NBYTE) C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IN' THE NEXT BYTE APPEARS. INDEX=ISKIP/NBITSW C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD. II=MOD(ISKIP,NBITSW) C ISTEP IS THE DISTANCE IN BITS FROM THE START OF ONE BYTE TO THE NEXT. ISTEP=NBYTE+NSKIP C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. IWORDS=ISTEP/NBITSW C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. IBITS=MOD(ISTEP,NBITSW) DO 6 I=1,N C MOVER SPECIFIES HOW FAR TO THE RIGHT A BYTE MUST BE MOVED IN ORDER C TO BE RIGHT ADJUSTED. MOVER=ICON-II IF(MOVER) 2,3,4 C C THE BYTE IS SPLIT ACROSS A WORD BREAK. 2 MOVEL=-MOVER MOVER=NBITSW-MOVEL C EXPAND STATEMENT SINCE MSFORTRAN SEEMS TO FAIL OTHERWISE NP1=LEFTSH(IN(INDEX+1),MOVEL) NP2=RGHTSH(IN(INDEX+2),MOVER) C NP3=OR(LEFTSH(IN(INDEX+1),MOVEL),RGHTSH(IN(INDEX+2),MOVER)) IOUT(I)=AND(OR(NP1,NP2),MASK) C IOUT(I)=AND(OR(LEFTSH(IN(INDEX+1),MOVEL),RGHTSH(IN(INDEX+2),MOVER) C 1 ),MASK) GO TO 5 C C THE BYTE IS ALREADY RIGHT ADJUSTED. 3 IOUT(I)=AND(IN(INDEX+1),MASK) GO TO 5 C C RIGHT ADJUST THE BYTE. 4 IOUT(I)=AND(RGHTSH(IN(INDEX+1),MOVER),MASK) C C INCREMENT II AND INDEX. 5 II=II+IBITS INDEX=INDEX+IWORDS IF(II.LT.NBITSW) GO TO 6 II=II-NBITSW INDEX=INDEX+1 6 CONTINUE RETURN END SUBROUTINE SBYTES(IOUT,IN,ISKIP,NBYTE,NSKIP,N) C THIS PROGRAM WRITTEN BY..... C DR. ROBERT C. GAMMILL, CONSULTANT C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH C JULY 1972 C THIS IS THE FORTRAN VERSIONS OF SBYTES. COMMON/MACHIN/NBITSW,NBITSC,MASK0,MASKS(32) DIMENSION IN(1),IOUT(1) C C THE STATEMENTS BETWEEN ASTERISK LINES GIVE ALL NECESSARY MACHINE C DEPENDENT INFORMATION C*********************************************************************** C THIS SPECIFICATION IS SUITABLE FOR CDC 6000 SERIES COMPUTERS. INTEGER RGHTSH,OR,AND OR(M,N)=IOR(M,N) AND(M,N)=IAND(M,N) C LEFTSH(M,N)=ISHFT(M,N) RGHTSH(M,N)=ISHFT(M,-N) C*********************************************************************** C C NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW ICON=NBITSW-NBYTE IF(ICON.LT.0) RETURN MASK=MASKS(NBYTE) C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED. INDEX=ISKIP/NBITSW C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT. II=MOD(ISKIP,NBITSW) C ISTEP IS THE DISTANCE IN BITS FROM ONE BYTE POSITION TO THE NEXT. ISTEP=NBYTE+NSKIP C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. IWORDS=ISTEP/NBITSW C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. IBITS=MOD(ISTEP,NBITSW) DO 6 I=1,N J=AND(MASK,IN(I)) MOVEL=ICON-II IF(MOVEL) 2,3,4 C C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK. 2 MSK=MASKS(NBYTE+MOVEL) IOUT(INDEX+1)=OR(AND(NOT(MSK),IOUT(INDEX+1)),RGHTSH(J,-MOVEL)) ITEMP=AND(MASKS(NBITSW+MOVEL),IOUT(INDEX+2)) IOUT(INDEX+2)=OR(ITEMP,LEFTSH(J,NBITSW+MOVEL)) GO TO 5 C C BYTE IS TO BE STORED RIGHT-ADJUSTED. 3 IOUT(INDEX+1)=OR(AND(NOT(MASK),IOUT(INDEX+1)),J) GO TO 5 C C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT. 4 MSK=LEFTSH(MASK,MOVEL) IOUT(INDEX+1)=OR(AND(NOT(MSK),IOUT(INDEX+1)),LEFTSH(J,MOVEL)) 5 II=II+IBITS INDEX=INDEX+IWORDS IF(II.LT.NBITSW) GO TO 6 II=II-NBITSW INDEX=INDEX+1 6 CONTINUE RETURN END SUBROUTINE SWAP4(IN,IO,NN) LOGICAL*1 IN(1),IO(1),IH DO 10 I=1,NN,4 IH=IN(I) IO(I)=IN(I+3) IO(I+3)=IH IH=IN(I+1) IO(I+1)=IN(I+2) IO(I+2)=IH 10 CONTINUE RETURN END