cat > p.f <<\EOR c-----maury.f: Conversion of the Maury Collection. c sdw, 23 Jun 2000, 01a: original version; utilizes cha1 for hour for c cft=1 reports, processes cix=3 present weather. c sdw, 1 Aug 2000, 01b: processing discontinued for WW; modified for c TI/HR; new for II/ID, TC, PB, SLP; call {fixid} c once per voyage; mapping of ctship to cts2, and c formation of csup from data record and header c fields; handling of {prep} len/ltrue=0 improved. c sdw, 23 Aug 2000, 01c: modify processing of HR for form type 1 data; c add {deblank}) to fix mis-handling of trailing c blanks for SLP, and add {fixt0,fixt1} to decode c temperature data (only {fixt1} is used); due to c the volume of messages, {pnsc,phrck} warnings c deactivated; truncate comm for supplemental, and c add from qc format: reel sequence number, day, c and hour (qc2, qc5, and qc6); fix {parsiq} error c (qlat was set to imiss when qlon was missing); c and add handling of wind data, including {pwind, c pwd32,ix32dd,ixdcdd,pwinf,pbfws}. c sdw, 23 Aug 2000, 01d: fix error in preparation of qhr for supplemental c (neglected to divide by 100, done via {fixi2}); c {p32wd} modified so that wind directions with "T" c or "A" are no longer considered equivalent to "X". c sdw, 29 Aug 2000, 01e: add temperature corrections with {ptfix,fixshc}. c sdw, 17 Oct 2000: Note: error detected (by sjl checkout): qhr as c written out to supplemental attachment is 0 if c originally 24--should be 24. Just noted here. c sdw, 20 Oct 2000, 01f: Forgot to type cbtx,cax,csx as character in main; c no apparent impact w/ before/after test of reel51. C=============================================================================C C Comprehensive Ocean-Atmosphere Data Set (COADS): Fortran 77 Program+Shell C C Filename:level: wrlmr6:01D 10 February 2000 C C Function: Write: Long Marine Reports (LMR6) Author: S.Lubker C C=============================================================================C C Software documentation for the (modifiable) example program {eg} and routine C {test}, and for the (invariant) user-interface routines {wrlmr,lentrm, C chrbin,binchr}, plus {iasc,ebcasc,ascebc} from {ebcasc.f} and {sbyte} from C {gsbytes.c}: 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 FTRUE1 (dimensioned 73 to cover the LMR6 location and regular C fields, plus the checksum from the control section), or missing FTRUE1 C elements should be set to the user-assigned value FMISS1. Parallel arrays C CTRUE (character*8) 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 FTRUE1. CTRUE and/or LTRUE are stored in the error attachment (Attm5) C only under two conditions: C 1) If FTRUE1 is FMISS1, and LTRUE is greater than zero (LTRUE characters C from CTRUE are stored in Attm5). C 2) If FTRUE1 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 FILENAM 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 FTRUE1 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 FTRUE1 C (or CTRUE/LTRUE) array location; this facilitates usage such as FTRUE1(DY) = C FMISS1, to set FTRUE1(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 FILENAM 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 FILENAM is less than eight characters in length (provided FILENAM is C left-justified on input). (d) A warning is issued if PNAME, PLEVEL, INITLS, C and/or FILENAM 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 FILENAM). C (e) One report of synthetic data is read from unit 1 into CTRUE, plus 56 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-72 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 maximum 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 largest lexical value (according to the ascii collating sequence) C representable in the ID fields. C The 56 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 one C character (^) not directly representable (thus stored in 12 bits). (f) A C DO loop through the 73 elements first sets LTRUE to LTRUE1 (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 FTRUE1 floating-point values, or FMISS1 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 (95 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) Integer data structures C ITRUE and ISUP, intended to parallel CTRUE and CSUP, are offered in case the C original input data format is binary (e.g., 32-bit integers). In this case C a transfer may be needed of the binary data assumed to be read into ITRUE C and ISUP, 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 the commented-out equivalance statement accomplishes the same thing. The C dimensions of ITRUE and ISUP, which are dependent on the machine word-size C (BPW; default 32) are specified so as to yield the appropriate alignments if C character and integer variables can be equivalenced. (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}), and of transfers of C characters in CTRUE and CSUP to and from identical bit-patterns stored in C variables ITRUE and ISUP (via {chrbin,binchr}). Note: The check that the C 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 FTRUE1 element in turn to FMISS1 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}, FTRUE1 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 32-bit binary 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) An integer is created by dividing each FTRUE1 value by the field's C units FUNITS (from common block /LMR6/). Using {sbyte}, this positive C integer is placed into the first element of ITRUE on 32-bit computers, C or into the left-hand 32-bits of the only element on 64-bit computers C (here referring to the first array dimension of ITRUE, either 2 or 1). 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 ITRUE data are transferred into CTRUE via {binchr}. 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 maury 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 REAL FTRUE1(NUMBER),FMISS1 DATA FMISS1/-999./ CHARACTER CTRUE(NUMBER)*8,CSUP*255 INTEGER LTRUE(NUMBER),LSUP,JEOF CHARACTER PNAME*16,PLEVEL*6,INITLS*2,FILNAM*8 DATA PNAME/'maury'/,PLEVEL/'01f'/,INITLS/'sd'/,FILNAM/'?'/ LOGICAL WRLMR CHARACTER CSET*3,MODE*3 COMMON /ENV/CSET,MODE 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) c INTEGER LTRUE1(NUMBER) c DATA LTRUE1/0,4,2*2,4,1,2*5,1,3,2*2,5*0,1,3,1,4,1,2*2,2*1,5,1,4*4 c &,2,2*1,2,1,11*2,3*1,3,1,2,1,2,14*1,3*0/ c================================================== c-----typing and/or initialization of new variables c================================================== c-----mio defines the maximum number of input lines data mio/2000000/ c data mio/5/ c-----echo true prints each input line logical echo data echo/.true./ c-----yorig flags fields for which original data reside in ctrue logical yorig(number) c-----y/cdummy are dummy arguments needed for handling att. thermometer logical ydummy character*8 cdummy c-----io stores each input digitization file line character io*173 c-----iq stores each input qc file line character iq*41 c-----nio counts lines input; tio1-2 count header and data lines input data nio/0/,tio1/0/,tio2/0/ c-----character variables from qc format character cvoyq*7,crsnq*5 c-----missing value for integer qc elements data imiss/99999/ c-----data structures for decoded header (ioh) and data (iod) records character*24 cvoyh*7,cnship,ctship*15,cft*2,comm,cfr,cto common /ioh/ cvoyh ,cnship,ctship ,cft ,comm,cfr,cto character*2 cvoyd*7,cyr*4,cmo,cdy,chr,clat*5,clon*6 + ,curd*7,cursi*1,curs*4,curm,curtp,cmvi*1,cmv*5 + ,chb,cb*4,ct1*1,cbt1*4,cbt2*4,cbt3*4,cha1 + ,ca1*4,cs1*4,cd1*4,cha2,ca2*4,cs2*4,cha3 + ,ca3*4,cs3*4,cwd1*7,cwf1*3,cwd2*7,cwf2*3,cwd3*7 + ,cwf3*3,ccf1,ccd1*7,ccf2,ccd2*7,ccf3,ccd3*7 + ,csc,chx,cix*1,cx*6,cmvq common /iod/ cvoyd ,cyr ,cmo,cdy,chr,clat ,clon + ,curd ,cursi ,curs ,curm,curtp,cmvi ,cmv + ,chb,cb ,ct1 ,cbt1 ,cbt2 ,cbt3 ,cha1 + ,ca1 ,cs1 ,cd1 ,cha2,ca2 ,cs2 ,cha3 + ,ca3 ,cs3 ,cwd1 ,cwf1 ,cwd2 ,cwf2 ,cwd3 + ,cwf3 ,ccf1,ccd1 ,ccf2,ccd2 ,ccf3,ccd3 + ,csc,chx,cix ,cx ,cmvq c-----character variables: unpadded filnam; input path, + filnam; output path character cfile*6,cpath*21,cpatf*27,cpato*7 data cpath/'/data/sjl/maury/data/'/,cpato/'output/'/ c-----character variable for transformation of ctship into cts2 character*2 cts2 c-----character variables for transformation into of qdy and qhr character*2 cqdy,cqhr c-----character variables for working copies of temperature character*4 cbtx,cax,csx 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 cfile = filnam(:lentrm(filnam)) cpatf = cpath//cfile OPEN(1,FILE=cpatf) OPEN(2,FILE=cpato//cfile//'_rej') OPEN(3,FILE=cpato//cfile//'_lmr',FORM='UNFORMATTED') OPEN(8,FILE=cpato//cfile//'_sum') c-----new unit for qc file open(9,file=cpatf//'_qc') C write(*,1) 1 format('=====================maury start======================') 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' print *,pname(:lentrm(pname)),'.',plevel(:lentrm(plevel)) + ,' opening filnam=',cfile C C READ REPORT JEOF=1 100 continue c-----read and parse digitization record read(1,'(a)',end=900) io nio = nio + 1 call parsio(echo,nio,io,tio,tio1,tio2,ift) c-----read and parse qc record read(9,'(a41)',end=890) iq call parsiq(echo,nio,iq,cvoyq,crsnq,qyr,qmo,qdy,qhr,qlat + ,qlon,qli,imiss,tio,cvoyh,cvoyd) c-----fix cnship; then no sequential output from header records if(tio.eq.1) then call fixid(cnship) goto 100 endif c-----initialize {wrlmr} data structures (to ensure no residual information) call winit(fmiss1,number,ftrue1,ctrue,ltrue,csup,lsup,yorig) c-----convert hour of first AT entry (cha1) to integer zha1 (in hundredths) call phrob(nio,'cha1',cha1,zha1,imiss) c-----similarly for other hours of observation (including of barometer) call phrob(nio,'cha2',cha2,zha2,imiss) call phrob(nio,'cha3',cha3,zha3,imiss) call phrob(nio,'chb ',chb ,zhb ,imiss) c-----cross-check various hours of observation (informative only) call phrck(nio,qhr,zha1,zha2,zha3,zhb,imiss) c-----preset uyr,umo,udy,uhr in case julian day/UTC calculation fails uyr = qyr umo = qmo udy = qdy uhr = qhr c-----if month or year is missing, set ijul<0 (to minimize {ixdtnd} messages) if(qmo.eq.imiss.or.qyr.eq.imiss) then ijul = -1 else c-----attempt to convert to julian day ijul = ixdtnd(qdy,qmo,qyr) endif c-----ijul<0 should indicate that day, month, and/or year are missing/illegal if(ijul.lt.0.or.qhr.eq.imiss.or.qlon.eq.imiss) then c-----if conversion fails (ijul<0), or if later UTC calculation would fail c because hour or longitude is missing, ensure hour is missing (since, c if extant, it can't be adjusted) and skip remaining UTC calculation uhr = imiss goto 200 endif c-----if hour is 2400, make it 0000 and increment julian day if(qhr.eq.2400) then qhr = 0000 ijul = ijul + 1 endif c-----transform from local to UTC, and then back from julian call rxltut(qhr,ijul,qlon,uhr,ujul) call rxnddt(ujul,udy,umo,uyr) if(echo) write(*,150) ijul,ujul,qlon,uhr,udy,umo,uyr 150 format('maury : ijul=',i6,' ujul=',i6,' qlon=',i5 + ,' uhr=',i4,' udy=',i2,' umo=',i2,' uyr=',i4) 200 continue c-----prep: 2) YR-6) TI call prep(echo,' yr',fmiss1,ftrue1( yr),ctrue( yr),ltrue( yr) + ,imiss, uyr,yorig( yr),4,1) call prep(echo,' mo',fmiss1,ftrue1( mo),ctrue( mo),ltrue( mo) + ,imiss, umo,yorig( mo),2,1) call prep(echo,' dy',fmiss1,ftrue1( dy),ctrue( dy),ltrue( dy) + ,imiss, udy,yorig( dy),2,1) c-----NOTE: uhr has length=4 versus original qhr (1-24) call prep(echo,' hr',fmiss1,ftrue1( hr),ctrue( hr),ltrue( hr) + ,imiss, uhr,yorig( hr),4,100) call prep(echo,' ti',fmiss1,ftrue1( ti),ctrue( ti),ltrue( ti) + ,imiss, 0,yorig( ti),0,1) c-----prep: 7) LON-9) LI call prep(echo,'lon',fmiss1,ftrue1(lon),ctrue(lon),ltrue(lon) + ,imiss, qlon,yorig(lon),5,100) call prep(echo,'lat',fmiss1,ftrue1(lat),ctrue(lat),ltrue(lat) + ,imiss, qlat,yorig(lat),5,100) call prep(echo,' li',fmiss1,ftrue1( li),ctrue( li),ltrue( li) + ,imiss, qli,yorig( li),0,1) c-----prep: 10) DCK-16) TC (QI-DC set by {init}; PB set below) call prep(echo,'dck',fmiss1,ftrue1(dck),ctrue(dck),ltrue(dck) + ,imiss, 701,yorig(dck),0,1) call prep(echo,'sid',fmiss1,ftrue1(sid),ctrue(sid),ltrue(sid) + ,imiss, 69,yorig(sid),0,1) call prep(echo,' pt',fmiss1,ftrue1( pt),ctrue( pt),ltrue( pt) + ,imiss, 5,yorig( pt),0,1) call prep(echo,' tc',fmiss1,ftrue1( tc),ctrue( tc),ltrue( tc) + ,imiss, 1,yorig( tc),0,1) c-----prep: 18) DI-21) W call prep(echo,' di',fmiss1,ftrue1( di),ctrue( di),ltrue( di) + ,imiss, 1,yorig( di),0,1) call pwind(cwd1,zwd,imiss,ctrue(d),ltrue(d),yorig(d)) call prep(echo,' d',fmiss1,ftrue1( d),ctrue( d),ltrue( d) + ,imiss, zwd,yorig( d),0,1) call prep(echo,' wi',fmiss1,ftrue1( wi),ctrue( wi),ltrue( wi) + ,imiss, 5,yorig( wi),0,1) call pwinf(cwf1,zws,imiss,ctrue(w),ltrue(w),yorig(w)) call prep(echo,' w',fmiss1,ftrue1( w),ctrue( w),ltrue( w) + ,imiss, zws,yorig( w),0,10) c-----prep: 22) VI-26) W2 zx = imiss c if(cix.eq.'3') c +call pwwx(cx,zx,imiss,ctrue( ww),ltrue( ww),yorig( ww)) call prep(echo,' ww',fmiss1,ftrue1( ww),ctrue( ww),ltrue( ww) + ,imiss, zx,yorig( ww),0,1) c-----prep: 27) SLP-33) SI; plus 17) PB call ptind(ct1,zt1,ut1,imiss,ctrue(t1),ltrue(t1),yorig(t1)) c-----temperature corrections for selected voyages (if so, zt1 becomes 9) call ptfix(echo,cvoyd,zt1,ut1,ub1,ua1,us1,imiss + ,cbt1,ca1,cs1,cbtx,cax,csx) c-----call {ptval} with 3 dummy arguments for 1st att. thermometer call ptval(cbtx,zbt1,imiss,ub1, cdummy, ldummy, ydummy) call ptval( cax, za1,imiss,ua1,ctrue( at),ltrue( at),yorig( at)) call ptval( csx, zs1,imiss,us1,ctrue(sst),ltrue(sst),yorig(sst)) call ptslp(echo,cb,zb,imiss,cbtx,zbt1,ub1,qlat,ctrue(slp) + ,ltrue(slp),yorig(slp),zpb) call prep(echo,' pb',fmiss1,ftrue1( pb),ctrue( pb),ltrue( pb) + ,imiss, zpb,yorig( pb),0,1) call prep(echo,'slp',fmiss1,ftrue1(slp),ctrue(slp),ltrue(slp) + ,imiss, zb,yorig(slp),0,10) call prep(echo,' t1',fmiss1,ftrue1( t1),ctrue( t1),ltrue( t1) + ,imiss, zt1,yorig( t1),0,1) call prep(echo,' at',fmiss1,ftrue1( at),ctrue( at),ltrue( at) + ,imiss, za1,yorig( at),0,10) call prep(echo,'sst',fmiss1,ftrue1(sst),ctrue(sst),ltrue(sst) + ,imiss, zs1,yorig(sst),0,10) call prep(echo,' si',fmiss1,ftrue1( si),ctrue( si),ltrue( si) + ,imiss,imiss,yorig( si),0,1) c-----prep: 34) N-55) RS call pnsc(csc,zsc,imiss,ctrue( n),ltrue( n),yorig( n)) call prep(echo,' n',fmiss1,ftrue1( n),ctrue( n),ltrue( n) + ,imiss, zsc,yorig( n),0,1) c-----prep: 56) II-72) A6 if(cnship.eq.' ') then zii = imiss else zii = 10 endif call prep(echo,' ii',fmiss1,ftrue1( ii),ctrue( ii),ltrue( ii) + ,imiss, zii,yorig( ii),0,1) call prei(echo,'id1',fmiss1,ftrue1(id1),ctrue(id1),ltrue(id1) + ,cnship,1) call prei(echo,'id2',fmiss1,ftrue1(id2),ctrue(id2),ltrue(id2) + ,cnship,2) call prei(echo,'id3',fmiss1,ftrue1(id3),ctrue(id3),ltrue(id3) + ,cnship,3) call prei(echo,'id4',fmiss1,ftrue1(id4),ctrue(id4),ltrue(id4) + ,cnship,4) call prei(echo,'id5',fmiss1,ftrue1(id5),ctrue(id5),ltrue(id5) + ,cnship,5) call prei(echo,'id6',fmiss1,ftrue1(id6),ctrue(id6),ltrue(id6) + ,cnship,6) call prei(echo,'id7',fmiss1,ftrue1(id7),ctrue(id7),ltrue(id7) + ,cnship,7) call prei(echo,'id8',fmiss1,ftrue1(id8),ctrue(id8),ltrue(id8) + ,cnship,8) c-----prepare, and concatenate, supplemental attachment data: all data record; c plus from header: cts2 (derived from ctship), cft, comm(:16), cfr, cto; c plus from qc format: reel sequence number, day, and hour (local time) c NOTE: other qc elements must be/are assumed, retained in regular fields call fixcts(ctship,cts2) call fixi2(qdy,cqdy,imiss,99, 1) c-----qhr must be divided by 100 to restore its original input form call fixi2(qhr,cqhr,imiss,99,100) csup = io//cts2//cft//comm(:16)//cfr//cto//crsnq//cqdy//cqhr C LENGTH OF SUPPLEMENTAL ATTACHMENT MINUS TRAILING BLANKS LSUP=LENTRM(CSUP) C C WRITE REPORT IF (.NOT.WRLMR(FTRUE1,FMISS1,CTRUE,LTRUE,CSUP,LSUP,JEOF &,PNAME,PLEVEL,INITLS,FILNAM)) THEN c-----write line to reject file write(2,'(a)') io ENDIF if(nio.lt.mio) GOTO 100 goto 900 890 continue print *,'maury error. eof on qc file.' C END OF FILE 900 JEOF=2 IF (WRLMR(FTRUE1,FMISS1,CTRUE,LTRUE,CSUP,LSUP,JEOF &,PNAME,PLEVEL,INITLS,FILNAM)) PRINT *,'NORMAL TERMINATION' write(*,1000) nio,mio,echo,tio1,tio2 1000 format('------------------------------------------------------'/ + ,'total record counts: nio=',i7,' mio=',i7,' echo=',l1,/ + ,'header/data counts: tio1=',i7,' tio2=',i7,/ + ,'=====================maury end========================') END C-----------------------------------------------------------------------3456789 subroutine parsio(echo,nio,io,tio,tio1,tio2,ift) c-----Parse input line io: into common: c return tio = 1 header record (if column 8 is blank) ioh c = 2 data record (if column 8 is otherwise) iod c Note: if tio=2 and column 8 is not 1, the record is assumed to be c data but has a problem in year in the digitization format, and may c later be rejected unless the problem was fixed in the qc format. c If echo=T, print header+input line, and interpreted fields. c Increment running counts of the numbers of tio types in tio1-2. c ift returns, for tio=1, form type (cft) as an integer, if legal. implicit integer(a-e,g-z) logical echo character io*173 character*24 cvoyh*7,cnship,ctship*15,cft*2,comm,cfr,cto common /ioh/ cvoyh ,cnship,ctship ,cft ,comm,cfr,cto character*2 cvoyd*7,cyr*4,cmo,cdy,chr,clat*5,clon*6 + ,curd*7,cursi*1,curs*4,curm,curtp,cmvi*1,cmv*5 + ,chb,cb*4,ct1*1,cbt1*4,cbt2*4,cbt3*4,cha1 + ,ca1*4,cs1*4,cd1*4,cha2,ca2*4,cs2*4,cha3 + ,ca3*4,cs3*4,cwd1*7,cwf1*3,cwd2*7,cwf2*3,cwd3*7 + ,cwf3*3,ccf1,ccd1*7,ccf2,ccd2*7,ccf3,ccd3*7 + ,csc,chx,cix*1,cx*6,cmvq common /iod/ cvoyd ,cyr ,cmo,cdy,chr,clat ,clon + ,curd ,cursi ,curs ,curm,curtp,cmvi ,cmv + ,chb,cb ,ct1 ,cbt1 ,cbt2 ,cbt3 ,cha1 + ,ca1 ,cs1 ,cd1 ,cha2,ca2 ,cs2 ,cha3 + ,ca3 ,cs3 ,cwd1 ,cwf1 ,cwd2 ,cwf2 ,cwd3 + ,cwf3 ,ccf1,ccd1 ,ccf2,ccd2 ,ccf3,ccd3 + ,csc,chx,cix ,cx ,cmvq if (echo) write(*,1) nio 1 format(/,'---------------------',/ + ,'parsio: nio=',i9,/ + ,'---------------------') c-----activate the following for a heading and echo of input line c if (echo) write(*,2) io c 2 format(' 1 2 3 4 5 ' c + ,' 6 7 8 9 0 1 ' c + ,' 2 3 4 5 6 7', c + /,'123456789012345678901234567890123456789012345678901234567' c + ,'890123456789012345678901234567890123456789012345678901234' c + ,'567890123456789012345678901234567890123456789012345678901' c + ,'2345',/ c + ,a) if(io(8:8).eq.' ') then tio = 1 tio1= tio1+1 read(io,101,err=902) + cvoyh ,cnship,ctship ,cft ,comm,cfr,cto 101 format(a,1x,6(a)) if(echo) write(*,111) nio,tio + ,cvoyh ,cnship,ctship ,cft ,comm,cfr,cto 111 format('parsio: nio=',i9,' line type tio=',i1,/ + ,8x,'cvoyh=',a,' cnship=',a,' ctship=',a,/ + ,8x,'cft=',a,' comm=',a,/ + ,8x,'cfr=',a,' cto=',a) c-----convert cft to ift, and check for legality (not requiring leading 0) read(cft,'(i2)',err=901) ift if(ift.lt.1.or.ift.gt.2) goto 901 else tio = 2 tio2=tio2 + 1 read(io,202,err=902) + cvoyd ,cyr ,cmo,cdy,chr,clat ,clon + ,curd ,cursi ,curs ,curm,curtp,cmvi ,cmv + ,chb,cb ,ct1 ,cbt1 ,cbt2 ,cbt3 ,cha1 + ,ca1 ,cs1 ,cd1 ,cha2,ca2 ,cs2 ,cha3 + ,ca3 ,cs3 ,cwd1 ,cwf1 ,cwd2 ,cwf2 ,cwd3 + ,cwf3 ,ccf1,ccd1 ,ccf2,ccd2 ,ccf3,ccd3 + ,csc,chx,cix ,cx ,cmvq 202 format(47(a)) if(echo) write(*,222) nio,tio + ,cvoyd ,cyr ,cmo,cdy,chr,clat ,clon + ,curd ,cursi ,curs ,curm,curtp,cmvi ,cmv + ,chb,cb ,ct1 ,cbt1 ,cbt2 ,cbt3 ,cha1 + ,ca1 ,cs1 ,cd1 ,cha2,ca2 ,cs2 ,cha3 + ,ca3 ,cs3 ,cwd1 ,cwf1 ,cwd2 ,cwf2 ,cwd3 + ,cwf3 ,ccf1,ccd1 ,ccf2,ccd2 ,ccf3,ccd3 + ,csc,chx,cix ,cx ,cmvq 222 format('parsio: nio=',i9,' line type tio=',i1,/ + ,8x,'cvoyd=',a,' cyr=',a,' cmo=',a,' cdy=',a + ,' chr=',a,' clat=',a,' clon=',a,/ + ,8x,'curd=',a,' cursi=',a,' curs=',a,' curm=',a + ,' curtp=',a,' cmvi=',a,' cmv=',a,/ + ,8x,'chb=',a,' cb=',a,' ct1=',a,' cbt1=',a + ,' cbt2=',a,' cbt3=',a,' cha1=',a,/ + ,8x,'ca1=',a,' cs1=',a,' cd1=',a,' cha2=',a + ,' ca2=',a,' cs2=',a,' cha3=',a,/ + ,8x,'ca3=',a,' cs3=',a,' cwd1=',a,' cwf1=',a + ,' cwd2=',a,' cwf2=',a,' cwd3=',a,/ + ,8x,'cwf3=',a,' ccf1=',a,' ccd1=',a,' ccf2=',a + ,' ccd2=',a,' ccf3=',a,' ccd3=',a,/ + ,8x,'csc=',a,' chx=',a,' cix=',a,' cx=',a,' cmvq=',a) endif c-----reel file must start with header record if(nio.eq.1.and.tio.ne.1) then print *,'parsio error. nio=',nio,' tio=',tio stop endif return 901 print *,'parsio error. cft=',cft stop 902 print *,'parsio error. nio=',nio,' read tio=',tio stop end C-----------------------------------------------------------------------3456789 subroutine parsiq(echo,nio,iq,cvoyq,crsnq,qyr,qmo,qdy,qhr,qlat + ,qlon,qli,imiss,tio,cvoyh,cvoyd) c-----Parse qc record in iq into qc fields, with imiss as missing value. c tio is type of digitization input line; tiq is type of qc record: c tiq=1 header (must match tio) c tiq=2 data (must match tio) c Also, cvoyd and/or cvoyh are checked for consistency with cvoyq. implicit integer(a-e,g-z) logical echo character iq*41,cvoyq*7,crsnq*5,cyr*4,cvoyh*7,cvoyd*7 read(iq,100,err=901) cvoyq,crsnq,cyr,qmo,qdy,qhr,qlat,qlon,qli 100 format(a7,1x,a5,1x,a4,3(1x,i2),2(1x,i5),1x,i1) c-----if cyr is blank, this should be a header record if(cyr.eq.' ') then if( qmo .ne.0.or. qdy.ne.0.or. qhr.ne.0 + .or.qlat.ne.0.or.qlon.ne.0.or. qli.ne.0) then print *,'parsiq error. nio=',nio,' iq=',iq stop endif c-----for header record, make all numeric fields imiss qyr = imiss qmo = imiss qdy = imiss qhr = imiss qlat= imiss qlat= imiss qli = imiss tiq = 1 else tiq = 2 read(cyr,'(i4)',err=902) qyr c-----otherwise for integer fields, convert missing values into imiss if(qyr .eq.9999 ) qyr = imiss if(qmo .eq.99 ) qmo = imiss if(qdy .eq.99 ) qdy = imiss if(qhr .eq.99 ) then qhr = imiss else c-----convert extant hour to hundredths qhr = qhr * 100 endif if(qlat.eq.9999 ) qlat= imiss if(qlon.eq.99999) qlon= imiss if(qli .eq.9 ) qli = imiss endif if(echo) write(*,200) nio,iq,cvoyq,crsnq,qyr,qmo,qdy,qhr + ,qlat,qlon,qli,imiss,tiq 200 format('parsiq: nio=',i9,' iq=',a,/,8x,'cvoyq=',a,' crsnq=',a,/ + ,8x,'qyr=',i5,' qmo=',i5,' qdy=',i5,' qhr=',i5,/,8x,'qlat=' + ,i5,' qlon=',i5, ' qli=',i5,' imiss=',i5,' tiq=',i1) c-----require consistency between tio and tiq if(tio.ne.tiq) then print *,'parsiq error. nio=',nio,' tio=',tio,' tiq=',tiq stop endif c-----require consistency between cvoyq and cvoyh and, if applicable, cvoyd if(cvoyq.ne.cvoyh) then print *,'parsiq error. nio=',nio,' cvoyq/h=',cvoyq,'/',cvoyh stop endif if(tiq.eq.2.and.(cvoyq.ne.cvoyd)) then print *,'parsiq error. nio=',nio,' cvoyq/d=',cvoyq,'/',cvoyd stop endif return 901 print *,'parsiq error. read of iq failed.' stop 902 print *,'parsiq error. read of cyr failed.' stop end C-----------------------------------------------------------------------3456789 subroutine winit(fmiss1,number,ftrue1,ctrue,ltrue,csup,lsup,yorig) c-----Initialize, or reinitialize, the storage elements input to {wrlmr}. implicit integer(a-e,g-z) dimension ftrue1(number),ltrue(number) character*8 ctrue(number),csup*255 logical yorig(number) do 500 j=1,number ftrue1(j) = fmiss1 ctrue (j) = ' ' ltrue (j) = 0 yorig (j) = .false. 500 continue lsup = 0 csup = ' ' return end C-----------------------------------------------------------------------3456789 subroutine phrob(nio,cf,chr,zhr,imiss) c-----Convert hour of ob from char to integer*100 (to hundredths); or c set to imiss if missing or erroneous, and issue warning. implicit integer(a-e,g-z) character*4 cf,chr*2 zhr = imiss if(chr.eq.' ') return read(chr,'(i2)',err=901) zhr if(zhr.lt.0.or.zhr.gt.24) goto 901 c-----convert hour to hundredths zhr = zhr * 100 return 901 print *,'phrob warning. ',cf,' nio=',nio,' chr=',chr return end C-----------------------------------------------------------------------3456789 subroutine phrck(nio,qhr,zha1,zha2,zha3,zhb,imiss) c-----Cross-check of qhr and hours of observation (informative checks) c qhr = hour of data record c zha1-3 = hour of 1st, 2nd, or 3rd temperature entry c zhb = hour of barometric observation implicit integer(a-e,g-z) c-----at level 01c, remaining check is performed regardless of form type if(zha1.eq.imiss.and.(zha2.ne.imiss.or.zha3.ne.imiss)) +print *,'phrck warning. nio=',nio,' zha1-3=',zha1,'/',zha2 + ,'/',zha3 c-----deactivated due to print volume c if(zhb.ne.imiss) c +print *,'phrck warning. nio=',nio,' qhr=',qhr,' zhb=',zhb return end C-----------------------------------------------------------------------3456789 subroutine pwind(cwd,zwd,imiss,ctrue,ltrue,yorig) c-----Convert (character) wind direction cwd into (integer) degrees zwd, or c set to imiss if missing or erroneous. Also set ctrue, ltrue, yorig. implicit integer(a-e,g-z) logical yorig character*7 cwd,ctrue*8 c-----set original data for use by {prep} ctrue = cwd ltrue = 7 yorig = .true. c-----if cwd is missing (ltrue must be changed) if(cwd.eq.' ') then zwd = imiss ltrue = 0 else c-----transform from character to degrees call p32wd(cwd,zwd,imiss) endif return end C-----------------------------------------------------------------------3456789 subroutine p32wd(cwd,zwd,imiss) c-----Convert 7-character wind direction abbreviation cwd into zwd in c degrees, or return imiss if unrecognized. parameter (mdd=3) implicit integer(a-e,g-z) character*7 cwd,c32*4,cdd(mdd) dimension ddd(mdd) data cdd/'C ','V ','B '/ data ddd/ 361, 362, 362/ zwd = imiss c-----check against the mdd additional patterns in cdd (mappings in ddd) do 200 j=1,mdd if(cwd.eq.cdd(j)) then zwd = ddd(j) return endif 200 continue c-----otherwise patterns non-blank > position 4 cannot be recognized if(cwd(5:7).ne.' ') return c-----move first 4 characters into c32 c32 = cwd(1:4) c-----substitute 'X' in place of (non-leading and -trailing) 'T' or 'A' c NOTE: processing made rigorous at level 01c. c do 300 j=2,3 c if(c32(j:j).eq.'T'.or.c32(j:j).eq.'A') c32(j:j) = 'X' c if(c32(j:j).eq.'T') c32(j:j) = 'X' c 300 continue zwd = ix32dd(c32,dc,imiss) return end C-----------------------------------------------------------------------3456789 integer function ix32dd(c32,dc,imiss) c-----Convert 4-character 32-point wind direction abbreviation c32 into c degrees, or return imiss if unrecognized; also return numeric code c 1-32 (or imiss) in dc (see {ixdcdd} for background). Recognized c abbreviations are in cwd, with these characteristics: left-justified, c upper-case, with trailing blank fill, and where "X" stands for "by". c NOTE: No constraint is placed on imiss (it could overlap with data). implicit integer(a-e,g-z) character*4 c32,cwd(32) data cwd/'NXE ','NNE ','NEXN','NE ','NEXE','ENE ','EXN ','E ', + 'EXS ','ESE ','SEXE','SE ','SEXS','SSE ','SXE ','S ', + 'SXW ','SSW ','SWXS','SW ','SWXW','WSW ','WXS ','W ', + 'WXN ','WNW ','NWXW','NW ','NWXN','NNW ','NXW ','N '/ ix32dd = imiss do 500 j=1,32 if(c32.eq.cwd(j)) then ix32dd = ixdcdd(j,imiss) dc = j return endif 500 continue return end C-----------------------------------------------------------------------3456789 integer function ixdcdd(dc,imiss) c-----Convert 32-point wind direction numeric code dc into degrees, or c return imiss if dc is out of range 1-32. Release 1, Table F2-1 c defines the mapping of code dc to degrees in dwd. c NOTE: No constraint is placed on imiss (it could overlap with data). implicit integer(a-e,g-z) dimension dwd(32) data dwd/ 11, 23, 34, 45, 56, 68, 79, 90, + 101, 113, 124, 135, 146, 158, 169, 180, + 191, 203, 214, 225, 236, 248, 259, 270, + 281, 293, 304, 315, 326, 338, 349, 360/ if(dc.ge.1.and.dc.le.32) then ixdcdd = dwd(dc) else ixdcdd = imiss endif return end C-----------------------------------------------------------------------3456789 subroutine pwinf(cwf,zws,imiss,ctrue,ltrue,yorig) c-----Convert (character) wind force cwf into (integer) m/s*10 zws, or c set to imiss if missing or erroneous. Also set ctrue, ltrue, yorig. implicit integer(a-e,g-z) logical yorig character*3 cwf,ctrue*8 c-----set original data for use by {prep} ctrue = cwf ltrue = 3 yorig = .true. c-----if cwf is missing (ltrue must be changed) if(cwf.eq.' ') then zws = imiss ltrue = 0 else c-----transform from character to m/s*10 call pbfws(cwf,zws,imiss) endif return end C-----------------------------------------------------------------------3456789 subroutine pbfws(cwf,zws,imiss) c-----Convert 3-character wind force abbreviation cwf into m/s*10 zws, c or return imiss if unrecognized. parameter (mff=8) implicit integer(a-e,g-z) character*3 cwf,cff(8) dimension bff(8) data cff/'501','601','511','441','571','512','442','572'/ data bff/ 2, 3, 4, 5, 6, 7, 8, 9/ zws = imiss c-----entirely blank patterns are missing if(cwf.eq.' ') return c-----check against the mff additional patterns in cff (mappings in bff) do 200 j=1,mff if(cwf.eq.cff(j)) then zws = nint(fxbfms(bff(j))*10.) return endif 200 continue c-----otherwise, patterns non-blank > position 3 cannot be recognized if(cwf(3:3).ne.' ') return c-----attempt to convert first 2 characters into integer bf using c default integer input (trailing blank results in right-shift) read(cwf(1:2),'(i2)',err=901) bf c-----transform 20-32 into 0-12 (ignore 33, which we can't convert) if(bf.ge.20.and.bf.le.32) then bf = bf - 20 else if(bf.lt.0.or.bf.gt.12) then return endif c-----translate to m/s zws = nint(fxbfms(bf)*10.) return 901 continue return end C-----------------------------------------------------------------------3456789 subroutine pwwx(cx,zx,imiss,ctrue,ltrue,yorig) c-----Convert (character) present weather cx into integer zx; or set to c imiss if missing or erroneous (issue warning in the latter case). c Also set ctrue, ltrue, yorig. This routine should be called only c if the present weather indicator cix is 2 (WMO Code 4677). c NOTE: routine no longer called for data production implicit integer(a-e,g-z) logical yorig character*6 cx, ctrue*8 c-----set original data for use by {prep} (storing all six cx positions) ctrue = cx ltrue = 6 yorig = .true. c-----if cx is missing (ltrue must be changed) if(cx.eq.' ') then zx = imiss ltrue = 0 else c-----convert to integer (note: using only the left-most two cx positions) read(cx(1:2),'(i2)',err=901) zx c-----check for numeric validity if(zx.lt.00.or.zx.gt.99) goto 901 endif return 901 zx = imiss print *,'pwwx warning. read error on cx=',cx return end C-----------------------------------------------------------------------3456789 subroutine ptind(ct1,zt1,ut1,imiss,ctrue,ltrue,yorig) c-----Convert (character) temperature indicator value ct1 into integer zt1 c value zt1 for T1, and into units ut1 for {ptval}; or set zt1 and ut1 c to imiss if missing or erroneous (issue warning in the latter case). c Also set ctrue, ltrue, yorig. c-----NOTE: At level 01a this routine handled ct1=1-6, but subsequent data c inventories showed only ct1=1-2 extant so the routine was simplified. implicit integer(a-e,g-z) logical yorig character*1 ct1,ctrue*8 c-----set original data for use by {prep} ctrue = ct1 ltrue = 1 yorig = .true. c-----if ct1 is missing (ltrue must be changed) if(ct1.eq.' ') then zt1 = imiss ut1 = imiss ltrue = 0 return endif c-----otherwise, convert ct1 from character to integer it1 read(ct1,'(i1)',err=901) it1 if(it1.lt.1.or.it1.gt.2) goto 901 if(it1.eq.1) then zt1 = 7 ut1 = 1 else if(it1.eq.2) then zt1 = 3 ut1 = 0 c else c zt1 = 9 c if(it1.eq.3) then c ua = 2 c us = 2 c-----note: it1=6 has an additional meaning, ignored: att'd therm. Fahrenheit c else if(it1.eq.4.or.it1.eq.6) then c ua = 1 c us = 0 c else c ua = 0 c us = 1 c endif endif return 901 zt1 = imiss ut1 = imiss print *,'ptind warning. read error on ct1=',ct1 return end C-----------------------------------------------------------------------3456789 subroutine ptfix(echo,cvoyd,zt1,ut1,ub1,ua1,us1,imiss + ,cbt1,ca1,cs1,cbtx,cax,csx) c-----Fix temperatures: first make working copies: c ut1 to ub1,ua1,us1 c cbt1,ca1,cs1 to cbtx,cax,csx c then check if cvoyd is one of the ml voyages subject to temperature c units changes or other corrections as specified by these arrays: c governing action units action: units: c --------- ------ ----- =0 none =0 Celsius c cbt1 nbx nbu =1 do R-shift =1 Fahrenheit c ca1 nax nau =2 do L-shift c cs1 nsx nsu c If so, then zt1 is changed to 9 (T1 = other, refer to metadata). parameter(ml=107) implicit integer(a-e,g-z) logical echo character*4 cvoyd*7,cbt1,ca1,cs1,cbtx,cax,csx c-----parameter, dimension, and data statements generated by the following c program (plus editing to add terminating "/" in place of comma): c Tue Aug 29 14:33:21 MDT 2000 maur1.01a. dimension tvoy(ml) dimension nbx(ml),nbu(ml) dimension nax(ml),nau(ml) dimension nsx(ml),nsu(ml) data tvoy +/1502821,1502851,1502891,1502921,1502931,1502941,1502991,1503021, + 1503041,2701881,4605761,4605861,4605871,4605881,4605901,4905971, + 4905981,4906221,4906241,4906321,4906341,4906411,4906461,4906471, + 4906531,4906651,4906661,4906741,4906771,4906781,4906811,4906851, + 4907001,4907021,4907031,4907161,4907221,5601261,5601511,5601761, + 5601901,5700711,5700781,5700871,5701061,5701231,5701881,6703151, + 6703201,6703221,6703251,6703291,6703331,6703351,6703401,6900021, + 6900251,6900271,6900301,6900341,6900511,6900661,6900701,6900731, + 6900841,6901501,6901721,6901781,6901831,6901981,6902201,6902251, + 6902271,6902391,6902441,6902501,6902681,6902831,6902851,6902901, + 6903031,6903051,6903261,6903331,6903501,6903711,6903801,6903931, + 6904021,6904181,6904221,6904401,6904491,6904561,6904711,6904991, + 6905751,7400041,7400061,7400071,7400101,7400121,7400141,7400161, + 7506861,7702531,8405121/ data nbx +/ 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0/ data nbu +/ 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 0, 0, 0, + 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1, + 1, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 1/ data nax +/ 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 2, + 2, 0, 0, 0, 0, 0, 0, 0, + 2, 0, 0/ data nau +/ 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 0, 0, 0, + 0, 1, 1, 1, 0, 0, 0, 1, + 1, 1, 1, 1, 1, 1, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1, + 1, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 0/ data nsx +/ 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0/ data nsu +/ 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 0, 0, 0, + 0, 1, 1, 1, 0, 0, 0, 1, + 1, 1, 1, 1, 1, 1, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1, + 1, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 0/ c-----make working copies of indicator and data ub1 = ut1 ua1 = ut1 us1 = ut1 cbtx = cbt1 cax = ca1 csx = cs1 c-----done if zt1 (temperature indicator) is missing if(zt1.eq.imiss) return c-----otherwise convert cvoyd to integer nvoy read(cvoyd,'(i7)',err=1000) nvoy c-----see if it is among the ml voyages tvoy do 500 j=1,ml if(nvoy.eq.tvoy(j)) then call fixshc('cbtx',cbtx,nbx(j)) call fixshc('cax ',cax ,nax(j)) call fixshc('csx ',csx ,nsx(j)) ub1 = nbu(j) ua1 = nau(j) us1 = nsu(j) zt1 = 9 if(echo) write(*,400) cvoyd,zt1,ut1,ub1,ua1,us1 + ,nbx(j),nax(j),nsx(j) + ,cbt1,ca1,cs1,cbtx,cax,csx 400 format('ptfix : ',a,' z/ut1=',i1,'/',i1,' ub/a/s1=' + ,i1,'/',i1,'/',i1,' nb/a/sx=',i1,'/',i1,'/',i1,/ + ,' cbt1=',a,' ca/s1=',a,'/',a,/ + ,' cbtx=',a,' ca/sx=',a,'/',a) endif 500 continue return 1000 print *,'ptfix error. read failure.' stop end C-----------------------------------------------------------------------3456789 subroutine fixshc(cf,c,x) c-----1-byte end-around shift of string c for field named cf, such that c direction is dependent on x: =0 no shift (return with c unchanged) c =1 right-shift c =2 left-shift c Note: c is unchanged and warning issued if end-around is non-blank implicit integer(a-e,g-z) character*4 cf,c if(x.eq.0) return if(x.eq.1) then if(c(4:4).ne.' ') then print *,'fixshc warning. ' + ,cf,': nonblank trailer c=',c,' x=',x else c = c(4:4)//c(1:1)//c(2:2)//c(3:3) endif else if(x.eq.2) then if(c(1:1).ne.' ') then print *,'fixshc warning. ' + ,cf,': nonblank leader c=',c,' x=',x else c = c(2:2)//c(3:3)//c(4:4)//c(1:1) endif else print *,'fixshc error. c=',c,' x=',x stop endif return end C-----------------------------------------------------------------------3456789 subroutine ptval(ct,zt,imiss,ut1,ctrue,ltrue,yorig) c-----Convert (character) temperature value ct, in units ut1: c 0: Celsius c 1: Fahrenheit c 2: Reaumur c into integer zt (tenths); or set to imiss if missing or erroneous c (issue warnings in two cases). Also set ctrue, ltrue, yorig. implicit integer(a-e,g-z) c-----NOTE: only one yfixt? routine is typed and used logical yorig,yfixt1 character*4 ct,ctrue*8 c-----set original data for use by {prep} ctrue = ct ltrue = 4 yorig = .true. c-----if ct is missing (ltrue must be changed) if(ct.eq.' ') then zt = imiss ltrue = 0 else c-----transform from character to real, and check if ct is illegal if(.not.yfixt1(ct,ft)) then zt = imiss print *,'ptval warning. illegal ct=',ct return endif c-----transform units if needed, and back to integer zt in tenths if (ut1.eq.0) then zt = nint( ft *10.) else if(ut1.eq.1) then zt = nint(fxtftc(ft)*10.) else if(ut1.eq.2) then c-----NOTE: inventories showed no temperatures flagged as Reaumur c zt = nint(fxtrtc(ft)*10.) print *,'ptval error. ut1=',ut1,' unexpected.' stop else c-----for extant ct but missing or erroneous ut1, data written to Attm5 zt = imiss print *,'ptval warning. extant ct=',ct,' but ut1=',ut1 endif endif return end C-----------------------------------------------------------------------3456789 subroutine ptslp(echo,cb,zb,imiss,cbtx,zbt1,ub1,qlat,ctrue + ,ltrue,yorig,zpb) c-----Convert (character) barometric pressure value cb into integer c zb (tenths hPa). Set zb to imiss if cb is missing or erroneous c (issue warning in the latter case), or if latitude qlat is imiss. c If the 1st attached thermometer (zbt1; from corrected characters c cbtx) is extant (and other requirements given below), correct for c temperature. Then correct for gravity. Set ctrue, ltrue, yorig; c and zpb (used for PB) depending on if a temperature correction is c made (gravity correction always made). implicit integer(a-e,g-z) logical echo,yorig character*4 cb,db,cbtx,ctrue*8 c-----set original data for use by {prep} ctrue = cb//cbtx ltrue = 8 yorig = .true. c-----if cb is missing (ltrue must be changed) if(cb.eq.' '.or.qlat.eq.imiss) then zb = imiss zpb = imiss ltrue = 0 else c-----db = cb without embedded/trailing (and leading) blanks call deblnk(cb,db,4) c-----convert to integer zb0 read(db,'(i4)',err=901) zb0 c-----inches: if 1st digit of cb is 2 or 3 (English inches are assumed) if(cb(1:1).eq.'2'.or.cb(1:1).eq.'3') then fb0 = float(zb0)/100. c----- to correct inches, cbtx must be F (ub1=1) and zbt1 range -50:50C if(ub1.ne.1.or.zbt1.eq.imiss.or.zbt1.lt.-500.or.zbt1.gt.500) + then c----- PB=2: no temperature correction (data not available or unsuitable) fbt = -99.999 fb1 = fb0 zpb = 2 else c----- PB=1: calculate and add temp. (converted back to F) correction (fbt) fbt = fwbptf(fb0,fxtctf(float(zbt1/10.))) fb1 = fb0 + fbt zpb = 1 endif c----- calculate and add gravity correction (fbg) (gmode = 2) fbg = fwbpgv(fb1,float(qlat)/100.,2) fb2 = fb1 + fbg c----- units and integer transformations fb = fxeimb(fb2) zb = nint(fb * 10.) c-----data are echoed only for extant SLP/PB, including intermediate results c fb0 = uncorrected c fbt = value of temperature correction c fb1 = corrected for temperature (printed twice, on separate lines) c fbg = value of gravity correction c fb2 = corrected for gravity if(echo) + write(*,200) 'in',cb,db,zb,cbtx,zbt1,ub1,ctrue,ltrue,yorig + ,zpb,fb0,fbt,fb1,fb1,qlat,fbg,fb2,fb 200 format('ptslp : units=',a,': c/d/zb=',a,'/',a,'/',i5 + ,' c/zbt1=',a,'/',i5,' ub1=',i1,' c/ltrue=',a8,'/',i1 + ,/,8x,'yorig=',l1,' zpb=',i1,' fb0=',f6.2 + ,' fbt (missing=-99.999)=',f7.3,' fb1=',f6.2 + ,/,8x,'fb1=',f6.2,' qlat=',i5,' fbg=',f7.3 + ,' fb2=',f6.2,' fb=',f6.1) c-----mm : if 1st digit of cb is 7 (inventories showed no 6 or 8) else if(cb(1:1).eq.'7') then fb0 = float(zb0)/10. c----- to correct mm , cbtx must be C (ub1=0) and zbt1 range -50:50C if(ub1.ne.0.or.zbt1.eq.imiss.or.zbt1.lt.-500.or.zbt1.gt.500) + then c----- PB=2: no temperature correction (data not available or unsuitable) fbt = -99.999 fb1 = fb0 zpb = 2 else c----- PB=1: calculate and add temp. (already in C) correction (fbt) fbt = fwbptc(fb0, float(zbt1/10.)) fb1 = fb0 + fbt zpb = 1 endif c----- calculate and add gravity correction (fbg) (gmode = 2) fbg = fwbpgv(fb1,float(qlat)/100.,2) fb2 = fb1 + fbg c-----units and integer transformations fb = fxmmmb(fb2) zb = nint(fb * 10.) c-----data are echoed only for extant SLP/PB (as above) if(echo) + write(*,200) 'mm',cb,db,zb,cbtx,zbt1,ub1,ctrue,ltrue,yorig + ,zpb,fb0,fbt,fb1,fb1,qlat,fbg,fb2,fb c-----otherwise, barometric units are considered to be unrecognizable else zb = imiss zpb = imiss return endif endif return 901 zb = imiss zpb = imiss print *,'ptslp warning. read error on cb=',cb return end C-----------------------------------------------------------------------3456789 subroutine pnsc(csc,zsc,imiss,ctrue,ltrue,yorig) c-----Convert (character) proportion of sky clear csc (tenths) into oktas c of cloud cover in zsc; or set to imiss if missing or erroneous (issue c a warning in the latter case). Also set ctrue, ltrue, yorig. implicit integer(a-e,g-z) logical yorig character*2 csc,ctrue*8 c-----set original data for use by {prep} ctrue = csc ltrue = 2 yorig = .true. c-----if csc is missing (ltrue must be changed) if(csc.eq.' ') then zsc = imiss ltrue = 0 else c-----convert to integer, and check for numeric validity read(csc,'(i2)',err=901) zsc if(zsc.lt.0.or.zsc.gt.10) goto 901 c-----convert from tenths of sky clear, to modern oktas of cloud cover zsc = ixt0ok(zsc) endif return 901 zsc = imiss c-----deactivated due to print volume c print *,'pnsc warning. read error on csc=',csc return end C-----------------------------------------------------------------------3456789 subroutine prep(echo,cf,fmiss1,ftrue1,ctrue,ltrue + ,imiss,itrue,yorig,len,div) c-----Prepare input data structures for {wrlmr} for the field named cf: c ftrue1 = the floating point datum is obtained by converting itrue c to real, and dividing by div; or, if itrue=imiss, ftrue1 c is set to fmiss1. c ctrue = the original data character-string (left justified), and c ltrue = its length, are handled according to yorig: c true : ctrue (ltrue) already contains string (length); c but for missing original data, supply ltrue=0 c false: converted into len characters from itrue, c and ltrue is set to len (which may be zero); c unless itrue=imiss, in which case ltrue=0 c NOTE: For yorig=T (F), len (ltrue) must be zero (unused). c For yorig=T, ltrue=0 indicates missing original data. c For yorig=F, len=0 indicates missing original data, thus ltrue=0. c For supplied or resultant ltrue=0, ctrue is always set to blank. implicit integer(a-e,g-z) logical echo,yorig character*8 cf*3,ctrue,ctemp c-----if integer input is missing if(itrue.eq.imiss) then ftrue1 = fmiss1 c-----otherwise, convert into ftrue1 else if(div.eq.1) then ftrue1 = float(itrue) else ftrue1 = float(itrue)/float(div) endif endif c-----set/check ltrue/len if(yorig) then if(len.ne.0) then print *,'prep error. ',cf,' len=',len,' yorig=',yorig stop endif else if(ltrue.ne.0) then print *,'prep error. ',cf,' ltrue=',ltrue,' yorig=',yorig stop endif ltrue = len endif if(ltrue.lt.0.or.ltrue.gt.8) then print *,'prep error. ',cf,' ltrue=',ltrue,' len=',len + ,' yorig=',yorig stop else if(ltrue.eq.0) then c-----ltrue = 0 ctrue = ' ' c-----ltrue > 0 else c-----only for yorig=F if(.not.yorig) then if(ctrue.ne.' ') then c-----disallow input ctrue non-blank print *,'prep error. ',cf,' yorig=',yorig,' ctrue=',ctrue stop endif c-----unless itrue=imiss if(itrue.eq.imiss) then ltrue = 0 else c-----obtain ctemp from itrue write(ctemp,'(i8)') itrue ctrue = ctemp(9-ltrue:8) endif endif c-----for either yorig=T or F if(ltrue.lt.8) then if(ctrue(ltrue+1:8).ne.' ') then c-----disallow for the trailing, unused portion of ctrue to be non-blank print *,'prep error. ',cf,' ltrue=',ltrue,' ctrue=',ctrue stop endif endif endif if(echo) +write(*,500) cf,ftrue1,ctrue,ltrue,itrue,yorig,len,div 500 format('prep : ',a,' f/c/ltrue=',f9.2,'/',a8,'/',i1 + ,' itrue=',i7,' yorig=',l1,' len=',i1,' div=',i6) return end C-----------------------------------------------------------------------3456789 subroutine prei(echo,cf,fmiss1,ftrue1,ctrue,ltrue,cnship,num) c-----Prepare input data structures for {wrlmr} for ID(num) named cf, c where cnship is the ship name (echo,...,ltrue are as for {prep}). implicit integer(a-e,g-z) logical echo character*8 cf*3,ctrue,cnship*24 c-----extract out the relevant character ctrue = cnship(num:num) if(ctrue.ne.' ') then c-----convert to integer and then real ascii-equivalent ftrue1 = ichar(ctrue(1:1)) ltrue = 1 else ftrue1 = fmiss1 ltrue = 0 endif if(echo) +write(*,500) cf,ftrue1,ctrue,ltrue,cnship,num 500 format('prei : ',a,' f/c/ltrue=',f9.2,'/',a8,'/',i1 + ,' cnship=',a,' num=',i1) return end C-----------------------------------------------------------------------3456789 logical function yfixt0(ct,ft) c-----fix temperature string ct into real ft (if illegal, return false) c mode = 0 replace blanks by zeros, strict column interpretation implicit integer(a-e,g-z) character*4 ct,dt call deblnk(ct,dt,4) read(dt,'(i4)',err=901) zt ft = float(zt)/10. yfixt0 = .true. return 901 yfixt0 = .false. return end C-----------------------------------------------------------------------3456789 logical function yfixt1(ct,ft) c-----fix temperature string ct into real ft (if illegal, return false) c mode = 1 trailing blanks impact read of 3 higher-order positions implicit integer(a-e,g-z) character*4 ct read(ct,'(i3 )',err=901) zt1 read(ct,'(3x,i1)',err=901) zt2 ft = float(zt1) + (float(zt2)/10.) yfixt1 = .true. return 901 yfixt1 = .false. return end c----------------------------------------------------------------------3456789 subroutine deblnk(c,d,len) c-----copy c(:len) to d, except make any blanks in c into zeros in d character*(*) c,d do 500 j=1,len if(c(j:j).eq.' ') then d(j:j) = '0' else d(j:j) = c(j:j) endif 500 continue return end C-----------------------------------------------------------------------3456789 subroutine fixid(cn) c-----Fix ship name cn according to predetermined rules. implicit integer(a-e,g-z) logical shrank character*24 cn c-----ln is the length of cn minus trailing blanks ln = lentrm(cn) if(ln.lt.2.or.ln.gt.24) then print *,'fixid error. cn=',cn,' ln=',ln stop endif j = 1 shrank = .false. c-----remove unnecessary blanks associated with patterns 100 if(.not.shrank) j = j + 1 if(j.gt.ln-1) goto 199 shrank = .false. if( cn(j:j+1).eq.' ') then call fix12(cn,ln,j,1,shrank) else if(cn(j:j+1).eq.'. ') then c-----note: no ' .' was keyed call fix12(cn,ln,j,2,shrank) else if(cn(j:j+1).eq.' &') then call fix12(cn,ln,j,1,shrank) else if(cn(j:j+1).eq.'& ') then call fix12(cn,ln,j,2,shrank) endif goto 100 199 continue c-----re-check lentrm if(ln.ne.lentrm(cn)) then print *,'fixid error. ln=',ln,' lentrm(',cn,')=',lentrm(cn) stop endif c-----replace one or more embedded blank(s) by underline do 200 j=1,ln if(cn(j:j).eq.' ') cn(j:j)='_' 200 continue c-----ad hoc rules if(cn(:17).eq.'ABSTRACT_JOURNALS') cn = 'AJ*'//cn(19:) if(cn(: 8).eq.'ADELAIDE') cn = 'ADELA*'//cn(9:) if(cn(: 9).eq.'ALEXANDER') cn = 'ALEXA*'//cn(10:) if(cn(: 6).eq.'AMAZON') cn = 'AMA*'//cn(11:) if(cn(:10).eq.'AMERICA_OF') cn = 'AME*'//cn(11:) if(cn(: 8).eq.'AMERICAN') cn = 'AMERI*'//cn(9:) if(cn(: 8).eq.'ASHBURTO') cn = 'ASHBUR*'//cn(9:) if(cn(: 8).eq.'BENJAMIN') cn = 'BENJA*'//cn(9:) if(cn(: 8).eq.'CAROLINE') cn = 'CAROL*'//cn(9:) if(cn(: 9).eq.'CATHERINE') cn = 'CATHE*'//cn(10:) if(cn(: 9).eq.'CELESTIAL') cn = 'CELES*'//cn(10:) if(cn(: 9).eq.'CHALLENGE') cn = 'CHALLE*'//cn(10:) if(cn(: 8).eq.'CHARLES_') cn = 'CHAR*'//cn(8:) if(cn(: 9).eq.'CHARLOTTE') cn = 'CHARL*'//cn(10:) if(cn(: 9).eq.'CINCINNAT') cn = 'CINCIN*'//cn(10:) if(cn(: 7).eq.'CITY_OF') cn = 'CITY*'//cn(8:) if(cn(: 8).eq.'CORNELIA') cn = 'CORNE*'//cn(9:) if(cn(: 8).eq.'CRESCENT') cn = 'CRESC*'//cn(9:) if(cn(: 8).eq.'DEFIANCE') cn = 'DEFIA*'//cn(12:) if(cn(: 8).eq.'EARL_OF_') cn = 'EARL*'//cn(9:) if(cn(: 8).eq.'EASTERN_') cn = 'EAS*'//cn(9:) if(cn(: 8).eq.'ELECTRIC') cn = 'ELECT*'//cn(9:) if(cn(: 9).eq.'ELIZA-AND') cn = 'ELIZ*&'//cn(10:) if(cn(: 9).eq.'ELIZABETH') cn = 'ELIZAB*'//cn(11:) if(cn(:10).eq.'EMPRESS_OF') cn = 'EMPRE*'//cn(11:) if(cn(: 6).eq.'FLYING') cn = 'FLYI*'//cn(7:) if(cn(: 8).eq.'FRANCES_') cn = 'FRAN*'//cn(8:) if(cn(: 8).eq.'FRANCIS_') cn = 'FRAN*'//cn(8:) if(cn(: 8).eq.'FRANKLIN') cn = 'FRANK*'//cn(12:) if(cn(: 8).eq.'FREDERIC') cn = 'FRED*'//cn(9:) if(cn(: 7).eq.'GENERAL') cn = 'GEN*'//cn(8:) if(cn(:10).eq.'GEORGE_AND') cn = 'G*&'//cn(11:) if(cn(: 7).eq.'GEORGE_') cn = 'GEO*'//cn(7:) if(cn(: 6).eq.'GOLDEN') cn = 'GOL*'//cn(7:) if(cn(: 7).eq.'HARRIET') cn = 'HARRI*'//cn(8:) if(cn(: 5).eq.'HENRY') cn = 'HEN*'//cn(6:) if(cn(:13).eq.'ISAAC_HOWLAND') cn = 'I_HOW*'//cn(17:) if(cn(: 9).eq.'ISABELLA_') cn = 'ISABE*'//cn(12:) if(cn(: 9).eq.'JEFFERSON') cn = 'JEF*'//cn(10:) if(cn(:10).eq.'JUDGE_SHAW') cn = 'JUD_S*'//cn(14:) if(cn(: 9).eq.'KATE_AND_') cn = 'K*&'//cn(10:) if(cn(: 8).eq.'KATHLEEN') cn = 'KAT*'//cn(12:) if(cn(:10).eq.'MACEDONIAN') cn = 'MACEDO*'//cn(10:) if(cn(: 8).eq.'MAJESTIC') cn = 'MAJ*'//cn(12:) if(cn(:10).eq.'MANCHESTER') cn = 'MAN*'//cn(14:) if(cn(: 8).eq.'MARGARET') cn = 'MAR*'//cn(9:) if(cn(: 9).eq.'MARY_ANNA') cn = 'MAR_A*'//cn(14:) if(cn(: 8).eq.'MARY_FRA') cn = 'MAR_FR*'//cn(9:) if(cn(: 9).eq.'MAYFLOWER') cn = 'MAYF*'//cn(13:) if(cn(: 9).eq.'MECHANICS') cn = 'MEC*'//cn(10:) if(cn(: 9).eq.'MERCATOR_') cn = 'MERCA*'//cn(16:) c-----note: following is a special case, which converts NO_ followed by c LIST, LIST_SHIP, SHIP_LIST, or SPIP_LIST to blank (ID missing) if(cn(: 3).eq.'NO_') cn = ' ' if(cn(:13).eq.'NORTH_AMERICA') cn = 'N_AMER*'//cn(14:) if(cn(: 9).eq.'NORTHERN_') cn = 'N*'//cn(9:) if(cn(: 8).eq.'PLYMOUTH') cn = 'PL*'//cn(9:) if(cn(: 9).eq.'PRINCE_OF') cn = 'P*'//cn(10:) if(cn(: 8).eq.'PRINCESS') cn = 'PR*'//cn(6:) if(cn(: 9).eq.'QUEEN_OF_') cn = 'Q*'//cn(9:) if(cn(: 9).eq.'REINDEER_') cn = 'REIND*'//cn(12:) if(cn(: 9).eq.'RESOLUTE_') cn = 'RES*'//cn(13:) if(cn(: 9).eq.'RETRIEVER') cn = 'RETRI*'//cn(8:) if(cn(: 7).eq.'RICHARD') cn = 'RICHA*'//cn(8:) if(cn(: 6).eq.'SAMUEL') cn = 'SAM*'//cn(7:) if(cn(: 8).eq.'SARAH_H.') cn = 'SA*'//cn(6:) if(cn(:10).eq.'SIR_ROBERT') cn = 'SIR_R*'//cn(12:) if(cn(: 9).eq.'SPARKLING') cn = 'SPARK*'//cn(10:) if(cn(: 8).eq.'SPLENDID') cn = 'SPLE*'//cn(12:) if(cn(:11).eq.'STAR_OF_THE') cn = 'STAR_T*'//cn(13:) if(cn(: 7).eq.'STEPHEN') cn = 'STEP*'//cn(9:) if(cn(: 8).eq.'SULPHUR,') cn = 'SUL*'//cn(9:) if(cn(: 7).eq.'THOMAS_') cn = 'THOM*'//cn(8:) if(cn(:14).eq.'UNITED_STATES_') cn = 'U.S.*'//cn(14:) if(cn(: 9).eq.'VIRGINIAN') cn = 'VIRGIN*'//cn(9:) if(cn(: 7).eq.'WESTERN') cn = 'WESTE*'//cn(8:) if(cn(: 8).eq.'WILLIAM_') cn = 'WILLI*'//cn(8:) if(cn(:11).eq.'YOUNG_EAGLE') cn = 'Y_EAG*'//cn(15:) return end C-----------------------------------------------------------------------3456789 subroutine fix12(cn,ln,j,i12,shrank) c-----Remove from cn(j:j+1), depending on i12=1 (cn(j:)) or =2 (cn(j+1:) implicit integer(a-e,g-z) logical shrank character*24 cn c-----removal is not implemented starting at j=1, etc. if(j.eq.1.or.j.gt.22.or.i12.lt.1.or.i12.gt.2) then print *,'fix12 error. cn=',cn,' j=',j,' i12=',i12 stop endif c-----i12 = 1 (remove 1st position) if(i12.eq.1) then cn = cn(1:j-1)//cn(j+1:24) c-----i12 = 2 (remove 2nd position) else cn = cn(1: j)//cn(j+2:24) endif c-----decrement the length of cn ln = ln - 1 c-----shrank=T indicates that the string size shrank shrank = .true. return end C-----------------------------------------------------------------------3456789 subroutine fixcts(ctship,cts2) c-----Fix type of ship ctship into 2-character cts2 (predetermined rules). implicit integer(a-e,g-z) character*15 ctship,cts0(55),cts1(55)*2,cts2*2 c-----cts0 holds the set of 55 patterns detected by inventory {maurx.f} data cts0 1/' ','3 MAST CLIPPER ','BARK ' 2,'BARQUE ','BRIG ','BRIGANTINE ' 3,'BRIT. SCHOONER ','BRITISH ','BRITISH BARK ' 4,'BRITISH BARQUE ','BRITISH RMS ','CHILIAN ' 5,'CHILIAN BARK ','CLIPPER ','CUTTER ' 6,'DUTCH BARK ','DUTCH FRIGATE ','FINNISH ' 7,'FRENCH ','FRENCH SLOOP ','FRIGATE ' 8,'GERMAN ','GERMAN BRIG ','NOT LISTED ' 9,'PACKET ','PILOT ','PILOT BOAT ' X,'PORTUG.CORVETTE','PORTUGUESE BRIG','PRUSSIAN ' 1,'R.M.S.BRITISH ','R.M.S.S.BRITISH','REVENUE ' 2,'RUSSIAN CORVET ','RUSSIAN STEAMER','SARDINI. FRIGAT' 3,'SCHOONER ','SCHOONER,HMS ','SCOONER ' 4,'SCREW SLOOP ','SHIP ','SLOOP ' 5,'SLOOP OF WAR ','SPANISH ','STEAM FRIGATE ' 6,'STEAMER ','STEAMSHIP ','SURVEY SHIP ' 7,'SWEDISH BRIG ','TRANSPORT ','U.S. SHIP ' 8,'U.S. SQUADRON ','U.S. STORE SHIP','U.S.FRIGATE ' 9,'WHALER '/ c-----cts1 holds the set of 2-character (blank if missing) mappings data cts1 1/' ',' 1',' 2' 2,' 3',' 4',' 5' 3,' 6',' 7',' 8' 4,' 9','10','11' 5,'12','13','14' 6,'15','16','17' 7,'18','19','20' 8,'21','22',' ' 9,'23','24','25' X,'26','27','28' 1,'29','29','30' 2,'31','32','33' 3,'34','35','34' 4,'36','37','38' 5,'39','40','41' 6,'42','43','44' 7,'45','46','47' 8,'48','49','50' 9,'51'/ do 200 j=1,55 if(ctship.eq.cts0(j)) then cts2 = cts1(j) return endif 200 continue print *,'fixcts error. ctship=',ctship,' not found in cts0.' stop end C-----------------------------------------------------------------------3456789 subroutine tstcts c-----Test {fixcts} by producing table of the 55 patterns versus mappings c NOTE: routine not called for data production implicit integer(a-e,g-z) character*15 ctship(55),cts2*2 c-----this is the same array content as cts0 from {fixcts} data ctship 1/' ','3 MAST CLIPPER ','BARK ' 2,'BARQUE ','BRIG ','BRIGANTINE ' 3,'BRIT. SCHOONER ','BRITISH ','BRITISH BARK ' 4,'BRITISH BARQUE ','BRITISH RMS ','CHILIAN ' 5,'CHILIAN BARK ','CLIPPER ','CUTTER ' 6,'DUTCH BARK ','DUTCH FRIGATE ','FINNISH ' 7,'FRENCH ','FRENCH SLOOP ','FRIGATE ' 8,'GERMAN ','GERMAN BRIG ','NOT LISTED ' 9,'PACKET ','PILOT ','PILOT BOAT ' X,'PORTUG.CORVETTE','PORTUGUESE BRIG','PRUSSIAN ' 1,'R.M.S.BRITISH ','R.M.S.S.BRITISH','REVENUE ' 2,'RUSSIAN CORVET ','RUSSIAN STEAMER','SARDINI. FRIGAT' 3,'SCHOONER ','SCHOONER,HMS ','SCOONER ' 4,'SCREW SLOOP ','SHIP ','SLOOP ' 5,'SLOOP OF WAR ','SPANISH ','STEAM FRIGATE ' 6,'STEAMER ','STEAMSHIP ','SURVEY SHIP ' 7,'SWEDISH BRIG ','TRANSPORT ','U.S. SHIP ' 8,'U.S. SQUADRON ','U.S. STORE SHIP','U.S.FRIGATE ' 9,'WHALER '/ do 200 j=1,55 call fixcts(ctship(j),cts2) print *,'tstcts. cts2=',cts2,' <- ctship(',j,')=',ctship(j) 200 continue return end C-----------------------------------------------------------------------3456789 subroutine fixi2(q,c,imiss,jmiss,idiv) c-----fix i2 integer q into character c, first replacing imiss by jmiss, c and otherwise dividing by idiv if not 1 implicit integer(a-e,g-z) character*2 c if(q.eq.imiss) then qj = jmiss else if(idiv.eq.1) then qj = q else qj = q/idiv endif endif write(c,'(i2)') qj return 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(8,73) (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 array) 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*8) (upper case) 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) 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(8,NUMBER),CSUP(255) INTEGER LTRUE(NUMBER),LSUP,JEOF CHARACTER PNAME*16,PLEVEL*6,INITLS*2,FILNAM*8 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) c DATA PTR c +/ 8, 7, 3, 2, -1, 4, 5, 6, 9,10,11,12,-13,-14,-15,-16,-17 c +,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37 c +,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57 c +,58,59,60,61,62,63,64,65,66,67,68,69,70,-71,-72,-73/ c-----sdw modification of above, 26 Jul 2000: active TC (16),PB (17),A6 (72) 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 *,'ERROR: 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 *,'ERROR: FMISS1 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)))STOP 'B10XY' 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 *,'ERROR: NERR > 51' STOP ENDIF ERRNUM(NERR)=I IF(LTRUE(I).LT.0.OR.LTRUE(I).GT.8)THEN PRINT *,'ERROR: LTRUE('//FIELD(I)(1:3)//') < 0 OR > 8' STOP ENDIF ERRLEN(NERR)=LTRUE(I) DO 681 M=1,ERRLEN(NERR) 681 ERR(M,NERR)=ICHAR(CTRUE(M,I)) 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)STOP 'B10' 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 *,'ERROR: LSUP < 0 OR > 255' STOP ENDIF SUPLEN=LSUP DO 790 J=1,SUPLEN 790 SUP(J)=ICHAR(CSUP(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}.01D '//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))STOP 'NREC(3)' 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,'(A4 ' 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., 99., 1., -1., 8, 104,',A2 ' 2,'PT ', 0., 15., 1., -1., 5, 112,',A2 ' 3,'QI ', 0., 2., 1., -1., 2, 117,',A1 ' 4,'DS ', 0., 13., 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., 6., 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 SUBROUTINE PBYTE(P,U,Q,B) IMPLICIT INTEGER(A-Z) IF(U.LT.0 .OR. U.GT.2**B-1)THEN PRINT *,'ERROR: ',U,' CAN NOT BE PACKED INTO ',B,' BITS' STOP ENDIF CALL SBYTE(P,U,Q,B) END C-----------------------------------------------------------------------3456789 SUBROUTINE PBYTES(P,U,Q,B,S,N) IMPLICIT INTEGER(A-Z) DIMENSION U(*) DO 1 I=1,N IF(U(I).LT.0 .OR. U(I).GT.2**B-1)THEN PRINT *,'ERROR: ',U(I),' CAN NOT BE PACKED INTO ',B,' BITS' STOP ENDIF 1 CONTINUE CALL SBYTES(P,U,Q,B,S,N) END C-----------------------------------------------------------------------3456789 FUNCTION PUTATT(RPT,AL,AD) C PACK ATTACHMENTS RETURNING LENGTH OF RPT IN BITS C IMPLICIT INTEGER(A-E,G-Z) DIMENSION 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 PBYTE(RPT,AID,PUTATT+8,4) CALL PBYTE(RPT,AL(AID),PUTATT,8) CALL PBYTES(RPT,AD(1,AID),PUTATT+12,4,0,AL(AID)) PUTATT=PUTATT+12+4*AL(AID) AC=AC+1 190 CONTINUE CALL PBYTE(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 *,'ERROR: 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(BPR=452+(3+255)*4*15,DIM RPT=(BPR-1)/BPW+1) DIMENSION RPT(DIM RPT) C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) COMMON /LMR6/FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER) COMMON /LMR6/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 *,'ERROR: 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,DIM RPT 110 RPT(I)=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) DIMENSION RPT(*) DIMENSION CODED(*),FTRUE(*),FUNITS(*),FBASE(*),BITS(*),OFFSET(*) C CALL SBYTE(RPT,RPTID,12,4) 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 *,'ERROR: FTRUE(',I,')=',FTRUE(I) + ,' TOO SMALL OR LARGE' STOP ENDIF CODED(INDXCK)=CODED(INDXCK)+CODED(I) C IF RPT.NE.NULL SBYTE AFTER ENDIF!!! CALL SBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) ENDIF C CALL SBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) 190 CONTINUE I=INDXCK CODED(I)=MOD(CODED(I),2**BITS(I)-1) CALL SBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) FTRUE(I)=CODED(I) 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 *,'ERROR: 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) COMMON /LMR6/FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER) COMMON /LMR6/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 *,'ERROR: 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) COMMON /LMR6/FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER) COMMON /LMR6/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 *,'ERROR: 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 *,'ERROR: MODE=',MODE STOP ENDIF 110 FORMAT(I3,1X,A3,1X,15A1,1X,15Z2.2) END C-----------------------------------------------------------------------3456789 SUBROUTINE BINCHR(BIN,CHR,LEN) C IF EQUIVALENCE OF INTEGER TO CHARACTER NOT PERMITTED C COPY BIN TO CHR*LEN C CHARACTER CHR(LEN) INTEGER BIN(*),XBIN(840) C IF (LEN.GT.840) THEN PRINT *,'ERROR: LEN > 840' STOP ENDIF CALL GBYTES(BIN,XBIN,0,8,0,LEN) DO 190 I=1,LEN CHR(I)=CHAR(XBIN(I)) 190 CONTINUE END C-----------------------------------------------------------------------3456789 SUBROUTINE CHRBIN(CHR,BIN,LEN) C IF EQUIVALENCE OF CHARACTER TO INTEGER NOT PERMITTED C COPY CHR*LEN TO BIN C CHARACTER CHR(LEN) INTEGER BIN(*),XBIN(840) C IF (LEN.GT.840) THEN PRINT *,'ERROR: LEN > 840' STOP ENDIF DO 190 I=1,LEN XBIN(I)=ICHAR(CHR(I)) 190 CONTINUE CALL SBYTES(BIN,XBIN,0,8,0,LEN) 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 EOR a=/data/coads/software rm a.out output/$1_lmr output/$1_rej output/$1_sum f77 p.f lmrlib.o $a/date.o $a/ebcasc.o $a/gsbytes.o $a/rptin.o #following introduces blank line to separate runs echo date echo $1 | a.out