PROGRAM QV7_PC C READ AND PRINT LMRF6 DATA ON A PC C IMPLICIT INTEGER(A-E,G-Z) C PARAMETER(DIM BUF=6) DIMENSION BUF(DIM BUF) C CHARACTER RPT*64 C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) +,FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER),OFFSET(NUMBER) +,FORMAT(NUMBER),RPTID,INDXCK C DIMENSION CODED(NUMBER),FTRUE(NUMBER) C DIMENSION AL(15),AD(255,15) DIMENSION TRFLG(23) C DATA AL(2)/16/ DATA UNIT/1/,FMISS/-9999./ C DATA (BUF(I),I=1,6)/6*0/,DEOF/0/ C OPEN(UNIT,FILE='lmrf_dat',FORM='UNFORMATTED', + ACCESS='DIRECT',RECL=LEN(RPT)) C-----READ REPORT 100 READ(UNIT,REC=BUF(2)+1,IOSTAT=EOF)RPT c swap each 4 byte word for PC word order call cswap_4(rpt,len(rpt)) IF(EOF.NE.0)GOTO 900 DEOF=0 IF(BUF(2).EQ.0)THEN PRINT*,'PROGRAM QV7_PC OUTPUT <-----' CALL PRNFLD(FIELD,FORMAT,NUMBER) ENDIF BUF(2)=BUF(2)+1 C C-----UNPACK REPORT AND CONVERT CODED TO TRUE VALUES CALL GETRPT(RPT,CODED,FTRUE,FMISS +,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK) C-----PRINT REPORT AND TRIMMING ATTACHMENT FOR THE FIRST 10 RECORDS IF(BUF(2).LE.10)THEN CALL PRNRPT(FTRUE,FMISS,FUNITS,FORMAT,NUMBER) C-----GET TRIMMING ATTACHMENT CALL GBYTES(RPT,AD(1,2),448,4,0,16) CALL GETTRF(AL,AD,TRFLG) c PRINT *,'TRIM ATT: "',TRFLG,'"' WRITE(*,1001)(TRFLG(i),i=1,23) 1001 FORMAT('TRIM ATT: ',I5,22I3) ENDIF IF(BUF(2).GT.10.AND.MOD(BUF(2),5000).EQ.0)THEN PRINT*,'PROCESSING RECORDS NUMBER : ',BUF(2) ENDIF C STOP PROCESS AFTER 10 RECORDS, FOR FULL FILE READ REMOVE THIS STATEMENT IF(BUF(2).GE.10)STOP 'PROCESSING STOPPED AFTER 10 RECORDS' GOTO 100 C 900 PRINT *,' REPORTS ',BUF(2),', EOF ',EOF DEOF=DEOF+1 IF(DEOF.LT.2)GOTO 100 END C-----------------------------------------------------------------------3456789 BLOCK DATA BDLMR6 IMPLICIT INTEGER(A-E,G-Z) C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) +,FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER),OFFSET(NUMBER) +,FORMAT(NUMBER),RPTID,INDXCK C DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I= 1,10) 1/'B10 ', 1., 648., 1., 0., 10, 16,'(A4 ' 2,'YR ', 1770., 2024., 1., 1769., 8, 26,',A4 ' 3,'MO ', 1., 12., 1., 0., 4, 34,',A2 ' 4,'DY ', 1., 31., 1., 0., 5, 38,',A2 ' 5,'HR ', 0.00, 23.99, 0.01, -1.00, 12, 43,',A4 ' 6,'TI ', 0., 3., 1., -1., 4, 55,',A1 ' 7,'LON ', 0.00, 359.99, 0.01, -1.00, 16, 59,',A5 ' 8,'LAT ', -90.00, 90.00, 0.01,-9001.00, 15, 75,',A5 ' 9,'LI ', 0., 6., 1., -1., 4, 90,',A1 ' 1,'DCK ', 0., 999., 1., -1., 10, 94,',A3 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=11,20) 1/'SID ', 0., 80., 1., -1., 8, 104,',A2 ' 2,'PT ', 0., 15., 1., -1., 5, 112,',A2 ' 3,'QI ', 0., 2., 1., -1., 2, 117,',A1 ' 4,'DS ', 0., 13., 1., -1., 5, 119,',A2 ' 5,'DC ', 0., 2., 1., -1., 4, 124,',A2 ' 6,'TC ', 0., 1., 1., -1., 3, 128,',A1 ' 7,'PB ', 0., 2., 1., -1., 2, 131,',A1 ' 8,'DI ', 0., 6., 1., -1., 4, 133,',A1 ' 9,'D ', 1., 362., 1., 0., 9, 137,',A3 ' 2,'WI ', 0., 8., 1., -1., 4, 146,',A1 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=21,30) 1/'W ', 0.0, 102.2, 0.1, -1.0, 10, 150,',A4 ' 2,'VI ', 0., 2., 1., -1., 2, 160,',A1 ' 3,'VV ', 90., 99., 1., 89., 4, 162,',A2 ' 4,'WW ', 0., 99., 1., -1., 7, 166,',A2 ' 5,'W1 ', 0., 9., 1., -1., 4, 173,',A1 ' 6,'W2 ', 0., 9., 1., -1., 4, 177,',A1 ' 7,'SLP ', 870.0, 1074.6, 0.1, 8699.0, 11, 181,',A5 ' 8,'T1 ', 0., 9., 1., -1., 4, 192,',A1 ' 9,'AT ', -99.9, 99.9, 0.1, -1000.0, 11, 196,',A4 ' 3,'WBT ', -99.9, 99.9, 0.1, -1000.0, 11, 207,',A4 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=31,40) 1/'DPT ', -99.9, 99.9, 0.1, -1000.0, 11, 218,',A4 ' 2,'SST ', -99.9, 99.9, 0.1, -1000.0, 11, 229,',A4 ' 3,'SI ', 0., 12., 1., -1., 4, 240,',A2 ' 4,'N ', 0., 9., 1., -1., 4, 244,',A1 ' 5,'NH ', 0., 9., 1., -1., 4, 248,',A1 ' 6,'CL ', 0., 10., 1., -1., 4, 252,',A2 ' 7,'HI ', 0., 1., 1., -1., 2, 256,',A1 ' 8,'H ', 0., 10., 1., -1., 4, 258,',A2 ' 9,'CM ', 0., 10., 1., -1., 4, 262,',A2 ' 4,'CH ', 0., 10., 1., -1., 4, 266,',A2 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=41,50) 1/'WD ', 0., 38., 1., -1., 6, 270,',A2 ' 2,'WP ', 0., 30., 1., -1., 5, 276,',A2 ' 3,'WH ', 0., 49.5, 0.5, -1., 7, 281,',A2 ' 4,'SD ', 0., 38., 1., -1., 6, 288,',A2 ' 5,'SP ', 0., 30., 1., -1., 5, 294,',A2 ' 6,'SH ', 0., 49.5, 0.5, -1., 7, 299,',A2 ' 7,'C1 ', 0., 40., 1., -1., 7, 306,',A2 ' 8,'C2 ', 0., 40., 1., -1., 7, 313,',A2 ' 9,'SC ', 0., 9., 1., -1., 4, 320,',A1 ' 5,'SS ', 0., 9., 1., -1., 4, 324,',A1 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=51,60) 1/'A ', 0., 8., 1., -1., 4, 328,',A1 ' 2,'PPP ', 0.0, 51.0, 0.1, -1.0, 9, 332,',A3 ' 3,'IS ', 1., 5., 1., 0., 3, 341,',A1 ' 4,'ES ', 0., 99., 1., -1., 7, 344,',A2 ' 5,'RS ', 0., 4., 1., -1., 3, 351,',A1 ' 6,'II ', 0., 10., 1., -1., 4, 354,',A2 ' 7,'ID1 ', 33., 95., 1., 32., 6, 358,', A1' 8,'ID2 ', 33., 95., 1., 32., 6, 364,', A1' 9,'ID3 ', 33., 95., 1., 32., 6, 370,', A1' 6,'ID4 ', 33., 95., 1., 32., 6, 376,', A1'/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=61,70) 1/'ID5 ', 33., 95., 1., 32., 6, 382,', A1' 2,'ID6 ', 33., 95., 1., 32., 6, 388,', A1' 3,'ID7 ', 33., 95., 1., 32., 6, 394,', A1' 4,'ID8 ', 33., 95., 1., 32., 6, 400,', A1' 5,'OS ', 0., 6., 1., -1., 4, 406,',A1 ' 6,'OP ', 0., 9., 1., -1., 4, 410,',A1 ' 7,'T2 ', 0., 6., 1., -1., 3, 414,',A1 ' 8,'IX ', 1., 6., 1., 0., 4, 417,',A1 ' 9,'WX ', 1., 1., 1., 0., 1, 421,',A1 ' 7,'SX ', 1., 1., 1., 0., 1, 422,',A1 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=71,73) 1/'IRD ', 1., 255., 1., 0., 8, 423,',A3 ' 2,'A6 ', 0., 1., 1., -1., 2, 431,',A1 ' 3,'CK ', 0., 30., 1., 0., 5, 443,',A2)'/ C DATA INDXCK/NUMBER/,RPTID/6/ END C-----------------------------------------------------------------------3456789 SUBROUTINE GETRPT(RPT,CODED,FTRUE,FMISS +,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK) C UNPACK REPORT AND CONVERT CODED TO TRUE VALUES C IMPLICIT INTEGER(A-E,G-Z) C CHARACTER*(*) RPT DIMENSION CODED(*),FTRUE(*),FUNITS(*),FBASE(*),BITS(*),OFFSET(*) C IF(MOD(ICHAR(RPT(3:3)),16).NE.RPTID)STOP 'RPTID' C CODED(INDXCK)=0 DO 190 I=1,NUMBER IF(I.EQ.INDXCK)GOTO 190 CALL GBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) IF(CODED(I).EQ.0)THEN FTRUE(I)=FMISS ELSE FTRUE(I)=(CODED(I)+FBASE(I))*FUNITS(I) CODED(INDXCK)=CODED(INDXCK)+CODED(I) ENDIF 190 CONTINUE I=INDXCK FTRUE(I)=MOD(CODED(I),2**BITS(I)-1) CALL GBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) IF(FTRUE(I).NE.CODED(I))STOP 'CHECKSUM' END C-----------------------------------------------------------------------3456789 SUBROUTINE GETTRF(AL,AD,TRFLG) C GET TRIMMING ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION TRFLG(23) C IF(AL(2).EQ.16)THEN TRFLG( 1)=((AD( 1,2)*16+AD( 2,2))*16+AD( 3,2))*4+AD( 4,2)/4 TRFLG( 2)=MOD(AD( 4,2) ,4) TRFLG( 3)= AD( 5,2) TRFLG( 4)= AD( 6,2) TRFLG( 5)= AD( 7,2) TRFLG( 6)= AD( 8,2) TRFLG( 7)= AD( 9,2) TRFLG( 8)= AD(10,2) TRFLG( 9)= AD(11,2)/4 TRFLG(10)=MOD(AD(11,2) ,4) TRFLG(11)= AD(12,2)/4 TRFLG(12)=MOD(AD(12,2) ,4) TRFLG(13)= AD(13,2)/4 TRFLG(14)=MOD(AD(13,2) ,4) TRFLG(15)= AD(14,2)/4 TRFLG(16)=MOD(AD(14,2) ,4) TRFLG(17)= AD(15,2)/4 TRFLG(18)=MOD(AD(15,2)/2 ,2) TRFLG(19)=MOD(AD(15,2) ,2) TRFLG(20)= AD(16,2)/2/2/2 TRFLG(21)=MOD(AD(16,2)/2/2 ,2) TRFLG(22)=MOD(AD(16,2)/2 ,2) TRFLG(23)=MOD(AD(16,2) ,2) ELSE DO 190 I=1,23 TRFLG(I)=0 190 CONTINUE ENDIF END C-----------------------------------------------------------------------3456789 SUBROUTINE PRNFLD(FIELD,FORMAT,NUMBER) C PRINT FIELDS C IMPLICIT INTEGER(A-E,G-Z) CHARACTER*8 FIELD CHARACTER FORMAT*584 DIMENSION FIELD(*) CHARACTER FLD*1 FLD(I,J)=FIELD(I)(J:J) WRITE(*,FORMAT)((FLD(I,MOD(J+INDEX(FIELD(I)(1:3)//' ',' ')-1,3)+1) +,I=1,NUMBER),J=0,2) WRITE(*,FORMAT)('-',I=1,NUMBER) END C-----------------------------------------------------------------------3456789 SUBROUTINE PRNRPT(FTRUE,FMISS,FUNITS,FORMAT,NUMBER) C PRINT REPORT C IMPLICIT INTEGER(A-E,G-Z) CHARACTER FORMAT*584,ITC*1 DIMENSION FTRUE(*),FUNITS(*) CHARACTER*8 ATRUE(104) C DO 190 I=1,NUMBER IC=8*(I-1) IF(FTRUE(I).EQ.FMISS)THEN ATRUE(I)=' ' ELSE IF(FORMAT(2+IC:2+IC).EQ.' ')THEN ATRUE(I)(1:1)=CHAR(NINT(FTRUE(I))) ELSE ITC=FORMAT(3+IC:3+IC) WRITE(ATRUE(I),'(I'//ITC//')') + NINT(FTRUE(I)/FUNITS(I)) ENDIF 190 CONTINUE C WRITE(*,FORMAT)(ATRUE(I),I=1,NUMBER) END subroutine cswap_4(crec,lrec) character*64 crec character*1 c if(lrec.ne.64)then print*,'length in cswap_4 is incompatabile',lrec stop endif do i=1,lrec,4 c = crec(i:i) crec(i:i) = crec(i+3:i+3) crec(i+3:i+3) = c c = crec(i+1:i+1) crec(i+1:i+1)=crec(i+2:i+2) crec(i+2:i+2)=c enddo 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