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