cat > p.f <<\EOR
C=============================================================================C
C International Comprehensive Ocean-Atmosphere Data Set (ICOADS) 20 Apr 2004 C
C Filename:level: rdlmr6:01H Fortran 77 program+shell C
C Function: Read/print: Long Marine Reports (LMR6) Author: S.Lubker C
C=============================================================================C
C Software Revision Information (previous version: 9 Oct 2002, level 01G):
C Change in level to extend the upper limits of DS and IX, and to correct
C the upper limit of SID.
C-----------------------------------------------------------------------3456789
C Software documentation for the (modifiable) example program {rdlmr}, and
C for the (invariant) user-interface routines {prnfld,rptin,getrpt,getid,
C getatt,getqcf,gettrf,getsup,geterr,prnrpt,prnqcf,prntrf,prnsup,prnsu2,
C prnerr, prner2}:
C
C As provided {rdlmr}: (a) Reads FILE, a filename of up to 80 characters
C supplied by the user from standard input. Prints the program name and level,
C and FILE. Also, {prnfld} prints a 3-line header for all the regular and
C location fields in the LMR6 format. An OPEN statement associates UNIT=1
C with FILE. (b) Reads a report via {rptin} (from UNIT=1), and unpacks all
C the regular and location fields via {getrpt}. This makes coded (integer)
C values available in array CODED (zero for missing data), and true (floating
C point) values available in array FTRUE (FMISS for missing data). (c) For
C location and regular fields, a PARAMETER statement relates each field
C abbreviation to an FTRUE (or CODED) array location; this facilitates usage
C such as FDY = FTRUE(DY), to obtain the floating point value for day. (d)
C Prints a report via {prnrpt}, under the aforementioned field headings. For
C readability, blank is printed for missing data. (e) The program iterates
C (to step b) reading reports until an end-of-file (EOF) is encountered twice
C (the blocked file structure in which LMR6 data are stored permits internally-
C identified multi-file files). (f) FILE is closed, buffer variables are re-
C initialized, and the program iterates (to step a) reading another FILE (if
C any) for input. Caution: IMPLICIT INTEGER(A-E,G-Z) is used; users may need
C to explicitly type additional variables when modifying this program.
C
C Notes on the printed format: In the header, field abbreviations according
C to <lmr> are listed vertically. The checksum (CK) from the control section
C is also printed. All decimal points are removed by the following uniform
C procedure. Each FTRUE value is divided by the corresponding units as listed
C in <lmr>, e.g., LON=33.80/0.01 = 3380 printed. Only in the case of wave and
C swell heights (WH/SH), which are stored as meters to tenths with a half-meter
C increment, does this produce a non-intuitive result, e.g., WH=6.5/0.5 = 13
C printed (as printed, WH/SH represent 0.5 m increments: 1=0.5 m, 2=1 m, etc.).
C
C The following optional features are initially deactivated in the Fortran
C code; they may be activated by changing the appropriate Fortran comment
C lines to executable statements, i.e., remove the letter "C" from column 1:
C
C (a) Activate the call to {getid} and ID will be returned as an 8-character
C string, with blank-fill for any (all) missing ID elements (CSET determines
C whether ID is returned in ascii or ebcdic). (b) The test for NREC greater
C than 50 can be activated to stop before reading/printing the entire (possibly
C multi-file) file. (c) After the call to {getrpt}, any attachments must first
C be unpacked via integer function {getatt}, before they can be, selectively,
C processed into appropriately-typed data structures via {getqcf,gettrf,getsup,
C geterr}, and then printed via {prnqcf,prntrf,prnsup,prnerr} (execution
C efficiency may be improved by processing only desired attachments). (d)
C PARAMETER statements associated with the quality control (Attm1) and trimming
C (Attm2) attachments relate field abbreviations to coded values in integer
C arrays QCFLG and TRFLG, respectively. Coded arrays are provided because of
C the convenience of using these fields as integers (with zero for missing;
C coded and true value ranges are the same owing to units=0 and base=1). (e)
C The representation of data in the supplemental (Attm4) and error (Attm5)
C attachments varies according to each original input format, as identified
C by source ID (field 11). Interpretation of these attachments will require
C additional documentation, not yet available in convenient electronic form
C (format documentation can be located upon request). The appropriate print
C MODE ('CHR' or 'BIN') for {prnsup,prnerr} will depend on the original input
C data format (CSET determines whether data in 'CHR' mode are printed in ascii
C or ebcdic). Alternative (more detailed) print routines {prnsu2,prner2}
C also are available with the same arguments and MODE options. When MODE=CHR,
C any characters judged unprintable by the print routines are set to blank
C (intrinsic Fortran function ICHAR is used to determine if the stored ascii
C characters fall outside the inclusive range 32-126, i.e., space through "~").
C When MODE=BIN, the output is printed in hexadecimal rather than literally
C in binary, thus "HEX" (rather than BIN) is printed for labelling purposes.
C
C Multiple input/output files: As provided, the program will read multiple
C input files (each of which may in turn be an internally-identified multi-
C file file), if more than one filename FILE is supplied from standard input
C (e.g., if "$*" in the terminating Unix script is replaced by a list of
C pathnames/filenames). This occurs unless the optional test for NREC greater
C than 50 is activated and exceeded (or changed to GOTO 940, instead of STOP).
C The ability to write one output LMR file also is provided as an optional
C feature. Three code sections must be activated: the OPEN statement for
C UNIT+1, the call to {rptout}, and the {rptout} call and CLOSE statement
C preceding the END statement. Optional statements are also included just
C before the END statement for re-initialization of output buffer variables in
C the event that multiple output files are desired, but this requires
C additional modifications depending on specific requirements (e.g., looping
C and UNIT handling).
C
C External libraries: {ebcasc.f,gsbytes.c,rptin.f}.
C Machine dependencies: Change BPW from 32 (its default) to reflect the actual
C computer word size in bits. However, a replacement for {rptin.f}, which is
C limited to 32-bit, must also be available (e.g., on a 64-bit Cray). Change
C CSET from its default ('ASC') to 'EBC' on a native-ebcdic (IBM) computer.
C For more information: See <soft_info> and <soft_lmr> (electronic documents).
C-----------------------------------------------------------------------3456789
PROGRAM RDLMR
IMPLICIT INTEGER(A-E,G-Z)
C
DATA UNIT/1/,FMISS/-999./
C
C BITS PER WORD
PARAMETER(BPW=32)
C
PARAMETER(DIM BUF=(1006*64-1)/BPW+1)
DIMENSION BUF(DIM BUF,2)
DATA ((BUF(I,J),I=1,6),J=1,2)/12*0/
C
PARAMETER(DIM RPT=(452+(3+255)*4*15-1)/64+1)
CHARACTER RPT*(DIM RPT*8)
C
PARAMETER(B10=1,YR=2,MO=3,DY=4,HR=5,TI=6,LON=7,LAT=8,LI=9,DCK=10
+,SID=11,PT=12,QI=13,DS=14,DC=15,TC=16,PB=17,DI=18,D=19,WI=20,W=21
+,VI=22,VV=23,WW=24,W1=25,W2=26,SLP=27,T1=28,AT=29,WBT=30,DPT=31
+,SST=32,SI=33,N=34,NH=35,CL=36,HI=37,H=38,CM=39,CH=40,WD=41,WP=42
+,WH=43,SD=44,SP=45,SH=46,C1=47,C2=48,SC=49,SS=50,A=51,PPP=52,IS=53
+,ES=54,RS=55,II=56,ID1=57,ID2=58,ID3=59,ID4=60,ID5=61,ID6=62
+,ID7=63,ID8=64,OS=65,OP=66,T2=67,IX=68,WX=69,SX=70,IRD=71,A6=72
+,CK=73)
PARAMETER(SHIPF=1,WINDF=2,VISF=3,PRSWXF=4,PSTWXF=5,PRESSF=6,DRYF=7
+,WETF=8,DEWF=9,SEAF=10,CLOUDF=11,SEAWVF=12,SWLWVF=13,PTENDF=14
+,QLTY=15)
PARAMETER(B2=1,ND=2,SF=3,AF=4,UF=5,VF=6,PF=7,RF=8,ZQ=9,SQ=10,AQ=11
+,WQ=12,PQ=13,RQ=14,XQ=15,CQ=16,EQ=17,LZ=18,SZ=19,AZ=20,WZ=21,PZ=22
+,RZ=23)
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)
DIMENSION AL(15),AD(255,15)
DIMENSION QCFLG(15)
DIMENSION TRFLG(23)
DIMENSION SUP(255)
DIMENSION ERRNUM(51),ERRLEN(51),ERR(15,51)
C
CHARACTER CSET*3
COMMON /ENV/CSET
CHARACTER FILE*80,ID*8
C
C ENVIRONMENT CHARACTER SET (ASCII 'ASC' OR EBCDIC 'EBC')
CSET='ASC'
C CSET='EBC'
C
CC OPEN OUTPUT FILE (OPTIONAL)
CC OPEN(UNIT+1,FORM='UNFORMATTED')
C
C READ INPUT FILE NAME
10 READ(*,'(A)',END=990)FILE
C PRINT PROGRAM HEADER
PRINT '(A)',' RDLMR.01H < '//FILE
C PRINT REPORT HEADER
CALL PRNFLD(FIELD,FORMAT,NUMBER)
C INITIALIZE NUMBER OF RECORDS READ
NREC=0
C INITIALIZE DOUBLE END OF FILE INDICATOR
DEOF=0
C
C OPEN INPUT FILE
OPEN(UNIT,FORM='UNFORMATTED',FILE=FILE)
C
C READ REPORT WRITTEN BY RPTOUT
100 CALL RPTIN(UNIT,BUF(1,1),RPT,NRPT,1,DIM RPT,EOF)
C EOF OF ZERO INDICATES A SUCCESSFUL READ
IF(EOF.NE.0)GOTO 900
C INCREMENT NUMBER OF RECORDS READ
NREC=NREC+1
C INITIALIZE DOUBLE END OF FILE INDICATOR
DEOF=0
C
C UNPACK REPORT AND CONVERT CODED TO TRUE VALUES
CALL GETRPT(RPT,CODED,FTRUE,FMISS
+,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK)
C
C GET ID STRING (OPTIONAL)
C CALL GETID(CODED(ID1),ID)
C
C UNPACK ATTACHMENTS (OPTIONAL)
C IF((GETATT(RPT,AL,AD)-1)/64+1.NE.NRPT)STOP 'GETATT ERROR'
C CALL GETQCF(AL,AD,QCFLG)
C CALL GETTRF(AL,AD,TRFLG)
C CALL GETSUP(AL,AD,SUP,SUPLEN)
C CALL GETERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR)
C
C PRINT REPORT
CALL PRNRPT(FTRUE,FMISS,FUNITS,FORMAT,NUMBER)
C
C PRINT ATTACHMENTS IN CHARACTER 'CHR' OR BINARY 'BIN' MODE (OPTIONAL)
C IF(QCFLG(1).NE.0)CALL PRNQCF(QCFLG)
C IF(TRFLG(1).NE.0)CALL PRNTRF(TRFLG)
C IF(SUPLEN.NE.0)CALL PRNSUP(SUP,SUPLEN,'CHR')
C IF(NERR.NE.0)CALL PRNERR(FIELD,ERRNUM,ERRLEN,ERR,NERR,'CHR')
C
CC WRITE REPORT READ BY RPTIN (OPTIONAL)
CC CALL RPTOUT(UNIT+1,BUF(1,2),RPT,NRPT,1)
C
C STOP AFTER SEVERAL REPORTS HAVE BEEN READ
C IF(NREC.GE.50)STOP 'REMOVE STOP TO READ ALL REPORTS'
GOTO 100
C
C END OF FILE IF EOF IS ONE ELSE AN ERROR
900 CONTINUE
PRINT *,'REPORTS ',NREC,', EOF ',EOF
C INITIALIZE NUMBER OF RECORDS READ
NREC=0
C INCREMENT DOUBLE END OF FILE INDICATOR
DEOF=DEOF+1
C DOUBLE END OF FILE IF DEOF IS TWO
IF(DEOF.LT.2)GOTO 100
C
C CLOSE INPUT FILE
940 CONTINUE
CLOSE(UNIT)
DO 945 I=1,6
BUF(I,1)=0
945 CONTINUE
GOTO 10
C
CC CLOSE OUTPUT FILE (OPTIONAL)
990 CONTINUE
CC IF(BUF(1,2).GT.0)
CC +CALL RPTOUT(UNIT+1,BUF(1,2),RPT,NRPT,2)
CC CLOSE(UNIT+1)
CC DO 995 I=1,6
CC BUF(I,2)=0
CC 995 CONTINUE
END
C=============================================================================C
C WARNING: Code beyond this point should not require any modification. C
C=============================================================================C
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,'(A3 '
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., 254., 1., -1., 8, 104,',A3 '
2,'PT ', 0., 15., 1., -1., 5, 112,',A2 '
3,'QI ', 0., 2., 1., -1., 2, 117,',A1 '
4,'DS ', 0., 14., 1., -1., 5, 119,',A2 '
5,'DC ', 0., 2., 1., -1., 4, 124,',A1 '
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., 7., 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)
CHARACTER*(*) RPT
DIMENSION AL(15),AD(255,15)
C
GETATT=452
DO 90 AID=1,15
AL(AID)=0
90 CONTINUE
CALL GBYTE(RPT,AC,452-4,4)
DO 190 I=1,AC
CALL GBYTE(RPT,AID,GETATT+8,4)
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)
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 GETID(CODED,ID)
C GET ID STRING
C
INTEGER CODED(*)
CHARACTER ID*(*)
CHARACTER CSET*3
COMMON /ENV/CSET
C
IF(CSET.EQ.'EBC')THEN
WRITE(ID,'(80A)')(CHAR(IEBC(32+CODED(I))),I=1,LEN(ID))
ELSE
WRITE(ID,'(80A)')(CHAR(32+CODED(I)),I=1,LEN(ID))
ENDIF
END
C-----------------------------------------------------------------------3456789
SUBROUTINE GETQCF(AL,AD,QCFLG)
C GET QUALITY CONTROL ATTACHMENT
C
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION AL(15),AD(255,15)
DIMENSION QCFLG(15)
C
IF(AL(1).NE.16)THEN
DO 90 I=1,14
QCFLG(I)=0
90 CONTINUE
QCFLG(15)=-1
RETURN
ENDIF
C
DO 190 I=1,14
QCFLG(I)=AD(I,1)
190 CONTINUE
QCFLG(15)=AD(15,1)*16+AD(16,1)-1
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)
CHARACTER*(*) RPT
DIMENSION CODED(*),FTRUE(*),FUNITS(*),FBASE(*),BITS(*),OFFSET(*)
C
IF(MOD(ICHAR(RPT(2:2)),16).NE.RPTID)STOP 'RPTID ERROR'
CALL UNPACK(RPT,CODED)
FTRUE(INDXCK)=CODED(INDXCK)
CODED(INDXCK)=0
DO 190 I=1,NUMBER
IF(I.EQ.INDXCK)GOTO 190
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
CODED(INDXCK)=MOD(CODED(INDXCK),2**BITS(INDXCK)-1)
IF(FTRUE(INDXCK).NE.CODED(INDXCK))STOP 'CHECKSUM ERROR'
END
C-----------------------------------------------------------------------3456789
SUBROUTINE UNPACK(RPT,CODED)
C UNPACK REPORT
C
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*(*) RPT
DIMENSION CODED(*)
C
CODED(1)=ICHAR(RPT(3:3))*4+MOD(ICHAR(RPT(4:4))/64,4)
CODED(2)=MOD(ICHAR(RPT(4:4)),64)*4+MOD(ICHAR(RPT(5:5))/64,4)
CODED(3)=MOD(ICHAR(RPT(5:5))/4,16)
CODED(4)=MOD(ICHAR(RPT(5:5)),4)*8+MOD(ICHAR(RPT(6:6))/32,8)
CODED(5)=MOD(ICHAR(RPT(6:6)),32)*128+MOD(ICHAR(RPT(7:7))/2,128)
CODED(6)=MOD(ICHAR(RPT(7:7)),2)*8+MOD(ICHAR(RPT(8:8))/32,8)
CODED(7)=(MOD(ICHAR(RPT(8:8)),32)*256+ICHAR(RPT(9:9)))*8
++MOD(ICHAR(RPT(10:10))/32,8)
CODED(8)=(MOD(ICHAR(RPT(10:10)),32)*256+ICHAR(RPT(11:11)))*4
++MOD(ICHAR(RPT(12:12))/64,4)
CODED(9)=MOD(ICHAR(RPT(12:12))/4,16)
CODED(10)=MOD(ICHAR(RPT(12:12)),4)*256+ICHAR(RPT(13:13))
CODED(11)=ICHAR(RPT(14:14))
CODED(12)=MOD(ICHAR(RPT(15:15))/8,32)
CODED(13)=MOD(ICHAR(RPT(15:15))/2,4)
CODED(14)=MOD(ICHAR(RPT(15:15)),2)*16+MOD(ICHAR(RPT(16:16))/16,16)
CODED(15)=MOD(ICHAR(RPT(16:16)),16)
CODED(16)=MOD(ICHAR(RPT(17:17))/32,8)
CODED(17)=MOD(ICHAR(RPT(17:17))/8,4)
CODED(18)=MOD(ICHAR(RPT(17:17)),8)*2+MOD(ICHAR(RPT(18:18))/128,2)
CODED(19)=MOD(ICHAR(RPT(18:18)),128)*4+MOD(ICHAR(RPT(19:19))/64,4)
CODED(20)=MOD(ICHAR(RPT(19:19))/4,16)
CODED(21)=MOD(ICHAR(RPT(19:19)),4)*256+ICHAR(RPT(20:20))
CODED(22)=MOD(ICHAR(RPT(21:21))/64,4)
CODED(23)=MOD(ICHAR(RPT(21:21))/4,16)
CODED(24)=MOD(ICHAR(RPT(21:21)),4)*32+MOD(ICHAR(RPT(22:22))/8,32)
CODED(25)=MOD(ICHAR(RPT(22:22)),8)*2+MOD(ICHAR(RPT(23:23))/128,2)
CODED(26)=MOD(ICHAR(RPT(23:23))/8,16)
CODED(27)=MOD(ICHAR(RPT(23:23)),8)*256+ICHAR(RPT(24:24))
CODED(28)=MOD(ICHAR(RPT(25:25))/16,16)
CODED(29)=MOD(ICHAR(RPT(25:25)),16)*128
++MOD(ICHAR(RPT(26:26))/2,128)
CODED(30)=(MOD(ICHAR(RPT(26:26)),2)*256+ICHAR(RPT(27:27)))*4
++MOD(ICHAR(RPT(28:28))/64,4)
CODED(31)=MOD(ICHAR(RPT(28:28)),64)*32+MOD(ICHAR(RPT(29:29))/8,32)
CODED(32)=MOD(ICHAR(RPT(29:29)),8)*256+ICHAR(RPT(30:30))
CODED(33)=MOD(ICHAR(RPT(31:31))/16,16)
CODED(34)=MOD(ICHAR(RPT(31:31)),16)
CODED(35)=MOD(ICHAR(RPT(32:32))/16,16)
CODED(36)=MOD(ICHAR(RPT(32:32)),16)
CODED(37)=MOD(ICHAR(RPT(33:33))/64,4)
CODED(38)=MOD(ICHAR(RPT(33:33))/4,16)
CODED(39)=MOD(ICHAR(RPT(33:33)),4)*4+MOD(ICHAR(RPT(34:34))/64,4)
CODED(40)=MOD(ICHAR(RPT(34:34))/4,16)
CODED(41)=MOD(ICHAR(RPT(34:34)),4)*16+MOD(ICHAR(RPT(35:35))/16,16)
CODED(42)=MOD(ICHAR(RPT(35:35)),16)*2+MOD(ICHAR(RPT(36:36))/128,2)
CODED(43)=MOD(ICHAR(RPT(36:36)),128)
CODED(44)=MOD(ICHAR(RPT(37:37))/4,64)
CODED(45)=MOD(ICHAR(RPT(37:37)),4)*8+MOD(ICHAR(RPT(38:38))/32,8)
CODED(46)=MOD(ICHAR(RPT(38:38)),32)*4+MOD(ICHAR(RPT(39:39))/64,4)
CODED(47)=MOD(ICHAR(RPT(39:39)),64)*2+MOD(ICHAR(RPT(40:40))/128,2)
CODED(48)=MOD(ICHAR(RPT(40:40)),128)
CODED(49)=MOD(ICHAR(RPT(41:41))/16,16)
CODED(50)=MOD(ICHAR(RPT(41:41)),16)
CODED(51)=MOD(ICHAR(RPT(42:42))/16,16)
CODED(52)=MOD(ICHAR(RPT(42:42)),16)*32+MOD(ICHAR(RPT(43:43))/8,32)
CODED(53)=MOD(ICHAR(RPT(43:43)),8)
CODED(54)=MOD(ICHAR(RPT(44:44))/2,128)
CODED(55)=MOD(ICHAR(RPT(44:44)),2)*4+MOD(ICHAR(RPT(45:45))/64,4)
CODED(56)=MOD(ICHAR(RPT(45:45))/4,16)
CODED(57)=MOD(ICHAR(RPT(45:45)),4)*16+MOD(ICHAR(RPT(46:46))/16,16)
CODED(58)=MOD(ICHAR(RPT(46:46)),16)*4+MOD(ICHAR(RPT(47:47))/64,4)
CODED(59)=MOD(ICHAR(RPT(47:47)),64)
CODED(60)=MOD(ICHAR(RPT(48:48))/4,64)
CODED(61)=MOD(ICHAR(RPT(48:48)),4)*16+MOD(ICHAR(RPT(49:49))/16,16)
CODED(62)=MOD(ICHAR(RPT(49:49)),16)*4+MOD(ICHAR(RPT(50:50))/64,4)
CODED(63)=MOD(ICHAR(RPT(50:50)),64)
CODED(64)=MOD(ICHAR(RPT(51:51))/4,64)
CODED(65)=MOD(ICHAR(RPT(51:51)),4)*4+MOD(ICHAR(RPT(52:52))/64,4)
CODED(66)=MOD(ICHAR(RPT(52:52))/4,16)
CODED(67)=MOD(ICHAR(RPT(52:52)),4)*2+MOD(ICHAR(RPT(53:53))/128,2)
CODED(68)=MOD(ICHAR(RPT(53:53))/8,16)
CODED(69)=MOD(ICHAR(RPT(53:53))/4,2)
CODED(70)=MOD(ICHAR(RPT(53:53))/2,2)
CODED(71)=MOD(ICHAR(RPT(53:53)),2)*128
++MOD(ICHAR(RPT(54:54))/2,128)
CODED(72)=MOD(ICHAR(RPT(54:54)),2)*2+MOD(ICHAR(RPT(55:55))/128,2)
CODED(73)=MOD(ICHAR(RPT(56:56)),32)
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 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).NE.16)THEN
DO 90 I=1,23
TRFLG(I)=0
90 CONTINUE
RETURN
ENDIF
C
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)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PRNERR(FIELD,ERRNUM,ERRLEN,ERR,NERR,MODE)
C PRINT ERROR ATTACHMENT
C
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*8 FIELD(*)
DIMENSION ERRNUM(51),ERRLEN(51),ERR(15,51)
CHARACTER MODE*3,ATRUE(51)*30
CHARACTER CSET*3
COMMON /ENV/CSET
C
IF(MODE.EQ.'BIN')THEN
WRITE(ATRUE,'(15Z2.2)')ERR
PRINT '('' ERR(HEX):'',130A)'
+ ,((FIELD(ERRNUM(J))(I:I),I=1,LENTRM(FIELD(ERRNUM(J)))),'='
+ ,(ATRUE(J)(I:I),I=1,2*ERRLEN(J))
+ ,' ',J=1,NERR)
ELSE IF(CSET.EQ.'EBC')THEN
PRINT '('' ERR(CHR):'',130A)'
+ ,((FIELD(ERRNUM(J))(I:I),I=1,LENTRM(FIELD(ERRNUM(J)))),'='
+ ,(CHAR(IEBC(MAX(MOD(ERR(I,J)+129,256)-129,32))),I=1,ERRLEN(J))
+ ,' ',J=1,NERR)
ELSE
PRINT '('' ERR(CHR):'',130A)'
+ ,((FIELD(ERRNUM(J))(I:I),I=1,LENTRM(FIELD(ERRNUM(J)))),'='
+ ,(CHAR(MAX(MOD(ERR(I,J)+129,256)-129,32)),I=1,ERRLEN(J))
+ ,' ',J=1,NERR)
ENDIF
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PRNQCF(QCFLG)
C PRINT QUALITY CONTROL ATTACHMENT
C
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION QCFLG(15)
CHARACTER*8 ATT,FIELD(15),ATRUE(15)
DATA ATT/' QC:'/
+,FIELD/' SHIPF=',' WINDF=',' VISF=',' PRSWXF=',' PSTWXF='
+,' PRESSF=',' DRYF=',' WETF=',' DEWF=',' SEAF=',' CLOUDF='
+,' SEAWVF=',' SWLWVF=',' PTENDF=',' QLTY='/
C
DO 90 I=1,15
IF (QCFLG(I).EQ.-I/15) THEN
ATRUE(I)=' '
ELSE
WRITE(ATRUE(I),'(I2)')QCFLG(I)
ENDIF
90 CONTINUE
WRITE(*,'(A4,2(A7,A2),A6,A2,3(A8,A2),4(A6,A2),4(A8,A2),A6,A2)')
+ATT,(FIELD(I),ATRUE(I),I=1,15)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PRNFLD(FIELD,FORMAT,NUMBER)
C PRINT FIELD
C
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*8 FIELD,FORMAT
DIMENSION FIELD(NUMBER),FORMAT(NUMBER)
C
WRITE(*,FORMAT)((FIELD(I)
+(MOD(J+INDEX(FIELD(I)(1:3)//' ',' ')-1,3)+1
+: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(NUMBER),FUNITS(NUMBER),FORMAT(NUMBER)
CHARACTER*8 ATRUE(200)
CHARACTER CSET*3
COMMON /ENV/CSET
C
IF(NUMBER.GT.200)STOP 'NUMBER ERROR'
DO 190 I=1,NUMBER
IF(FTRUE(I).EQ.FMISS)THEN
ATRUE(I)=' '
ELSE IF(FORMAT(I)(2:2).EQ.' ')THEN
IF(CSET.EQ.'EBC')THEN
ATRUE(I)=CHAR(IEBC(NINT(FTRUE(I))))
ELSE
ATRUE(I)=CHAR(NINT(FTRUE(I)))
ENDIF
ELSE
WRITE(ATRUE(I),'(I'//FORMAT(I)(3:3)//')')
+ NINT(FTRUE(I)/FUNITS(I))
ENDIF
190 CONTINUE
WRITE(*,FORMAT)(ATRUE(I),I=1,NUMBER)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PRNSUP(SUP,SUPLEN,MODE)
C PRINT SUPPLEMENTAL ATTACHMENT
C
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION SUP(255)
CHARACTER MODE*3
CHARACTER CSET*3
COMMON /ENV/CSET
C
IF(MODE.EQ.'BIN')THEN
PRINT '('' SUP(HEX):'',65Z2.2)',(SUP(I),I=1,SUPLEN)
ELSE IF(CSET.EQ.'EBC')THEN
PRINT '('' SUP(CHR):'',130A)'
+ ,(CHAR(IEBC(MAX(MOD(SUP(I)+129,256)-129,32))),I=1,SUPLEN)
ELSE
PRINT '('' SUP(CHR):'',130A)'
+ ,(CHAR(MAX(MOD(SUP(I)+129,256)-129,32)),I=1,SUPLEN)
ENDIF
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PRNTRF(TRFLG)
C PRINT TRIMMING ATTACHMENT OR SECTION
C
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION TRFLG(23)
CHARACTER*8 ATT,FIELD(23),ATRUE(23)
DATA ATT/' TRIM:'/
+,FIELD/' B2=',' ND=',' SF=',' AF=',' UF=',' VF=',' PF=',' RF='
+,' ZQ=',' SQ=',' AQ=',' WQ=',' PQ=',' RQ=',' XQ=',' CQ=',' EQ='
+,' LZ=',' SZ=',' AZ=',' WZ=',' PZ=',' RZ='/
C
DO 90 I=1,23
IF (TRFLG(I).EQ.0) THEN
ATRUE(I)=' '
ELSE IF (I.EQ.1) THEN
WRITE(ATRUE(I),'(I5)')TRFLG(I)
ELSE IF (I.GE.3 .AND. I.LE.8) THEN
WRITE(ATRUE(I),'(I2)')TRFLG(I)
ELSE
WRITE(ATRUE(I),'(I1)')TRFLG(I)
ENDIF
90 CONTINUE
WRITE(*,'(A6,A4,A5,A4,A1,6(A4,A2),15(A4,A1))')
+ATT,(FIELD(I),ATRUE(I),I=1,23)
END
C-----------------------------------------------------------------------3456789
FUNCTION LENTRM(STR)
C LENGTH OF A STRING MINUS TRAILING BLANKS
CHARACTER STR*(*)
DO 190 LENTRM=LEN(STR),1,-1
IF (STR(LENTRM:LENTRM).NE.' ') RETURN
190 CONTINUE
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PRNER2(FIELD,ERRNUM,ERRLEN,ERR,NERR,MODE)
C PRINT ERROR ATTACHMENT: IN HEXADECIMAL IF MODE IS 'BIN'; OTHERWISE IN
C CHARACTERS AS APPROPRIATE TO THE PROCESSOR CHARACTER SET IN CSET
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*8 FIELD(*)
DIMENSION ERRNUM(51),ERRLEN(51),ERR(15,51)
COMMON/ENV/ CSET
CHARACTER*3 CSET,MODE
IF(MODE.EQ.'BIN') THEN
C PRINT IN HEXADECIMAL:
PRINT *,'ERR(HEX) (NERR=',NERR,'):'
DO 150 J=1,NERR
WRITE(*,101) FIELD(ERRNUM(J))(1:3),ERRLEN(J)
+ ,(ERR(I,J),I=1,ERRLEN(J))
101 FORMAT(1X,A,'(ERRLEN=',I2,' BYTES):',(2(8Z2.2,1X)))
150 CONTINUE
ELSE IF(CSET.EQ.'ASC') THEN
C PRINT IN CHARACTERS: ASCII
PRINT *,'ERR(',MODE,') (NERR=',NERR,'):'
DO 250 J=1,NERR
WRITE(*,201) FIELD(ERRNUM(J))(1:3),ERRLEN(J)
+ ,(CHAR(MAX(MOD(ERR(I,J)+129,256)-129,32))
+ ,I=1,ERRLEN(J)),'"'
201 FORMAT(1X,A,'(ERRLEN=',I2,' BYTES):"',(15(A1)))
250 CONTINUE
ELSE IF(CSET.EQ.'EBC') THEN
C PRINT IN CHARACTERS: EBCDIC
PRINT *,'ERR(',MODE,') (NERR=',NERR,'):'
DO 350 J=1,NERR
WRITE(*,201) FIELD(ERRNUM(J))(1:3),ERRLEN(J)
+ ,(CHAR(IEBC(MAX(MOD(ERR(I,J)+129,256)-129,32)))
+ ,I=1,ERRLEN(J)),'"'
350 CONTINUE
C FALL THROUGH TO ERROR
ELSE
PRINT *,'PRNER2 ERROR. MODE=',MODE,' CSET=',CSET
STOP
ENDIF
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PRNSU2(SUP,SUPLEN,MODE)
C PRINT SUPPLEMENTAL ATTACHMENT
C
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION SUP(255)
CHARACTER MODE*3
CHARACTER CSET*3
COMMON /ENV/CSET
C PRINT IN HEXADECIMAL:
IF(MODE.EQ.'BIN') THEN
PRINT *,'SUP(HEX) (SUPLEN=',SUPLEN,'):'
WRITE(*,101) ' 8-BIT BYTES:'
101 FORMAT(A14,' 1 2 '
+ ,' 3 4 5'
+ ,/,14X,' 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5'
+ ,' 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0'
+ )
DO 150 J=1,SUPLEN,50
ELINE = MIN(J+49,SUPLEN)
WRITE(*,102) J,ELINE,(SUP(I),I=J,ELINE)
102 FORMAT(1X,'SUP(',I3,'-',I3,'):',50Z2.2)
150 CONTINUE
ELSE IF(CSET.EQ.'ASC') THEN
C PRINT IN CHARACTERS: ASCII
PRINT *,'SUP(',MODE,') (SUPLEN=',SUPLEN,'):'
WRITE(*,201) ' 8-BIT BYTES:'
201 FORMAT(A14,' 1 2 3 4 5'
+ ,' 6 7 8 9 0'
+ ,/,14X,'12345678901234567890123456789012345678901234567890'
+ ,'12345678901234567890123456789012345678901234567890'
+ )
DO 250 J=1,SUPLEN,100
ELINE = MIN(J+99,SUPLEN)
WRITE(*,202) J,ELINE
+ ,(CHAR(MAX(MOD(SUP(I)+129,256)-129,32))
+ ,I=J,ELINE)
202 FORMAT(1X,'SUP(',I3,'-',I3,'):',100A1)
250 CONTINUE
ELSE IF(CSET.EQ.'EBC') THEN
C PRINT IN CHARACTERS: EBCDIC
PRINT *,'SUP(',MODE,') (SUPLEN=',SUPLEN,'):'
WRITE(*,201) ' 8-BIT BYTES:'
DO 350 J=1,SUPLEN,100
ELINE = MIN(J+99,SUPLEN)
WRITE(*,202) J,ELINE
+ ,(CHAR(IEBC(MAX(MOD(SUP(I)+129,256)-129,32)))
+ ,I=J,ELINE)
350 CONTINUE
C FALL THROUGH TO ERROR
ELSE
PRINT *,'PRNSU2 ERROR. MODE=',MODE,' CSET=',CSET
STOP
ENDIF
END
EOR
a=/data/coads/software
rm a.out
f77 p.f $a/ebcasc.o $a/gsbytes.o $a/rptin.o
date
ls -1 $* | ./a.out