PROGRAM GETSLP C COMMON/A/NTAPE,NSTATE,IFM(1),IYR,IMO,IDA,IHR,ILV,ITYPE,ISRC,IGRID, *POLE,NUM,SLP(72,15),NREC CHARACTER FLNM*48 C C*** C*** COMMON BLOCK A IS USED TO LINK WITH CALLING PROGRAM C*** NTAPE - LUN SUPPLIED IN CALLING ROUTINE C*** NSTATE - STATUS OF READ OPERATION C*** IFM - FORMAT NUMBER C*** IYR - YEAR OF GRID, E.G. 1901 C*** IMO - MONTH OF GRID C*** IDA - DAY OF GRID C*** IHR - HOUR C*** ILV - LEVEL C*** ITYPE - TYPE C*** ISRC - SOURCE C*** IGRID - GRID C*** POLE - NORTH POLE VALUE C*** NUM - FOR MONTHLY GRIDS, NUMBER OF DAYS IN MEAN C*** SLP - ARRAY OF SEA LEVEL PRESSURES (0=MISSING) C*** C C*** SET NTAPE .EQ. LOGICAL UNIT NUMBER ON VOLUME OR ASSIGN CARD NREC=0 NTAPE=1 C WRITE(6,*)' Enter filename to read ' READ(5,'(A)')FLNM WRITE(6,*)' Enter starting year for complete grid print ' READ(5,*)ISYR OPEN(NTAPE,FILE=FLNM,FORM='UNFORMATTED',ACCESS='DIRECT',RECL=2048) 10 NREC=NREC+1 C*** READ RECORD AND UNPACK ID PARAMETERS CALL RDSLP IF(NSTATE.EQ.1.OR.NSTATE.EQ.3) GO TO 1000 IF(NSTATE.EQ.0) GO TO 15 C C*** HANDLE PARITY (NSTATE.NE.0) C 15 CONTINUE C*** SELECT GRIDS HERE C 20 CONTINUE C*** UNPACK SEA LEVEL PRESSURE GRID CALL UPSLP C C*** PROCESS GRID C PRINT 100,IFM,IYR,IMO,IDA,IHR,ILV,ITYPE,ISRC,IGRID, POLE,NUM 100 FORMAT(1H0,9I10,F10.1,I10) IF(IYR.LT.ISYR) GO TO 10 PRINT 101,(I,I=15,85,5) 101 FORMAT(1H0,5X,15(I7,'N')) DO 500 I=1,72 LON=(I-1)*5 PRINT 150,LON,(SLP(I,J),J=1,15) 150 FORMAT(2X,I3,'E',15F8.1) 500 CONTINUE GO TO 10 1000 CONTINUE C*** NSTATE=1 FOR EOF , NSTATE=3 FOR EOT C END SUBROUTINE RDSLP C*** C*** ENTRY RDSLP READS A RECORD FROM DAILY OR MONTHLY SEA LEVEL PRESSURE TAPE C*** AND RETURNS READ STATUS AND ID INFORMATION C*** C*** ENTRY UPSLP UNPACKS AND FLOATS ARRAY OF SLP C*** COMMON/A/NTAPE,NSTATE,IFM(1),IYR,IMO,IDA,IHR,ILV,ITYPE,ISRC,IGRID, *POLE,NUM,SLP(72,15),NREC C*** C*** COMMON BLOCK A IS USED TO LINK WITH CALLING PROGRAM C*** NTAPE - LUN SUPPLIED IN CALLING ROUTINE C*** NSTATE - STATUS OF READ OPERATION C*** IFM - FORMAT NUMBER C*** IYR - YEAR OF GRID, E.G. 1901 C*** IMO - MONTH OF GRID C*** IDA - DAY OF GRID C*** IHR - HOUR C*** ILV - LEVEL C*** ITYPE - TYPE C*** ISRC - SOURCE C*** IGRID - GRID C*** POLE - NORTH POLE VALUE C*** NUM - FOR MONTHLY GRIDS, NUMBER OF DAYS IN MEAN C*** SLP - ARRAY OF SEA LEVEL PRESSURES (0=MISSING) C*** DIMENSION IBUF(512),LCON(12),IDATA(72,15) EQUIVALENCE(SLP,IDATA) DATA LCON/06,11,04,05,05,10,09,06,04,15,06,00/ NSTATE=0 READ(NTAPE,ERR=99,REC=NREC)IBUF C THE FOLLOWING STATEMENT IS ONLY NEEDED ON BYTE REVERSED MACHINES (DEC,PC) CALL SWAP4(IBUF,IBUF,2048) C NOFF=0 DO 100 I=1,11 CALL GBYTE(IBUF,IFM(I),NOFF,LCON(I)) NOFF=NOFF+LCON(I) 100 CONTINUE CALL GBYTE(IBUF,IPOLE,61,14) POLE=IPOLE*.1 RETURN 99 NSTATE=1 RETURN C ENTRY UPSLP CALL GBYTES(IBUF,IDATA,121,14,1,1080) DO 200 I=1,1080 SLP(I,1)=IDATA(I,1)*.1 200 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/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