cat > p.f <<\EOR
C=============================================================================C
C International Comprehensive Ocean-Atmosphere Data Set (ICOADS)  20 Apr 2004 C
C Filename:level: rdlmrf6:01G                        Fortran 77 program+shell C
C Function: Read/print: Long Mar. Rpts Fixed-length: (LMRF6) Author: S.Lubker C
C=============================================================================C
C Software Revision Information (previous version: 9 Oct 2002, level 01F):
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 {rdlmrf} and for
C the (invariant) user-interface routines {prnfld,getrpt,getid,gettrf,prnrpt,
C prntrf}:
C
C As provided {rdlmrf}: (a) Prints the program name and level, and FILE (up to
C 80 characters supplied by the user from standard input).  Also, {prnfld}
C prints a 3-line header for all the regular and location fields in the LMRF6
C format.  (b) Reads a report (from UNIT=1) via an unformatted direct-access
C read, and unpacks all the regular and location fields via {getrpt}.  This
C makes coded (integer) values available in array CODED (zero for missing
C data), and true (floating point) values available in array FTRUE (FMISS for
C missing data).  (c) For location and regular fields, a PARAMETER statement
C relates each field abbreviation to an FTRUE (or CODED) array location; this
C facilitates usage such as FDY = FTRUE(DY), to obtain the floating point value
C for day.  (d) Prints a report via {prnrpt}, under the aforementioned field
C headings.  For readability, blank is printed for missing data.  (e) The
C program iterates (to step b) reading reports until an end-of-file (EOF) is
C encountered.  Caution: IMPLICIT INTEGER(A-E,G-Z) is used; users may need to
C 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 file.
C (c) After the call to {getrpt}, the trimming section can be unpacked and
C converted into true values via {gettrf}, and then printed via {prntrf}.
C (d) A separate PARAMETER statement associated with the trimming section
C relates field abbreviations to corresponding true and coded values in FTRUE
C and CODED.
C
C External libraries: {ebcasc.f}.
C Machine dependencies:  Change CSET from its default ('ASC') to 'EBC' on a
C native-ebcdic (IBM) computer.
C For more information: See <soft_info> and <soft_lmr> (electronic documents).
C-----------------------------------------------------------------------3456789
      PROGRAM RDLMRF
      IMPLICIT INTEGER(A-E,G-Z)
C
      DATA UNIT/1/,FMISS/-999./
C
      CHARACTER RPT*64
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)
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+23),FTRUE(NUMBER+23)
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
C READ INPUT FILE NAME
      READ(*,'(A)')FILE
C PRINT PROGRAM HEADER
      PRINT '(A)',' RDLMRF.01G < '//FILE
C PRINT REPORT HEADER
      CALL PRNFLD(FIELD,FORMAT,NUMBER)
C INITIALIZE NUMBER OF RECORDS READ
      NREC=0
C
C OPEN TO READ BINARY DATA (MACHINE-DEPENDENT MODIFICATIONS MAY BE NEEDED)
      OPEN(UNIT,FORM='UNFORMATTED',ACCESS='DIRECT',RECL=LEN(RPT)
     +,FILE=FILE)
C
C READ REPORT (MACHINE-DEPENDENT MODIFICATIONS MAY BE NEEDED)
  100 READ(UNIT,REC=NREC+1,IOSTAT=EOF)RPT
C EOF OF ZERO INDICATES A SUCCESSFUL READ
      IF(EOF.NE.0)GOTO 900
C INCREMENT NUMBER OF RECORDS READ
      NREC=NREC+1
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 TRIMMING SECTION AND CONVERT CODED TO TRUE VALUES (OPTIONAL)
C      CALL GETTRF(RPT,CODED,FTRUE,FMISS)
C
C PRINT REPORT
      CALL PRNRPT(FTRUE,FMISS,FUNITS,FORMAT,NUMBER)
C
C PRINT TRIMMING SECTION (OPTIONAL)
C      CALL PRNTRF(CODED(NUMBER+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 NEGATIVE ELSE AN ERROR
  900 CONTINUE
      PRINT *,'REPORTS ',NREC,', EOF ',EOF
      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
      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 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 GETTRF(RPT,CODED,FTRUE,FMISS)
C     GET TRIMMING SECTION
C
      IMPLICIT INTEGER(A-E,G-Z)
      CHARACTER*(*) RPT
      DIMENSION CODED(*),FTRUE(*)
C
      CODED(74)=ICHAR(RPT(57:57))*64+MOD(ICHAR(RPT(58:58))/4,64)
      CODED(75)=MOD(ICHAR(RPT(58:58)),4)
      CODED(76)=MOD(ICHAR(RPT(59:59))/16,16)
      CODED(77)=MOD(ICHAR(RPT(59:59)),16)
      CODED(78)=MOD(ICHAR(RPT(60:60))/16,16)
      CODED(79)=MOD(ICHAR(RPT(60:60)),16)
      CODED(80)=MOD(ICHAR(RPT(61:61))/16,16)
      CODED(81)=MOD(ICHAR(RPT(61:61)),16)
      CODED(82)=MOD(ICHAR(RPT(62:62))/64,4)
      CODED(83)=MOD(ICHAR(RPT(62:62))/16,4)
      CODED(84)=MOD(ICHAR(RPT(62:62))/4,4)
      CODED(85)=MOD(ICHAR(RPT(62:62)),4)
      CODED(86)=MOD(ICHAR(RPT(63:63))/64,4)
      CODED(87)=MOD(ICHAR(RPT(63:63))/16,4)
      CODED(88)=MOD(ICHAR(RPT(63:63))/4,4)
      CODED(89)=MOD(ICHAR(RPT(63:63)),4)
      CODED(90)=MOD(ICHAR(RPT(64:64))/64,4)
      CODED(91)=MOD(ICHAR(RPT(64:64))/32,2)
      CODED(92)=MOD(ICHAR(RPT(64:64))/16,2)
      CODED(93)=MOD(ICHAR(RPT(64:64))/8,2)
      CODED(94)=MOD(ICHAR(RPT(64:64))/4,2)
      CODED(95)=MOD(ICHAR(RPT(64:64))/2,2)
      CODED(96)=MOD(ICHAR(RPT(64:64)),2)
      DO 190 I=74,96
        IF (CODED(I).EQ.0) THEN
          FTRUE(I)=FMISS
        ELSE
          FTRUE(I)=CODED(I)
        ENDIF
  190 CONTINUE
      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 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
EOR
rm a.out
f77 p.f /data/coads/software/ebcasc.o
date
echo $1 | ./a.out