PROGRAM NAVY C C WRITTEN BY D. JOSEPH, C A COUPLE OF CHANGES BY G. WALTERS DEC86 C MODIFIED BY D. JOSEPH, MAY93, TO RUN ON SUN WORKSTATIONS. C PARAMETER (ND=1994,NIJ=15625) DIMENSION NBF(ND),AR(NIJ), ITAIL(16), JTAIL(22) C SAMPLE TEST DRIVER FOR RDNAVY/UNNAVY NR=0 NRO=0 OPEN(11,ACCESS='DIRECT',FORM='UNFORMATTED',RECL=ND*4, 2 STATUS='OLD') 10 CALL RDNAVY(11,NFMT,NYR,NMO,NDY,NHR,NPR,NFC,NFT,NMS,NSC,NST, 2 BSE,NBF,ND,NER) IF(NER.EQ.1) GO TO 90 IF(NER.EQ.3) GO TO 90 NR=NR+1 IF(NDY.NE.1) GO TO 10 NRO=NRO+1 CALL UPNAVY(NBF,ND,BSE,AR,NIJ,NI,NJ) NIX=NI*NJ TAR = 0 DO 80 NAVG = 1, NIX TAR = TAR + AR(NAVG) 80 CONTINUE TAR = TAR / NIX PRINT 1001,NR,NFMT,NI,NJ,NYR,NMO,NDY,NHR,NPR,NFC,NFT,NMS, P NSC,NST,BSE 1001 FORMAT (/,' REC JFO NI NJ YRMODYHR JLVL JFC',18X,'BASE', F /, I7, I4, 2I5, I3,3I2, I5, I4,I3,I5,2I3,F12.2) MID = NIX/2 PRINT 1002, MID, NIX, (AR(II),II=1,5), P (AR(MID-3+II),II=1,5), P (AR(NIX-5+II),II=1,5), TAR 1002 FORMAT(7X,'POINTS (MID=',I4,'), (END=',I5,') VALUES', F /7X,' 1, 2, 3, 4, 5 ',5F16.6, F /7X,'MID-2, MID-1, MID, MID+1, MID+2 ',5F16.6, F /7X,'END-4, END-3, END-2, END-1, END ',5F16.6, F /7X,' AVERAGE ',F16.6) IF (NIX.EQ. 3969) IOFF = 5362 IF (NIX.EQ.15625) IOFF = 20904 IF (NIX.EQ. 7056) IOFF = 9478 IF (NIX.EQ.10512) IOFF = 14086 IOFF = 12 * IOFF C CALL GBYTES (NBF,ITAIL,IOFF,64,0,16) C CALL CCONV (ITAIL,0,JTAIL,171,NCSTAT) C PRINT 1003,JTAIL C1003 FORMAT (2(/,7X,'TAIL ',11A8)) IF (NRO.LT.120) GO TO 10 90 CONTINUE PRINT 1004,NER,NR 1004 FORMAT(//,' STOP - STATUS ',I2,', RECS READ ',I8) END SUBROUTINE RDNAVY(NUN,NFMT,NYR,NMO,NDY,NHR,NPR,NFC,NFT, 2 NMS,NSC,NST,BSE,NFD,NDIM,NER) SAVE NUMR C C READS NAVY FORMAT GRID RECORDS. C UNMODIFIED ARGS C NUN - FORTRAN LOGICAL UNIT C NDIM - DIMENSION OF NFD (NDIM=3911 WILL HANDLE ALL CURRENT NAVY GRIDS) C C MODIFIED ARGS (SEE APRIL 1979 FORMAT DESCRIPTION FOR MORE DETAIL) C C MIN C NFMT NDIM DESCRIPTION C 3 997 63X63 POLAR STEREO, N.POLE PT 32,32, +X=10E, 2A=31.204359052 C 4 997 63X63 POLAR STEREO, S.POLE PT 32,32, +X=10E, 2A=31.204359052 C 10 1768 49X144 MERCATOR (1,1) = 59.745N,60E, (1,2)=59.745N,62.5E C 11 2632 73X144 2.5DEG LAT/LON (1,1)=90N,60E, (2,1)=87.5N,60E C (1,2)=90N,62.5E C 13 3911 125X125 POLAR STEREO, N.POLE PT 63,63, +X=10E,2A=2*31.204359052 C 14 3911 125X125 POLAR STEREO, S.POLE PT 63,63, +X=10E,2A=2*31.204359052 C C NYR,NMO,NDY,NHR - DATE TIME IDENTIFIERS OF CURRENT RECORD C NPR - PRESSURE LEVEL C NFC - FUNCTION CODE C NFT - FORECAST HOUR C NMS - ADDITIONAL ID (USUALLY SECOND PRESSURE LEVEL FOR THICKNESSES) C NSC - SOURCE CODE OF DATA, 3=NAVY C NST - STATUS FOR THIS GRID C BSE - BASE VALUE C NFD - ARRAY FOR INPUT BUFFER TO CONTAIN EACH PACKED RECORD C NER - STATUS RETURN WHERE 0=GOOD, 1=EOF, 2=ERROR, 3=EOD C (2 CONSECUTIVE EOF'S = EOD). C DIMENSION NFD(NDIM) DATA NUMR/0/ C CALL RDTAPE(NUN,1,0,NFD,NDIM) C CALL IOWAIT(NUN,NER,NWDS) C IF(NER.EQ.0) GO TO 10 C IF(NER.EQ.2) GO TO 10 C RETURN NUMR=NUMR+1 READ(NUN,REC=NUMR,ERR=90)NFD C 10 CONTINUE CALL GBYTE(NFD,NFMT,0,6) CALL GBYTE(NFD,NYR,6,7) CALL GBYTE(NFD,NMO,13,4) CALL GBYTE(NFD,NDY,17,5) CALL GBYTE(NFD,NHR,22,5) CALL GBYTE(NFD,NPR,27,10) CALL GBYTE(NFD,NFC,37,9) CALL GBYTE(NFD,NFT,46,9) CALL GBYTE(NFD,NMS,55,10) CALL GBYTE(NFD,NSC,67,6) CALL GBYTE(NFD,NST,73,5) C CALL GBYTE(NFD,XBSE,120,64) CALL cd2xx(NFD,BSE,120,1) C CALL SCONV(XBSE,BSE,1,6,60,LOC,IER) NPR=1023-NPR NMS=1023-NMS RETURN 90 NER=1 RETURN END SUBROUTINE UPNAVY(NFD,NDIM,BSE,AR,NIJ,NI,NJ) SAVE IFMT C C UNPACK DATA READ BY RDNAVY C UNMODIFIED ARGS C NFD - BUFFER CONTAINING RECORD READ BY RDNAVY C NDIM - DIMENSION OF NFD C BSE - BASE VALUE TO BE ADDED TO UNPACKED DATA VALUES (USUALLY THE C VALUE RETURNED BY RDNAVY) C NIJ - DIMENSION OF AR (ONE DIMENSION EQUIVALENT IF NIJ IS 2D) C MODIFIED ARGS C AR - ARRAY TO CONTAIN UNPACKED DATA VALUES C NI,NJ - DIMENSIONS OF UNPACKED ARRAY C C SET WORD SIZE OF READING COMPUTER PARAMETER (IWSZ=32) C DIMENSION NFD(NDIM),AR(NIJ) DIMENSION IFMT(2,20) DATA IFMT/4*0,4*63,10*0,49,144,73,144,2*0,4*125,12*0/ CALL GBYTE(NFD,NFMT,0,6) NI=IFMT(1,NFMT) NJ=IFMT(2,NFMT) NPTS=NI*NJ IF(NPTS.LE.NIJ) GO TO 8 PRINT 1001,NPTS,NIJ 1001 FORMAT(' +++ ERROR IN UPNAVY, ARRAY TOO SMALL- NPTS/NIJ ',3I5) 8 CONTINUE C C THE 16 ASSUMES WE ALWAYS USE A 16-BIT PACK, REGARDLESS OF ORIGINAL C NAVY PACK C C NCSW=(NPTS*16+299)/60 C CALL N76SUM(NFD,NCSW,KST) C IF(KST.EQ.0) GO TO 9 C PRINT 1002, KST C1002 FORMAT(' +++ ERROR IN UPNAVY, CSKUM ERR- DIFF ',O23) 9 CONTINUE CALL GBYTES(NFD,AR,180,16,0,NPTS) CALL GBYTE(NFD,IBI,78,16) CALL GBYTE(NFD,ISC,94,16) ISC=ISC-IBI C CALL SBYTE (BSE7,BSE,0,60) MODE = 6 CALL cd2xx(BSE7,BSE,0,1) C CALL SCONV (BSE7,BSEC,1,MODE,60,LOCEND,IER) C DO 10 I = 1,NPTS CALL GBYTE(AR(I),IV,0,IWSZ) AR(I)=FLOAT(IV-IBI)*2.**ISC + BSEC 10 CONTINUE RETURN END subroutine cd2xx(in,io,ioff,n) c c cdc internal words (integer or single real) to native word format. c in input array containing contiguous 60bit words after offset of ioff bits. c io output array of local words. c n number of values to convert. c c set iwz to word size of executing machine (must be .ge. 32) parameter (iwz=32) c c set isgn = 0 for normal cyber sign convention, = 1 for sign magnitude c version used for many dss base values. parameter (isgn=0) c dimension in(1),io(1) dimension ifr(2) data nc24/16777215/,m24/16777216/,x24/16777216./ iof=ioff do 20 i=1,n call gbytes(in,isn,iof,1,0,1) iof=iof+1 call gbytes(in,iex,iof,11,0,1) iof=iof+11 call gbytes(in,ifr,iof,24,0,2) iof=iof+48 if (isn .eq. 0 .or. isgn.eq.1) goto 12 iex=2047-iex ifr(1)=nc24-ifr(1) ifr(2)=nc24-ifr(2) 12 continue if(iex .ne. 0) go to 15 io(i)=m24*ifr(1)+ifr(2) if(isn .ne. 0) io(i)=-io(i) go to 20 15 continue iex=iex-1024 if(iex .lt. 0) iex=iex+1 xx=(float(ifr(1))*x24+float(ifr(2)))*2.**iex if(isn .eq. 1) xx=-xx call gbytes(xx,io(i),0,iwz,0,1) 20 continue 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/'0'X/ DATA MASKS/'1'X,'3'X,'7'X,'F'X,'1F'X,'3F'X,'7F'X,'FF'X, 2 '1FF'X,'3FF'X,'7FF'X,'FFF'X,'1FFF'X,'3FFF'X,'7FFF'X,'FFFF'X, 3 '1FFFF'X,'3FFFF'X,'7FFFF'X,'FFFFF'X,'1FFFFF'X,'3FFFFF'X, 4 '7FFFFF'X,'FFFFFF'X,'1FFFFFF'X,'3FFFFFF'X,'7FFFFFF'X,'FFFFFFF'X, 5 '1FFFFFFF'X,'3FFFFFFF'X,'7FFFFFFF'X,'FFFFFFFF'X/ 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 SUBROUTINE INITAL RETURN END