PROGRAM QV7 C READ AND PRINT LMRF6 C C-----GBYTE/S, DATE AND CLOCK ARE MACHINE-DEPENDENT ROUTINES AND C FUNCTIONS. SEE COADS RELEASE 1 SUPPLEMENT H FOR A DESCRIPTION C OF THEIR BEHAVIOR. C AUTHOR: S.LUBKER, 93/08/25. 16:40:27. C -----------REVISION HISTORY---------------------------------------34567898 C LEVEL AUTHOR DATE DESCRIPTION C ===== ====== ========== ==================== C .01A. SJL 93/08/25. ORIGINAL VERSION. C ------------------------------------------------------------------34567898 IMPLICIT INTEGER(A-E,G-Z) C DATA UNIT/1/,FMISS/-9999./ C PARAMETER(DIM BUF=6) DIMENSION BUF(DIM BUF) DATA (BUF(I),I=1,6)/6*0/,DEOF/0/ 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) DATA AL(2)/16/ DIMENSION TRFLG(23) C CHARACTER*8 YYMMDD,HHMMSS CHARACTER LEVEL*4,FILE*64 DATA LEVEL/'.01A'/ C CALL DATE(YYMMDD) CALL CLOCK(HHMMSS) C OPEN(UNIT,FILE='f001',FORM='UNFORMATTED',ACCESS='DIRECT' +,RECL=LEN(RPT)) C-----READ REPORT 100 READ(UNIT,REC=BUF(2)+1,IOSTAT=EOF)RPT IF(EOF.NE.0)GOTO 900 DEOF=0 IF(MOD(BUF(2),53).EQ.0)THEN PRINT 1,LEVEL,YYMMDD,HHMMSS,FILE,BUF(2)/53+1 1 FORMAT('1QV7',A4,2A9,' < ',A,T132,I10) 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 CALL PRNRPT(FTRUE,FMISS,FUNITS,FORMAT,NUMBER) C GOTO 700 C C-----GET TRIMMING ATTACHMENT CALL GBYTES(RPT,AD(1,2),448,4,0,16) CALL GETTRF(AL,AD,TRFLG) PRINT *,'TRIM ATT: "',TRFLG,'"' C 700 IF(BUF(2).EQ.5)STOP 'ETC' 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(2:2)),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,FORMAT DIMENSION FIELD(*),FORMAT(*) 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*8 FORMAT DIMENSION FTRUE(*),FUNITS(*),FORMAT(*) CHARACTER*8 ATRUE(104) C DO 190 I=1,NUMBER IF(FTRUE(I).EQ.FMISS)THEN ATRUE(I)=' ' ELSE IF(FORMAT(I)(2:2).EQ.' ')THEN ATRUE(I)(1:1)=CHAR(NINT(FTRUE(I))) ELSE WRITE(ATRUE(I),'(I'//FORMAT(I)(3:3)//')') + NINT(FTRUE(I)/FUNITS(I)) ENDIF 190 CONTINUE C WRITE(*,FORMAT)(ATRUE(I),I=1,NUMBER) END