C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C * sigmaread.F C * C * SAMPLE READ PROGRAM FOR Kuwait region subset of Northern C * Hemisphere longitude/latitude grid. C * C * Copyright 1993, University Corporation for C * Atmospheric Research, All Rights Reserved C * C * ADM (NCAR/ATD/RAF) 21 JUL 93 C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * C C Data start March 6 (date of NMC model change) C C Range is 9.028 - 80.125 longitude (64), 60.75 - -1.125 latitude (55) C with a ~1.125 degree resolution (Gaussian grid), 4 per day (hours C 0,6,12,18). The data start at -1.125, 9.028 and scan east along a C latitude line, then move north. C C ------------------------ C NMC Office Note 94 (ON84) format C C M=2 for all data: C means a field of Q for a layer bounded by S1 and S2 C ------------------------ C C each YY MM DD II contains: C one record for geometric distance above earth's surface C one record for atmospheric surface pressure C SIGMA levels: C ten records for atmospheric temperature C ten sets of two records for U and V wind speed components C ten records for specific humidity C C ------------------------ C filenames are: C KUDA01 1991MAR06-1991MAR07 C KUDA02 1991MAR07-1991MAR16 C KUDA03 1991MAR17-1991MAR26 C KUDA04 1991MAR27-1991APR05 C KUDA05 1991APR06-1991APR15 C KUDA06 1991APR16-1991APR25 C KUDA07 1991APR26-1991MAY05 C KUDA08 1991MAY06-1991MAY15 C KUDA09 1991MAY16-1991MAY25 C KUDA10 1991MAY26-1991JUN04 C KUDA11 1991JUN05-1991JUN14 C KUDA12 1991JUN15-1991JUN24 C KUDA13 1991JUN25-1991JUL04 C KUDA14 1991JUL05-1991JUL14 C KUDA15 1991JUL15-1991JUL24 C KUDA16 1991JUL25-1991AUG03 C KUDA17 1991AUG04-1991AUG13 C KUDA18 1991AUG14-1991AUG23 C KUDA19 1991AUG24-1991SEP02 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_SIGMA.DAT. The program loops to repeat the C month selection. C 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_SIGMA.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=64,JDM=55) 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(6),SINDEX(2),IQQ,ICE,ISS,SIGLEV,SLEV INTEGER YY,MM,DD,HH CHARACTER*40 ANSWER CHARACTER*4 QTXT(6) CHARACTER*15 LTXT(2) CHARACTER*25 STXT(10) LOGICAL ITIS DIMENSION NBF(IBDM),VAL(IDM,JDM),DATA(IJDM),NDATA(IJDM) EQUIVALENCE(VAL,DATA) EQUIVALENCE(NDATA,DATA) C------------------------------------------------------------------- C C INITIALIZATION C SIGLEV=1 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)=129 SINDEX(2)=148 QINDEX(1)=6 !129 QINDEX(2)=8 !129 QINDEX(3)=16 !148 QINDEX(4)=48 !148 QINDEX(5)=49 !148 QINDEX(6)=95 !148 QTXT(1)='DIST' QTXT(2)='PRES' QTXT(3)='TMP ' QTXT(4)='U ' QTXT(5)='V ' QTXT(6)='SPFH' LTXT(1)= 'EARTH''S SURFACE' LTXT(2)= 'SIGMA DOMAIN ' STXT(1)= ' 1) 1.000 0.990' STXT(2)= ' 2) 0.990 0.973' STXT(3)= ' 3) 0.973 0.948' STXT(4)= ' 4) 0.948 0.893' STXT(5)= ' 5) 0.893 0.820' STXT(6)= ' 6) 0.820 0.735' STXT(7)= ' 7) 0.735 0.642' STXT(8)= ' 8) 0.642 0.546' STXT(9)= ' 9) 0.546 0.450' STXT(10)=' 10) 0.450 0.400' C ----------- COLLECT THE DESIRED QUANTITY ----------- 66 WRITE(*,*) WRITE(*,'(5X,A)') WRITE(*,'(5X,A)') + '1) DIST m distance above Earth''s surface' WRITE(*,'(5X,A)') + '2) PRES mb Surface pressure' WRITE(*,'(5X,A)') + '3) TMP degree K temperature' WRITE(*,'(5X,A)') + '4) U m/sec zonal wind speed' WRITE(*,'(5X,A)') + '5) V m/sec meridional wind speed' WRITE(*,'(5X,A)') + '6) SPFH kg/kg specific humidity' WRITE(*,*) WRITE(*,'(A,$)') + 'SELECT A QUANTITY [1-6/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.6) GO TO 66 ICE=2 IF (IQQ.EQ.1 .OR. IQQ.EQ.2) THEN ICE=1 ELSE 67 WRITE(*,*) DO 70 J=1,10 WRITE(*,'(A)') STXT(J) 70 CONTINUE WRITE(*,'(A,$)') + 'SELECT A SIGMA LEVEL [1-10/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)') SIGLEV IF (SIGLEV.LT.1 .OR. SIGLEV.GT.10) GO TO 67 ENDIF SLEV=SIGLEV 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.LT.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.NE.DD) THEN GOTO 500 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 IF (ISS.EQ.2) THEN SIGLEV=SIGLEV-1 IF (SIGLEV.GT.0) GOTO 500 !read another record ENDIF C --- display some header information C 555 CONTINUE C write ('(A,I)') 'ICE=',ICE IF (ICE.EQ.1) THEN 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,A25) ELSE PRINT 1301 1301 FORMAT(' YEAR MONTH DAY HOUR QUANTITY', + ' SIGMA LEVEL BOTTOM AND TOP') PRINT 1303,NYY,NMM,NDD,NII,QTXT(IQQ),SFC1,SFC2 1303 FORMAT(4I6,2X,A6,6X,2F10.3) ENDIF 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 INQUIRE(FILE='NMC_SIGMA.DAT.'//QTXT(IQQ),EXIST=ITIS) IF (.NOT.ITIS) THEN OPEN(UNIT=IOUT, FILE='NMC_SIGMA.DAT.'//QTXT(IQQ), + FORM='FORMATTED',ACCESS='SEQUENTIAL', + STATUS='NEW') ELSE OPEN(UNIT=IOUT, FILE='NMC_SIGMA.DAT.'//QTXT(IQQ), + FORM='FORMATTED',ACCESS='APPEND', + STATUS='OLD') ENDIF IF (ICE.EQ.1) THEN 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 ELSE WRITE(IOUT, 1301) WRITE(IOUT, 1303) NYY,NMM,NDD,NII,QTXT(IQQ),SFC1,SFC2 WRITE(IOUT, 1008) IDM,JDM WRITE(IOUT, 1001) DATA(1),DATA(NJJ),XAVE,XMIN,XMAX ENDIF C GAUSSIAN GRID RANGE: C -1.125 lat 9.028 lon C 60.75 lat 80.125 lon C The data start at -1.125, 9.028 and scan east along a C latitude line, then move north. WRITE(IOUT,'(A)') 'First value is at (-1.125N, 9.028E).' WRITE(IOUT,'(A)') 'Last value is at (60.75N, 80.125E).' WRITE(IOUT,'(A)') +'Data scan east along a latitude line, then move north.' WRITE(IOUT,'(A)') 'Gaussian Grid spacing is ~1.125 degrees.' WRITE(IOUT,*) DO 40 J=1,JDM WRITE(IOUT,1005) (VAL(I,J),I=1,IDM) 1005 FORMAT(2X,64F10.3) 40 CONTINUE WRITE(IOUT,*) CLOSE(IOUT) WRITE(*,'(2X,A,A)') + 'GRID VALUES HAVE BEEN APPENDED TO FILE NMC_SIGMA.DAT.',QTXT(IQQ) C C------------------------------------------------------------------- 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) THEN NE1=128-NE1 NE1=NE1.AND.127 NE1=NE1*(-1) ENDIF IF(NE2 .GT. 128) THEN NE2=128-NE2 NE2=NE2.AND.127 NE2=NE2*(-1) ENDIF 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(19) DATA FILNAM/"G004.1.19910306120000.all", + "G004.2.19910308000000.all", + "G004.3.19910317000000.all", "G004.4.19910327000000.all", + "G004.5.19910406000000.all", "G004.6.19910416000000.all", + "G004.7.19910426000000.all", "G004.8.19910506000000.all", + "G004.9.19910516000000.all", "G004.10.19910526020000.all", + "G004.11.19910605000000.all", "G004.12.19910615000000.all", + "G004.13.19910625000000.all", "G004.14.19910705000000.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 ---------------------------------------------------------------------- + "G004.15.19910715000000.all", "G004.16.19910725000000.all", + "G004.17.19910804000000.all", "G004.18.19910814000000.all", + "G004.19.19910824000000.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) MAR06-MAR07", " 8) MAY06-MAY15", " 15) JUL15-JUL24" WRITE(*,'(A,A,A)') + " 2) MAR07-MAR16", " 9) MAY16-MAY25", " 16) JUL25-AUG03" WRITE(*,'(A,A,A)') + " 3) MAR17-MAR26", " 10) MAY26-JUN04", " 17) AUG04-AUG13" WRITE(*,'(A,A,A)') + " 4) MAR27-APR05", " 11) JUN05-JUN14", " 18) AUG14-AUG23" WRITE(*,'(A,A,A)') + " 5) APR06-APR15", " 12) JUN15-JUN24", " 19) AUG24-SEP02" WRITE(*,'(A,A,A)') + " 6) APR16-APR25", " 13) JUN25-JUL04" WRITE(*,'(A,A,A)') + " 7) APR26-MAY05", " 14) JUL05-JUL14" PRINT 1000 1000 FORMAT(' SELECT A DATE RANGE [1-19/quit]-> ',$) READ(5,'(A32)') USERIN IF (USERIN.EQ.'QUIT' .OR. USERIN.EQ.'quit') THEN IST=4 GOTO 199 ELSE C convert to integer READ(USERIN, '(I)') I C make sure entry is from 1 to 19 IF (I.LT.1 .OR. I.GT.19) THEN WRITE(*,'(A)') 'ERROR: ENTER A NUMBER BETWEEN 1 AND 19' GOTO 800 ENDIF C WRITE(*,'(I,2X,A6)')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 "A6) GOTO 800 ELSE WRITE(*,80)IERR,FILNAM(I) 80 FORMAT(' ERROR OPENING FILE ='I9,' ',A6) C quit program C IST=2 ENDIF ENDIF ENDIF IF (I.EQ.1 .OR. I.EQ.2 .OR. I.EQ.3) THEN MM=3 ELSEIF (I.EQ.5 .OR. I.EQ.6) THEN MM=4 ELSEIF (I.EQ.8 .OR. I.EQ.9) THEN MM=5 ELSEIF (I.EQ.11 .OR. I.EQ.12) THEN MM=6 ELSEIF (I.EQ.14 .OR. I.EQ.15 .OR. I.EQ.16) THEN MM=7 ELSEIF (I.EQ.17 .OR. I.EQ.18) THEN MM=8 ELSE 1700 PRINT 1800 1800 FORMAT(' WHICH MONTH [1-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 9 IF (I.LT.3 .OR. I.GT.9) THEN WRITE(*,'(A)') 'ERROR: ENTER A NUMBER BETWEEN 3 AND 9' GOTO 1700 ENDIF MM=I ENDIF ENDIF 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') 199 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 sigmaread.F C -----------------------------------------------------------------------