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 , 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., ); 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 , 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 and (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.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