PROGRAM READON C SAMPLE READ DRIVER FOR ON84 READ OF IDMXJDM GRIDS. C C SET WORD SIZE OF READING AND ORGINATING MACHINES (IN BITS) PARAMETER (IWSZ=32,IOWSZ=64) C C SET DIMENSIONS OF GRID TO BE READ PARAMETER (IDM=65,JDM=65) C PARAMETER (IJDM=IDM*JDM,NBITS=384+16*IJDM) PARAMETER (NOWDS=(NBITS+IOWSZ-1)/IOWSZ,NBYTES=(NOWDS*IOWSZ+7)/8) PARAMETER (IBDM=(NBYTES*8+IWSZ-1)/IWSZ) c BECAUSE OF DIFFERENCES IN WORD LENGTHS ON OLDER c AND NEWER COMPUTERS AT NCAR, THIS DATA SET CONTAINS DATA WITH C 2 DIFFERENT RECORD LENGTHS. THE DATA FROM JULY,1976 THROUGH MARCH, c 1983 HAVE A RECORD LENGTH OF 10,792 BYTES. THE DATA AFTER c MARCH 1993 HAS A RECORD LENGHT OF 10,784 BYTES. PARAMETER c ILT TELLS THE PROGRAM WHICH RECORD LENGTH YOU ARE TRYING TO READ c c NOTE 1) THIS IS ONLY A PROBLEM WHEN USING I/O THAT EXPECTS c FIXED LENGTH RECORDS (LIKE DIRECT ACCESS I/O ...WHICH c THIS PROGRAM USES) c NOTE 2) AT THIS TIME (12/10/93) , SOME OF THE FILES HAVE MIXED c RECORD LENGTHS...THIS PROGRAM WILL NOT READ THIS DATA...PLEASE c CONTACT DATA SUPPORT FOR HELP WITH THIS PROBLEM c NOTE 3) IF YOU ARE READING THE DATA ON A CRAY-YMP, YOU SHOULD USE c PROGRAM read.qsub IN THE SAME DIRECTORY THAT THIS FILE IS IN. 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 DIMENSION NBF(IBDM),VAL(IDM,JDM),DATA(IJDM),NDATA(IJDM) CHARACTER NFLNM*64 EQUIVALENCE(VAL,DATA) EQUIVALENCE(NDATA,DATA) IUN=1 PRINT 1000 1000 FORMAT(' ENTER FILE NAME - ') READ(5,'(A64)')NFLNM CALL GOPEN (IUN,NBYTES,NFLNM) 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,' BASE VAL(1,1) VAL(33,33) AVERAGE', 2 ' MINIMUM MAXIMUM') PRINT 1001,BASE,VAL(1,1),VAL(33,33),XAVE,XMIN,XMAX 1001 FORMAT(1X,8F12.3) IF(NPREC.GE. 1) 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 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 DIMENSION ISZ(40) 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/ 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 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 NERR=0 CALL GBYTES(NBF,NDATA,384,16,0,NJJ) 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) SAVE CHARACTER NFLNM*64 DIMENSION NBF(MXB) DATA NRPT/0/ 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 C SWAP4 CALLS ARE NECESSARY ON DEC (VAX), PC, AND OTHER BYTE SWAPPED MACHINES C 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,NBYTES,NFLNM) C ENTRY TO ALLOW OPEN OF FILE IF NECESSARY C C The exact I/O statements to be used depend on the form of the data file C and possible fortran extensions available. On many systems (UNIX and C most PC Fortrans) direct access I/O will work because the file structure C contains no control information and the record access is dependent C only on the correct record length being specified in the OPEN. C Sequential I/O will usually work if the file structure is either modified C to include the local control information or a tape is read directly. C Another option might be to use formatted I/O (with an "A" format) to C read in the records. This is often used on IBM systems. C NRECL=NBYTES OPEN(IUN,FILE=NFLNM,ACCESS='DIRECT',RECL=NRECL,FORM='UNFORMATTED') C OPEN(IUN,FILE=NFLNM,ACCESS='SEQUENTIAL',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 Get bytes - unpack bits: Extract arbitrary size values from a C packed bit string, right justifying each value in the unpacked C array. DIMENSION IN(*), IOUT(*) C IN = packed array input C IO = unpacked array output C ISKIP = initial number of bits to skip C NBYTE = number of bits to take C NSKIP = additional number of bits to skip on each iteration C N = number of iterations C************************************** MACHINE SPECIFIC CHANGES START HERE C Machine dependent information required: C LMWD = Number of bits in a word on this machine C MASKS = Set of word masks where the first element has only the C right most bit set to 1, the second has the two, ... C LEFTSH = Shift left bits in word M to the by N bits C RGHTSH = Shift right C OR = Logical OR (add) on this machine. C AND = Logical AND (multiply) on this machine C This is for Sun UNIX Fortran, DEC Alpha, and RS6000 PARAMETER (LMWD=32) DIMENSION MASKS(LMWD) SAVE MASKS DATA MASKS /'1'X,'3'X,'7'X,'F'X, '1F'X,'3F'X,'7F'X,'FF'X, +'1FF'X,'3FF'X,'7FF'X,'FFF'X, '1FFF'X,'3FFF'X,'7FFF'X,'FFFF'X, +'1FFFF'X, '3FFFF'X, '7FFFF'X, 'FFFFF'X, +'1FFFFF'X, '3FFFFF'X, '7FFFFF'X, 'FFFFFF'X, +'1FFFFFF'X, '3FFFFFF'X, '7FFFFFF'X, 'FFFFFFF'X, +'1FFFFFFF'X, '3FFFFFFF'X, '7FFFFFFF'X, 'FFFFFFFF'X/ C +'1FFFFFFFF'X, '3FFFFFFFF'X, '7FFFFFFFF'X, 'FFFFFFFFF'X, C +'1FFFFFFFFF'X, '3FFFFFFFFF'X, '7FFFFFFFFF'X, 'FFFFFFFFFF'X, C +'1FFFFFFFFFF'X, '3FFFFFFFFFF'X, '7FFFFFFFFFF'X, 'FFFFFFFFFFF'X, C +'1FFFFFFFFFFF'X,'3FFFFFFFFFFF'X,'7FFFFFFFFFFF'X,'FFFFFFFFFFFF'X, C +'1FFFFFFFFFFFF'X, '3FFFFFFFFFFFF'X, '7FFFFFFFFFFFF'X, C + 'FFFFFFFFFFFFF'X, C +'1FFFFFFFFFFFFF'X, '3FFFFFFFFFFFFF'X, '7FFFFFFFFFFFFF'X, C 'FFFFFFFFFFFFFF'X, C +'1FFFFFFFFFFFFFF'X, '3FFFFFFFFFFFFFF'X, '7FFFFFFFFFFFFFF'X, C 'FFFFFFFFFFFFFFF'X, C +'1FFFFFFFFFFFFFFF'X,'3FFFFFFFFFFFFFFF'X,'7FFFFFFFFFFFFFFF'X, C 'FFFFFFFFFFFFFFFF'X/ C IBM PC using Microsoft Fortran uses different syntax: C DATA MASKS/16#1,16#3,16#7,16#F,16#1F,16#3F,16#7F,16#FF, C + 16#1FF,16#3FF,16#7FF,16#FFF,16#1FFF,16#3FFF,16#7FFF,16#FFFF, C + 16#1FFFF,16#3FFFF,16#7FFFF,16#FFFFF,16#1FFFFF,16#3FFFFF, C + 16#7FFFFF,16#FFFFFF,16#1FFFFFF,16#3FFFFFF,16#7FFFFFF,16#FFFFFFF, C + 16#1FFFFFFF,16#3FFFFFFF,16#7FFFFFFF,16#FFFFFFFF/ INTEGER RGHTSH, OR, AND LEFTSH(M,N) = ISHFT(M,N) RGHTSH(M,N) = ISHFT(M,-N) C OR(M,N) = M.OR.N C AND(M,N) = M.AND.N C************************************** MACHINE SPECIFIC CHANGES END HERE C History: written by Robert C. Gammill, jul 1972. C NBYTE must be less than or equal to LMWD ICON = LMWD-NBYTE IF (ICON.LT.0) RETURN MASK = MASKS (NBYTE) C INDEX = number of words into IN before the next "byte" appears C II = number of bits the "byte" is from the left side of the word C ISTEP = number of bits from the start of one "byte" to the next C IWORDS = number of words to skip from one "byte" to the next C IBITS = number of bits to skip after skipping IWORDS C MOVER = number of bits to the right, a byte must be moved to be C right adjusted INDEX = ISKIP/LMWD II = MOD (ISKIP,LMWD) ISTEP = NBYTE+NSKIP IWORDS= ISTEP/LMWD IBITS = MOD (ISTEP,LMWD) DO 6 I=1,N MOVER = ICON-II IF (MOVER) 2,3,4 C The "byte" is split across a word break. 2 MOVEL = -MOVER MOVER = LMWD-MOVEL NP1 = LEFTSH (IN(INDEX+1),MOVEL) NP2 = RGHTSH (IN(INDEX+2),MOVER) IOUT(I) = AND (OR (NP1,NP2) , MASK) GO TO 5 C The "byte" is already right adjusted. 3 IOUT(I) = AND (IN (INDEX+1) , MASK) GO TO 5 C Right adjust the "byte". 4 IOUT(I) = AND (RGHTSH (IN (INDEX+1),MOVER) , MASK) 5 II = II+IBITS INDEX = INDEX+IWORDS IF (II .LT. LMWD) GO TO 6 II = II-LMWD INDEX = INDEX+1 6 CONTINUE RETURN END SUBROUTINE SBYTES (IOUT,IN,ISKIP,NBYTE,NSKIP,N) C Store bytes - pack bits: Put arbitrary size values into a C packed bit string, taking the low order bits from each value C in the unpacked array. DIMENSION IN(*), IOUT(*) C IOUT = packed array output C IN = unpacked array input C ISKIP = initial number of bits to skip C NBYTE = number of bits to pack C NSKIP = additional number of bits to skip on each iteration C N = number of iterations C************************************** MACHINE SPECIFIC CHANGES START HERE C Machine dependent information required: C LMWD = Number of bits in a word on this machine C MASKS = Set of word masks where the first element has only the C right most bit set to 1, the second has the two, ... C LEFTSH = Shift left bits in word M to the by N bits C RGHTSH = Shift right C OR = Logical OR (add) on this machine C AND = Logical AND (multiply) on this machine C NOT = Logical NOT (negation) on this machine C This is for Sun UNIX Fortran PARAMETER (LMWD=32) DIMENSION MASKS(LMWD) SAVE MASKS DATA MASKS /'1'X,'3'X,'7'X,'F'X, '1F'X,'3F'X,'7F'X,'FF'X, +'1FF'X,'3FF'X,'7FF'X,'FFF'X, '1FFF'X,'3FFF'X,'7FFF'X,'FFFF'X, +'1FFFF'X, '3FFFF'X, '7FFFF'X, 'FFFFF'X, +'1FFFFF'X, '3FFFFF'X, '7FFFFF'X, 'FFFFFF'X, +'1FFFFFF'X, '3FFFFFF'X, '7FFFFFF'X, 'FFFFFFF'X, +'1FFFFFFF'X, '3FFFFFFF'X, '7FFFFFFF'X, 'FFFFFFFF'X/ INTEGER RGHTSH, OR, AND LEFTSH(M,N) = ISHFT(M,N) RGHTSH(M,N) = ISHFT(M,-N) C OR(M,N) = M.OR.N C AND(M,N) = M.AND.N C NOT(M) = .NOT.M C*********************************************************************** C NBYTE must be less than or equal to LMWD ICON = LMWD-NBYTE IF (ICON .LT. 0) RETURN MASK = MASKS(NBYTE) C INDEX = number of words into IOUT the next "byte" is to be stored C II = number of bits in from the left side of the word to store it C ISTEP = number of bits from the start of one "byte" to the next C IWORDS = number of words to skip from one "byte" to the next C IBITS = number of bits to skip after skipping IWORDS C MOVER = number of bits to the right, a byte must be moved to be C right adjusted INDEX = ISKIP/LMWD II = MOD(ISKIP,LMWD) ISTEP = NBYTE+NSKIP IWORDS = ISTEP/LMWD IBITS = MOD(ISTEP,LMWD) DO 6 I=1,N J = AND (MASK,IN(I)) MOVEL = ICON-II IF (MOVEL) 2,3,4 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(LMWD+MOVEL),IOUT(INDEX+2)) IOUT(INDEX+2) = OR(ITEMP,LEFTSH(J,LMWD+MOVEL)) GO TO 5 C The "byte" is to be stored right-adjusted 3 IOUT(INDEX+1) = OR ( AND (NOT(MASK),IOUT(INDEX+1)) , J) GO TO 5 C The "byte" is to be stored in middle of word, so 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. LMWD) GO TO 6 II = II-LMWD INDEX = INDEX+1 6 CONTINUE RETURN END