cat > p.f <<\EOR
C=============================================================================C
C International Comprehensive Ocean-Atmosphere Data Set (ICOADS) 4 May 2004 C
C Filename:level: wrlmr6:01E Fortran 77 program+shell C
C Function: Write: Long Marine Reports (LMR6) Author: S.Lubker C
C=============================================================================C
C Software Revision Information (previous version: 10 Feb 2000, level 01D):
C Change in level to read SID in three characters by eliminating the blank
C carriage control position previously in column 1. Rewrite of the binary
C example in routine {test}.
C-----------------------------------------------------------------------3456789
C Software documentation for the (modifiable) example program {eg} and routine
C {test}, and for the (invariant) user-interface routines {wrlmr,lentrm}, plus
C {iasc,ebcasc,ascebc} from {ebcasc.f}:
C
C Logical function {wrlmr} is available to assist conversions into, and write
C out reports in, LMR6 format (unit 3). Also, a conversion summary (unit 8)
C is written at run termination. Floating-point data are passed to {wrlmr}
C via argument FTRUE (dimensioned 73 to cover the LMR6 location and regular
C fields, plus the checksum from the control section), or missing FTRUE
C elements should be set to the user-assigned value FMISS. Parallel arrays
C CTRUE (character*16) and LTRUE (integer) are used to pass the contents and
C length, respectively, of each input original data field (or, possibly, a
C concatenation of multiple fields) used to construct the corresponding element
C of FTRUE. CTRUE and/or LTRUE are stored in the error attachment (Attm5)
C only under two conditions:
C 1) If FTRUE is FMISS, and LTRUE is greater than zero (LTRUE characters
C from CTRUE are stored in Attm5).
C 2) If FTRUE is less than the minimum or greater than the maximum
C allowable true value for the field (determined by {wrlmr}); in this case
C LTRUE characters from CTRUE are stored in Attm5, or Attm5 may be of zero
C length if LTRUE is zero (no original input available).
C Argument CSUP (character*255) is used to pass data for storage in the
C supplemental attachment (Attm4), with its length indicated by LSUP (may be
C zero). Argument JEOF=1 is passed to write each individual report, and
C finally JEOF=2 is passed to flush the {wrlmr} internal buffer and write the
C conversion summary (this final call does not write a new LMR, and should be
C invoked only once at run termination). When JEOF=1, {wrlmr} returns either
C true, if an LMR has been successfully written (to the write buffer); or
C false, if LAT, LON, MO, and/or YR were missing or erroneous. In this case it
C is suggested that the user write the original input report to the reject file
C (discussed below) for examination. When JEOF=2, {wrlmr} always returns true.
C The remaining (character) arguments PNAME, PLEVEL, INITLS, and FILNAM supply
C the program name and level, the programmer's initials, and the input
C filename; these are used to construct an "index record" forming the third
C line of the conversion summary. Further details about {wrlmr} are given in
C <soft_lmr>, including FTRUE elements that must be extant, or missing, or
C warnings are issued.
C
C As provided, {eg} has the following features: (a) For location and regular
C fields, a PARAMETER statement relates each field abbreviation to an FTRUE
C (or CTRUE/LTRUE) array location; this facilitates usage such as FTRUE(DY) =
C FMISS, to set FTRUE(DY) to missing. (b) By default, the native computer
C environment character set CSET is set to ascii (ASC), and the input data MODE
C to character (CHR). (c) {eg} reads the name FILNAM of the input file from
C standard input, and opens and names that file (unit 1) and the output files
C (units 2, 3, and 8). The reject file (unit 2) is assigned to receive copies
C of any input reports rejected by {wrlmr} (as signaled by a false return).
C Integer function {lentrm} returns the length of a character string minus
C trailing blanks, e.g., to construct filenames without embedded blanks
C when FILNAM is less than sixteen characters in length (provided FILNAM is
C left-justified on input). (d) A warning is issued if PNAME, PLEVEL, INITLS,
C and/or FILNAM have not been changed from their default ("?"), to help ensure
C that valid information is included in the index record (the default Unix
C shell commands echo "FILENAME" to standard input, thereby setting FILNAM).
C (e) One report of synthetic data is read from unit 1 into CTRUE, plus 106
C characters of supplemental data read into CSUP. The format of the data read
C into CTRUE is identical to that output by {rdlmr6} (i.e., fields 1-73 are
C read according to FORMAT stored in common block /LMR6/). Similarly, the
C format of the data read into CSUP is compatible with that output by {rdlmr6}
C (i.e., by {prnsup} when called with MODE=CHR, except preceded by 10 blanks
C rather than the string " SUP(CHR):"). CTRUE then contains the minimum
C true value (in the form of characters) allowable for each field, with two
C exceptions:
C 1) Fields that {wrlmr} expects to be missing, which are blank.
C 2) For the eight ID fields, CTRUE contains "!": the character with
C the smallest lexical value (according to the ascii collating sequence)
C representable in the ID fields.
C The 106 characters of supplemental data consist of: 43 non-blank characters
C directly representable in the 4/8/12-bit "ship" character set (ref., <lmr>);
C one blank; 2-, 3-, and 6-blank sequences (the latter trailing); and 51
C characters not directly representable (thus stored in 12 bits). (f) A DO
C loop through the 73 elements first sets LTRUE via {lentrm} to the field width
C associated with each extant field, or zero for fields expected by {wrlmr} to
C be missing. Then, an internal read transforms non-blank CTRUE elements for
C numeric (non-ID) fields into FTRUE floating-point values, or FMISS in the
C event of a read error (no read errors occur when using the provided set of
C FILENAME data). Or, for the ID fields, "!" is converted to a corresponding
C numeric value, i.e., the position of the character in the processor
C collating-sequence according to the intrinsic Fortran function ICHAR (33 is
C expected in a native-ascii environment). (g) The length of the supplemental
C attachment minus trailing blanks is determined via {lentrm}. (h) If the
C environment is native-ebcdic (as indicated by CSET), the ID fields are mapped
C using {iasc} from the ICHAR of each ebcdic character to the corresponding
C ascii number, and the CTRUE and CSUP characters are converted from ebcdic to
C ascii via {ebcasc}. (i) {wrlmr} is invoked with JEOF=1 to write one report;
C a true return indicates that the report has been successfully written. Or,
C upon a false return, a copy of the input data would be written to the reject
C file, first converted from ascii to ebcdic via {ascebc} if CSET=EBC. (j) As
C discussed above, the FILENAME input format corresponds to one style of output
C available from {rdlmr6} (i.e., without headers, and with only supplemental
C attachment data printed by {prnsup} with MODE=CHR). Activation of GOTO 100
C allows reading in, and writing out, multiple such reports output by {rdlmr6}
C into FILENAME. (k) As provided, however, {test} is called to help check the
C reversibility of character transformations and of binary data transfers, and
C to write out additional reports based on the initial synthetic data (details
C discussed below). (l) Finally, {wrlmr} is called with JEOF=2 to flush its
C internal write buffer. Caution: IMPLICIT INTEGER(A-E,G-Z) is used; users
C may need to explicitly type additional variables when modifying this program.
C
C As provided, {test} has the following features: (a) In case the
C original input data format is binary (e.g., 8- or 16-bit integers)
C a transfer may be needed of the binary data assumed to be read into integer
C variables into characters forming identical bit-patterns in CTRUE and CSUP.
C Alternatively, if the system allows an equivalence between character and
C integer variables (not permitted under the ANSI Fortran 77 standard), then
C an equivalance statement accomplishes the same thing. (b) At this stage, the
C characters in CTRUE and CSUP should be ascii (transformed in {eg} from ebcdic
C if CSET=EBC). (c) The reversibility is tested of the transformations of
C CTRUE and CSUP to and from ebcdic (via {ebcasc,ascebc}). Note: The check that
C the reversibility tests did not introduce any changes occurs only when reports
C later output from {test} are mechanically verified by the user against the
C benchmark outputs provided with {wrlmr6}, as discussed below. (d) A DO loop
C then attempts to write out 72 reports representing minor variations of the
C synthetic data earlier read by {eg}. Specifically, this works backwards
C through the 72 location/regular elements from field 72 (A6) to 1 (B10),
C setting each FTRUE element in turn to FMISS and then calling {wrlmr} to
C write the report. For missing fields (LTRUE zero), the report data are
C unchanged from the last iteration. For extant fields (LTRUE greater than
C zero) the result is either:
C 1) To force {wrlmr} to store the CTRUE value in the error attachment.
C 2) Or, in the case of LAT, LON, MO, and YR, {wrlmr} returns false and
C a copy of the input data is written to the reject file. In this case
C when MODE=CHR and CSET=EBC, the input data are converted from ascii to
C ebcdic for writing out, and then back to ascii for continued processing.
C After each call to {wrlmr}, FTRUE fields that were previously extant are
C re-set to the maximum allowable value (as stored in common block /LMR6/).
C (e) If the default MODE=CHR is changed to BIN, all of the extant fields first
C are transformed into 8- or 16-bit integers in CTRUE before iterating through
C the 72 field modifications (note that the supplemental data are still in the
C form of characters for either MODE). This occurs in two steps:
C 1) A positive integer is created by dividing each FTRUE value by the field's
C units FUNITS and subtracting its base FBASE (from common block /LMR6/).
C Note: Negative integers may be stored using different conventions (e.g.,
C ones versus twos complement) on different computer systems, hence the
C choice of storing all positive values to ensure more robust benchmark
C results.
C 2) The binary data are transferred into CTRUE via intrinsic Fortran
C function CHAR.
C In total, 69 LMR6 reports are output (one previously by {eg}), and four
C reports are written to the reject file.
C
C Additional notes: When {wrlmr} is invoked with JEOF=2 at run termination,
C the settings of CSET and MODE are displayed in the first line of the
C conversion summary. Benchmark results are supplied with {wrlmr6} for both
C MODE=CHR and BIN. To help ensure proper installation of the software, it
C is suggested that {eg} be run once with MODE=CHR and once with MODE=BIN,
C and verifications be made against benchmark outputs described in <soft_lmr>,
C including the reject files. When MODE=BIN, it should be noted that
C the reject file contains a meaningless mixture of binary data and ascii
C characters. In contrast, when MODE=CHR, the reject file contains readable
C character information, converted from ascii to ebcdic if CSET=EBC.
C
C External libraries: {date.f,ebcasc.f,gsbytes,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). Also,
C the software has not been tested on computers with byte-swapping conventions
C used in storage within computer words (e.g., VAX and PCs), and MODE=BIN will
C work properly only on 32- or 64-bit computers. Change CSET from its default
C ('ASC') to 'EBC' on a native-ebcdic (IBM) computer.
C For more information: See <soft_info> and <soft_lmr> (electronic documents).
C-----------------------------------------------------------------------3456789
PROGRAM EG
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
REAL FTRUE(NUMBER),FMISS
CHARACTER CTRUE(NUMBER)*16,CSUP(4)*255
INTEGER LTRUE(NUMBER),LSUP,JEOF
CHARACTER PNAME*16,PLEVEL*6,INITLS*2,FILNAM*16
CHARACTER CSET*3,MODE*3
COMMON /ENV/CSET,MODE
LOGICAL WRLMR
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)
DATA FTRUE/NUMBER*-999./,FMISS/-999./
DATA CTRUE/NUMBER*' '/,CSUP/4*' '/
DATA LTRUE/NUMBER*0/,LSUP/0/,JEOF/1/
DATA PNAME/'usmmj'/,PLEVEL/'.01A'/,INITLS/'SL'/,FILNAM/'?'/
+,JULIAN/0/,HOUR/0/
REAL DLON,DLAT
C
C ENVIRONMENT CHARACTER SET (ASCII 'ASC' OR EBCDIC 'EBC')
CSET='ASC'
C CSET='EBC'
C INPUT DATA MODE (CHARACTER 'CHR' OR BINARY 'BIN')
MODE='CHR'
C MODE='BIN'
C
C OPEN FILES
READ(*,'(A)')FILNAM
IF (FILNAM.EQ.' ') FILNAM=PNAME
OPEN(1,FILE=FILNAM(:LENTRM(FILNAM)))
OPEN(2,FILE=FILNAM(:LENTRM(FILNAM))//'_REJ')
OPEN(3,FILE=FILNAM(:LENTRM(FILNAM))//'_LMR',FORM='UNFORMATTED')
OPEN(8,FILE=FILNAM(:LENTRM(FILNAM))//'_SUM')
C
IF(PNAME.EQ.'?'.OR.PLEVEL.EQ.'?'
+.OR.INITLS.EQ.'?'.OR.FILNAM.EQ.'?')
+PRINT *,'WARNING: MISSING PROGRAM NAME, PROGRAM VERSION, '
+//'PROGRAMMER''S INITIALS, OR FILE NAME'
C
C READ REPORT
100 READ(*,'(A)',END=900)CSUP(4)
LSUP=LENTRM(CSUP(4))
IF (ICHAR(CSUP(4)(LSUP:LSUP)).EQ.13) THEN
CSUP(4)(LSUP:LSUP)=' '
LSUP=LENTRM(CSUP(4)(:LSUP))
ENDIF
IF (CSUP(4)(:1).GE.'1' .AND. CSUP(4)(:1).LE.'3') THEN
CSUP(INDEX('123',CSUP(4)(:1)))=CSUP(4)
JULIAN=0
HOUR=0
GOTO 100
ELSE IF (CSUP(4)(:1).EQ.'4' .OR. CSUP(4)(:1).EQ.'5') THEN
IF (CSUP(2)(2:8).EQ.CSUP(1)(2:8)
+ .AND. CSUP(3)(2:12).EQ.CSUP(2)(2:12)
+ .AND. CSUP(4)(2:12).EQ.CSUP(2)(2:12)) THEN
ELSE
+ IF (CSUP(2)(2:8).EQ.'0230462'
+ .AND. CSUP(3)(2:12).EQ.CSUP(2)(2:12)
+ .AND. CSUP(4)(2:12).EQ.CSUP(2)(2:12)) THEN
CSUP(1)=' '
ELSE
+ IF (CSUP(1)(2:8).EQ.'3643747'
+ .AND. CSUP(3)(2:8).EQ.CSUP(1)(2:8)
+ .AND. CSUP(4)(2:8).EQ.CSUP(1)(2:8)) THEN
CSUP(2)=' '
CSUP(3)(9:12)=' '
CSUP(4)(9:12)=' '
ELSE
STOP 2
ENDIF
ELSE
STOP 1
ENDIF
IF (CSUP(3)(17:24).NE.CSUP(4)(17:24)) STOP 3
IF (CSUP(4)(39:40).NE.' ') STOP 5
C
C CTRUE(ID1)=CSUP(1)(13:13)
C CTRUE(ID2)=CSUP(1)(14:14)
C CTRUE(ID3)=CSUP(1)(15:15)
C CTRUE(ID4)=CSUP(1)(16:16)
C CTRUE(ID5)=CSUP(1)(17:17)
C CTRUE(ID6)=CSUP(1)(18:18)
C CTRUE(ID7)=CSUP(1)(19:19)
C CTRUE(ID8)=CSUP(1)(20:20)
CTRUE(ID1)=CSUP(4)(2:2)
CTRUE(ID2)=CSUP(4)(3:3)
CTRUE(ID3)=CSUP(4)(4:4)
CTRUE(ID4)=CSUP(4)(5:5)
CTRUE(ID5)=CSUP(4)(6:6)
CTRUE(ID6)=CSUP(4)(7:7)
CTRUE(ID7)=CSUP(4)(8:8)
CTRUE(PB)=CSUP(1)(111:115)
CTRUE(SI)=CSUP(1)(117:117)
CTRUE(LAT)=CSUP(3)(40:43)
IF (CTRUE(LAT).EQ.' ')
+CTRUE(LAT)=CSUP(3)(29:32)
CTRUE(LON)=CSUP(3)(45:49)
IF (CTRUE(LON).EQ.' ')
+CTRUE(LON)=CSUP(3)(34:38)
CTRUE(YR)=CSUP(4)(17:20)
CTRUE(MO)=CSUP(4)(21:22)
CTRUE(DY)=CSUP(4)(23:24)
CTRUE(HR)=CSUP(4)(25:27)
CTRUE(SS)=CSUP(4)(28:30)
CTRUE(SC)=CSUP(4)(41:47)
IF (CTRUE(SC).EQ.' ')
+CTRUE(SC)=CSUP(4)(32:38)
CTRUE(D)=CSUP(4)(55:61)
IF (CTRUE(D).EQ.' ')
+CTRUE(D)=CSUP(4)(48:54)
CTRUE(W)=CSUP(4)(62:63)
CTRUE(SLP)=CSUP(4)(64:67)
CTRUE(T1)=CSUP(4)(68:68)
CTRUE(DPT)=CSUP(4)(69:72)
CTRUE(AT)=CSUP(4)(73:76)
CTRUE(WBT)=CSUP(4)(77:80)
CTRUE(SST)=CSUP(4)(81:84)
CTRUE(N)=CSUP(4)(92:93)
CTRUE(DI)=CSUP(4)(99:102)
C
C CONVERT FIELDS TO FLOATING POINT VALUES
DO 190 I=1,NUMBER
IF (CTRUE(I).NE.' ') THEN
LTRUE(I)=LENTRM(CTRUE(I))
IF (I.GE.ID1.AND.I.LE.ID8) THEN
FTRUE(I)=ICHAR(CTRUE(I)(1:1))
IF (NINT(FTRUE(I)).GE.97 .AND. NINT(FTRUE(I)).LE.122)
+ FTRUE(I)=FTRUE(I)-97.+65.
ELSE
READ(CTRUE(I),'(BZ,F<LTRUE(I)>.0)',ERR=180)FTRUE(I)
FTRUE(I)=FTRUE(I)*FUNITS(I)
ENDIF
GOTO 190
ENDIF
LTRUE(I)=0
180 FTRUE(I)=FMISS
190 CONTINUE
C
IF (CSUP(4)(2:8).EQ.'0610920') THEN
IF (NINT(FTRUE(MO)).EQ.2) FTRUE(YR)=1884.
ELSE
+IF (CSUP(4)(2:8).EQ.'0871118'
+.OR.CSUP(4)(2:8).EQ.'0871119') THEN
FTRUE(YR)=FTRUE(YR)-1.
ELSE
+IF (CSUP(4)(2:8).EQ.'1471619') THEN
IF (NINT(FTRUE(MO)).NE.12) FTRUE(YR)=1885.
ELSE
+IF (CSUP(4)(2:8).EQ.'3493633') THEN
IF (NINT(FTRUE(MO)).LE.4) FTRUE(YR)=1889.
ENDIF
IF (CSUP(4)(2:8).EQ.'1091303') THEN
IF (CSUP(4)(9:12).EQ.'0458') FTRUE(MO)=FTRUE(MO)+3.
ENDIF
IF (CSUP(4)(2:8).EQ.'0851109') THEN
IF (NINT(FTRUE(MO)).EQ.11 .AND. NINT(FTRUE(DY)).EQ.31)
+ FTRUE(DY)=30.
ELSE
+IF (CSUP(4)(2:8).EQ.'2732890'
+.OR.CSUP(4)(2:8).EQ.'3213332') THEN
IF (NINT(FTRUE(MO)).EQ.2 .AND. NINT(FTRUE(DY)).EQ.29) THEN
FTRUE(MO)=3.
FTRUE(DY)=1.
ENDIF
ENDIF
IF (CSUP(4)(2:8).EQ.'0590898') THEN
IF (NINT(FTRUE(T1)).EQ.3) FTRUE(T1)=7.
ELSE
+IF (CSUP(4)(2:8).EQ.'0891129'
+.OR.CSUP(4)(2:8).EQ.'0891134') THEN
IF (FTRUE(DPT).NE.FMISS) FTRUE(DPT)=FTRUE(DPT)*10.
ELSE
+IF (CSUP(4)(2:8).EQ.'3293423') THEN
IF (NINT(FTRUE(T1)).NE.1) FTRUE(T1)=1.
ELSE
+IF (CSUP(4)(2:8).EQ.'0550879'
+.OR.CSUP(4)(2:8).EQ.'0550880'
+.OR.CSUP(4)(2:8).EQ.'0560882') THEN
FTRUE(WBT)=FMISS
ELSE
+IF (CSUP(4)(2:8).EQ.'0180362') THEN
ENDIF
IF (CSUP(4)(2:8).EQ.'0300656'
+.AND. NINT(FTRUE(MO)).EQ.07 .AND. NINT(FTRUE(DY)).EQ.19) THEN
FTRUE(LON)=16.48
FTRUE(TC)=1.
ELSE
+IF (CSUP(4)(2:8).EQ.'1761885'
+.AND. NINT(FTRUE(MO)).EQ.07 .AND. NINT(FTRUE(DY)).EQ.10) THEN
FTRUE(LAT)=8.30
FTRUE(TC)=1.
ENDIF
EAST=1
IF (CSUP(4)(2:8).EQ.'0620924'
+.AND. NINT(FTRUE(MO)).EQ.03 .AND. NINT(FTRUE(DY)).EQ.27
+.OR.CSUP(4)(2:8).EQ.'2362480'
+.AND. NINT(FTRUE(MO)).EQ.07 .AND. NINT(FTRUE(DY)).EQ.14
+.OR.CSUP(4)(2:8).EQ.'2903069'
+.AND. NINT(FTRUE(MO)).EQ.06 .AND. NINT(FTRUE(DY)).GE.01
+ .AND. NINT(FTRUE(DY)).LE.03
+.OR.CSUP(4)(2:8).EQ.'2933095'
+.AND. NINT(FTRUE(MO)).EQ.10 .AND. NINT(FTRUE(DY)).EQ.03
+.OR.CSUP(4)(2:8).EQ.'2973124' .AND. CSUP(4)(9:12).EQ.'0310'
+.AND. NINT(FTRUE(MO)).EQ.07 .AND. NINT(FTRUE(DY)).EQ.21
+.OR.CSUP(4)(2:8).EQ.'3393524'
+.AND.(NINT(FTRUE(MO)).EQ.08 .AND. NINT(FTRUE(DY)).GE.26
+ .OR. NINT(FTRUE(MO)).EQ.09)
+.OR.CSUP(4)(2:8).EQ.'3433574'
+.AND.(NINT(FTRUE(MO)).EQ.06 .AND. NINT(FTRUE(DY)).EQ.17
+ .OR. NINT(FTRUE(MO)).EQ.07 .AND. NINT(FTRUE(DY)).EQ.28)) THEN
EAST=-1
FTRUE(TC)=1.
ENDIF
NORTH=1
IF (CSUP(4)(2:8).EQ.'1641775'
+.AND. NINT(FTRUE(MO)).EQ.02 .AND. NINT(FTRUE(DY)).GE.07) THEN
NORTH=-1
FTRUE(TC)=1.
ENDIF
IF (CSUP(4)(2:8).EQ.'3113257'
+.AND. NINT(FTRUE(MO)).EQ.07 .AND. NINT(FTRUE(DY)).EQ.26
+.OR.CSUP(4)(2:8).EQ.'2973124' .AND.(CSUP(4)(9:12).EQ.'0262'
+ .OR. CSUP(4)(9:12).EQ.'0296')
+.OR.CSUP(4)(2:8).EQ.'1291452' .AND. CSUP(4)(9:12).EQ.'0016'
+.OR.CSUP(4)(2:8).EQ.'0861113')
+GOTO 100
IF (CSUP(4)(2:8).EQ.'0050104' .OR.CSUP(4)(2:8).EQ.'0090177'
+.OR.CSUP(4)(2:8).EQ.'0110224' .OR.CSUP(4)(2:8).EQ.'0210444'
+.OR.CSUP(4)(2:8).EQ.'0680984' .OR.CSUP(4)(2:8).EQ.'0901138'
+.OR.CSUP(4)(2:8).EQ.'0901139' .OR.CSUP(4)(2:8).EQ.'1121321'
+.OR.CSUP(4)(2:8).EQ.'1131323' .OR.CSUP(4)(2:8).EQ.'1281445'
+.OR.CSUP(4)(2:8).EQ.'1341491' .OR.CSUP(4)(2:8).EQ.'1341492'
+.OR.CSUP(4)(2:8).EQ.'1341493' .OR.CSUP(4)(2:8).EQ.'1381528'
+.OR.CSUP(4)(2:8).EQ.'1511651' .OR.CSUP(4)(2:8).EQ.'1511655'
+.OR.CSUP(4)(2:8).EQ.'1601742' .OR.CSUP(4)(2:8).EQ.'1601743'
+.OR.CSUP(4)(2:8).EQ.'1601744' .OR.CSUP(4)(2:8).EQ.'1631769'
+.OR.CSUP(4)(2:8).EQ.'1641770' .OR.CSUP(4)(2:8).EQ.'1651794'
+.OR.CSUP(4)(2:8).EQ.'1661802' .OR.CSUP(4)(2:8).EQ.'1661803'
+.OR.CSUP(4)(2:8).EQ.'1681819' .OR.CSUP(4)(2:8).EQ.'1681820'
+.OR.CSUP(4)(2:8).EQ.'1701843' .OR.CSUP(4)(2:8).EQ.'1721854'
+.OR.CSUP(4)(2:8).EQ.'1801910' .OR.CSUP(4)(2:8).EQ.'1841944'
+.OR.CSUP(4)(2:8).EQ.'1851946') FTRUE(DI)=0.
FTRUE(DCK)=704.
FTRUE(SID)=125.
FTRUE(PT)=5.
FTRUE(WI)=5.
FTRUE(II)=10.
C
IF (FTRUE(YR).NE.FMISS) THEN
IF (NINT(FTRUE(YR)).LT.1878 .OR. NINT(FTRUE(YR)).GT.1894) THEN
FTRUE(YR)=FMISS
ENDIF
ENDIF
C
IF (FTRUE(MO).NE.FMISS) THEN
IF (NINT(FTRUE(MO)).LT.1 .OR. NINT(FTRUE(MO)).GT.12) THEN
FTRUE(MO)=FMISS
ENDIF
ENDIF
C
IF (CSUP(3)(45:49).NE.' ') THEN
CTRUE(LON)=CSUP(3)(45:50)
ELSE
CTRUE(LON)=CSUP(3)(34:39)
ENDIF
LTRUE(LON)=LTRUE(LON)+1
IF (FTRUE(LON).NE.FMISS) THEN
IF (NINT(FTRUE(LON)*100.)/100.LT.0
+ .OR. NINT(FTRUE(LON)*100.)/100.GT.180) THEN
FTRUE(LON)=FMISS
ELSE
IF (MOD(NINT(FTRUE(LON)*100.),100).GT.60) THEN
ELSE
FTRUE(LON)=NINT(FTRUE(LON)*100.)/100
+ +MOD(NINT(FTRUE(LON)*100.),100)/60.
ENDIF
IF (CTRUE(LON)(6:6).EQ.'E') THEN
ELSE IF (CTRUE(LON)(6:6).EQ.'W') THEN
FTRUE(LON)=-FTRUE(LON)
ELSE
FTRUE(LON)=FMISS
ENDIF
ENDIF
ENDIF
IF (FTRUE(LON).NE.FMISS)
+FTRUE(LON)=MOD(FTRUE(LON)*EAST+360.,360.)
C
IF (CSUP(3)(40:43).NE.' ') THEN
CTRUE(LAT)=CSUP(3)(40:44)
ELSE
CTRUE(LAT)=CSUP(3)(29:33)
ENDIF
LTRUE(LAT)=LTRUE(LAT)+1
IF (FTRUE(LAT).NE.FMISS) THEN
IF (NINT(FTRUE(LAT)*100.)/100.LT.0
+ .OR. NINT(FTRUE(LAT)*100.)/100.GT.90) THEN
FTRUE(LAT)=FMISS
ELSE
IF (MOD(NINT(FTRUE(LAT)*100.),100).GT.60) THEN
ELSE
FTRUE(LAT)=NINT(FTRUE(LAT)*100.)/100
+ +MOD(NINT(FTRUE(LAT)*100.),100)/60.
ENDIF
IF (CTRUE(LAT)(5:5).EQ.'N') THEN
ELSE IF (CTRUE(LAT)(5:5).EQ.'S') THEN
FTRUE(LAT)=-FTRUE(LAT)
ELSE
FTRUE(LAT)=FMISS
ENDIF
ENDIF
ENDIF
IF (FTRUE(LAT).NE.FMISS)
+FTRUE(LAT)=FTRUE(LAT)*NORTH
C
IF (FTRUE(YR).EQ.FMISS .OR. FTRUE(MO).EQ.FMISS
+.OR.FTRUE(LON).EQ.FMISS .OR. FTRUE(LAT).EQ.FMISS) GOTO 800
C
IF (FTRUE(HR).NE.FMISS) THEN
FTRUE(HR)=FTRUE(HR)*100.
IF (NINT(FTRUE(HR))/100.LT.1 .OR.
+ MOD(NINT(FTRUE(HR)),100).LT.1
+ .OR. NINT(FTRUE(HR))/100.GT.2 .OR.
+ MOD(NINT(FTRUE(HR)),100).GT.12) THEN
FTRUE(HR)=FMISS
ELSE
FTRUE(HR)=(NINT(FTRUE(HR))/100-1)*12+MOD(NINT(FTRUE(HR)),100)
ENDIF
ENDIF
C
IF (FTRUE(DI).NE.FMISS .AND. NINT(FTRUE(DI)).NE.0) THEN
FTRUE(DI)=FMISS
IF (CSUP(4)(98:98).EQ.'1' .OR. CSUP(4)(98:98).EQ.'2') THEN
IF (CSUP(4)(103:103).EQ.'E' .OR. CSUP(4)(103:103).EQ.'W') THEN
READ(CTRUE(DI),'(BZ,F4.1)')FTRUE(DI)
IF (CSUP(4)(98:98).EQ.'1') FTRUE(DI)=360./32.*FTRUE(DI)
IF (CSUP(4)(103:103).EQ.'W') FTRUE(DI)=-FTRUE(DI)
ENDIF
ENDIF
ENDIF
IF (FTRUE(DI).NE.FMISS) THEN
ELSE
CALL GUFM1(FTRUE(LAT),FTRUE(LON),FTRUE(YR) ,FTRUE(DI))
ENDIF
IF (CTRUE(D).NE.' ') THEN
IF (CTRUE(D).EQ.'C') THEN
FTRUE(D)=361.
ELSE
+ IF (CTRUE(D).EQ.'V') THEN
FTRUE(D)=362.
ELSE
IF (CSUP(4)(55:61).NE.' ') THEN
FLOAT=FMISS
ELSE
FLOAT=FTRUE(DI)
ENDIF
FLOAT=FX32DD(CTRUE(D),FLOAT,FTRUE(D),FMISS)
ENDIF
ENDIF
C
FTRUE(TI)=FMISS
IF (FTRUE(SS).NE.FMISS) THEN
IF (NINT(FTRUE(SS)).LT.0) THEN
FTRUE(SS)=FMISS
ELSE
IF (LTRUE(SS).EQ.3) FTRUE(SS)=FTRUE(SS)/10.
FTRUE(TI)=FTRUE(SS)
IF (NINT(FTRUE(SS)).NE.0)
+ FTRUE(SS)=MIN((NINT(FTRUE(SS))-1)/3+1,9)
ENDIF
ENDIF
C
FTRUE(LI)=FMISS
IF (CTRUE(SC).NE.' ') THEN
IF (CTRUE(SC).EQ.'C') THEN
FTRUE(SC)=0.
ELSE
IF (CSUP(4)(41:47).NE.' ') THEN
FLOAT=FMISS
ELSE
FLOAT=FTRUE(DI)
ENDIF
FTRUE(LI)=FX32DD(CTRUE(SC),FLOAT,FTRUE(SC),FMISS)
IF (FTRUE(SC).NE.FMISS) THEN
IF (FTRUE(SC).LT.22.5) FTRUE(SC)=FTRUE(SC)+360.
FTRUE(SC)=(NINT(FTRUE(SC))-23)/45+1
ENDIF
ENDIF
ENDIF
C
IF (FTRUE(HR).NE.FMISS) THEN
JUL=IXDTND(NINT(FTRUE(DY)),NINT(FTRUE(MO)),NINT(FTRUE(YR)))
IF (JUL.LT.0) THEN
FTRUE(HR)=FMISS
ELSE
CALL RXLTUT(12*100,JUL,NINT(FTRUE(LON)*100.)
+ ,UHR,UDY)
IF (FTRUE(TI).EQ.FMISS .OR. FTRUE(LI).EQ.FMISS) THEN
FTRUE(TI)=FMISS
FTRUE(LI)=FMISS
ELSE
CALL RXDVUV(FTRUE(LI),FTRUE(TI)*2.,FTRUE(TI),FTRUE(LI))
FTRUE(TI)=-FTRUE(TI)/60./COSD(FTRUE(LAT))
FTRUE(LI)=-FTRUE(LI)/60.
ENDIF
IF (JUL.NE.JULIAN .OR. NINT(FTRUE(HR))/13.NE.HOUR/13) THEN
DLON=0.000
DLAT=0.000
ENDIF
JULIAN=JUL
HOUR=NINT(FTRUE(HR))
IF (HOUR.LT.13) THEN
FTRUE(LON)=FTRUE(LON)-DLON
FTRUE(LAT)=FTRUE(LAT)-DLAT
IF (FTRUE(TI).NE.FMISS) THEN
DLON=DLON+FTRUE(TI)
DLAT=DLAT+FTRUE(LI)
ENDIF
ELSE
IF (FTRUE(TI).NE.FMISS) THEN
DLON=DLON+FTRUE(TI)
DLAT=DLAT+FTRUE(LI)
ENDIF
FTRUE(LON)=FTRUE(LON)+DLON
FTRUE(LAT)=FTRUE(LAT)+DLAT
ENDIF
UHR=UHR/100+HOUR-12
IF (UHR.LT.0) THEN
UDY=UDY-1
ELSE IF (UHR.GE.24) THEN
UDY=UDY+1
ENDIF
IF (UDY.NE.JULIAN) THEN
CALL RXNDDT(UDY,DAY,MONTH,YEAR)
FTRUE(YR)=YEAR
FTRUE(MO)=MONTH
FTRUE(DY)=DAY
ENDIF
FTRUE(HR)=MOD(UHR+24,24)
FTRUE(LON)=MOD(NINT(FTRUE(LON)*100.)/100.+360.,360.)
ENDIF
ENDIF
FTRUE(DI)=1.
CTRUE(DI)=' '
LTRUE(DI)=0
FTRUE(TI)=0.
CTRUE(TI)=' '
LTRUE(TI)=0
IF (CTRUE(HR).EQ.'112') THEN
FTRUE(LI)=4.
ELSE
FTRUE(LI)=6.
ENDIF
CTRUE(LI)=' '
LTRUE(LI)=0
C
IF (FTRUE(W).NE.FMISS) THEN
FTRUE(W)=FTRUE(W)*10.
IF (NINT(FTRUE(W)).LT.0 .OR. NINT(FTRUE(W)).GT.12) THEN
FTRUE(W)=FMISS
ELSE
FTRUE(W)=FXBFMS(NINT(FTRUE(W)))
ENDIF
ENDIF
C
IF (FTRUE(T1).NE.FMISS) THEN
IF (NINT(FTRUE(T1)).LT.1 .OR. NINT(FTRUE(T1)).GT.7) THEN
FTRUE(T1)=FMISS
ENDIF
ENDIF
DO 193 I=AT,SST
IF (FTRUE(I).NE.FMISS) THEN
IF (FTRUE(T1).EQ.FMISS) THEN
FTRUE(I)=FMISS
ELSE
IF (LTRUE(I).LT.4) FTRUE(I)=FTRUE(I)*10.
ENDIF
ENDIF
193 CONTINUE
C
IF (FTRUE(SLP).NE.FMISS) THEN
IF (FTRUE(SLP).LT.100.) THEN
IF (FTRUE(SLP).LT.5.
+ .OR. FTRUE(SLP).GT.50.) FTRUE(SLP)=FTRUE(SLP)*10.
ELSE
IF (FTRUE(SLP).LT.500.) FTRUE(SLP)=FTRUE(SLP)/10.
ENDIF
IF (FTRUE(PB).NE.FMISS) THEN
READ(CTRUE(PB),'(BZ,F5.2)')FTRUE(PB)
IF (FTRUE(SLP).GE.100.) FTRUE(PB)=FTRUE(PB)/.03937
FTRUE(SLP)=FTRUE(SLP)+FTRUE(PB)
ENDIF
FTRUE(PB)=FMISS
IF (CSUP(1)(74:74).EQ.'2' .AND. FTRUE(LAT).NE.FMISS) THEN
FTRUE(PB)=2.
IF (FTRUE(DPT).NE.FMISS) THEN
IF (FTRUE(SLP).LT.100.) THEN
IF (NINT(FTRUE(T1)).EQ.1 .OR. NINT(FTRUE(T1)).EQ.3
+ .OR. NINT(FTRUE(T1)).GE.5) THEN
IF (NINT(FXTFTC(FTRUE(DPT))*10.).GE.-500
+ .AND. NINT(FXTFTC(FTRUE(DPT))*10.).LE. 500) THEN
FTRUE(PB)=1.
FTRUE(SLP)=FTRUE(SLP)+FWBPTF(FTRUE(SLP),FTRUE(DPT))
ENDIF
ENDIF
ELSE
IF (NINT(FTRUE(T1)).EQ.2 .OR. NINT(FTRUE(T1)).EQ.4) THEN
IF (NINT(FTRUE(DPT)*10.).GE.-500
+ .AND. NINT(FTRUE(DPT)*10.).LE. 500) THEN
FTRUE(PB)=1.
FTRUE(SLP)=FTRUE(SLP)+FWBPTC(FTRUE(SLP),FTRUE(DPT))
ENDIF
ENDIF
ENDIF
ENDIF
FTRUE(SLP)=FTRUE(SLP)+FWBPGV(FTRUE(SLP),FTRUE(LAT),2)
ENDIF
IF (FTRUE(SLP).LT.100.) THEN
FTRUE(SLP)=FXEIMB(FTRUE(SLP))
ELSE
FTRUE(SLP)=FXMMMB(FTRUE(SLP))
ENDIF
ELSE
FTRUE(PB)=FMISS
ENDIF
CTRUE(PB)=' '
LTRUE(PB)=0
FTRUE(DPT)=FMISS
CTRUE(DPT)=' '
LTRUE(DPT)=0
C
IF (FTRUE(AT).NE.FMISS
+.AND.(NINT(FTRUE(T1)).EQ.1
+ .OR. NINT(FTRUE(T1)).EQ.4
+ .OR. NINT(FTRUE(T1)).EQ.5))
+ FTRUE(AT)=FXTFTC(FTRUE(AT))
IF (FTRUE(WBT).NE.FMISS
+.AND.(NINT(FTRUE(T1)).EQ.1
+ .OR. NINT(FTRUE(T1)).EQ.4
+ .OR. NINT(FTRUE(T1)).EQ.5
+ .OR. NINT(FTRUE(T1)).EQ.7))
+ FTRUE(WBT)=FXTFTC(FTRUE(WBT))
IF (FTRUE(DPT).NE.FMISS
+.AND.(NINT(FTRUE(T1)).EQ.1
+ .OR. NINT(FTRUE(T1)).EQ.3
+ .OR. NINT(FTRUE(T1)).GE.5))
+ FTRUE(DPT)=FXTFTC(FTRUE(DPT))
IF (FTRUE(SST).NE.FMISS
+.AND.(NINT(FTRUE(T1)).EQ.1
+ .OR. NINT(FTRUE(T1)).EQ.4
+ .OR. NINT(FTRUE(T1)).EQ.6))
+ FTRUE(SST)=FXTFTC(FTRUE(SST))
C
IF (FTRUE(T1).NE.FMISS) THEN
IF (NINT(FTRUE(T1)).EQ.2
+ .OR. NINT(FTRUE(T1)).EQ.3) THEN
FTRUE(T1)=3.
ELSE
+ IF (NINT(FTRUE(T1)).EQ.1
+ .OR. NINT(FTRUE(T1)).EQ.4) THEN
FTRUE(T1)=7.
ELSE
+ IF (NINT(FTRUE(T1)).GE.5) THEN
FTRUE(T1)=9.
ELSE
FTRUE(T1)=FMISS
ENDIF
ENDIF
C
IF (FTRUE(SI).NE.FMISS) THEN
IF (NINT(FTRUE(SI)).EQ.1
+ .OR. NINT(FTRUE(SI)).EQ.2) THEN
FTRUE(SI)=FTRUE(SI)-1.
C ELSE
C + IF (NINT(FTRUE(SI)).EQ.3
C + .OR. NINT(FTRUE(SI)).EQ.4) THEN
ELSE
FTRUE(SI)=FMISS
ENDIF
ENDIF
C
IF (FTRUE(N).NE.FMISS) THEN
IF (NINT(FTRUE(N)).LT.0 .OR. NINT(FTRUE(N)).GT.10) THEN
FTRUE(N)=FMISS
ELSE
FTRUE(N)=IXT0OK(NINT(FTRUE(N)))
ENDIF
ENDIF
C
800 CONTINUE
C LENGTH OF SUPPLEMENTAL ATTACHMENT MINUS TRAILING BLANKS
C LSUP=LENTRM(CSUP)
C
C CONVERT FIELDS AND SUPPLEMENTAL ATTACHMENT FROM EBCDIC TO ASCII
IF (CSET.EQ.'EBC') THEN
DO 195 I=ID1,ID8
IF (FTRUE(I).NE.FMISS) FTRUE(I)=IASC(NINT(FTRUE(I)))
195 CONTINUE
CALL EBCASC(CTRUE,CTRUE,NUMBER*16)
CALL EBCASC(CSUP,CSUP,255)
ENDIF
C
C WRITE REPORT
IF (.NOT.WRLMR(FTRUE,FMISS,CTRUE,LTRUE,CSUP(4),LSUP,JEOF
+,PNAME,PLEVEL,INITLS,FILNAM)) THEN
IF (CSET.EQ.'EBC') THEN
CALL ASCEBC(CTRUE,CTRUE,NUMBER*16)
CALL ASCEBC(CSUP,CSUP,255)
ENDIF
WRITE(2,'(A)')CSUP(1)(:117),CSUP(2)(:52),CSUP(3)(:61)
+ ,CSUP(4)(:LSUP)
ELSE
WRITE(1,'(A)')CSUP(1)(:117)//CSUP(2)(:52)//CSUP(3)(:61)
+ //CSUP(4)(:LSUP)
ENDIF
GOTO 100
C
C TEST CSET='EBC' ROUTINES AND GENERATE TEST REPORTS
CALL TEST(FTRUE,FMISS,CTRUE,LTRUE,CSUP,LSUP,JEOF
+,PNAME,PLEVEL,INITLS,FILNAM)
C
C END OF FILE
900 JEOF=2
IF (WRLMR(FTRUE,FMISS,CTRUE,LTRUE,CSUP,LSUP,JEOF
+,PNAME,PLEVEL,INITLS,FILNAM)) PRINT *,'NORMAL TERMINATION'
END
C-----------------------------------------------------------------------3456789
SUBROUTINE TEST(FTRUE,FMISS,CTRUE,LTRUE,CSUP,LSUP,JEOF
+,PNAME,PLEVEL,INITLS,FILNAM)
C TEST CSET='EBC' ROUTINES AND GENERATE TEST REPORTS
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
REAL FTRUE(NUMBER),FMISS
CHARACTER CTRUE(NUMBER)*16,CSUP*255
INTEGER LTRUE(NUMBER),LSUP,JEOF
CHARACTER PNAME*16,PLEVEL*6,INITLS*2,FILNAM*16
CHARACTER CSET*3,MODE*3
COMMON /ENV/CSET,MODE
LOGICAL WRLMR
C BITS PER WORD
PARAMETER(BPW=32)
C
C TEST CSET='EBC' ROUTINES ASCEBC AND EBCASC
C CONVERT FIELDS AND SUPPLEMENTAL ATTACHMENT FROM ASCII TO EBCDIC
CALL ASCEBC(CTRUE,CTRUE,NUMBER*16)
CALL ASCEBC(CSUP,CSUP,255)
C CONVERT FIELDS AND SUPPLEMENTAL ATTACHMENT FROM EBCDIC TO ASCII
CALL EBCASC(CTRUE,CTRUE,NUMBER*16)
CALL EBCASC(CSUP,CSUP,255)
C
C INIT FOR MODE='BIN'
IF (MODE.EQ.'BIN') THEN
DO 390 I=1,NUMBER
IF (LTRUE(I).GT.0) THEN
CODED=NINT(FTRUE(I)/FUNITS(I)-FBASE(I))
LTRUE(I)=(BITS(I)-1)/8+1
IF (LTRUE(I).EQ.1) THEN
CTRUE(I)=CHAR(CODED)
ELSE
CTRUE(I)=CHAR(CODED/256)//CHAR(MOD(CODED,256))
ENDIF
ENDIF
390 CONTINUE
ENDIF
C GENERATE TEST REPORTS
DO 590 I=NUMBER-1,1,-1
FTRUE(I)=FMISS
IF (.NOT.WRLMR(FTRUE,FMISS,CTRUE,LTRUE,CSUP,LSUP,JEOF
+ ,PNAME,PLEVEL,INITLS,FILNAM)) THEN
IF (MODE.EQ.'CHR'.AND.CSET.EQ.'EBC') THEN
CALL ASCEBC(CTRUE,CTRUE,NUMBER*16)
CALL ASCEBC(CSUP,CSUP,255)
ENDIF
WRITE(2,FORMAT)CTRUE
WRITE(2,'(10X,A)')CSUP(:LSUP)
IF (MODE.EQ.'CHR'.AND.CSET.EQ.'EBC') THEN
CALL EBCASC(CTRUE,CTRUE,NUMBER*16)
CALL EBCASC(CSUP,CSUP,255)
ENDIF
ENDIF
IF (LTRUE(I).GT.0) FTRUE(I)=FTRUEU(I)
590 CONTINUE
END
C=============================================================================C
C WARNING: Code beyond this point should not require any modification. C
C=============================================================================C
C-----------------------------------------------------------------------3456789
LOGICAL FUNCTION WRLMR(FTRUE1,FMISS1,CTRUE,LTRUE,CSUP,LSUP,JEOF
+,PNAME,PLEVEL,INITLS,FILNAM)
C
C input
C FTRUE1(73) (real array)
C LMR fields
C FMISS1 (real)
C FTRUE1 missing value
C CTRUE(73)*16 (character array)
C original input field(s) (if any) used to construct each FTRUE1 (ascii
C characters; or binary data transferred unchanged, or equivalenced)
C LTRUE(73) (integer array)
C number of CTRUE characters in each field (0 if no original input)
C CTRUE and/or LTRUE are stored in the error attachment only if:
C 1) FTRUE1 is equal to FMISS1, and LTRUE is greater than 0. In this
C case LTRUE characters from CTRUE are stored in the error attachment.
C 2) FTRUE1 is less than the minimum or greater than the maximum
C allowable true value for the field. In this case LTRUE characters
C from CTRUE are stored in the error attachment, or the attachment
C may be of 0 length if LTRUE equals 0 (no original input available).
C NOTE: CTRUE and LTRUE are not stored under any other circumstances.
C CSUP*255 (character string)
C original input data (if any) to be stored in the supplemental
C attachment (ascii characters; or binary data transferred unchanged,
C or equivalenced)
C LSUP (integer)
C number of CSUP characters to store
C JEOF (integer)
C 1 = write an LMR
C 2 = flush the LMR buffer (do not write an LMR)
C PNAME (character*16)
C name of the conversion program (for the conversion summary)
C PLEVEL (character*6)
C version of PNAME (for the conversion summary)
C INITLS (character*2) (upper case)
C first and last initials of the programmer (for the index record)
C FILNAM (character*16)
C input file name (for the index record)
C
C output
C WRLMR (logical function)
C .TRUE. (JEOF=1) = an LMR was written
C .FALSE.(JEOF=1) = an LMR was not written because LMR field
C LAT, LON, MO, or YR was missing or erroneous, the input
C report should be written to the reject file
C .TRUE. (JEOF=2) = the LMR buffer was flushed
C .FALSE.(JEOF=2) = undefined (WRLMR always =.TRUE. when JEOF=2)
C
C units
C output
C fortran unit 3 LMR
C fortran unit 8 conversion summary
C
C object files
C WRLMR calls routines in date.o, ebcasc.o, gsbytes.o, and rptin.o
C
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
REAL FTRUE1(NUMBER),FMISS1
CHARACTER CTRUE(NUMBER)*16,CSUP*255
INTEGER LTRUE(NUMBER),LSUP,JEOF
CHARACTER PNAME*16,PLEVEL*6,INITLS*2,FILNAM*16
CHARACTER CSET*3,MODE*3
COMMON /ENV/CSET,MODE
COMMON /DAT/CODED(NUMBER),FTRUE(NUMBER),FMISS
COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR
CHARACTER PATH*27
C
DIMENSION PTR(NUMBER)
DATA PTR
+/ 8, 7, 3, 2, -1, 4, 5, 6, 9,10,11,12,-13,-14,-15, 16, 17
+,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37
+,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57
+,58,59,60,61,62,63,64,65,66,67,68,69,70,-71,-72,-73/
C
DIMENSION NREC(3)
DATA NREC/3*0/
C
LOGICAL B10XY,INSIDE
INSIDE(A2,A1,A3)=.NOT.(A2.LT.A1.OR.A2.GT.A3)
C
GOTO(500,900)JEOF
PRINT *,'STOP: JEOF < 1 OR > 2'
STOP
C
C JEOF EQUALS 1, WRITE AN LMR REPORT
500 NREC(1)=NREC(1)+1
IF(.NOT.(FMISS1.LT.-99.9.OR.FMISS1.GT.2024.))THEN
PRINT *,'STOP: FMISS NOT < -99.9 OR > 2024.'
STOP
ENDIF
FMISS=FMISS1
C
C TRANSFER THE ERROR ATTACHMENT
NERR=0
DO 690 J=1,NUMBER
I=ABS(PTR(J))
FTRUE(I)=FTRUE1(I)
C
C NON MISSING FIELDS SET TO MISSING
IF(PTR(J).LT.0)THEN
IF(LTRUE(I).GT.0.OR.FTRUE(I).NE.FMISS)
+ PRINT *,'WARNING: NON MISSING '//FIELD(I)
C B10
IF(I.EQ.1)THEN
IF(.NOT.B10XY(NINT(FTRUE(7)*100.),NINT(FTRUE(8)*100.)
+ ,CODED(1)))THEN
PRINT *,'STOP: LON < 0. OR > 359.99 OR |LAT| > 90.'
STOP
ENDIF
FTRUE(1)=CODED(1)
ELSE
GOTO 682
ENDIF
ENDIF
C
C NON MISSING INDICATORS SET TO MISSING
IF(LTRUE(I).GT.0.OR.FTRUE(I).NE.FMISS)THEN
IF(I.EQ.6)THEN
IF(.NOT.(LTRUE(5).GT.0.OR.FTRUE1(5).NE.FMISS))GOTO 682
ELSE IF(I.EQ.18)THEN
IF(.NOT.(LTRUE(19).GT.0.OR.FTRUE1(19).NE.FMISS))GOTO 682
ELSE IF(I.EQ.20)THEN
IF(.NOT.(LTRUE(21).GT.0.OR.FTRUE1(21).NE.FMISS))GOTO 682
ELSE IF(I.EQ.22)THEN
IF(.NOT.(LTRUE(23).GT.0.OR.FTRUE1(23).NE.FMISS))GOTO 682
ELSE IF(I.EQ.28)THEN
IF(.NOT.(LTRUE(29).GT.0.OR.FTRUE1(29).NE.FMISS
+ .OR.LTRUE(30).GT.0.OR.FTRUE1(30).NE.FMISS
+ .OR.LTRUE(31).GT.0.OR.FTRUE1(31).NE.FMISS
+ .OR.LTRUE(32).GT.0.OR.FTRUE1(32).NE.FMISS))GOTO 682
ELSE IF(I.EQ.33)THEN
IF(.NOT.(LTRUE(32).GT.0.OR.FTRUE1(32).NE.FMISS))GOTO 682
ELSE IF(I.EQ.37)THEN
IF(.NOT.(LTRUE(38).GT.0.OR.FTRUE1(38).NE.FMISS))GOTO 682
ELSE IF(I.EQ.56)THEN
IF(.NOT.(LTRUE(57).GT.0.OR.FTRUE1(57).NE.FMISS
+ .OR.LTRUE(58).GT.0.OR.FTRUE1(58).NE.FMISS
+ .OR.LTRUE(59).GT.0.OR.FTRUE1(59).NE.FMISS
+ .OR.LTRUE(60).GT.0.OR.FTRUE1(60).NE.FMISS
+ .OR.LTRUE(61).GT.0.OR.FTRUE1(61).NE.FMISS
+ .OR.LTRUE(62).GT.0.OR.FTRUE1(62).NE.FMISS
+ .OR.LTRUE(63).GT.0.OR.FTRUE1(63).NE.FMISS
+ .OR.LTRUE(64).GT.0.OR.FTRUE1(64).NE.FMISS))GOTO 682
ELSE IF(I.EQ.67)THEN
IF(.NOT.(LTRUE(30).GT.0.OR.FTRUE1(30).NE.FMISS
+ .OR.LTRUE(31).GT.0.OR.FTRUE1(31).NE.FMISS))GOTO 682
ELSE IF(I.EQ.69)THEN
IF(.NOT.(LTRUE(42).GT.0.OR.FTRUE1(42).NE.FMISS))GOTO 682
ELSE IF(I.EQ.70)THEN
IF(.NOT.(LTRUE(45).GT.0.OR.FTRUE1(45).NE.FMISS))GOTO 682
ENDIF
ENDIF
C
IF(FTRUE(I).EQ.FMISS)THEN
IF(I.EQ.1.OR.I.EQ.2.OR.I.EQ.3.OR.I.EQ.7.OR.I.EQ.8
+ .OR.LTRUE(I).GT.0)GOTO 680
IF(I.EQ.10.OR.I.EQ.11)PRINT *,'WARNING: MISSING '//FIELD(I)
GOTO 690
ENDIF
IF(INSIDE(NINT(FTRUE(I)/FUNITS(I))
+ ,NINT(FTRUEL(I)/FUNITS(I)),NINT(FTRUEU(I)/FUNITS(I))))GOTO 690
C
680 NERR=NERR+1
IF(NERR.GT.51)THEN
PRINT *,'STOP: NERR > 51'
STOP
ENDIF
ERRNUM(NERR)=I
IF(LTRUE(I).LT.0.OR.LTRUE(I).GT.15)THEN
PRINT *,'STOP: LTRUE('//FIELD(I)(1:3)//') < 0 OR > 15'
STOP
ENDIF
ERRLEN(NERR)=LTRUE(I)
DO 681 M=1,ERRLEN(NERR)
681 ERR(M,NERR)=ICHAR(CTRUE(I)(M:M))
C DO NOT WRITE A REPORT
IF(I.EQ.1.OR.I.EQ.2.OR.I.EQ.3.OR.I.EQ.7.OR.I.EQ.8)THEN
IF(I.EQ.1)THEN
PRINT *,'STOP: MISSING B10'
STOP
ENDIF
NREC(3)=NREC(3)+1
CALL SAVSUM3
WRLMR=.FALSE.
RETURN
ENDIF
682 FTRUE(I)=FMISS
690 CONTINUE
C
C TRANSFER THE SUPPLEMENTAL ATTACHMENT
IF(LSUP.LT.0.OR.LSUP.GT.255)THEN
PRINT *,'STOP: LSUP < 0 OR > 255'
STOP
ENDIF
SUPLEN=LSUP
DO 790 J=1,SUPLEN
790 SUP(J)=ICHAR(CSUP(J:J))
C
C WRITE A REPORT
NREC(2)=NREC(2)+1
CALL PUTLMR(JEOF,PATH)
WRLMR=.TRUE.
RETURN
C
C JEOF EQUALS 2, FLUSH THE OUTPUT BUFFER
900 PATH='/DSS/LMR6/'//INITLS//'/'//FILNAM
WRITE(8,'(A)')' '//PNAME(:LENTRM(PNAME))//PLEVEL
+//' {WRLMR6}.01E '//MODE//' '//CSET
WRITE(8,'(I8,A,T27,I8,A,T53,I8,A,I3,A)')
+ NREC(1),' REPORTS READ'
+,NREC(3),' REPORTS REJECTED'
+,NREC(2),' LMR6 WRITTEN ('
+,NINT(FLOAT(NREC(2)*100)/MAX(NREC(1),1)),'%)'
IF(NREC(3).NE.NREC(1)-NREC(2))THEN
PRINT *,'STOP: WRITTEN & REJECTED .NOT.= TO READ'
STOP
ENDIF
C
CALL PUTLMR(JEOF,PATH)
WRLMR=.TRUE.
END
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
LOGICAL FUNCTION B10XY(X,Y,B10)
C CONVERT LON AND LAT IN HUNDREDTHS TO B10
C
IMPLICIT INTEGER(A-E,G-Z)
C
B10XY=.FALSE.
IF(X.LT.0.OR.X.GT.35999.OR.ABS(Y).GT.9000)RETURN
C
IF(X.EQ.0.OR.X.GT.18000)THEN
C=35-MOD(36000-X,36000)/1000
ELSE
C=X/1000
ENDIF
C
R=8-SIGN(MIN(ABS(Y),8999)/1000,Y)
IF(Y.LT.0)R=R+1
C
B10=R*36+MOD(C+36-3,36)+1
B10XY=.TRUE.
END
C-----------------------------------------------------------------------3456789
FUNCTION PUTATT(RPT,AL,AD)
C PACK ATTACHMENTS RETURNING LENGTH OF RPT IN BITS
C
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*(*) RPT
DIMENSION AL(15),AD(255,15)
C
PUTATT=452
AC=0
DO 190 AID=1,15
IF(AL(AID).EQ.0)GOTO 190
CALL SBYTE(RPT,AID,PUTATT+8,4)
CALL SBYTE(RPT,AL(AID),PUTATT,8)
CALL SBYTES(RPT,AD(1,AID),PUTATT+12,4,0,AL(AID))
PUTATT=PUTATT+12+4*AL(AID)
AC=AC+1
190 CONTINUE
CALL SBYTE(RPT,AC,452-4,4)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PUTERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR)
C PUT ERROR ATTACHMENT
C
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION AL(15),AD(255,15)
DIMENSION ERRNUM(51),ERRLEN(51),ERR(15,51)
C
AL(5)=0
DO 190 J=1,NERR
AD(AL(5)+1,5)=ERRNUM(J)/16
AD(AL(5)+2,5)=MOD(ERRNUM(J),16)
AD(AL(5)+3,5)=ERRLEN(J)
AL(5)=AL(5)+3
DO 190 I=1,ERRLEN(J)
AD(AL(5)+1,5)=ERR(I,J)/16
AD(AL(5)+2,5)=MOD(ERR(I,J),16)
AL(5)=AL(5)+2
190 CONTINUE
IF(AL(5).GT.255)THEN
PRINT *,'STOP: ERROR ATTACHMENT EXCEEDS 255 4-BIT BYTES'
STOP
ENDIF
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PUTLMR(JEOF,PATH)
IMPLICIT INTEGER(A-E,G-Z)
C BITS PER WORD
PARAMETER(BPW=32)
C
PARAMETER(DIM BUF=(1006*64-1)/BPW+1)
DIMENSION BUF(DIM BUF)
DATA (BUF(I),I=1,6)/6*0/
DATA UNIT/3/
C
PARAMETER(DIM RPT=(452+(3+255)*4*15-1)/64+1)
CHARACTER RPT*(DIM RPT*8)
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
COMMON /DAT/CODED(NUMBER),FTRUE(NUMBER),FMISS
C
DIMENSION AL(15),AD(255,15)
DATA AL/15*0/
C
COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR
C
CHARACTER PATH*27
CHARACTER MMDDYY*8,HHMMSS*8
DIMENSION B10YR(4)
DATA B10YR/999,0,9999,0/
SAVE
EXTERNAL DATE
C
GOTO(100,200)JEOF
PRINT *,'STOP: JEOF < 1 OR > 2'
STOP
C
100 CALL PUTSUP(AL,AD,SUP,SUPLEN)
CALL PUTERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR)
DO 110 I=1,LEN(RPT)
110 RPT(I:I)=CHAR(0)
CALL PUTRPT(RPT,CODED,FTRUE,FMISS
+,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK)
CALL RPTOUT(UNIT,BUF,RPT,(PUTATT(RPT,AL,AD)-1)/64+1,JEOF)
B10YR(1)=MIN(B10YR(1),NINT(FTRUE(1)))
B10YR(2)=MAX(B10YR(2),NINT(FTRUE(1)))
B10YR(3)=MIN(B10YR(3),NINT(FTRUE(2)))
B10YR(4)=MAX(B10YR(4),NINT(FTRUE(2)))
CALL SAVSUM1
CALL SAVSUM2
RETURN
C
200 CALL RPTOUT(UNIT,BUF,RPT,998,JEOF)
CALL DATE(MMDDYY)
CALL CLOCK(HHMMSS)
WRITE(8,'(A,2I4,2I5,2I8,I10,2A9,I4)')PATH,B10YR
+,BUF(2),BUF(3),BUF(4),MMDDYY,HHMMSS,1
CALL PRNSUM1
CALL PRNSUM2
CALL PRNSUM3
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PUTRPT(RPT,CODED,FTRUE,FMISS
+,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK)
C CONVERT TRUE TO CODED VALUES AND PACK REPORT
C
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*(*) RPT
DIMENSION CODED(*),FTRUE(*),FUNITS(*),FBASE(*),BITS(*),OFFSET(*)
C
CODED(INDXCK)=0
DO 190 I=1,NUMBER
IF(I.EQ.INDXCK)GOTO 190
IF(FTRUE(I).EQ.FMISS)THEN
CODED(I)=0
ELSE
CODED(I)=NINT(FTRUE(I)/FUNITS(I)-FBASE(I))
IF(CODED(I).LT.1.OR.CODED(I).GT.2**BITS(I)-1)THEN
PRINT *,'STOP: FTRUE(',I,') = ',FTRUE(I)
PRINT *,' FTRUE = ',(FTRUE(J),J=1,NUMBER)
STOP
ENDIF
CODED(INDXCK)=CODED(INDXCK)+CODED(I)
ENDIF
190 CONTINUE
CODED(INDXCK)=MOD(CODED(INDXCK),2**BITS(INDXCK)-1)
FTRUE(INDXCK)=CODED(INDXCK)
CALL PACK(RPT,CODED)
RPT(2:2)=CHAR(MOD(RPTID,16))
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PUTSUP(AL,AD,SUP,SUPLEN)
C PUT SUPPLEMENTAL ATTACHMENT
C
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION AL(15),AD(255,15)
DIMENSION SUP(255)
DIMENSION SHIP(256)
DATA SHIP
+/32*15,10,5*15,202,3*15,234,203,15,218,15,225
+,0,1,2,3,4,5,6,7,8,9,7*15
+,193,194,195,196,197,198,199,200,201
+,209,210,211,212,213,214,215,216,217
+,226,227,228,229,230,231,232,233,32*15,192,15,208,130*15/
C
AL(4)=0
DO 9 I=1,SUPLEN
AL(4)=AL(4)+1
C
AD(AL(4),4)=SHIP(SUP(I)+1)
GOTO(9,9,9,9,9,9,9,9,9,9,11,11,14,14,14,15)AD(AL(4),4)+1
C
14 AD(AL(4)+1,4)=MOD(AD(AL(4),4),16)
AD(AL(4),4)=AD(AL(4),4)/16
AL(4)=AL(4)+1
GOTO 9
C
11 IF(I.LT.3.OR.SUP(I-2).NE.SUP(I).OR.SUP(I-1).NE.SUP(I))GOTO 9
IF(AD(AL(4)-2,4).EQ.11.AND.AD(AL(4)-1,4).LT.15)THEN
AD(AL(4)-1,4)=AD(AL(4)-1,4)+1
AL(4)=AL(4)-1
ELSE IF(AD(AL(4)-2,4).EQ.10.AND.AD(AL(4)-1,4).EQ.10)THEN
AD(AL(4)-2,4)=11
AD(AL(4)-1,4)=0
AL(4)=AL(4)-1
ENDIF
GOTO 9
C
15 AD(AL(4)+2,4)=MOD(SUP(I),16)
AD(AL(4)+1,4)=SUP(I)/16
AL(4)=AL(4)+2
9 CONTINUE
IF(AL(4).GT.255)THEN
PRINT *,'STOP: SUPPLEMENTAL ATTACHMENT EXCEEDS 255 4-BIT BYTES'
STOP
ENDIF
END
C-----------------------------------------------------------------------3456789
SUBROUTINE SAVSUM1
C SUMMARY OF FIELDS
C
IMPLICIT INTEGER(A-E,G-Z)
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
COMMON /DAT/CODED(NUMBER),FTRUE(NUMBER),FMISS
COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR
C
DIMENSION SUM1(NUMBER),SUM2(NUMBER),SUM3(NUMBER)
SAVE SUM1,SUM2,SUM3
DATA SUM1/NUMBER*0/,SUM2/NUMBER*0/,SUM3/NUMBER*0/
PC(A1,A2)=NINT(FLOAT(A1*100)/MAX(A2,1))
C
DO 190 I=1,NUMBER-1
IF(FTRUE(I).NE.FMISS)THEN
SUM1(I)=SUM1(I)+1
ELSE
SUM2(I)=SUM2(I)+1
ENDIF
190 CONTINUE
DO 290 I=1,NERR
SUM3(ERRNUM(I))=SUM3(ERRNUM(I))+1
290 CONTINUE
RETURN
C
ENTRY PRNSUM1
WRITE(8,'(1X,A)')'SUMMARY OF FIELDS'
WRITE(8,'(A6,2X,A10,A11,A13,2X,A10,A11,A13)')'FIELD'
+,'# EXTANT','# MISSING','# ERRONEOUS'
+,'% EXTANT','% MISSING','% ERRONEOUS'
TOTAL=SUM1(1)+SUM2(1)
WRITE(8,'(I3,1X,A3,1X,I10,I11,I13,2X,I10,I11,I13)')(I,FIELD(I)
+,SUM1(I),SUM2(I),SUM3(I)
+,PC(SUM1(I),TOTAL),PC(SUM2(I),TOTAL),PC(SUM3(I),TOTAL)
+,I=1,NUMBER-1)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE SAVSUM2
C SUMMARY OF ERROR ATTACHMENTS
C
IMPLICIT INTEGER(A-E,G-Z)
COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR
C
PARAMETER(NMAX=5000)
CHARACTER*56 STR,ARR1(NMAX)
DIMENSION ARR2(NMAX)
SAVE ARR1,ARR2,N
DATA N/0/
CHARACTER CSET*3,MODE*3
COMMON /ENV/CSET,MODE
C
DO 290 J=1,NERR
CALL GETSTR(STR,ERRNUM(J),ERRLEN(J),ERR(1,J))
CALL SAVSTR(STR,ARR1,ARR2,N,NMAX)
290 CONTINUE
RETURN
C
ENTRY PRNSUM2
WRITE(8,'(1X,A)')'SUMMARY OF ERROR ATTACHMENTS'
IF(MODE.EQ.'CHR')THEN
WRITE(8,'(4A)')' FIELD-',' CHARACTER------'
+ ,' HEXADECIMAL-------------------',' --------------FREQUENCY'
ELSE
WRITE(8,'(4A)')' FIELD-','----------------'
+ ,' HEXADECIMAL-------------------',' --------------FREQUENCY'
ENDIF
CALL PRNSTR(STR,ARR1,ARR2,N,NMAX)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE SAVSUM3
C SUMMARY OF ADDITIONAL INFORMATION
C
IMPLICIT INTEGER(A-E,G-Z)
COMMON /ATT/SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR
C
PARAMETER(NMAX=5000)
CHARACTER*56 STR,ARR1(NMAX)
DIMENSION ARR2(NMAX)
SAVE ARR1,ARR2,N
DATA N/0/
CHARACTER CSET*3,MODE*3
COMMON /ENV/CSET,MODE
C
CALL GETSTR(STR,ERRNUM(NERR),ERRLEN(NERR),ERR(1,NERR))
CALL SAVSTR(STR,ARR1,ARR2,N,NMAX)
RETURN
C
ENTRY PRNSUM3
WRITE(8,'(1X,A)')'SUMMARY OF ADDITIONAL INFORMATION'
IF(MODE.EQ.'CHR')THEN
WRITE(8,'(4A)')' FIELD-',' CHARACTER------'
+ ,' HEXADECIMAL-------------------',' --------------FREQUENCY'
ELSE
WRITE(8,'(4A)')' FIELD-','----------------'
+ ,' HEXADECIMAL-------------------',' --------------FREQUENCY'
ENDIF
CALL PRNSTR(STR,ARR1,ARR2,N,NMAX)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE SAVSTR(STR,ARR1,ARR2,N,NMAX)
C FREQUENCY OF A STRING
C
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*(*) STR,ARR1(NMAX)
DIMENSION ARR2(NMAX)
C
DO 190 M=1,N
IF(STR.NE.ARR1(M))GOTO 190
ARR2(M)=ARR2(M)+1
RETURN
190 CONTINUE
N=N+1
IF(N.GT.NMAX-1)THEN
PRINT *,'STOP: INCREASE NMAX IN ROUTINES WHICH CALL SAVSTR'
STOP
ENDIF
ARR1(N)=STR
ARR2(N)=1
RETURN
C
ENTRY PRNSTR(STR,ARR1,ARR2,N,NMAX)
DO 290 I=1,N-1
M=I
DO 280 J=I+1,N
IF(LLT(ARR1(J),ARR1(M)))M=J
280 CONTINUE
IF(M.NE.I)THEN
ARR1(NMAX)=ARR1(I)
ARR2(NMAX)=ARR2(I)
ARR1(I)=ARR1(M)
ARR2(I)=ARR2(M)
ARR1(M)=ARR1(NMAX)
ARR2(M)=ARR2(NMAX)
ENDIF
290 CONTINUE
WRITE(8,'(A,I22)')(ARR1(I),ARR2(I),I=1,N)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE GETSTR(STR,ERRNUM,ERRLEN,ERR)
C WRITE ERROR FROM ERROR ATTACHMENT TO STR
C
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION ERR(*)
CHARACTER*(*) STR
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
CHARACTER CSET*3,MODE*3
COMMON /ENV/CSET,MODE
C
IF(MODE.EQ.'CHR')THEN
IF(CSET.EQ.'EBC') THEN
WRITE(STR,110)ERRNUM,FIELD(ERRNUM)
+ ,(CHAR(IEBC(MAX(MOD(ERR(I)+129,256)-129,32))),I=1,ERRLEN)
+ ,(' ',I=ERRLEN+1,15),(ERR(I),I=1,ERRLEN)
ELSE IF(CSET.EQ.'ASC')THEN
WRITE(STR,110)ERRNUM,FIELD(ERRNUM)
+ ,(CHAR(MAX(MOD(ERR(I)+129,256)-129,32)),I=1,ERRLEN)
+ ,(' ',I=ERRLEN+1,15),(ERR(I),I=1,ERRLEN)
ELSE
PRINT *,'STOP: CSET=',CSET
STOP
ENDIF
ELSE IF(MODE.EQ.'BIN') THEN
WRITE(STR,110)ERRNUM,FIELD(ERRNUM)
+ ,(' ',I=1,ERRLEN)
+ ,(' ',I=ERRLEN+1,15),(ERR(I),I=1,ERRLEN)
ELSE
PRINT *,'STOP: MODE=',MODE
STOP
ENDIF
110 FORMAT(I3,1X,A3,1X,15A1,1X,15Z2.2)
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 PACK(RPT,CODED)
C PACK REPORT
C
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*(*) RPT
DIMENSION CODED(*)
C
RPT(3:3)=CHAR(CODED(1)/4)
RPT(4:4)=CHAR(CODED(1)*64+CODED(2)/4)
RPT(5:5)=CHAR(CODED(2)*64+CODED(3)*4+CODED(4)/8)
RPT(6:6)=CHAR(CODED(4)*32+CODED(5)/128)
RPT(7:7)=CHAR(CODED(5)*2+CODED(6)/8)
RPT(8:8)=CHAR(CODED(6)*32+CODED(7)/256/8)
RPT(9:9)=CHAR(CODED(7)/8)
RPT(10:10)=CHAR(CODED(7)*32+CODED(8)/256/4)
RPT(11:11)=CHAR(CODED(8)/4)
RPT(12:12)=CHAR(CODED(8)*64+CODED(9)*4+CODED(10)/256)
RPT(13:13)=CHAR(CODED(10))
RPT(14:14)=CHAR(CODED(11))
RPT(15:15)=CHAR(CODED(12)*8+CODED(13)*2+CODED(14)/16)
RPT(16:16)=CHAR(CODED(14)*16+CODED(15))
RPT(17:17)=CHAR(CODED(16)*32+CODED(17)*8+CODED(18)/2)
RPT(18:18)=CHAR(CODED(18)*128+CODED(19)/4)
RPT(19:19)=CHAR(CODED(19)*64+CODED(20)*4+CODED(21)/256)
RPT(20:20)=CHAR(CODED(21))
RPT(21:21)=CHAR(CODED(22)*64+CODED(23)*4+CODED(24)/32)
RPT(22:22)=CHAR(CODED(24)*8+CODED(25)/2)
RPT(23:23)=CHAR(CODED(25)*128+CODED(26)*8+CODED(27)/256)
RPT(24:24)=CHAR(CODED(27))
RPT(25:25)=CHAR(CODED(28)*16+CODED(29)/128)
RPT(26:26)=CHAR(CODED(29)*2+CODED(30)/256/4)
RPT(27:27)=CHAR(CODED(30)/4)
RPT(28:28)=CHAR(CODED(30)*64+CODED(31)/32)
RPT(29:29)=CHAR(CODED(31)*8+CODED(32)/256)
RPT(30:30)=CHAR(CODED(32))
RPT(31:31)=CHAR(CODED(33)*16+CODED(34))
RPT(32:32)=CHAR(CODED(35)*16+CODED(36))
RPT(33:33)=CHAR(CODED(37)*64+CODED(38)*4+CODED(39)/4)
RPT(34:34)=CHAR(CODED(39)*64+CODED(40)*4+CODED(41)/16)
RPT(35:35)=CHAR(CODED(41)*16+CODED(42)/2)
RPT(36:36)=CHAR(CODED(42)*128+CODED(43))
RPT(37:37)=CHAR(CODED(44)*4+CODED(45)/8)
RPT(38:38)=CHAR(CODED(45)*32+CODED(46)/4)
RPT(39:39)=CHAR(CODED(46)*64+CODED(47)/2)
RPT(40:40)=CHAR(CODED(47)*128+CODED(48))
RPT(41:41)=CHAR(CODED(49)*16+CODED(50))
RPT(42:42)=CHAR(CODED(51)*16+CODED(52)/32)
RPT(43:43)=CHAR(CODED(52)*8+CODED(53))
RPT(44:44)=CHAR(CODED(54)*2+CODED(55)/4)
RPT(45:45)=CHAR(CODED(55)*64+CODED(56)*4+CODED(57)/16)
RPT(46:46)=CHAR(CODED(57)*16+CODED(58)/4)
RPT(47:47)=CHAR(CODED(58)*64+CODED(59))
RPT(48:48)=CHAR(CODED(60)*4+CODED(61)/16)
RPT(49:49)=CHAR(CODED(61)*16+CODED(62)/4)
RPT(50:50)=CHAR(CODED(62)*64+CODED(63))
RPT(51:51)=CHAR(CODED(64)*4+CODED(65)/4)
RPT(52:52)=CHAR(CODED(65)*64+CODED(66)*4+CODED(67)/2)
RPT(53:53)=CHAR(CODED(67)*128+CODED(68)*8+CODED(69)*4+CODED(70)*2
++CODED(71)/128)
RPT(54:54)=CHAR(CODED(71)*2+CODED(72)/2)
RPT(55:55)=CHAR(CODED(72)*128)
RPT(56:56)=CHAR(CODED(73))
END
C-----------------------------------------------------------------------3456789
real function fx32dd(c32,corr,dd,fmiss)
character*(*) c32
real corr,dd,fmiss
character eighth(7)*2
data eighth/'18','14','38','12','58','34','78'/,imiss/999/
integer dc,dc2
c
fx32dd = fmiss
dd = fmiss
pts = 0.
do 700 j = 2,len(c32)
if (index("1234567",c32(j:j)).ne.0) then
do 500 j2 = j+1,len(c32)
if (index("12345678",c32(j2:j2)).eq.0) then
c
if (j2-j.le.3) then
if (j2-j.ne.2) then
pts = 360./32.*index("1234567",c32(j:j))
if (j2-j.lt.2) goto 900
endif
if (c32(j2-2:j2-1).eq."13"
+ .or. c32(j2-2:j2-1).eq."23") then
pts = pts+360./32./3.*index("12",c32(j2-2:j2-2))
goto 900
endif
do 300 k = 1,7
pts = pts+360./32./8.
if (c32(j2-2:j2-1).eq.eighth(k)) goto 900
300 continue
endif
c
return
endif
500 continue
return
endif
700 continue
c
900 if (ix32dd(c32(:j-1)//' ',dc,imiss).eq.imiss) return
if (pts.ne.0.) then
if (ix32dd(c32(j2:)//' ',dc2,imiss).eq.imiss) return
pts = sign(pts,dc2-dc)
if (abs(dc2-dc).gt.16) pts = -pts
endif
fx32dd = 360./32.*dc+pts
if (corr.ne.fmiss) fx32dd = fx32dd+corr
fx32dd = mod(fx32dd,360.)
if (fx32dd.le.0.) fx32dd = fx32dd+360.
dd = nint(fx32dd)
if (nint(dd).eq.0) dd = 360
end
EOR
a=/data/coads/software
rm sort a.out
f77_6U2 -o sort sort.f
f77_6U2 p.f $a/date.o $a/ebcasc.o $a/gsbytes.o $a/rptin.o lmrlib.f calc_di_vs_time.f
(echo $1 ; zcat nas/W$1*.Z | ./sort) | ./a.out