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/-999999./
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(B2=74,ND=75,SF=76,AF=77,UF=78,VF=79,PF=80,RF=81,ZQ=82
     +,SQ=83,AQ=84,WQ=85,PQ=86,RQ=87,XQ=88,CQ=89,EQ=90,LZ=91,SZ=92,AZ=93
     +,WZ=94,PZ=95,RZ=96)
      PARAMETER(SHIPF=97,WINDF=98,VISF=99,PRSWXF=100,PSTWXF=101
     +,PRESSF=102,DRYF=103,WETF=104,DEWF=105,SEAF=106,CLOUDF=107
     +,SEAWVF=108,SWLWVF=109,PTENDF=110,QLTY=111)
C
      CHARACTER*8 FIELD,FORMAT
      PARAMETER(NUMBER=111)
      COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER)
     +,FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER),OFFSET(NUMBER)
     +,FORMAT(NUMBER),RPTID,INDXCK
C
      COMMON /ATT/AL(15),AD(255,15)
     +,SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR
      DIMENSION CODED(NUMBER),FTRUE(NUMBER)
     +,TRFLG(B2:RZ),QCFLG(SHIPF:QLTY)
      EQUIVALENCE(CODED(B2),TRFLG),(CODED(SHIPF),QCFLG)
      DATA CODED/NUMBER*0/
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
c      PRINT '(A)',' RDLMR.02C < '//FILE
C PRINT REPORT HEADER
c      CALL PRNFL2(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 ATTACHMENTS (OPTIONAL)
      IF((GETATT(RPT,AL,AD)-1)/64+1.NE.NRPT)STOP 'GETATT ERROR'
      CALL GETQCF(AL,AD,QCFLG)
      CALL GETTRF(AL,AD,TRFLG)
      CALL GETSUP(AL,AD,SUP,SUPLEN)
C      CALL GETERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR)
C
C UNPACK REPORT AND CONVERT CODED TO TRUE VALUES
      CALL GETRPT(RPT,CODED,FTRUE,FMISS
     +,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK)
      if (nint(ftrue(ds)).gt.2) then
        if (.not.(nint(ftrue(yr)).le.1949
     +      .and. nint(ftrue(ds)).eq.6)) goto 100
      endif
      if (nint(ftrue(lz)).eq.1) goto 100
      if (nint(ftrue(sid)).eq.25 .and. nint(ftrue(yr)).gt.1984) goto 100
      if (nint(ftrue(sid)).eq.30 .and. nint(ftrue(yr)).gt.1984) goto 100
      if (nint(ftrue(sid)).eq.33 .and. nint(ftrue(yr)).lt.1986) then
        if (nint(ftrue(yr)).ge.1980) goto 100
      endif
C
C GET ID STRING (OPTIONAL)
C      CALL GETID(CODED(ID1),ID)
C
C PRINT REPORT
      CALL PRNRP2(FTRUE,FMISS,FUNITS,FORMAT,NUMBER)
C
C PRINT ATTACHMENTS IN CHARACTER 'CHR' OR BINARY 'BIN' MODE (OPTIONAL)
C      IF(QCFLG(SHIPF).NE.0)CALL PRNQCF(QCFLG)
C      IF(TRFLG(B2).NE.0)CALL PRNTRF(TRFLG)
      if (nint(ftrue(dck)).eq.732) then
      IF(SUPLEN.gE.0)CALL PRNSUP(ad(1,4),al(4),'BIN')
      else
      IF(SUPLEN.gE.0)CALL PRNSUP(SUP,SUPLEN,'CHR')
      endif
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
c      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 BDLMR
      IMPLICIT INTEGER(A-E,G-Z)
C
      CHARACTER*8 FIELD,FORMAT
      PARAMETER(NUMBER=111)
      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,80)
     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 '
     4,'B2  ',      1.,  16202.,      1.,      0.,  14, 540,',A5 '
     5,'ND  ',      1.,      2.,      1.,      0.,   2, 554,',A1 '
     6,'SF  ',      1.,     15.,      1.,      0.,   4, 556,',A2 '
     7,'AF  ',      1.,     15.,      1.,      0.,   4, 560,',A2 '
     8,'UF  ',      1.,     15.,      1.,      0.,   4, 564,',A2 '
     9,'VF  ',      1.,     15.,      1.,      0.,   4, 568,',A2 '
     8,'PF  ',      1.,     15.,      1.,      0.,   4, 572,',A2 '/
      DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I)
     +,BITS(I),OFFSET(I),FORMAT(I),I=81,90)
     1/'RF  ',      1.,     15.,      1.,      0.,   4, 576,',A2 '
     2,'ZQ  ',      1.,      3.,      1.,      0.,   2, 580,',A1 '
     3,'SQ  ',      1.,      3.,      1.,      0.,   2, 582,',A1 '
     4,'AQ  ',      1.,      3.,      1.,      0.,   2, 584,',A1 '
     5,'WQ  ',      1.,      3.,      1.,      0.,   2, 586,',A1 '
     6,'PQ  ',      1.,      3.,      1.,      0.,   2, 588,',A1 '
     7,'RQ  ',      1.,      3.,      1.,      0.,   2, 590,',A1 '
     8,'XQ  ',      1.,      3.,      1.,      0.,   2, 592,',A1 '
     9,'CQ  ',      1.,      3.,      1.,      0.,   2, 594,',A1 '
     9,'EQ  ',      1.,      3.,      1.,      0.,   2, 596,',A1 '/
      DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I)
     +,BITS(I),OFFSET(I),FORMAT(I),I=91,100)
     1/'LZ  ',      1.,      1.,      1.,      0.,   1, 598,',A1 '
     2,'SZ  ',      1.,      1.,      1.,      0.,   1, 599,',A1 '
     3,'AZ  ',      1.,      1.,      1.,      0.,   1, 600,',A1 '
     4,'WZ  ',      1.,      1.,      1.,      0.,   1, 601,',A1 '
     5,'PZ  ',      1.,      1.,      1.,      0.,   1, 602,',A1 '
     6,'RZ  ',      1.,      1.,      1.,      0.,   1, 603,',A1 '
     7,'SHIP',      1.,     10.,      1.,      0.,   4, 464,',A2 '
     8,'WIND',      1.,     10.,      1.,      0.,   4, 468,',A2 '
     9,'VIS ',      1.,     10.,      1.,      0.,   4, 472,',A2 '
     A,'PRSW',      1.,     10.,      1.,      0.,   4, 476,',A2 '/
      DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I)
     +,BITS(I),OFFSET(I),FORMAT(I),I=101,110)
     1/'PSTW',      1.,     10.,      1.,      0.,   4, 480,',A2 '
     2,'PRES',      1.,     10.,      1.,      0.,   4, 484,',A2 '
     3,'DRY ',      1.,     10.,      1.,      0.,   4, 488,',A2 '
     4,'WET ',      1.,     10.,      1.,      0.,   4, 492,',A2 '
     5,'DEW ',      1.,     10.,      1.,      0.,   4, 496,',A2 '
     6,'SEA ',      1.,     10.,      1.,      0.,   4, 500,',A2 '
     7,'CLOU',      1.,     10.,      1.,      0.,   4, 504,',A2 '
     8,'SEAW',      1.,     10.,      1.,      0.,   4, 508,',A2 '
     9,'SWLW',      1.,     10.,      1.,      0.,   4, 512,',A2 '
     B,'PTEN',      1.,     10.,      1.,      0.,   4, 516,',A2 '/
      DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I)
     +,BITS(I),OFFSET(I),FORMAT(I),I=111,111)
     1/'QLTY',      0.,     42.,      1.,     -1.,   8, 520,',A2)'/
C
      DATA INDXCK/73/,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,15
          QCFLG(I)=0
   90   CONTINUE
        RETURN
      ENDIF
C
      DO 190 I=1,14
        QCFLG(I)=AD(I,1)
  190 CONTINUE
      QCFLG(15)=AD(15,1)*16+AD(16,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)
          IF(I.LT.INDXCK)
     +    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)
      DATA ATT/' QC:'/
     +,FIELD/' SHIPF=',' WINDF=',' VISF=',' PRSWXF=',' PSTWXF='
     +,' PRESSF=',' DRYF=',' WETF=',' DEWF=',' SEAF=',' CLOUDF='
     +,' SEAWVF=',' SWLWVF=',' PTENDF=',' QLTY='/
C
      WRITE(*,'(A4,2(A7,I2.0),A6,I2.0,3(A8,I2.0),4(A6,I2.0),4(A8,I2.0)
     +,A6,I2.0)')ATT,(FIELD(I),QCFLG(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(1024)
C
      DO 190 J=1,4
        WRITE(*,FORMAT)(FIELD(I)
     +  (MOD(J+INDEX(FIELD(I)(1:4)//' ',' ')-2,4)+1
     +  :MOD(J+INDEX(FIELD(I)(1:4)//' ',' ')-2,4)+1)
     +  ,I=1,NUMBER)
  190 CONTINUE
C      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(1024)
      CHARACTER CSET*3
      COMMON /ENV/CSET
      CHARACTER CTRUE(1024)*8,C,FUNC
C
      DO 190 I=1,NUMBER
        IF(FTRUE(I).EQ.FMISS)THEN
          CTRUE(I)=' '
        ELSE IF(INDEX(FORMAT(I),':').NE.0)THEN
          IF(CSET.EQ.'EBC')THEN
            CTRUE(I)=CHAR(IEBC(NINT(FTRUE(I))))
          ELSE
            CTRUE(I)=CHAR(NINT(FTRUE(I)))
          ENDIF
        ELSE
          C=FORMAT(I)(INDEX(FORMAT(I),'A')+1:)
          IF(C.EQ.'1')THEN
            FUNC='Z'
          ELSE
            FUNC='I'
          ENDIF
          WRITE(CTRUE(I),'('//FUNC//C//')')NINT(FTRUE(I)/FUNITS(I))
        ENDIF
  190 CONTINUE
      WRITE(*,FORMAT)(CTRUE(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 '(51x,''99 01'',255Z1)',(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 '(51x,''99 0 '',1024A)'
     +  ,(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)
      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
      WRITE(*,'(A6,A4,I5.0,A4,I1.0,6(A4,I2.0),15(A4,I1.0))')
     +ATT,(FIELD(I),TRFLG(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
C-----------------------------------------------------------------------3456789
      SUBROUTINE PRNFL2(FIELD,FORMAT,NUMBER)
C     PRINT FIELD IN ARCHIVE FORMAT
C
      IMPLICIT INTEGER(A-E,G-Z)
      CHARACTER*8 FIELD,FORMAT
      DIMENSION FIELD(NUMBER),FORMAT(NUMBER)
     +,FTRUE(NUMBER),FUNITS(NUMBER)
      PARAMETER(W=21,SI=33,C1=47,T2=67,ZQ=82,SQ=83,AQ=84,WQ=85,PQ=86
     +,RQ=87,SZ=92,AZ=93,WZ=94,PZ=95,RZ=96)
      CHARACTER FOR*(*),MAT*180
      PARAMETER(FOR='(T114,A3,  T1,A4,  T5,A2,  T7,A2,  T9,A4, T27,A1, T
     +18,A6, T13,A5, T28,A1,T119,A3,T122,A3,T125,A2,T109,A1,T127,A2,T129
     +,A1,T130,A1,T131,A1, T46,A1, T47,A3, T50,A1, T51,A3, T54,A1, T55,A
     +2, T57,A2, T59,A1,T183,A1, T60,A5, T69,A1, T70,A4, T75,A4, T80,A4,
     + T86,A4, T84,A2, T90,A1, T91,A1, T92,A1, T93,A1, T94,A1, T95,A1, T
     +96,A1, T97,A2, T99,A2,T101,A2,T103,A2,T105,A2,T107,A2, T44,A2,T134
     +,A2, T29,A1, T30,A1, T65,A1, T66,A3,T195,A1,T196,A2,T198,A1, T33,A
     +2, T35:A1, T36:A1, T37:A1, T38:A1, T39:A1, T40:A1, T41:A1, T42:A1,
     +T178,A1,T179,A1, T74,A1,T182,A1,T132,A1,T133,A1,T109,A1,T109,A1,T1
     +09,A1,T109,A1,T148,A1,T149,A1,T150,A1,T151,A1,T152,A1,T153,A1,T154
     +,A1,T109,A1,T109,A1,T109,A1,T109,A1,T109,A1,T109,A1,T109,A1,T109,A
     +1,T109,A1,T171,A1,T109,A1,T109,A1,T109,A1,T109,A1,T109,A1,T155,A1,
     +T156,A1,T157,A1,T158,A1,T159,A1,T160,A1,T161,A1,T162,A1,T163,A1,T1
     +64,A1,T165,A1,T166,A1,T167,A1,T168,A1,T109,A1')
      SAVE
C
      CALL PRNFLD(FIELD,FOR(:NUMBER*8)//',T109,'' '')',NUMBER)
      RETURN
C-----------------------------------------------------------------------3456789
      ENTRY PRNRP2(FTRUE,FMISS,FUNITS,FORMAT,NUMBER)
C     PRINT REPORT IN ARCHIVE FORMAT
C
      MAT=',T24,'' 03'',T109,'' 165'',T174,'' 276'')'
C
C      IF(NINT(FTRUE(LI)).EQ.2)CONTINUE
      IF(FTRUE(W).NE.FMISS)THEN
        IF(NINT(FTRUE(W)*10).GT.999)
     +  MAT(INDEX(MAT,')'):)=',T51,''   '')'
      ENDIF
      IF(NINT(FTRUE(SI)).EQ.8)
     +MAT(INDEX(MAT,')'):)=',T84,''  '')'
      IF(FTRUE(C1).NE.FMISS)THEN
        IF(NINT(FTRUE(C1)).LE.9)
     +  MAT(INDEX(MAT,')'):)=',T44,''0'')'
      ENDIF
      IF(FTRUE(T2).NE.FMISS)THEN
             IF(NINT(FTRUE(T2)).EQ.0
     +     .OR. NINT(FTRUE(T2)).EQ.4)THEN
          MAT(INDEX(MAT,')'):)=',T74,''0'')'
        ELSE IF(NINT(FTRUE(T2)).EQ.1
     +     .OR. NINT(FTRUE(T2)).EQ.5)THEN
          MAT(INDEX(MAT,')'):)=',T74,''1'')'
        ELSE IF(NINT(FTRUE(T2)).EQ.2
     +     .OR. NINT(FTRUE(T2)).EQ.6)THEN
          MAT(INDEX(MAT,')'):)=',T74,''2'')'
        ELSE IF(NINT(FTRUE(T2)).EQ.3)THEN
          MAT(INDEX(MAT,')'):)=',T74,'' '')'
        ENDIF
             IF(NINT(FTRUE(T2)).EQ.6)THEN
          MAT(INDEX(MAT,')'):)=',T79,''3'')'
        ELSE IF(NINT(FTRUE(T2)).GE.3)THEN
          MAT(INDEX(MAT,')'):)=',T79,''1'')'
        ENDIF
      ENDIF
      IF(NUMBER.GE.RQ)
     +WRITE(MAT(INDEX(MAT,')'):),'('',T169,'''''',I2.0,'''''')'')')NINT(
     + MIN(MOD(DIM(4.,ABS(FTRUE(ZQ))),3.),1.)*2.*2.*2.*2.*2.
     ++MIN(MOD(DIM(4.,ABS(FTRUE(SQ))),3.),1.)*2.*2.*2.*2.
     ++MIN(MOD(DIM(4.,ABS(FTRUE(AQ))),3.),1.)*2.*2.*2.
     ++MIN(MOD(DIM(4.,ABS(FTRUE(WQ))),3.),1.)*2.*2.
     ++MIN(MOD(DIM(4.,ABS(FTRUE(PQ))),3.),1.)*2.
     ++MIN(MOD(DIM(4.,ABS(FTRUE(RQ))),3.),1.)
     +)
      IF(NUMBER.GE.RZ)
     +WRITE(MAT(INDEX(MAT,')'):),'('',T172,'''''',I2.0,'''''')'')')NINT(
     + DIM(2.,ABS(FTRUE(SZ)))*2.*2.*2.*2.
     ++DIM(2.,ABS(FTRUE(AZ)))*2.*2.*2.
     ++DIM(2.,ABS(FTRUE(WZ)))*2.*2.
     ++DIM(2.,ABS(FTRUE(PZ)))*2.
     ++DIM(2.,ABS(FTRUE(RZ)))
     +)
      mat(index(mat,')'):)='$)'
      CALL PRNRPT(FTRUE,FMISS,FUNITS,FOR(:NUMBER*8)//MAT,NUMBER)
      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