PROGRAM QI27 C-----READ AND PRINT LMR5 C C-----RCDIN, BUFFER IN, UNIT, LENGTH, GBYTE/S, DATE AND TIME ARE C MACHINE-DEPENDENT ROUTINES AND FUNCTIONS. SEE COADS RELEASE 1 C SUPPLEMENT H FOR A DESCRIPTION OF THEIR BEHAVIOR. BPW IS A C PARAMETER WHICH MUST BE SET TO THE NUMBER OF BITS PER MACHINE C WORD. C ===1=========2=========3=========4=========5=========6=========7== C C -----------REVISION HISTORY--------------------------------------- C LEVEL AUTHOR DATE DESCRIPTION C ===== ====== ========== ==================== C .01A. SL 85/10/17. ORIGINAL VERSION. C ------------------------------------------------------------------ C C ===1=========2=========3=========4=========5=========6=========7== IMPLICIT INTEGER(A-E,G-Z) C PARAMETER(MAX=600,RPTOFF=0,FMISS=-999.9,INDEXCK=47,BPR=998*64,ID=0 +,BPW=60,DIM BUF=(1006*64-1)/BPW+1,DIM PK=(BPR-1)/BPW+1,DIM UN=47) C COMMON /LMR5/FIELD(47),FTRUEL(47),FTRUEU(47),FUNITS(47),FBASE(47) +,BITS(47),OFFSET(47) COMMON/IND/LOT,IMAX C DIMENSION BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN) +,QCF(14),IEB(70),IAS(70),NPAR(46),NCR(46),NDOR(8,46),NDAS(8,46) C DATA LEVEL/4H.01A/,BUF/DIM BUF*0/ +,LOT/BPW/,IMAX/DIM BUF/ C CALL DATE(DTE) CALL TIME(TME) PRINT 1,LEVEL,DTE,TME 1 FORMAT('1QI27',A4,2A9) C 100 CALL GETRPT(1,FMISS,FUNITS,FBASE,BITS,OFFSET,INDEXCK,ID +,BPR,BPW,RPTOFF,BUF,DIM BUF,PK,DIM PK,UN,DIM UN,FTRUE,JEOF) IF(JEOF.NE.0)GOTO 900 CALL GBYTE1(PK,UN48,296,4) CALL GETQCF(PK,QCF,QLTYCD) CALL GETSUP(PK,IEB,IAS,LTH) CALL GETERR(PK,NUM,NPAR,NCR,NDOR,NDAS) C PRINT 300,(FIELD(I),FTRUE(I),I=1,DIM UN),5HAC ,FLOAT(UN48) 300 FORMAT(6(1X,A5,F7.1)) PRINT 301,QCF,QLTYCD 301 FORMAT(' QC ATT=',14A1,I2) PRINT 302,LTH,(CHAR(IAS(I)-32),I=1,LTH) 302 FORMAT(' SUP ATT (LTH',I3,')=',70A1) PRINT 303,(NPAR(J),NCR(J),(CHAR(NDAS(I,J)-32),I=1,NCR(J)) +,(' ',I=NCR(J)+1,8),J=1,NUM) 303 FORMAT(' ERR ATT=',5(I3,I2,1X,8A1)) IF(BUF(2).LT.MAX)GOTO 100 C 900 PRINT *,' REPORTS ',BUF(2),', EOF ',JEOF END C======================================================================= BLOCK DATA LMR5 IMPLICIT INTEGER(A-E,G-Z) C COMMON /LMR5/FIELD(47),FTRUEL(47),FTRUEU(47),FUNITS(47),FBASE(47) +,BITS(47),OFFSET(47) C DATA FIELD/8HBOX10 ,8HYEAR ,8HMONTH ,8HDAY ,8HHOUR , +8HX ,8HY ,8HXYI ,8HCD ,8HSID ,8HST , +8HQI ,8HDS ,8HDC ,8HTC ,8HPB ,8HDI , +8HD ,8HWI ,8HW ,8HVI ,8HVB ,8HPW , +8HW1 ,8HW2 ,8HP ,8HTI ,8HA ,8HWB , +8HDPT ,8HS ,8HBI ,8HC ,8HNH ,8HCL , +8HHI ,8HH ,8HCM ,8HCH ,8HWD ,8HWP , +8HWH ,8HSD ,8HSP ,8HSH ,8HA6 ,8HCK / C DATA FTRUEL/1.,1800.,2*1.,2*0.,-90.0,9*0.,0.,1.,3*0.,90.,3*0. +,870.,0.,4*-99.9,16*0./ C DATA FTRUEU/648.,2054.,12.,31.,23.,359.9,90.0,3.,999.,254.,7. +,2.,5.,2.,1.,2.,5.,362.,3.,102.2,2.,2*99.,2*9.,1074.6 +,5.,4*99.9,2.,2*9.,10.,1.,3*10.,38.,30.,49.5,38.,30.,49.5,1. +,254./ C DATA FUNITS/5*1.,2*.1,12*1.,.1,5*1.,.1,1.,4*.1,10*1.,.5,2*1. +,.5,2*1./ C DATA FBASE/0,1799,2*0,2*-1,-901,10*-1,0,3*-1,89,3*-1,8699,-1 +,4*-1000,15*-1,0/ C DATA BITS/10,8,4,5,5,12,11,3,10,8,4,2,3,2,3,2,3,9,4,10,2,4 +,7,2*4,11,4,4*11,4*4,2,3*4,6,5,7,6,5,7,2,8/ C DATA OFFSET/16,26,34,38,43,48,60,71,74,84,92,96,98,101,103,106 +,108,111,120,124,134,136,140,147,151,155,166,170,181,192,203,214 +,218,222,226,230,232,236,240,244,250,255,262,268,273,280,288/ END C======================================================================= SUBROUTINE GETQCF(LMR,QCF,QLTYCD) C-----GET QUALITY CONTROL FLAGS FROM LMR5 ATTACHMENT 1 IMPLICIT INTEGER(A-Z) DIMENSION LMR(*),QCF(14),FTRUE(10) DATA OFFSET/312/,FTRUE/1HR,1HA,1HB,1HJ,1HK,1HL,1HM,1HN,1HQ,1HS/ CALL GBYTE1S(LMR,QCF,OFFSET,4,0,14) CALL GBYTE1(LMR,QLTYCD,OFFSET+56,8) DO 100 I=1,14 100 QCF(I)=FTRUE(QCF(I)) QLTYCD=QLTYCD-1 END C======================================================================= SUBROUTINE GETSUP(NB,IEB,IAS,LTH) DIMENSION NB(1),IEB(1),IAS(1) DIMENSION IC(100),ITBL(48) DATA IOFF/296/ DATA ITBL/192,193,194,195,196,197,198,199,200,201,80,78,4*0, 2 208,209,210,211,212,213,214,215,216,217,96,5*0, 3 000,097,226,227,228,229,230,231,232,233,92,5*0/ C C RETURNS SUPPLEMENTAL DATA ONE CHARACTER PER WORD C C INPUT C NB - BUFFER CONTAINING ONE LMR RECORD C OUTPUT C IEB - CHARACTER STRING IN EBCDIC (RT JUSTIFIED IN WORD) C IAS - CHARACTER STRING IN ASCII (RT JUSTIFIED IN WORD) C LTH - NUMBER OF CHARACTERS IN STRING (TRAILING BLANKS NOT COUNTED) C LTH=0 WHEN THERE IS NO SUPPLEMENTAL DATA C LTH=0 NLTH=0 CALL GBYTE1(NB,NATT,IOFF,4) KOFF=IOFF+4 1 KOFF=KOFF+4*NLTH IF(NATT .LE. 0) GO TO 90 CALL GBYTE1(NB,NLTH,KOFF,8) KOFF=KOFF+8 CALL GBYTE1(NB,NSUP,KOFF,4) KOFF=KOFF+4 NATT=NATT-1 IF(NSUP .NE. 4) GO TO 1 IF(NLTH.LE.0) GO TO 90 CALL GBYTE1S(NB,IC,KOFF,4,0,NLTH) IO=0 I=0 2 I=I+1 IF(I .GT. NLTH) GO TO 30 ICC=IC(I) IF(ICC .GT. 9) GO TO 8 C NUMERIC IO=IO+1 IEB(IO)=240+ICC GO TO 2 8 CONTINUE IF(ICC .NE. 10) GO TO 10 C BLANK IO=IO+1 IEB(IO)=64 GO TO 2 10 CONTINUE IF(ICC .NE. 11) GO TO 14 C MULTIPLE BLANKS I=I+1 NN=IC(I)+3 DO 12 K=1,NN IO=IO+1 IEB(IO)=64 12 CONTINUE GO TO 2 14 CONTINUE IF(ICC .GT. 14) GO TO 20 C SHIP 8-BIT CODES IO=IO+1 I=I+1 IX=IC(I)+16*(ICC-12) + 1 IEB(IO)=ITBL(IX) GO TO 2 20 CONTINUE I=I+1 IO=IO+1 IEB(IO)=16*IC(I)+IC(I+1) I=I+1 GO TO 2 30 CONTINUE LTH=IO IF(LTH .GT. 0) CALL EB2AS(IEB,IAS,LTH) 90 CONTINUE END C======================================================================= SUBROUTINE EB2AS(IN,NOT,N) C C CHARACTER CONVERSION EBCDIC TO ASCII C INPUT C IN - EBCDIC ARRAY, ONE CHAR/WORD RIGHT JUSTIFIED C N - NUMBER OF CHARACTERS TO CONVERT. C OUTPUT C NOT - OUTPUT ASCII ARRAY, ONE/CHAR WORD, RIGHT JUSTIFIED. C C DIMENSION NTB(256) DIMENSION IN(1),NOT(1) DATA NTB/64*0, +032,000,000,000,000,000,000,000,000,000,091,046,060,040,043,033, +038,000,000,000,000,000,000,000,000,000,093,036,042,041,059,094, +045,047,000,000,000,000,000,000,000,000,000,044,037,095,062,063, +000,000,000,000,000,000,000,000,000,000,058,035,064,039,061,034, +64*0, +123,065,066,067,068,069,070,071,072,073,000,000,000,000,000,000, +125,074,075,076,077,078,079,080,081,082,000,000,000,000,000,000, +092,000,083,084,085,086,087,088,089,090,000,000,000,000,000,000, +048,049,050,051,052,053,054,055,056,057,000,000,000,000,000,000/ DO 20 I=1,N IND=IN(I)+1 NOT(I)=NTB(IND) 20 CONTINUE RETURN END C======================================================================= SUBROUTINE GETERR(NB,NUM,NPAR,NCR,NDOR,NDAS) DIMENSION NB(1),NPAR(1),NCR(1),NDOR(8,1),NDAS(8,1) C RETURN ERROR FIELD INFORMATION C C INPUT C NB - BUFFER CONTAINING LMR RECORD C C OUTPUT C NUM - NUMBER OF ERROR FIELDS C ARRAYS C NPAR - LIST OF PARAMETER NUMBERS C NCR - LIST OF CHARACTER COUNTS FOR EACH PARAMETER C NDOR - ARRAY CONTAINING DATA IN ORIG CHARACTER SET C NDAS - ARRAY CONTAINING DATA IN ASCII C DATA IOFF/296/ NUM=0 LTH=0 CALL GBYTE1(NB,NATT,IOFF,4) KOFF=IOFF+4 5 KOFF=KOFF+4*LTH IF(NATT .LE. 0) GO TO 90 CALL GBYTE1(NB,LTH,KOFF,8) KOFF=KOFF+8 CALL GBYTE1(NB,NSUP,KOFF,4) KOFF=KOFF+4 NATT=NATT-1 IF(NSUP .NE. 5) GO TO 5 I=0 NBE=KOFF+4*LTH 10 IF(KOFF .GE. NBE) GO TO 80 I=I+1 CALL GBYTE1(NB,NPAR(I),KOFF,8) KOFF=KOFF+8 CALL GBYTE1(NB,NCR(I),KOFF,4) KOFF=KOFF+4 IF(NCR(I).LE.0) GO TO 95 IF(NCR(I).GT.8) GO TO 95 CALL GBYTE1S(NB,NDOR(1,I),KOFF,8,0,NCR(I)) KOFF=KOFF+8*NCR(I) CALL EB2AS(NDOR(1,I),NDAS(1,I),NCR(I)) GO TO 10 80 NUM=I 90 RETURN 95 PRINT 1001,I,NCR(I),LTH 1001 FORMAT(1X,'0SUSPICIOUS ERROR ATTACHMENT,I,NCR,LTH',3I6) NUM=I-1 RETURN END C======================================================================= SUBROUTINE GBYTE1(P,U,Q,B) IMPLICIT INTEGER(A-E,G-Z) COMMON/IND/LOT,IMAX DIMENSION P(*),U(*) CALL GBYTE(P(Q/LOT+1),U,MOD(Q,LOT),B) END C======================================================================= SUBROUTINE GBYTE1S(P,U,Q,B,S,N) IMPLICIT INTEGER(A-E,G-Z) COMMON/IND/LOT,IMAX DIMENSION P(*),U(*) CALL GBYTES(P(Q/LOT+1),U,MOD(Q,LOT),B,S,N) END C======================================================================= SUBROUTINE RPTIN (NUNIT,NBUF,LOCRPT,NWDS,JJ,KLMAX,JEOF) C TO READ RPTOUT RECORDS WRITTEN ON A MACHINE OF WORD LENGTH $LIN$ BITS IN TO C A MACHINE OF WORD LENGTH $LOT$ BITS - BUFFER LENGTH IN IS IMAX C LOT WORDS - IE LARGE ENOUGH FOR THE BUFFER SIZE IN LIN BIT WORDS C ALL LENGTHS IN THE CALLING SEQUENCE ARE $LOT$ BIT WORDS C NCAR 2 JUL 71 D JOSEPH COMMON/IND/LOT,IMAX DIMENSION NBUF(*),LOCRPT(1) DATA LIN/64/ IF (NBUF(1) .EQ. 0) GO TO 3 IF (NBUF(1) .NE. 7) GO TO 40 GO TO 6 3 CALL IOWAIT(NUNIT,NBUF(6),NWRED) XL=LOT XF=LIN XF=XL/XF YF=1./XF ID=LIN-LOT LII=7 LGET=LIN-4 LOFF=4 IF (LOT .GE. LIN) GO TO 4 LOFF=ID LGET=LOT XOFF=LOFF XP=XOFF/XL IP=XP LOFF=(XP-IP)*XL+.01 LII=IP+7 4 CONTINUE 5 CALL RDTAPE(NUNIT,1,2,NBUF(7),IMAX-6) 6 CALL IOWAIT(NUNIT,NBUF(6),NWRED) IBITS=LIN NBUF(1)=8 JEOF=NBUF(6) IF (JEOF .EQ. 1) GO TO 42 NTST=XF*NWRED+.01 IF (NTST .GT. 2) GO TO 10 IEREC=NBUF(3)+1 PRINT 960,NUNIT,IEREC,NWRED,NBUF(6) 960 FORMAT(' +++ RPTINX SHORT PHYS REC,UNIT,PHYS REC,EXP LTH ',4I8) 10 NBUF(5)=NWRED CALL GBYTES(NBUF(LII),IWDS,LOFF,LGET,0,1) NWU=(XF*NWRED)+0.01 NWL=NWU-XF+.99 IF (IWDS .GE. NWL .AND. IWDS .LE. NWU) GO TO 18 IEREC=NBUF(3)+1 PRINT 962,NUNIT,IEREC,NWRED,IWDS,NBUF(6) 962 FORMAT(' +++ RPTINX - BAD PHYS LTH,UNIT,PHYS REC , LTH, EXP LTH, 2 STATUS',5I8) GO TO 5 18 CONTINUE NBUF(6)=0 NBUF(3)=NBUF(3)+1 NBUF(4)=NBUF(4)+NWRED LBITS=LIN*(IWDS-1) 40 JEOF=NBUF(6) XBITS=IBITS XP=XBITS/XL IP=XP IOF=(XP-IP)*XL+.01 II=IP+1 CALL GBYTES(NBUF(II+6),NWDS,IOF,12,0,1) IF (NWDS .GT. 0 .AND. NWDS .LE.(IWDS-2)) GO TO 46 IEREC=NBUF(2)+1 PRINT 964,NUNIT,IEREC,NWDS 964 FORMAT(' +++ RPTINX- BAD LOGICAL LENGTH,UNIT,LOG REC,LTH ',5I8) GO TO 3 46 CONTINUE LTH=XF*NWDS+.99 IBITS=IBITS+LIN*NWDS NWDS=YF*NWDS+.99 CALL GBYTES(NBUF(II+6),LOCRPT,IOF,LOT,0,NWDS) NBUF(2)=NBUF(2)+1 NBUF(1)=NBUF(1)+NWDS IF (IBITS .GE. LBITS) GO TO 52 RETURN 52 NBUF(1)=7 CALL RDTAPE(NUNIT,1,2,NBUF(7),IMAX-6) 42 CONTINUE RETURN END C======================================================================= SUBROUTINE RDTAPE(NUzefLENGTH) DIMENSION BUFFER(1) IF(MODE.GT.1) MODE=MODE-2 BUFFER IN(NUNIT,MODE) (BUFFER(1),BUFFER(LENGTH)) RETURN END C======================================================================= SUBROUTINE IOWAIT(NUNIT,NSTATE,NWORDS) 10 IF (UNIT(NUNIT)) 11,12,13 11 NSTATE=0 NWORDS=LENGTH(NUNIT) RETURN 12 NSTATE=1 RETURN 13 NSTATE=2 NWORDS=LENGTH(NUNIT) RETURN END C======================================================================= SUBROUTINE GETRPT(TAPE,FMISS,FUNITS,FBASE,BITS,OFFSET,INDEXCK,ID +,BPR,BPW,RPTOFF,BUF,DIM BUF,PK,DIM PK,UN,DIM UN,FTRUE,JEOF) C C-----RETURN FLOATING POINT VALUES IN FTRUE C C INPUT C TAPE - RPTIN/RCDIN UNIT C FMISS - MISSING VALUE C FUNITS(DIM UN) - UNITS FOR UNCODING C FBASE(DIM UN) - BASE FOR UNCODING C BITS(DIM UN) - BITS FOR UNPACKING C OFFSET(DIM UN) - OFFSET FOR UNPACKING C INDEXCK - UN(INDEXCK) = CHECKSUM C ID - GROUP NUMBER FOR IDENTIFICATION CHECKSUM C BPR - BITS PER REPORT C BPW - BITS PER WORD C RPTOFF - 0=FALSE 1=TRUE C OUTPUT C BUF(DIM BUF) - RPTIN/RCDIN BUFFER C PK(DIM PK) - PACKED REPORT C UN(DIM UN) - UNPACKED REPORT C FTRUE(DIM UN) - TRUE VALUES C JEOF - 0=FALSE 1=TRUE C IMPLICIT INTEGER(A-E,G-Z) DIMENSION FUNITS(DIM UN),FBASE(DIM UN),BITS(DIM UN),OFFSET(DIM UN) +,BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN) C C-----RPTIN/RCDIN IF(RPTOFF.NE.0)GOTO 100 CALL RPTIN(TAPE,BUF,PK,KWDS,1,DIM PK,JEOF) GOTO 110 100 CALL RCDIN(TAPE,BUF,DIM BUF,PK,DIM PK,BPR,BPW,JEOF) 110 IF(JEOF-1)200,900,800 C C-----GBYTE AND CONVERT TO TRUE 200 CK=ID DO 230 I=1,DIM UN CALL GBYTE(PK(OFFSET(I)/BPW+1),UN(I),MOD(OFFSET(I),BPW),BITS(I)) IF(I.EQ.INDEXCK)GOTO 210 IF(UN(I).EQ.0)GOTO 220 FTRUE(I)=(UN(I)+FBASE(I))*FUNITS(I) CK=CK+UN(I) GOTO 230 210 FTRUE(INDEXCK)=UN(INDEXCK) GOTO 230 220 FTRUE(I)=FMISS 230 CONTINUE IF(MOD(CK,2**BITS(INDEXCK)-1).EQ.UN(INDEXCK))RETURN C C-----ERROR PRINT *,' SUBROUTINE GETRPT -- CHECKSUM ERROR, TAPE = ',TAPE +,', REPORT = ',BUF(2) PRINT *,' FTRUE = ',FTRUE 800 STOP C 900 END