C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * fluxread.F C * C * SAMPLE READ PROGRAM FOR Kuwait region subset of Northern C * Hemisphere longitude/latitude grid. C * C * Copyright 1992, University Corporation for C * Atmospheric Research, All Rights Reserved C * C * DJ (NCAR/SCD/DSS) C * ADM (NCAR/ATD/RAF) modified 30 June 92 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Data start March 7 (date of NMC model change) C Range is 9.375-80.625 longitude (77), -0.472-60 latitude (65) with a C ~.975 degree resolution (Gaussian grid), 4 per day (hours 0,6,12,18). C The data start at -0.472, 9.375 and scan east along a C latitude line, then move north. C C NMC ON84 format plus these: (sensible heat, latent heat) C 594: SH flux, 595: LH flux, 522: soil moisture. C Also top of atmosphere: 528 (as a "level" value, for radiation etc.) C filenames are: C --- jan 1991 C --- feb 1991 C Y11085 mar 1991 G003.3.19910307000000.all C Y11086 apr 1991 G003.4.19910401000000.all C Y11087 may 1991 G003.5.19910501000000.all C Y11088 jun 1991 G003.6.19910601000000.all C Y11089 jul 1991 G003.7.19910701000000.all C Y11090 aug 1991 G003.8.19910801000000.all C Y11091 sep 1991 G003.9.19910901000000.all C Y11092 oct 1991 G003.10.19911001000000.all C Y11093 nov 1991 G003.11.19911101000000.all C Y11094 dec 1991 G003.12.19911201000000.all C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C PROGRAM DESCRIPTION: C C PROGRAM READON asks the user to select a month,day,and hour, C and then the QUANTITY and PRESSURE LEVEL. The minimum, maximum, C and average values are displayed and the entire grid is written C to a text file NMC_FLUX.DAT. The program loops to repeat the C month selection. C C___________________________________________________ C C NOTE: this OPEN call may give you a compile C error. If so, replace ACCESS='APPEND' C with ACCESS='SEQUENTIAL' C C code is in section PRINT GRID: C ----------- PRINT GRID ----------- C ... C OPEN(UNIT=IOUT, FILE='NMC_FLUX.DAT', C + FORM='FORMATTED',ACCESS='APPEND', C + STATUS='OLD') C C___________________________________________________ C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * PROGRAM READON C * C * SAMPLE READ DRIVER FOR ON84 READ OF IDM X JDM GRIDS. C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * PROGRAM READON C C SET WORD SIZE OF READING MACHINE (IN BITS) PARAMETER (IWSZ=32) C C SET DIMENSIONS OF GRID TO BE READ PARAMETER (IDM=77,JDM=65) 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 INTEGER QINDEX(20),SINDEX(3),IQQ,ICE,ISS INTEGER YY,MM,DD,HH CHARACTER*40 ANSWER CHARACTER*4 QTXT(20) CHARACTER*20 LTXT(3) LOGICAL ITIS DIMENSION NBF(IBDM),VAL(IDM,JDM),DATA(IJDM),NDATA(IJDM) EQUIVALENCE(VAL,DATA) EQUIVALENCE(NDATA,DATA) C------------------------------------------------------------------- C C INITIALIZATION C IUN=1 IOUT=8 CALL INITAL C------------------------------------------------------------------- C C START LOOP THAT WILL END WHEN EOF OR ERROR OCCURS C 5 CONTINUE IST=0 CALL GOPEN (IUN,IBYT,FLNM,MM,IST) C --- check for OPEN ERROR --- IF (IST.NE.0) GO TO 90 MXB=IBDM NPREC=0 NREC=0 C------------------------------------------------------------------- C C ASK USER FOR DAY,HOUR, QUANTITY AND SURFACE VALUES C YY=91 !year must be 1991 15 WRITE(*,*) WRITE(*,'(A)') + 'ENTER A DAY [1-31/''quit''] --> ' READ(*,'(A)') ANSWER IF (ANSWER.EQ.'QUIT' .OR. ANSWER.EQ.'quit') THEN IST=4 !set flag to QUIT GO TO 90 ENDIF READ(ANSWER,'(I2)') DD IF (DD.LT.1 .OR. DD.GT.31) GO TO 15 16 WRITE(*,*) WRITE(*,'(A)') + 'ENTER AN HOUR(UTC) [0/6/12/18/''quit''] --> ' READ(*,'(A)') ANSWER IF (ANSWER.EQ.'QUIT' .OR. ANSWER.EQ.'quit') THEN IST=4 !set flag to QUIT GO TO 90 ENDIF READ(ANSWER,'(I2)') HH IF (HH.NE.0 .AND. HH.NE.6 .AND. HH.NE.12 .AND. HH.NE.18) GO TO 16 SINDEX(1)=6 SINDEX(2)=129 SINDEX(3)=528 QINDEX(1)=82 !129 QINDEX(2)=83 !129 QINDEX(3)=594 !129 QINDEX(4)=595 !129 QINDEX(5)=16 !129 QINDEX(6)=522 !129 QINDEX(7)=190 !129 QINDEX(8)=191 !129 QINDEX(9)=191 !528 QINDEX(10)=193 !528 QINDEX(11)=193 !129 QINDEX(12)=192 !129 QINDEX(13)=90 !129 QINDEX(14)=94 !129 QINDEX(15)=174 !129 QINDEX(16)=48 !6 QINDEX(17)=49 !6 QINDEX(18)=16 !6 QINDEX(19)=95 !6 QINDEX(20)=8 !129 QTXT(1)='U* ' QTXT(2)='V* ' QTXT(3)='SH ' QTXT(4)='LH ' QTXT(5)='Ts ' QTXT(6)='w ' QTXT(7)='LFDS' QTXT(8)='LFUS' QTXT(9)='OLR ' QTXT(10)='OSL ' QTXT(11)='SFUS' QTXT(12)='SFDS' QTXT(13)='RAIN' QTXT(14)='CVPR' QTXT(15)='GFLX' QTXT(16)='U10 ' QTXT(17)='V10 ' QTXT(18)='T2 ' QTXT(19)='q2 ' QTXT(20)='Ps ' LTXT(1)= 'DISTANCE ABOVE SFC' LTXT(2)= 'SURFACE' LTXT(3)= 'TOP OF ATMOSPHERE' C ----------- COLLECT THE DESIRED QUANTITY ----------- 66 WRITE(*,*) WRITE(*,'(5X,A)') + ' 1) U* N/m**2 Surface Stress in zonal direction' WRITE(*,'(5X,A)') + ' 2) V* N/m**2 Surface Stress in meridional direction' WRITE(*,'(5X,A)') + ' 3) SH W/m**2 Surface Sensible Heat flux, positive downwd' WRITE(*,'(5X,A)') + ' 4) LH W/m**2 Surface Latent Heat flux, positive downward' WRITE(*,'(5X,A)') + ' 5) Ts degree K Surface Temperature, skin temp.' WRITE(*,'(5X,A)') + ' 6) w mm Soil wetness' WRITE(*,'(5X,A)') + ' 7) LFDS W/m**2 Downward longwave flux at surface' WRITE(*,'(5X,A)') + ' 8) LFUS W/m**2 Upward longwave flux at surface' WRITE(*,'(5X,A)') + ' 9) OLR W/m**2 Upward longwave flux at top of model' WRITE(*,'(5X,A)') + '10) OSL W/m**2 Upward shortwave flux at top of model' WRITE(*,'(5X,A)') + '11) SFUS W/m**2 Upward shortwave flux at surface' WRITE(*,'(5X,A)') + '12) SFDS W/m**2 Downward shortwave flux at surface' WRITE(*,'(5X,A)') + '13) RAIN m Accumulated rain amount' WRITE(*,'(5X,A)') + '14) CVPR m Accumulated convective rain' WRITE(*,'(5X,A)') + '15) GFLX W/m**2 Ground heat flux' WRITE(*,'(5X,A)') + '16) U10 m/s 10-meter zonal wind' WRITE(*,'(5X,A)') + '17) V10 m/s 10-meter meridional wind' WRITE(*,'(5X,A)') + '18) T2 degree K 2-meter temperature' WRITE(*,'(5X,A)') + '19) q2 gm/gm 2-meter specific humidity' WRITE(*,'(5X,A)') + '20) Ps mb Surface pressure' WRITE(*,*) WRITE(*,'(A)') + 'SELECT A QUANTITY [1-20/''quit''] --> ' READ(*,'(A)') ANSWER IF (ANSWER.EQ.'QUIT' .OR. ANSWER.EQ.'quit') THEN IST=4 !set flag to QUIT GO TO 90 ENDIF READ(ANSWER,'(I2)') IQQ IF (IQQ.LT.1 .OR. IQQ.GT.20) GO TO 66 ICE=2 IF (IQQ.GE.16 .AND. IQQ.LE.19) ICE=1 IF (IQQ.EQ.9) ICE=3 IF (IQQ.EQ.10) ICE=3 ISS=ICE C------------------------------------------------------------------- C C READ A RECORD C 500 CONTINUE 10 CALL RON84(IUN,NBF,MXB,IST) C --- check for EOF --- IF(IST .NE. 0) GO TO 90 NREC=NREC+1 C --- round up --- NSFC1=SFC1+.5 NSFC2=SFC2+.5 IF (YY.LT.NYY .OR. MM.NE.NMM) THEN C --- NOT IN THIS FILE ANYWAY (SEE GOPEN) IST=5 !set flag to indicate date out of range GOTO 90 ENDIF IF (NDD.GT.DD) THEN IST=5 !set flag to indicate date out of range GOTO 90 ENDIF C --- check if Quantity matches --- IF (NQ(1).NE.QINDEX(IQQ)) GOTO 500 !read another record C --- check if Surface matches --- IF (NS1.NE.SINDEX(ISS)) GOTO 500 !read another record IF (NDD.LT.DD) GOTO 500 !read another record IF (NDD.EQ.DD .AND. NII.LT.HH) GOTO 500 !read another record IF (NDD.EQ.DD .AND. NII.GT.HH) THEN IST=5 !set flag to indicate date out of range GOTO 90 ENDIF C --- display some header information C 555 CONTINUE PRINT 1007 1007 FORMAT(' YEAR MONTH DAY HOUR QUANTITY VERTICAL LEVEL') PRINT 1003,NYY,NMM,NDD,NII,QTXT(IQQ),LTXT(ICE) 1003 FORMAT(4I6,2X,A6,6X,A20) C------------------------------------------------------------------- C C UNPACK THE DATA C CALL UON84(NBF,NDATA,DATA,NERR) C --- skip data records that are garbled --- IF(NERR .NE. 0) GO TO 500 C------------------------------------------------------------------- C NOTE: the grid array DATA or VAL is available at this point C in the code for use in your own programs C------------------------------------------------------------------- C------------------------------------------------------------------- C C CALCULATE AVERAGE VALUE AND DETERMINE C MINIMUM AND MAXIMUM VALUES XMAX=DATA(1) XMIN=DATA(1) XAVE=DATA(1) DO 21 I=2,NJJ 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 WRITE (*,1008)IDM,JDM 1008 FORMAT(1X,' DATA(1,1) DATA(',I3,',',I3,') AVERAGE', 2 ' MINIMUM MAXIMUM') PRINT 1001,DATA(1),DATA(NJJ),XAVE,XMIN,XMAX 1001 FORMAT(1X,5F12.3) C------------------------------------------------------------------- C C ----------- PRINT GRID ----------- C C GOTO 777 INQUIRE(FILE='NMC_FLUX.DAT',EXIST=ITIS) IF (.NOT.ITIS) THEN OPEN(UNIT=IOUT, FILE='NMC_FLUX.DAT', + FORM='FORMATTED',ACCESS='SEQUENTIAL', + STATUS='NEW') ELSE OPEN(UNIT=IOUT, FILE='NMC_FLUX.DAT', + FORM='FORMATTED',ACCESS='APPEND', + STATUS='OLD') ENDIF WRITE(IOUT, 1007) WRITE(IOUT, 1003) NYY,NMM,NDD,NII,QTXT(IQQ),LTXT(ICE) WRITE(IOUT, 1008) IDM,JDM WRITE(IOUT, 1001) DATA(1),DATA(NJJ),XAVE,XMIN,XMAX C GAUSSIAN GRID RANGE: C -0.472 lat 9.375 lon C 60 lat 80.625 lon C The data start at -0.472, 9.375 and scan east along a C latitude line, then move north. WRITE(IOUT,'(A)') 'First value is at (-0.472N, 9.375E).' WRITE(IOUT,'(A)') 'Last value is at (60N, 80.625E).' WRITE(IOUT,'(A)') +'Data scan east along a latitude line, then move north.' WRITE(IOUT,'(A)') 'Gaussian Grid spacing is ~.975 degrees.' WRITE(IOUT,*) DO 40 J=1,JDM WRITE(IOUT,1005) (VAL(I,J),I=1,IDM) 1005 FORMAT(2X,37F10.3) 40 CONTINUE WRITE(IOUT,*) CLOSE(IOUT) WRITE(*,'(2X,A)') + 'GRID VALUES HAVE BEEN WRITTEN TO FILE NMC_FLUX.DAT' C C------------------------------------------------------------------- 777 CONTINUE C------------------------------------------------------------------- C CHECK FLAG for OK, END OF FILE, ERROR, USER QUIT, DATE OUT OF RANGE C------------------------------------------------------------------- 90 CONTINUE CLOSE(UNIT=IUN) IF (IST.EQ.0) THEN C --- OK: Everything is running just fine GOTO 5 !go back and ask for another month C --- continue loop --- ELSEIF (IST.EQ.1) THEN C ---END OF FILE REACHED PRINT 1014,NREC PRINT 1017 1014 FORMAT('END OF FILE: NUMBER OF RECORDS = ',I9) ELSEIF (IST.EQ.2) THEN C ---ERROR ENCOUNTERED WRITE(*,'(A)')'UNRECOVERABLE ERROR: EXITING PROGRAM.' PRINT 1015,IST,NREC 1015 FORMAT('STATUS CODE = ',I8,' RECORD NUMBER = ',I9) ELSEIF (IST.EQ.4) THEN C ---USER ENTERED QUIT PRINT 1016 1016 FORMAT(' EXITING PROGRAM') ELSEIF (IST.EQ.5) THEN C ---DESIRED ENTRY NOT FOUND PRINT 1017 1017 FORMAT(' DESIRED ENTRY NOT FOUND') GOTO 5 ENDIF C --- exit program --- END C C -------------- END OF PROGRAM READON ---------------------- C C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * C * SUBROUTINE RON84 C * C * READS NMC OFFICE NOTE 84 FORMAT. C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SUBROUTINE RON84(IUN,NBF,MXB,IST) DIMENSION NBF(MXB) 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 C check for end of file 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 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * C * SUBROUTINE UON84 C * C * UNPACKS ON84 DATA WHICH HAS BEEN READ BY RON84. C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SUBROUTINE UON84(NBF,NDATA,DATA,NERR) C 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 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * C * SUBROUTINE GREAD C * C * . C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SUBROUTINE GREAD(IUN,NBF,MXB,IBYT,IST) C CHARACTER NFLNM*32 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 CHARACTER*30 FILNAM(12) DATA FILNAM/"","", 1 "G003.3.19910307000000.all","G003.4.19910401000000.all", C ---------------------------------------------------------------------- C if you put your data files in a directory other than flux.exe, put C the data file's full path name here as well, like "/home/data/Y11088" C ---------------------------------------------------------------------- 2 "G003.5.19910501000000.all","G003.6.19910601000000.all", 3 "G003.7.19910701000000.all","G003.8.19910801000000.all", 4 "G003.9.19910901000000.all","G003.10.19911001000000.all", 5 "G003.11.19911101000000.all","G003.12.19911201000000.all"/ CHARACTER*32 USERIN 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 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 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * C * SUBROUTINE ENTRY POINT GOPEN C * C * . C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ENTRY GOPEN(IUN,IBYT,FLNM,MM,IST) C ENTRY TO ALLOW OPEN OF FILE IF NECESSARY C NRECL=IBYT 800 WRITE(*,*) WRITE(*,'(A,A,A)') " 1) n/a", " 5) MAY", " 9) SEP" WRITE(*,'(A,A,A)') " 2) n/a", " 6) JUN", " 10) OCT" WRITE(*,'(A,A,A)') " 3) MAR", " 7) JUL", " 11) NOV" WRITE(*,'(A,A,A)') " 4) APR", " 8) AUG", " 12) DEC" PRINT 1000 1000 FORMAT(' SELECT A MONTH IN 1991 [3-12/quit]-> ',$) READ(5,'(A32)') USERIN IF (USERIN.EQ.'QUIT' .OR. USERIN.EQ.'quit') THEN IST=4 ELSE C convert to integer READ(USERIN, '(I)') I C make sure entry is from 3 to 12 IF (I.LT.3 .OR. I.GT.12) THEN WRITE(*,'(A)') 'ERROR: ENTER A NUMBER BETWEEN 3 AND 12' GOTO 800 ENDIF C WRITE(*,'(I,2X,A30)')I,FILNAM(I) C make sure file exists OPEN(IUN,FILE=FILNAM(I),ACCESS='DIRECT',RECL=NRECL, 2 FORM='UNFORMATTED',STATUS='OLD',IOSTAT=IERR) IF(IERR.NE.0) THEN IF(IERR.EQ.118) THEN WRITE(*,70)FILNAM(I) 70 FORMAT(" CANNOT FIND FILE "A30) GOTO 800 ELSE WRITE(*,80)IERR,FILNAM(I) 80 FORMAT(' ERROR OPENING FILE ='I9,' ',A30) C quit program C IST=2 ENDIF ENDIF ENDIF MM=I C 1000 FORMAT(' ENTER FILE NAME - ') C READ(5,'(A32)')NFLNM C OPEN(IUN,FILE=NFLNM,ACCESS='DIRECT',RECL=NRECL,FORM='UNFORMATTED', C 2 STATUS='OLD') NRPT=0 RETURN END C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * C * SUBROUTINE SWAP C * C * . C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 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 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * C * SUBROUTINE GBYTES C * C * . C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 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(64) DIMENSION IN(1),IOUT(1) C THE STATEMENTS BETWEEN ASTERISK LINES GIVE ALL NECESSARY MACHINE C DEPENDENT INFORMATION C*********************************************************************** C THIS SPECIFICATION IS FOR SUN UNIX FORTRAN INTEGER RGHTSH,OR,AND LEFTSH(M,N)=ISHFT(M,N) RGHTSH(M,N)=ISHFT(M,-N) OR(M,N)=M.OR.N AND(M,N)=M.AND.N 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 2: THE BYTE IS SPLIT ACROSS A WORD BREAK. 2 MOVEL=-MOVER MOVER=NBITSW-MOVEL NP1=LEFTSH(IN(INDEX+1),MOVEL) NP2=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 3: THE BYTE IS ALREADY RIGHT ADJUSTED. 3 IOUT(I)=AND(IN(INDEX+1),MASK) GO TO 5 C C 4: 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 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * C * SUBROUTINE INITIAL C * C * . C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SUBROUTINE INITAL C THIS PROGRAM WRITTEN BY..... C DR. ROBERT C. GAMMILL, CONSULTANT C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH C MAY 1972 C THIS ROUTINE INITIALIZES MACHIN COMMON TO DIRECT THE OPERATION OF THE C MACHINE INDEPENDENT ROUTINES. THE PRIMARY TASK IS CREATING MASKS. C INITAL MUST BE CALLED BEFORE GBYTE,GBYTES,SBYTE,SBYTES ARE CALLED. COMMON/MACHIN/NBITSW,NBITSC,MASK0,MASKS(64) C THE STATEMENTS BETWEEN ASTERISK LINES GIVE ALL NECESSARY MACHINE C DEPENDENT INFORMATION C*********************************************************************** C THIS SPECIFICATION IS FOR SUN UNIX FORTRAN. INTEGER OR C THE FOLLOWING ARITHMETIC STATEMENT FUNCTION DEFINES THE METHOD OF C LEFT SHIFTING ON THIS MACHINE. LEFTSH(M,N)=ISHFT(M,N) C THE FOLLOWING ARITHMETIC STATEMENT FUNCTION DEFINES THE METHOD OF C CARRYING OUT LOGICAL-OR ON THIS MACHINE. OR(M,N)=M.OR.N C THE FOLLOWING STATEMENT SPECIFIES HOW MANY BITS PER WORD. NBITSW=32 C*********************************************************************** MASK0=0 MASKS(1)=1 DO 1 I=2,NBITSW 1 MASKS(I)=OR(LEFTSH(MASKS(I-1),1),1) RETURN END C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * C * SUBROUTINE SBYTES C * C * . C * C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * 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(64) DIMENSION IN(1),IOUT(1) C C THE STATEMENTS BETWEEN ASTERISK LINES GIVE ALL NECESSARY MACHINE C DEPENDENT INFORMATION C*********************************************************************** C THIS SPECIFICATION IS FOR SUN UNIX FORTRAN INTEGER RGHTSH,OR,AND OR(M,N)=M.OR.N AND(M,N)=M.AND.N NOT(M)=.NOT.M 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 C 2: 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 3: BYTE IS TO BE STORED RIGHT-ADJUSTED. 3 IOUT(INDEX+1)=OR(AND(NOT(MASK),IOUT(INDEX+1)),J) GO TO 5 C C 4: 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)) C ------------ 5 II=II+IBITS INDEX=INDEX+IWORDS IF(II.LT.NBITSW) GO TO 6 II=II-NBITSW INDEX=INDEX+1 6 CONTINUE RETURN END C ----------------------------------------------------------------------- C end of file fluxread.F C -----------------------------------------------------------------------