# QSUB -q prem -s /bin/sh ja cd $TMPDIR EOF () { cft77 p.f f=/DSS/filename msread fort.1 $f segldr p.o -L /lib,/usr/lib,/usr/local/lib -l ncaro,net echo $f | a.out ja -cst } cat > p.f <<\EOR PROGRAM QS2 C-----READ AND PRINT LMR6 C C-----RPTIN, GBYTE/S, DATE AND CLOCK ARE MACHINE-DEPENDENT ROUTINES AND C FUNCTIONS. SEE COADS RELEASE 1 SUPPLEMENT H FOR A DESCRIPTION OF C THEIR BEHAVIOR. BPW IS A PARAMETER WHICH MUST BE SET TO THE NUMBER C OF BITS PER MACHINE WORD. C C AUTHOR: S.LUBKER, 93/10/15. 17:26:52. C -----------REVISION HISTORY---------------------------------------34567898 C LEVEL AUTHOR DATE DESCRIPTION C ===== ====== ========== ==================== C .01A. SJL 93/10/15. ORIGINAL VERSION. C ------------------------------------------------------------------34567898 IMPLICIT INTEGER(A-E,G-Z) C DATA UNIT/1/ DATA FMISS/-999./ C C-----BITS PER WORD PARAMETER(BPW=64) C PARAMETER(DIM BUF=(1006*64-1)/BPW+1) DIMENSION BUF(DIM BUF) DATA (BUF(I),I=1,6)/6*0/,DEOF/0/ C PARAMETER(BPR=452+(3+255)*4*15,DIM RPT=(BPR-1)/BPW+1) DIMENSION RPT(DIM RPT) C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) COMMON /LMR6/FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER) COMMON /LMR6/OFFSET(NUMBER),FORMAT(NUMBER),RPTID,INDXCK C DIMENSION CODED(NUMBER),FTRUE(NUMBER) C DIMENSION AL(15),AD(255,15) DIMENSION QCFLG(14) DIMENSION TRFLG(23) DIMENSION SUP(255) DIMENSION ERRNUM(51),ERRLEN(51),ERR(15,51) C CHARACTER*8 YYMMDD,HHMMSS CHARACTER LEVEL*4,FILE*32 DATA LEVEL/'.01A'/ C CALL DATE(YYMMDD) CALL CLOCK(HHMMSS) READ(*,'(A)')FILE C C-----READ REPORT 100 CALL RPTIN(UNIT,BUF,RPT,NRPT,1,DIM RPT,EOF) IF(EOF.NE.0)GOTO 900 DEOF=0 IF(MOD(BUF(2)-1,56).EQ.0)THEN PRINT 1,LEVEL,YYMMDD,HHMMSS,FILE,(BUF(2)-1)/56+1 1 FORMAT('1QS2',A4,2A9,' < ',A,T132,I10) CALL PRNFLD(FIELD,FORMAT,NUMBER) ENDIF 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 C-----UNPACK ATTACHMENTS C GOTO 700 IF(NRPT.NE.64/BPW*((GETATT(RPT,AL,AD)-1)/64+1))STOP 'NRPT' CALL GETQCF(AL,AD,QCFLG,QC) IF(QC.GE.0) +PRINT *,'QC ATT: "',(CHAR(QCFLG(I)),I=1,14),QC,'"' CALL GETTRF(AL,AD,TRFLG) IF(TRFLG(1).NE.0) +PRINT *,'TRIM ATT: "',TRFLG,'"' CALL GETSUP(AL,AD,SUP,SUPLEN) IF(SUPLEN.NE.0) +PRINT *,'SUP ATT: "',(CHAR(SUP(I)),I=1,SUPLEN),'"' CALL GETERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR) IF(NERR.NE.0) +PRINT *,'ERR ATT:',(' ',FIELD(ERRNUM(J))(1:3) +,' = "',(CHAR(ERR(I,J)),I=1,ERRLEN(J)),'"',J=1,NERR) 700 CONTINUE C IF(BUF(2).EQ.10)STOP 'ETC' GOTO 100 C C-----END OF FILE 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 FUNCTION GETATT(RPT,AL,AD) C UNPACK ATTACHMENTS RETURNING LENGTH OF RPT IN BITS C IMPLICIT INTEGER(A-E,G-Z) DIMENSION RPT(*) DIMENSION AL(15),AD(255,15) GETATT=452 CALL GBYTE(RPT,AC,452-4,4) DO 190 I=1,15 AL(I)=0 IF(AC.EQ.0)GOTO 190 CALL GBYTE(RPT,AID,GETATT+8,4) IF(AID.NE.I)GOTO 190 CALL GBYTE(RPT,AL(AID),GETATT,8) CALL GBYTES(RPT,AD(1,AID),GETATT+12,4,0,AL(AID)) GETATT=GETATT+12+4*AL(AID) AC=AC-1 190 CONTINUE END C-----------------------------------------------------------------------3456789 SUBROUTINE GETERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR) C GET ERROR ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION ERRNUM(51),ERRLEN(51),ERR(15,51) C J=0 NERR=0 100 J=J+1 IF(J.GT.AL(5))RETURN NERR=NERR+1 ERRNUM(NERR)=AD(J,5)*16+AD(J+1,5) ERRLEN(NERR)=AD(J+2,5) J=J+2 DO 190 I=1,ERRLEN(NERR) ERR(I,NERR)=AD(J+1,5)*16+AD(J+2,5) J=J+2 190 CONTINUE GOTO 100 END C-----------------------------------------------------------------------3456789 SUBROUTINE GETQCF(AL,AD,QCFLG,QC) C GET QUALITY CONTROL ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION QCFLG(14) DIMENSION ICHAR(11) DATA ICHAR/32,82,65,66,74,75,76,77,78,81,83/ C IF(AL(1).EQ.16)THEN DO 190 I=1,14 QCFLG(I)=ICHAR(AD(I,1)+1) 190 CONTINUE QC=AD(15,1)*16+AD(16,1)-1 ELSE QC=-999 ENDIF 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 C TRFLG( 1)= AD( 1,2)*16*16*4 C + +AD( 2,2)*16*4 C + +AD( 3,2)*4 C + +AD( 4,2)/4 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 GETSUP(AL,AD,SUP,SUPLEN) C GET SUPPLEMENTAL ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION SUP(255) DIMENSION SHIP(256) DATA SHIP +/48,49,50,51,52,53,54,55,56,57,32,181*15 +,123,65,66,67,68,69,70,71,72,73,38,43,4*15 +,125,74,75,76,77,78,79,80,81,82,45,6*15 +,47,83,84,85,86,87,88,89,90,42,21*15/ C I=0 SUPLEN=0 100 I=I+1 IF(I.GT.AL(4))RETURN SUPLEN=SUPLEN+1 C GOTO(9,9,9,9,9,9,9,9,9,9,9,11,14,14,14,15)AD(I,4)+1 C 9 SUP(SUPLEN)=SHIP(AD(I,4)+1) GOTO 100 C 11 DO 190 M=1,3+AD(I+1,4) SUP(SUPLEN)=SHIP(10+1) SUPLEN=SUPLEN+1 190 CONTINUE I=I+1 SUPLEN=SUPLEN-1 GOTO 100 C 14 SUP(SUPLEN)=SHIP(AD(I,4)*16+AD(I+1,4)+1) I=I+1 GOTO 100 C 15 SUP(SUPLEN)=AD(I+1,4)*16+AD(I+2,4) I=I+2 GOTO 100 END C-----------------------------------------------------------------------3456789 SUBROUTINE PRNFLD(FIELD,FORMAT,NUMBER) 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) IMPLICIT INTEGER(A-E,G-Z) CHARACTER*8 FORMAT DIMENSION FTRUE(*),FUNITS(*),FORMAT(*) COMMON /ATT/AL(15),AD(255,15) +,SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR 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 EOR EOF