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