cat > p.f90 <<\EOR ! Filename:level: icoads-immt5Ximma1.f90:01C 17 Oct 2013 ! Purpose: ICOADS translation program from IMMT5 (stdin) to IMMA1 (stdout) ! Author: S.Lubker !=============================================================================! ! International Comprehensive Ocean-Atmosphere Data Set (ICOADS) 27 Jun 2013 ! ! Filename:level: rdimma1:01D Fortran 90/77 program+shell ! ! Purpose: Read and print/write IMMA Author: S.Lubker ! !=============================================================================! ! Software Revision Information (previous version: 9 May 2013, level 01C): ! No longer recognizes deprecated attachments. Routine {getuid}, to get a ! Unique report ID, was added. Correction made in the comments below to a ! sentence which previously read "As discussed in Data Representation note ! (2) below, base36 data (ITYPE=3)..." (now reading correctly "ITYPE=2"). !-----------------------------------------------------------------------3456789 ! Software documentation for the (modifiable) example program {rdimma} and for ! the (invariant) user-interface routines {prnskp,prnhdr,getrpt,east,getuid, ! minmax,savsum,putrpt,prnrpt,prnsum,init}. ! ! As provided {rdimma}: (a) Prints PROGID (the program name and level). Also, ! {prnhdr} prints a 5-line header for the unabbreviated record type (i.e., core ! plus all currently defined attms: 1,5-8 and 98-99). (b) Reads a report (from ! standard input) via a formatted read and calls {getrpt} to extract the fields ! and convert them from characters to numeric values. This makes the fields ! available in three parallel arrays: ! CTRUE: characters (each length 1024) blank for missing data ! ITRUE: integers NINT(FMISS) for missing data ! FTRUE: true (floating point) values FMISS for missing data ! Additional parallel arrays available within common block IMMA1 provide ! metadata defining the properties of currently defined fields. These include ! each field's length (ILEN), abbreviation (ABBR), allowable range(s), units ! (FUNITS; missing for character data) and type (ITYPE; 1=numeric, 2=base36, ! 3=character) (see {bdimma} for details). (c) For the core and attms, a ! PARAMETER statement relates each field abbreviation to an FTRUE (CTRUE, ! ITRUE, etc.) array location; this facilitates usage such as FTRUE(DY), ! to obtain the floating point value for day. Each element of CTRUE is a ! 1024-character string, but the field length can be used to control printing, ! e.g., PRINT *,CTRUE(DY)(:ILEN(DY)). (d) Prints the original report, RPT, ! under the aforementioned field headings (constructed using ABBR). (e) The ! program iterates (to step b) reading and printing reports until end-of-file ! (EOF) is encountered. Caution: IMPLICIT INTEGER(A-E,G-Z) is used, users may ! need to explicitly type additional variables when modifying this program; ! and deprecated attms 2-4 are no longer recognized (but {rdimma} will continue ! to read any version of IMMA not containing deprecated attachments). ! ! The following optional features are initially deactivated in the Fortran ! code; they may be activated by changing the appropriate Fortran comment ! lines to executable statements, i.e., remove the "!" from column 1: ! ! (a) Activate one or more calls to {prnskp} to suppress printing of the core ! and/or selected attms; {prnskp} is designed to work with the default calls ! to {prnhdr} and {prnrpt} for a reduced-width printout. Or (b): Deactivate ! the default calls to {prnhdr} and {prnrpt}, and activate one (or more) of ! the alternative calls to {prnhdr} and {prnrpt}. This provides flexibility ! so that the core or an attm can be printed individually (if only one pair ! of {prnhdr,prnrpt} is activated; alternatively, this can be accomplished by ! activating all but one call to {prnskp}). Activating multiple alternative ! calls to {prnhdr} and {prnrpt} can be used to arrange the core and attms ! vertically (i.e., core and attms on multiple lines, for a single report). ! Moreover, any contiguous portion of the headers and reports can be printed ! by adjusting the fields that appear in the subroutine calls, e.g., activating ! CALL PRNHDR(STDOUT,ILEN,ABBR,YR,HR) and CALL PRNRPT(STDOUT,ILEN,CTRUE,YR,HR) ! prints just year, month, day, and hour. Features (a) and (b) provide ! flexibility to print selected portions of the data; however, note that those ! two features were not designed to be used together (e.g., activating {prnskp} ! to skip the core, and {prnhdr,prnrpt} to print the core, will produce blank ! lines). By default printing is to standard output (STDOUT=6), but optionally ! STDOUT can be changed to another unit number in the calls to {prnhdr,prnrpt}. ! ! Additional notes on using {prnrpt}: To minimize data volume, IMMA data may ! have a "sparse" record structure, such that attms without any extant data are ! omitted, and the attm structure can vary from report to report. Sparse data ! printed via the default calls to {prnhdr, prnrpt}, are expanded out into the ! complete IMMA structure. Or, using {prnskp}, sparse reports are expanded out ! into a reduced print structure. Alternatively, IMMA data may have a "fixed" ! record structure, such that a fixed number of attms is always present. In ! either case, it can be determined whether an attm was originally present in ! the input data from ATTI and ATTL: these are printed by {prnrpt} if the attm ! was extant, or blank if it was missing. ATTC will always reflect the number ! of attms originally present (e.g., regardless how many are omitted from ! printing through the use of {prnskp}). ! ! (c) Activating {east} will transform longitudes stored according to the ! NCDC-variant (obsolescent) convention -179.99 (W) to 180.00 (E), into the ! ICOADS convention 0-359.99 E. This action is applied only to the numeric data ! (ITRUE, FTRUE), and does not take effect on the printed data, unless feature ! (d) is also activated. Activate {getuid} to get the next Unique report ID ! (see feature (h) for details). ! ! (d) Activating {putrpt} will convert all the true values (e.g., longitudes ! transformed via {east}) back into characters for printing and/or writing. ! Specifically, if changes have been made to FTRUE, {putrpt} puts them also ! into ITRUE, CTRUE, and RPT. Then the changes can be printed, by leaving ! {prnrpt} statement(s) in operation, or written, by activating (instead of ! {prnrpt}) the adjacent WRITE statement. If both {prnrpt} and the WRITE ! statement are activated, each report will be output twice, possibly with ! differences in format (which provides a means to see how the two different ! output methods work). For example, note that {prnskp} has no effect on the ! WRITE statement, in contrast to its effect on {prnrpt}. Reports with a ! sparse record structure will be output when {putrpt} and the WRITE statement ! are used, and ATTC will reflect the output attm count. Reports with a fixed ! record structure can be correctly output when {prnrpt} is used, with these ! caveats: (1) ATTI and ATTL must be set, when the attm data are entirely ! missing, or they will be printed blank; (2) ATTC will be set incorrectly if ! {prnskp} is used, but any of the attm data are extant. ! ! (e) Activate calls: to {minmax}, to set any "extreme" true values to error ! value FERR (by default equal to the missing value FMISS); to {savsum}, to ! save summary information for each field; and to {prnsum}, to print the ! following summary information on unit 10 (using field abbreviations, ABBR): ! -- A summary of the numbers (and percentages) of each field that are ! extant, missing, or erroneous. Erroneous data are also counted ! as a subset of the missing category. Any field (or attm) entirely ! missing in the input data is omitted from the summary. ! -- A summary of any erroneous fields encountered in the input data, ! with each unique pattern and its frequency listed. ! ! (f) The test for NREC greater than or equal to 50 can be activated to stop ! before reading/printing the entire file. Regarding feature (e), note that ! the {prnsum} summary will only be output if statement 900 is reached. ! ! (g) With more extensive modifications, {rdimma} can be adapted to write ! IMMA data, using non-IMMA data as input. In this case it is important to ! note that a maintenance issue will arise as updates are made to {rdimma}. ! Therefore, we recommend that code added for this purpose be isolated (e.g., ! into separate routines) as much as possible. To adapt {rdimma}, the READ ! statement should be replaced by statements to read non-IMMA data, and ! {getrpt} deactivated. Prior to reading the non-IMMA data, {init} should ! be called to properly initialize the data structures: ! CALL INIT(CTRUE,ITRUE,FTRUE,FMISS,ILEN,NUM) ! Then the input data need to be transformed into the appropriate IMMA units, ! loaded into FTRUE (for numeric fields) or into CTRUE (for character fields), ! {putrpt} called, and the WRITE statement activated. For writing character ! fields into IMMA, {minmax} (see feature (e)), must also be called to signal ! to the program when character data are present in CTRUE. This also ensures ! that any data (numeric or character) not compliant with the format are not ! output (we also recommend that the other parts of feature (e), {savsum} and ! {prnsum}, be called). As discussed in Data Representation note (2) below, ! base36 data (ITYPE=2) need to be stored in FTRUE as the corresponding numeric ! value (e.g., 9=9.0, A=10.0). Data of ITYPE=3 (character) must be stored ! left-justified in CTRUE (see {bdimma} for field types and constraints). ! ! (h) Writing out new Unique IDs (UIDs): calls to {getuid} will return the UID ! number found in file LAST_UID on unit 98, incremented by one. Also, {getuid} ! then increments by one the UID number stored on unit 98. We emphasize that ! the ICOADS project manages the master list of UID assignments, thus new UIDs ! should not be assigned and written out without appropriate advance ! consultation. ! ! Data representation notes: ! (1) Printed data: In the header, the field abbreviations (from ABBR) are ! listed vertically. The abbreviations are 1-5 characters in length, so ! the header always occupies five lines (even if a selected subset of ! fields includes no 5-character abbreviations). All decimal points are ! omitted for printing (i.e., each FTRUE value is divided by its FUNITS; ! e.g., LON=33.80/0.01 = 3380 printed). Missing data (FTRUE=FMISS) are ! printed as blank, as are erroneous data, unless the default for FERR is ! changed (see note 3). ! (2) Stored data (FTRUE, ITRUE, and CTRUE): Some 1-character fields and ATTL ! of attm8 (i.e., those with ITYPE=2) have alphabetic base36 values defined ! (and printed) as part of the legal range. In ITRUE and FTRUE, these are ! stored as the corresponding numeric values: A=10, B=11, ..., Z=35. For ! character (ITYPE=3) fields, note that ITRUE and FTRUE contain the ICHAR ! of the first character of the field (e.g., if ID=WHRN, ITRUE(ID)=87). ! This simplifies the implementation of the program, but users should be ! aware of the data type in processing character fields. ! (3) Erroneous data: Erroneous data can be detected in two ways: (i) Data ! that could not be read properly (e.g., a numeric field containing a ! special character). (ii) "Extreme" data, which read properly, but failed ! to adhere to the ranges defined in {bdimma} (e.g., a numeric temperature ! outside of -99.9 to 99.9). Data of the first type are always set to ! FERR, but data of the second type are only set to FERR if {minmax} is ! called. FERR equals FMISS by default. If FERR is set to a non-default ! value such as -888888., the printed output will contain all asterisks in ! fields that contained erroneous data. The non-default setting is also ! used for quality control applications that need to distinguish between ! actual missing data and data that were extant but erroneous. ! ! Performance: The long character strings made necessary by the supplemental ! attm slow the program down. Anyone not interested in those data could ! replace: ! CHARACTER*1024 RPT,CTRUE ! with ! CHARACTER*1024 RPT,CTRUE*16 ! and ! CALL GETRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR & ! &,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM) ! with ! CALL GETRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR & ! &,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM-1) ! ! Machine/language dependencies: None known. Non-ANSI features: common block ! containing both character and non-character variables, and specification ! statements after data statements. ! The program conforms to Fortran 90 source code conventions for comments and ! continuation lines, but still compiles without change in many Fortran 77 ! environments. Added/included source code can be either free form or fixed. ! For more information: See ! ! (electronic document). !-----------------------------------------------------------------------3456789 PROGRAM RDIMMA IMPLICIT INTEGER(A-E,G-Z) INTEGER FNC,FM ! CHARACTER*(*) PROGID PARAMETER(PROGID='icoads-immt5Ximma1.01C') ! ! CORE PARAMETER(YR=1,MO=2,DY=3,HR=4,LAT=5,LON=6,IM=7,ATTC=8,TI=9,LI=10 & &,DS=11,VS=12,NID=13,II=14,ID=15,C1=16,DI=17,D=18,WI=19,W=20,VI=21 & &,VV=22,WW=23,W1=24,SLP=25,A=26,PPP=27,IT=28,AT=29,WBTI=30,WBT=31 & &,DPTI=32,DPT=33,SI=34,SST=35,N=36,NH=37,CL=38,HI=39,H=40,CM=41 & &,CH=42,WD=43,WP=44,WH=45,SD=46,SP=47,SH=48) ! ! ICOADS ATTACHMENT PARAMETER(ATTI1=49,ATTL1=50,BSI=51,B10=52,B1=53,DCK=54,SID=55 & &,PT=56,DUPS=57,DUPC=58,TC=59,PB=60,WX=61,SX=62,C2=63,SQZ=64,SQA=65 & &,AQZ=66,AQA=67,UQZ=68,UQA=69,VQZ=70,VQA=71,PQZ=72,PQA=73,DQZ=74 & &,DQA=75,ND=76,SF=77,AF=78,UF=79,VF=80,PF=81,RF=82,ZNC=83,WNC=84 & &,BNC=85,XNC=86,YNC=87,PNC=88,ANC=89,GNC=90,DNC=91,SNC=92,CNC=93 & &,ENC=94,FNC=95,TNC=96,QCE=97,LZ=98,QCZ=99) ! ! IMMT-5/FM13 ATTACHMENT PARAMETER(ATTI5=100,ATTL5=101,OS=102,OP=103,FM=104,IMMV=105,IX=106 & &,W2=107,WMI=108,SD2=109,SP2=110,SH2=111,IS=112,ES=113,RS=114 & &,IC1=115,IC2=116,IC3=117,IC4=118,IC5=119,IR=120,RRR=121,TR=122 & &,NU=123,QCI=124,QI1=125,QI2=126,QI3=127,QI4=128,QI5=129,QI6=130 & &,QI7=131,QI8=132,QI9=133,QI10=134,QI11=135,QI12=136,QI13=137 & &,QI14=138,QI15=139,QI16=140,QI17=141,QI18=142,QI19=143,QI20=144 & &,QI21=145,HDG=146,COG=147,SOG=148,SLL=149,SLHH=150,RWD=151,RWS=152 & &,QI22=153,QI23=154,QI24=155,QI25=156,QI26=157,QI27=158,QI28=159 & &,QI29=160,RH=161,RHI=162,AWSI=163,IMONO=164) ! ! MODEL QUALITY CONTROL ATTACHMENT PARAMETER(ATTI6=165,ATTL6=166,CCCC=167,BUID=168,FBSRC=169,BMP=170 & &,BSWU=171,SWU=172,BSWV=173,SWV=174,BSAT=175,BSRH=176,SRH=177 & &,BSST=178,MST=179,MSH=180,BY=181,BM=182,BD=183,BH=184,BFL=185) ! ! SHIP METADATA ATTACHMENT PARAMETER(ATTI7=186,ATTL7=187,MDS=188,C1M=189,OPM=190,KOV=191 & &,COR=192,TOB=193,TOT=194,EOT=195,LOT=196,TOH=197,EOH=198,SIM=199 & &,LOV=200,DOS=201,HOP=202,HOT=203,HOB=204,HOA=205,SMF=206,SME=207 & &,SMV=208) ! ! NEAR-SURFACE OCEANOGRAPHIC DATA ATTACHMENT PARAMETER(ATTI8=209,ATTL8=210,OTV=211,OTZ=212,OSV=213,OSZ=214 & &,OOV=215,OOZ=216,OPV=217,OPZ=218,OSIV=219,OSIZ=220,ONV=221,ONZ=222 & &,OPHV=223,OPHZ=224,OCV=225,OCZ=226,OAV=227,OAZ=228,OPCV=229 & &,OPCZ=230,ODV=231,ODZ=232,PUID=233) ! ! UNIQUE ID ATTACHMENT PARAMETER(ATTI98=234,ATTL98=235,UID=236,RN1=237,RN2=238,RN3=239 & &,RSA=240,IRF=241) ! ! SUPPLEMENTAL DATA ATTACHMENT PARAMETER(ATTI99=242,ATTL99=243,ATTE=244,SUPD=245) ! PARAMETER(NUM=245) CHARACTER*8 ABBR,RPTID COMMON /IMMA1/ILEN(NUM),ABBR(NUM),FMIN1(NUM),FMAX1(NUM) & &,FMIN2(NUM),FMAX2(NUM),FUNITS(NUM),ITYPE(NUM),RPTID ! CHARACTER*1024 RPT,CTRUE*172 DIMENSION CTRUE(NUM),ITRUE(NUM),FTRUE(NUM) DATA CTRUE/NUM*' '/,ITRUE/NUM*-999999/,FTRUE/NUM*-999999./ & &,FMISS/-999999./,FERR/-999999./,UNIT/10/,STDOUT/6/ ! ! PRINT PROGRAM HEADER !! WRITE(STDOUT,*)PROGID ! DO NOT PRINT CORE HEADER OR CORE ! CALL PRNSKP(YR,SH) ! DO NOT PRINT ATTACHMENT HEADER OR ATTACHMENT ! CALL PRNSKP(ATTI1,ATTI5-1) ! CALL PRNSKP(ATTI5,ATTI6-1) ! CALL PRNSKP(ATTI6,ATTI7-1) ! CALL PRNSKP(ATTI7,ATTI8-1) ! CALL PRNSKP(ATTI8,ATTI98-1) ! CALL PRNSKP(ATTI98,ATTI99-1) ! CALL PRNSKP(ATTI99,SUPD) ! ! PRINT REPORT HEADER !! CALL PRNHDR(STDOUT,ILEN,ABBR,YR,SUPD) ! PRINT CORE HEADER ! CALL PRNHDR(STDOUT,ILEN,ABBR,YR,SH) ! PRINT ATTACHMENT HEADER ! CALL PRNHDR(STDOUT,ILEN,ABBR,ATTI1,ATTI5-1) ! CALL PRNHDR(STDOUT,ILEN,ABBR,ATTI5,ATTI6-1) ! CALL PRNHDR(STDOUT,ILEN,ABBR,ATTI6,ATTI7-1) ! CALL PRNHDR(STDOUT,ILEN,ABBR,ATTI7,ATTI8-1) ! CALL PRNHDR(STDOUT,ILEN,ABBR,ATTI8,ATTI98-1) ! CALL PRNHDR(STDOUT,ILEN,ABBR,ATTI98,ATTI99-1) ! CALL PRNHDR(STDOUT,ILEN,ABBR,ATTI99,SUPD) ! INITIALIZE NUMBER OF REPORTS READ NREC=0 ! ! READ REPORT 100 CONTINUE READ(*,'(A)',END=900)ctrue(supd) ! INCREMENT NUMBER OF REPORTS READ NREC=NREC+1 ctrue(it)(:16)=ctrue(supd)(1:1) ctrue(yr)(:16)=ctrue(supd)(2:5) ctrue(mo)(:16)=ctrue(supd)(6:7) ctrue(dy)(:16)=ctrue(supd)(8:9) ctrue(hr)(:16)=ctrue(supd)(10:11) ctrue(li)(:16)=ctrue(supd)(12:12) ctrue(lat)(:16)=' '//ctrue(supd)(13:15)//' '//ctrue(supd)(12:12) ctrue(lon)(:16)=' '//ctrue(supd)(16:19)//' '//ctrue(supd)(12:12) ctrue(hi)(:16)=ctrue(supd)(20:20) ctrue(vi)(:16)=ctrue(supd)(20:20) ctrue(h)(:16)=ctrue(supd)(21:21) ctrue(vv)(:16)=ctrue(supd)(22:23) ctrue(n)(:16)=ctrue(supd)(24:24) ctrue(d)(:16)=' '//ctrue(supd)(25:26) ctrue(wi)(:16)=ctrue(supd)(27:27) ctrue(w)(:16)=ctrue(supd)(28:29) ctrue(at)(:16)=ctrue(supd)(30:30)//ctrue(supd)(31:33) ctrue(dpti)(:16)=ctrue(supd)(34:34) ctrue(dpt)(:16)=ctrue(supd)(34:34)//ctrue(supd)(35:37) ctrue(slp)(:16)=' '//ctrue(supd)(38:41) ctrue(ww)(:16)=ctrue(supd)(42:43) ctrue(w1)(:16)=ctrue(supd)(44:44) ctrue(w2)(:16)=ctrue(supd)(45:45) ctrue(nh)(:16)=ctrue(supd)(46:46) ctrue(cl)(:16)=ctrue(supd)(47:47) ctrue(cm)(:16)=ctrue(supd)(48:48) ctrue(ch)(:16)=ctrue(supd)(49:49) ctrue(sst)(:16)=ctrue(supd)(50:50)//ctrue(supd)(51:53) ctrue(si)(:16)=' '//ctrue(supd)(54:54) ctrue(wmi)(:16)=ctrue(supd)(55:55) ctrue(wp)(:16)=ctrue(supd)(56:57) ctrue(wh)(:16)=ctrue(supd)(58:59) ctrue(sd)(:16)=ctrue(supd)(60:61) ctrue(sp)(:16)=ctrue(supd)(62:63) ctrue(sh)(:16)=ctrue(supd)(64:65) ctrue(is)(:16)=ctrue(supd)(66:66) ctrue(es)(:16)=ctrue(supd)(67:68) ctrue(rs)(:16)=ctrue(supd)(69:69) ctrue(os)(:16)=ctrue(supd)(70:70) ctrue(op)(:16)=ctrue(supd)(71:71) ctrue(id)(:16)=adjustl(ctrue(supd)(72:78)) ctrue(c1)(:16)=ctrue(supd)(79:80) ctrue(nu)(:16)=ctrue(supd)(81:81) ctrue(qci)(:16)=ctrue(supd)(82:82) ctrue(ix)(:16)=ctrue(supd)(83:83) ctrue(ir)(:16)=ctrue(supd)(84:84) ctrue(rrr)(:16)=ctrue(supd)(85:87) ctrue(tr)(:16)=ctrue(supd)(88:88) ctrue(wbti)(:16)=ctrue(supd)(89:89) ctrue(wbt)(:16)=ctrue(supd)(89:89)//ctrue(supd)(90:92) ctrue(a)(:16)=ctrue(supd)(93:93) ctrue(ppp)(:16)=ctrue(supd)(94:96) ctrue(ds)(:16)=ctrue(supd)(97:97) ctrue(vs)(:16)=ctrue(supd)(98:98) ctrue(sd2)(:16)=ctrue(supd)(99:100) ctrue(sp2)(:16)=ctrue(supd)(101:102) ctrue(sh2)(:16)=ctrue(supd)(103:104) ctrue(ic1)(:16)=ctrue(supd)(105:105) ctrue(ic2)(:16)=ctrue(supd)(106:106) ctrue(ic3)(:16)=ctrue(supd)(107:107) ctrue(ic4)(:16)=ctrue(supd)(108:108) ctrue(ic5)(:16)=ctrue(supd)(109:109) ctrue(fm)(:16)=ctrue(supd)(110:110) ctrue(immv)(:16)=ctrue(supd)(111:111) ctrue(qi1)(:16)=ctrue(supd)(112:112) ctrue(qi2)(:16)=ctrue(supd)(113:113) ctrue(qi3)(:16)=ctrue(supd)(114:114) ctrue(qi4)(:16)=ctrue(supd)(115:115) ctrue(qi5)(:16)=ctrue(supd)(116:116) ctrue(qi6)(:16)=ctrue(supd)(117:117) ctrue(qi7)(:16)=ctrue(supd)(118:118) ctrue(qi8)(:16)=ctrue(supd)(119:119) ctrue(qi9)(:16)=ctrue(supd)(120:120) ctrue(qi10)(:16)=ctrue(supd)(121:121) ctrue(qi11)(:16)=ctrue(supd)(122:122) ctrue(qi12)(:16)=ctrue(supd)(123:123) ctrue(qi13)(:16)=ctrue(supd)(124:124) ctrue(qi14)(:16)=ctrue(supd)(125:125) ctrue(qi15)(:16)=ctrue(supd)(126:126) ctrue(qi16)(:16)=ctrue(supd)(127:127) ctrue(qi17)(:16)=ctrue(supd)(128:128) ctrue(qi18)(:16)=ctrue(supd)(129:129) ctrue(qi19)(:16)=ctrue(supd)(130:130) ctrue(qi20)(:16)=ctrue(supd)(131:131) ctrue(qi21)(:16)=ctrue(supd)(132:132) ctrue(hdg)(:16)=ctrue(supd)(133:135) ctrue(cog)(:16)=ctrue(supd)(136:138) ctrue(sog)(:16)=ctrue(supd)(139:140) ctrue(sll)(:16)=ctrue(supd)(141:142) ctrue(slhh)(:16)=ctrue(supd)(143:145) ctrue(rwd)(:16)=ctrue(supd)(146:148) ctrue(rws)(:16)=ctrue(supd)(149:151) ctrue(qi22)(:16)=ctrue(supd)(152:152) ctrue(qi23)(:16)=ctrue(supd)(153:153) ctrue(qi24)(:16)=ctrue(supd)(154:154) ctrue(qi25)(:16)=ctrue(supd)(155:155) ctrue(qi26)(:16)=ctrue(supd)(156:156) ctrue(qi27)(:16)=ctrue(supd)(157:157) ctrue(qi28)(:16)=ctrue(supd)(158:158) ctrue(qi29)(:16)=ctrue(supd)(159:159) ctrue(rh)(:16)=ctrue(supd)(160:163) ctrue(rhi)(:16)=ctrue(supd)(164:164) ctrue(awsi)(:16)=ctrue(supd)(165:165) ctrue(imono)(:16)=ctrue(supd)(166:172) ctrue(im)(:16)=' 1' ctrue(atti1)(:16)=' 1' ctrue(attl1)(:16)='65' ctrue(atti5)(:16)=' 5' ctrue(attl5)(:16)='94' ctrue(atti99)(:16)='99' ctrue(attl99)(:16)=' 0' write(rpt,110)(ctrue(i),i=1,atti6-1),(ctrue(i),i=atti99,supd) 110 format(a4,2a2,a4,a5,a6,a2,5a1,2a2,a9,a2,a1,a3,a1,a3,a1,2a2,a1,a5 & ,a1,a3,a1,a4,a1,a4,a1,a4,a2,a4,7a1,8a2,a1,a3,a2,2a3,2a2,5a1,a2 & ,33a1,a2,a1,3a2,7a1,3a2,a1,a2,7a1,a3,24a1,2a3,2a2,3a3,8a1,a4,2a1 & ,a7 & ,2a2,a1,a) ! ! CONVERT CHARACTERS TO FLOATING POINT VALUES CALL GETRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR & &,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM) do i=1,atti6-1 if (index(ctrue(i)(:16),'-').ne.0) ftrue(i)=fmiss enddo ftrue(dck)=720. ftrue(sid)=161. ftrue(pt)=4. ftrue(ii)=9. ! iT Format/temperature indicator if (ftrue(it).ne.fmiss) then if (itrue(it).ge.3 .and. itrue(it).le.5) then ftrue(it)=ftrue(it)-3. else ftrue(it)=fmiss endif endif ! Qc Quadrant of the globe if (ftrue(li).ne.fmiss) then if (itrue(li).ge.1 .and. itrue(li).le.7 & .and. mod(itrue(li),2).ne.0) then else ftrue(li)=fmiss endif endif ! LaLaLa Latitude if (ftrue(lat).ne.fmiss) then if (itrue(lat).ge.0 .and. itrue(lat).le.9000 & .and. ftrue(li).ne.fmiss) then if (itrue(li).eq.3 .or. itrue(li).eq.5) ftrue(lat)=-ftrue(lat) else ftrue(lat)=fmiss endif endif ! LoLoLoLo Longitude if (ftrue(lon).ne.fmiss) then if (itrue(lon).ge.0 .and. itrue(lon).le.18000 & .and. ftrue(li).ne.fmiss) then if (itrue(li).eq.5 .or. itrue(li).eq.7) ftrue(lon)=-ftrue(lon) else ftrue(lon)=fmiss endif endif ctrue(li)(:16)=' ' ftrue(li)=fmiss ! Cloud height (h) and visibility (VV) measuring indicator if (ftrue(hi).ne.fmiss) then if (itrue(hi).eq.0) then ftrue(hi)=0. ftrue(vi)=0. else if (itrue(hi).eq.1) then ftrue(hi)=1. ftrue(vi)=0. else if (itrue(hi).eq.2) then ftrue(hi)=1. ftrue(vi)=1. else if (itrue(hi).eq.3) then ftrue(hi)=0. ftrue(vi)=1. else ftrue(hi)=fmiss ftrue(vi)=fmiss endif endif ! h Height of clouds if (ctrue(h)(:1).eq.'/') ftrue(h)=10. ! DD True wind direction if (ftrue(d).ne.fmiss) then if (itrue(d).ge.1 .and. itrue(d).le.36) then ftrue(d)=ftrue(d)*10. else if (itrue(d).eq.0) then ftrue(d)=361. else if (itrue(d).eq.99) then ftrue(d)=362. else ftrue(d)=fmiss endif endif ! ff Wind speed if (ftrue(w).ne.fmiss) then if (itrue(wi).eq.0 .or. itrue(wi).eq.1) then else if (itrue(wi).eq.3 .or. itrue(wi).eq.4) then ftrue(w)=fxktms(ftrue(w)) else ftrue(w)=fmiss endif endif ! TTT Air temperature if (ftrue(at).ne.fmiss) then if ((ctrue(at)(:1).eq.'0' .or. ctrue(at)(:1).eq.'1') & .and. ctrue(at)(2:16).ne.' ') then if (ctrue(at)(:1).eq.'1') ftrue(at)=mod(-ftrue(at),100.) else ftrue(at)=fmiss endif endif ! Sign of dew-point temperature if (ftrue(dpti).ne.fmiss) then if (itrue(dpti).eq.0 .or. itrue(dpti).eq.1) then ftrue(dpti)=0. else if (itrue(dpti).eq.2) then ftrue(dpti)=2. else if (itrue(dpti).eq.5 .or. itrue(dpti).eq.6) then ftrue(dpti)=1. else if (itrue(dpti).eq.7) then ftrue(dpti)=3. else ftrue(dpti)=fmiss endif endif ! TdTdTd Dew-point temperature if (ftrue(dpt).ne.fmiss) then if (ftrue(dpti).ne.fmiss .and. ctrue(dpt)(2:16).ne.' ') then if (index('1267',ctrue(dpt)(:1)).ne.0) ftrue(dpt)=-ftrue(dpt) ftrue(dpt)=mod(ftrue(dpt),100.) else ftrue(dpt)=fmiss endif endif ! PPPP Air pressure if (ftrue(slp).ne.fmiss) then if (ftrue(slp).lt.500.) ftrue(slp)=1000.+ftrue(slp) endif ! Genus of clouds if (ctrue(cl)(:1).eq.'/') ftrue(cl)=10. if (ctrue(cm)(:1).eq.'/') ftrue(cm)=10. if (ctrue(ch)(:1).eq.'/') ftrue(ch)=10. ! TwTwTw Sea surface temperature if (ftrue(sst).ne.fmiss) then if ((ctrue(sst)(:1).eq.'0' .or. ctrue(sst)(:1).eq.'1') & .and. ctrue(sst)(2:16).ne.' ') then if (ctrue(sst)(:1).eq.'1') ftrue(sst)=mod(-ftrue(sst),100.) else ftrue(sst)=fmiss endif endif ! Indicator for sea-surface temperature measurement if (ftrue(si).ne.fmiss) then if (itrue(si).ge.0 .and. itrue(si).le.7) then else ftrue(si)=fmiss endif endif ! Direction of predominant swell waves if (ftrue(sd).ne.fmiss) then if (itrue(sd).ge.0 .and. itrue(sd).le.36) then else if (itrue(sd).eq.99) then ftrue(sd)=38. else ftrue(sd)=fmiss endif endif ! Observation platform if (ftrue(op).ne.fmiss) then !! if (itrue(op).eq.4) ftrue(op)=fmiss endif ! Weather data indicator if (ftrue(ix).ne.fmiss) then if (index('147',ctrue(ix)(:1)).eq.0) ftrue(ix)=fmiss endif ! Sign of wet-bulb temperature if (ftrue(wbti).ne.fmiss) then if (itrue(wbti).eq.0 .or. itrue(wbti).eq.1) then ftrue(wbti)=0. else if (itrue(wbti).eq.2) then ftrue(wbti)=2. else if (itrue(wbti).eq.5 .or. itrue(wbti).eq.6) then ftrue(wbti)=1. else if (itrue(wbti).eq.7) then ftrue(wbti)=3. else ftrue(wbti)=fmiss endif endif ! TbTbTb Wet-bulb temperature if (ftrue(wbt).ne.fmiss) then if (ftrue(wbti).ne.fmiss .and. ctrue(wbt)(2:16).ne.' ') then if (index('1267',ctrue(wbt)(:1)).ne.0) ftrue(wbt)=-ftrue(wbt) ftrue(wbt)=mod(ftrue(wbt),100.) else ftrue(wbt)=fmiss endif endif ! Direction of secondary swell waves if (ftrue(sd2).ne.fmiss) then if (itrue(sd2).ge.0 .and. itrue(sd2).le.36) then else if (itrue(sd2).eq.99) then ftrue(sd2)=38. else ftrue(sd2)=fmiss endif endif ! Concentration or arrangement of sea ice ! ... ! Present ice situation and trend of conditions over the preceding three hours if (ctrue(ic1)(:1).eq.'/') ftrue(ic1)=10. if (ctrue(ic2)(:1).eq.'/') ftrue(ic2)=10. if (ctrue(ic3)(:1).eq.'/') ftrue(ic3)=10. if (ctrue(ic4)(:1).eq.'/') ftrue(ic4)=10. if (ctrue(ic5)(:1).eq.'/') ftrue(ic5)=10. ! Departure of reference level from actual sea level if (ftrue(slhh).ne.fmiss) then if ((ctrue(slhh)(:1).eq.'0' .or. ctrue(slhh)(:1).eq.'1') & .and. ctrue(slhh)(2:16).ne.' ') then if (ctrue(slhh)(:1).eq.'1') ftrue(slhh)=mod(-ftrue(slhh),100.) else ftrue(slhh)=fmiss endif endif ! RWD if (ftrue(rwd).ne.fmiss) then if (itrue(rwd).ge.1 .and. itrue(rwd).le.360) then else if (itrue(rwd).eq.0) then ftrue(rwd)=361. else if (itrue(rwd).eq.999) then ftrue(rwd)=362. else ftrue(rwd)=fmiss endif endif ! RWS if (ftrue(rws).ne.fmiss) then if (itrue(wi).eq.0 .or. itrue(wi).eq.1) then ftrue(rws)=ftrue(rws)*10. else if (itrue(wi).eq.3 .or. itrue(wi).eq.4) then ftrue(rws)=fxktms(ftrue(rws)*10.) else ftrue(rws)=fmiss endif endif ! Relative humidity indicator if (ftrue(rhi).ne.fmiss) then if (index('0134',ctrue(rhi)(:1)).eq.0) ftrue(rhi)=fmiss endif ! ! CONVERT LONGITUDE TO DEGREES EAST CALL EAST(ITRUE(LON),FTRUE(LON),FERR) ! GET UNIQUE REPORT ID ! CALL GETUID(CTRUE(UID)) ! SET EXTREME FLOATING POINT VALUES TO ERROR VALUE CALL MINMAX(CTRUE,ITRUE,FTRUE,FMISS,FERR & &,ILEN,FMIN1,FMAX1,FMIN2,FMAX2,FUNITS,ITYPE,NUM) if (ftrue(hr).ne.fmiss) ftrue(ti)=0. if (ftrue(lat).ne.fmiss .or. ftrue(lon).ne.fmiss) ftrue(li)=0. if (ftrue(d).ne.fmiss) ftrue(di)=0. if (ftrue(w).eq.fmiss .and. ftrue(rws).eq.fmiss) ftrue(wi)=fmiss if (ftrue(vv).eq.fmiss) ftrue(vi)=fmiss if (ftrue(at).eq.fmiss .and. ftrue(wbt).eq.fmiss .and. & ftrue(dpt).eq.fmiss .and. ftrue(sst).eq.fmiss) ftrue(it)=fmiss if (ftrue(wbt).eq.fmiss) ftrue(wbti)=fmiss if (ftrue(dpt).eq.fmiss) ftrue(dpti)=fmiss if (ftrue(sst).eq.fmiss) ftrue(si)=fmiss if (ftrue(h).eq.fmiss) ftrue(hi)=fmiss if (ftrue(wd).eq.fmiss .and. ftrue(wp).eq.fmiss .and. & ftrue(wh).eq.fmiss .and. ftrue(sd).eq.fmiss .and. & ftrue(sp).eq.fmiss .and. ftrue(sh).eq.fmiss .and. & ftrue(sd2).eq.fmiss .and. ftrue(sp2).eq.fmiss .and. & ftrue(sh2).eq.fmiss) ftrue(wmi)=fmiss if (ftrue(rh).eq.fmiss) ftrue(rhi)=fmiss ! SAVE SUMMARY INFORMATION CALL SAVSUM(CTRUE,FTRUE,FMISS,FERR & &,ILEN,ABBR,NUM) ! ! CONVERT FLOATING POINT VALUES TO CHARACTERS CALL PUTRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR & &,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM) ! WRITE REPORT WRITE(STDOUT,'(A)')TRIM(RPT) ! ! PRINT REPORT !! CALL PRNRPT(STDOUT,ILEN,CTRUE,YR,SUPD) ! PRINT CORE ! CALL PRNRPT(STDOUT,ILEN,CTRUE,YR,SH) ! PRINT ATTACHMENT ! CALL PRNRPT(STDOUT,ILEN,CTRUE,ATTI1,ATTI5-1) ! CALL PRNRPT(STDOUT,ILEN,CTRUE,ATTI5,ATTI6-1) ! CALL PRNRPT(STDOUT,ILEN,CTRUE,ATTI6,ATTI7-1) ! CALL PRNRPT(STDOUT,ILEN,CTRUE,ATTI7,ATTI8-1) ! CALL PRNRPT(STDOUT,ILEN,CTRUE,ATTI8,ATTI98-1) ! CALL PRNRPT(STDOUT,ILEN,CTRUE,ATTI98,ATTI99-1) ! CALL PRNRPT(STDOUT,ILEN,CTRUE,ATTI99,SUPD) ! ! STOP AFTER SEVERAL REPORTS HAVE BEEN READ ! IF (NREC.GE.50) STOP 'REMOVE STOP TO READ ALL REPORTS' call INIT(CTRUE,ITRUE,FTRUE,FMISS,ILEN,NUM) GOTO 100 ! ! END OF FILE 900 CONTINUE !! WRITE(STDOUT,*)'REPORTS ',NREC ! ! PRINT SUMMARY INFORMATION TO UNIT CALL PRNSUM(UNIT,PROGID,ABBR,NUM) END !=============================================================================! ! WARNING: Code beyond this point should not require any modification. ! !=============================================================================! !-----------------------------------------------------------------------3456789 SUBROUTINE INIT(CTRUE,ITRUE,FTRUE,FMISS,ILEN,NUM) ! INITIALIZE CTRUE, ITRUE, AND FTRUE IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) CTRUE DIMENSION CTRUE(NUM),ITRUE(NUM),FTRUE(NUM),ILEN(NUM) ! DO 190 I=1,NUM IF (ILEN(I).EQ.1024) THEN CTRUE(I)(:)=' ' ELSE IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'INIT LEN CTRUE' CTRUE(I)(:ILEN(I))=' ' ENDIF ITRUE(I)=NINT(FMISS) FTRUE(I)=FMISS 190 CONTINUE END !-----------------------------------------------------------------------3456789 SUBROUTINE PRNSKP(BEG,END) ! DO NOT PRINT REPORT HEADER OR REPORT IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) ABBR,CTRUE DIMENSION ILEN(*),ABBR(*),CTRUE(*) CHARACTER*1024 HDR,RPT EQUIVALENCE(HDR,RPT) DIMENSION SKP(1024) DATA SKP/1024*0/ SAVE SKP ! DO 190 I=BEG,END SKP(I)=1 190 CONTINUE RETURN !-----------------------------------------------------------------------3456789 ENTRY PRNHDR(STDOUT,ILEN,ABBR,BEG,END) ! PRINT REPORT HEADER ! DO 290 J=1,5 HDR=' ' PTR=0 DO 280 I=BEG,END IF (SKP(I).NE.1) THEN IF (ILEN(I).EQ.1024) THEN PTR=PTR+1 ELSE PTR=PTR+ILEN(I) ENDIF IF (PTR.GT.LEN(HDR)) STOP 'PRNHDR LEN HDR' HDR(PTR:PTR)=ABBR(I)(J:J) ENDIF 280 CONTINUE WRITE(STDOUT,'(A)')HDR(:PTR) 290 CONTINUE RETURN !-----------------------------------------------------------------------3456789 ENTRY PRNRPT(STDOUT,ILEN,CTRUE,BEG,END) ! PRINT REPORT ! RPT=' ' PTR=0 DO 390 I=BEG,END IF (SKP(I).NE.1) THEN IF (ILEN(I).EQ.1024) THEN IF (CTRUE(I)(:).EQ.' ') THEN WRITE(STDOUT,'(2A)')RPT(:PTR),' ' ELSE WRITE(STDOUT,'(2A)')RPT(:PTR),TRIM(CTRUE(I)) ENDIF RETURN ENDIF IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'PRNRPT LEN CTRUE' IF (PTR+ILEN(I).GT.LEN(RPT)) STOP 'PRNRPT LEN RPT' RPT(PTR+1:PTR+ILEN(I))=CTRUE(I)(:ILEN(I)) PTR=PTR+ILEN(I) ENDIF 390 CONTINUE WRITE(STDOUT,'(A)')RPT(:PTR) END !-----------------------------------------------------------------------3456789 SUBROUTINE GETRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR & &,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM) ! CONVERT CHARACTERS TO FLOATING POINT VALUES IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) RPT,CTRUE,ABBR,RPTID DIMENSION CTRUE(NUM),ITRUE(NUM),FTRUE(NUM) & &,ILEN(NUM),ABBR(NUM),FMIN1(NUM),FUNITS(NUM),ITYPE(NUM) CHARACTER B36*5,IFMT(9)*8,STR*1024 DATA IFMT/'(BZ,I1)','(BZ,I2)','(BZ,I3)','(BZ,I4)' & &,'(BZ,I5)','(BZ,I6)','(BZ,I7)','(BZ,I8)','(BZ,I9)'/ SAVE IFMT ! PTR=0 ATTC=0 ATTI=0 TRS=0 DO 180 I=1,NUM IF (ABBR(I).EQ.' ATTI') THEN ATTI=NINT(FMIN1(I)) ATTL=NINT(FMIN1(I+1)) IF (ATTL.GT.99) THEN WRITE(STR(TRS+1:TRS+4),'(I2,A2)')ATTI,B36(ATTL,'**',2) ELSE WRITE(STR(TRS+1:TRS+4),'(2I2)')ATTI,ATTL ENDIF IF (ATTI.EQ.99) THEN IF (TRS+5.GT.LEN(STR)) STOP 'GETRPT LEN STR' IF (PTR+6.GT.LEN(RPT)) STOP 'GETRPT LEN RPT' IF (STR(TRS+1:TRS+4).NE.RPT(PTR+1:PTR+4)) THEN IF (RPT(PTR+1:).NE.' ') STOP 'GETRPT ATTI ATTL' STR(TRS+1:TRS+5)=' ' ELSE ATTC=ATTC+1 STR(TRS+1:TRS+5)=RPT(PTR+1:PTR+5) PTR=PTR+5 ENDIF IF (NUM.EQ.I+3) THEN CTRUE(NUM)(:)=RPT(PTR+1:) IF (CTRUE(NUM)(:).NE.RPT(PTR+1:)) STOP 'GETRPT LEN SUPD' ENDIF ELSE IF (TRS+ATTL.GT.LEN(STR)) STOP 'GETRPT LEN STR' IF (PTR+ATTL.GT.LEN(RPT)) STOP 'GETRPT LEN RPT' IF (STR(TRS+1:TRS+4).NE.RPT(PTR+1:PTR+4)) THEN STR(TRS+1:TRS+ATTL)=' ' ELSE ATTC=ATTC+1 STR(TRS+1:TRS+ATTL)=RPT(PTR+1:PTR+ATTL) PTR=PTR+ATTL ENDIF ENDIF ELSE IF (ATTI.EQ.0) THEN IF (TRS+ILEN(I).GT.LEN(STR)) STOP 'GETRPT LEN STR' IF (PTR+ILEN(I).GT.LEN(RPT)) STOP 'GETRPT LEN RPT' STR(TRS+1:TRS+ILEN(I))=RPT(PTR+1:PTR+ILEN(I)) PTR=PTR+ILEN(I) IF (ABBR(I).EQ.' IM') THEN ENDIF ENDIF TRS=TRS+ILEN(I) 180 CONTINUE ! TRS=0 DO 190 I=1,NUM IF (ILEN(I).NE.1024) THEN IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'GETRPT LEN CTRUE' CTRUE(I)(:ILEN(I))=STR(TRS+1:TRS+ILEN(I)) TRS=TRS+ILEN(I) ENDIF ! IF (CTRUE(I)(:MIN(ILEN(I),LEN(CTRUE(I)))).EQ.' ') THEN ITRUE(I)=NINT(FMISS) ELSE IF (ITYPE(I).EQ.1) THEN READ(CTRUE(I)(:ILEN(I)),IFMT(ILEN(I)),IOSTAT=IOS)ITRUE(I) IF (IOS.NE.0) ITRUE(I)=NINT(FERR) ELSE IF (ITYPE(I).EQ.2) THEN ITRUE(I)=IB36(CTRUE(I)(:ILEN(I)),NINT(FERR),ILEN(I)) ELSE ITRUE(I)=ICHAR(CTRUE(I)(:1)) ENDIF ! IF (ITRUE(I).EQ.NINT(FMISS)) THEN FTRUE(I)=FMISS ELSE IF (ITRUE(I).EQ.NINT(FERR)) THEN FTRUE(I)=FERR ELSE IF (ITYPE(I).LE.2) THEN FTRUE(I)=ITRUE(I)*FUNITS(I) ELSE FTRUE(I)=ITRUE(I) ENDIF 190 CONTINUE RETURN !-----------------------------------------------------------------------3456789 ENTRY PUTRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR & &,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM) ! CONVERT FLOATING POINT VALUES TO CHARACTERS ! STR=' ' TRS=0 DO 280 I=1,NUM IF (FTRUE(I).EQ.FMISS) THEN ITRUE(I)=NINT(FMISS) ELSE IF (FTRUE(I).EQ.FERR) THEN ITRUE(I)=NINT(FERR) ELSE IF (ITYPE(I).LE.2) THEN ITRUE(I)=NINT(FTRUE(I)/FUNITS(I)) ELSE ITRUE(I)=NINT(FTRUE(I)) ENDIF ! IF (ITRUE(I).EQ.NINT(FMISS)) THEN CTRUE(I)(:MIN(ILEN(I),LEN(CTRUE(I))))=' ' ELSE IF (ITYPE(I).EQ.1) THEN WRITE(CTRUE(I)(:ILEN(I)),IFMT(ILEN(I)))ITRUE(I) ELSE IF (ITYPE(I).EQ.2) THEN CTRUE(I)(:ILEN(I))=B36(ITRUE(I),'*****',ILEN(I)) ELSE ! CTRUE(I)(:ILEN(I))=REPEAT(CHAR(ITRUE(I)),ILEN(I)) ENDIF ! IF (ILEN(I).NE.1024) THEN IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'PUTRPT LEN CTRUE' STR(TRS+1:TRS+ILEN(I))=CTRUE(I)(:ILEN(I)) TRS=TRS+ILEN(I) ENDIF 280 CONTINUE ! RPT=' ' PTR=0 ATTC=0 ATTI=0 TRS=0 DO 290 I=1,NUM IF (ABBR(I).EQ.' ATTI') THEN ATTI=NINT(FMIN1(I)) ATTL=NINT(FMIN1(I+1)) IF (ATTL.GT.99) THEN WRITE(STR(TRS+1:TRS+4),'(I2,A2)')ATTI,B36(ATTL,'**',2) ELSE WRITE(STR(TRS+1:TRS+4),'(2I2)')ATTI,ATTL ENDIF IF (ATTI.EQ.99) THEN IF (TRS+5.GT.LEN(STR)) STOP 'PUTRPT LEN STR' IF (NUM.EQ.I+3) THEN IF (CTRUE(NUM)(:).NE.' ') THEN ATTC=ATTC+1 IF (PTR+6.GT.LEN(RPT)) STOP 'PUTRPT LEN RPT' RPT(PTR+1:PTR+5)=STR(TRS+1:TRS+5) PTR=PTR+5 RPT(PTR+1:)=CTRUE(NUM)(:) IF (RPT(PTR+1:).NE.CTRUE(NUM)(:)) STOP 'PUTRPT LEN SUPD' ENDIF ENDIF ELSE IF (TRS+ATTL.GT.LEN(STR)) STOP 'PUTRPT LEN STR' IF (STR(TRS+5:TRS+ATTL).NE.' ') THEN ATTC=ATTC+1 IF (PTR+ATTL.GT.LEN(RPT)) STOP 'PUTRPT LEN RPT' RPT(PTR+1:PTR+ATTL)=STR(TRS+1:TRS+ATTL) PTR=PTR+ATTL ENDIF ENDIF ELSE IF (ATTI.EQ.0) THEN IF (TRS+ILEN(I).GT.LEN(STR)) STOP 'PUTRPT LEN STR' IF (PTR+ILEN(I).GT.LEN(RPT)) STOP 'PUTRPT LEN RPT' IF (ABBR(I).EQ.' IM') THEN STR(TRS+1:TRS+ILEN(I))=RPTID ELSE IF (ABBR(I).EQ.' ATTC') THEN STR(TRS+1:TRS+ILEN(I))='%' ENDIF RPT(PTR+1:PTR+ILEN(I))=STR(TRS+1:TRS+ILEN(I)) PTR=PTR+ILEN(I) ENDIF TRS=TRS+ILEN(I) 290 CONTINUE PTR=INDEX(RPT,'%') RPT(PTR:PTR)=B36(ATTC,'*',1) END !-----------------------------------------------------------------------3456789 SUBROUTINE MINMAX(CTRUE,ITRUE,FTRUE,FMISS,FERR & &,ILEN,FMIN1,FMAX1,FMIN2,FMAX2,FUNITS,ITYPE,NUM) ! SET EXTREME FLOATING POINT VALUES TO ERROR VALUE IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) CTRUE DIMENSION CTRUE(NUM),ITRUE(NUM),FTRUE(NUM) & &,ILEN(NUM),FMIN1(NUM),FMAX1(NUM),FMIN2(NUM),FMAX2(NUM) & &,FUNITS(NUM),ITYPE(NUM) ! DO 190 I=1,NUM IF (ITYPE(I).LE.2) THEN IF (FTRUE(I).EQ.FMISS .OR. FTRUE(I).EQ.FERR) THEN ITRUE(I)=NINT(FTRUE(I)) GOTO 190 ENDIF ITRUE(I)=NINT(FTRUE(I)/FUNITS(I)) IF (ITRUE(I).GE.NINT(FMIN1(I)/FUNITS(I)) & & .AND.ITRUE(I).LE.NINT(FMAX1(I)/FUNITS(I)) & & .OR. FMIN2(I).NE.FMISS & & .AND.ITRUE(I).GE.NINT(FMIN2(I)/FUNITS(I)) & & .AND.ITRUE(I).LE.NINT(FMAX2(I)/FUNITS(I))) THEN ELSE FTRUE(I)=FERR ITRUE(I)=NINT(FERR) ENDIF ELSE IF (ILEN(I).EQ.1024) THEN LENGTH=LEN(CTRUE(I)) ELSE IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'MINMAX LEN CTRUE' LENGTH=ILEN(I) ENDIF IF (CTRUE(I)(:LENGTH).EQ.' ') THEN FTRUE(I)=FMISS ITRUE(I)=NINT(FMISS) GOTO 190 ENDIF FTRUE(I)=ICHAR(CTRUE(I)(:1)) ITRUE(I)=NINT(FTRUE(I)) DO 180 J=1,LENGTH IF (LGE(CTRUE(I)(J:J),'A') & & .AND.LLE(CTRUE(I)(J:J),'Z') & & .OR. NINT(FMIN1(I)).LE.48 & & .AND.LGE(CTRUE(I)(J:J),'0') & & .AND.LLE(CTRUE(I)(J:J),'9') & & .OR. NINT(FMIN1(I)).EQ.32 & & .AND.LGE(CTRUE(I)(J:J),' ') & & .AND.LLE(CTRUE(I)(J:J),'~')) THEN ELSE FTRUE(I)=FERR ITRUE(I)=NINT(FERR) GOTO 190 ENDIF 180 CONTINUE ENDIF 190 CONTINUE END !-----------------------------------------------------------------------3456789 SUBROUTINE SAVSUM(CTRUE,FTRUE,FMISS,FERR & &,ILEN,ABBR,NUM) ! SAVE SUMMARY INFORMATION IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) PROGID,ABBR,CTRUE DIMENSION CTRUE(NUM),FTRUE(NUM),ILEN(NUM),ABBR(NUM) CHARACTER*64 STR DIMENSION SUM1(1024),SUM2(1024),SUM3(1024) DATA SUM1,SUM2,SUM3/1024*0,1024*0,1024*0/ SAVE SUM1,SUM2,SUM3 PC(A1,A2)=NINT(FLOAT(A1*100)/MAX(A2,1)) ! DO 190 I=1,NUM IF (FTRUE(I).NE.FMISS .AND. FTRUE(I).NE.FERR) THEN SUM1(I)=SUM1(I)+1 ELSE SUM2(I)=SUM2(I)+1 IF (FTRUE(I).EQ.FMISS) THEN IF (ILEN(I).EQ.1024) THEN IF (CTRUE(I)(:).EQ.' ') GOTO 190 ELSE IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'SAVSUM LEN CTRUE' IF (CTRUE(I)(:ILEN(I)).EQ.' ') GOTO 190 ENDIF ENDIF SUM3(I)=SUM3(I)+1 WRITE(STR,'(I3,1X,A5,2X,A53)')I,ABBR(I),CTRUE(I) CALL SAVSTR(STR) ENDIF 190 CONTINUE RETURN !-----------------------------------------------------------------------3456789 ENTRY PRNSUM(UNIT,PROGID,ABBR,NUM) ! PRINT SUMMARY INFORMATION TO UNIT ! WRITE(UNIT,'(A)')PROGID WRITE(UNIT,'(/1X,A)')'SUMMARY OF FIELDS' WRITE(UNIT,'(A6,2(2X,A10,A11,A13))')'FIELD' & &,'# EXTANT','# MISSING','# ERRONEOUS' & &,'% EXTANT','% MISSING','% ERRONEOUS' DO 290 I=1,NUM IF (SUM1(I).GT.0 .OR. SUM3(I).GT.0) THEN TOTAL=SUM1(I)+SUM2(I) WRITE(UNIT,'(1X,A5,2(2X,I10,I11,I13))')ABBR(I) & & , SUM1(I) , SUM2(I) , SUM3(I) & & ,PC(SUM1(I),TOTAL),PC(SUM2(I),TOTAL),PC(SUM3(I),TOTAL) ENDIF SUM1(I)=0 SUM2(I)=0 SUM3(I)=0 290 CONTINUE WRITE(UNIT,'(/1X,A)')'SUMMARY OF ERRORS' WRITE(UNIT,'(A6,2X,A,T70,A)')'FIELD','ERROR','FREQUENCY' CALL PRNSTR(UNIT) END !-----------------------------------------------------------------------3456789 SUBROUTINE SAVSTR(STR) ! SAVE FREQUENCY OF STRING IMPLICIT INTEGER(A-E,G-Z) PARAMETER(MMAX=10000) CHARACTER*64 STR,ARR1 DIMENSION ARR1(MMAX),ARR2(MMAX) DATA M/0/ SAVE ! DO 190 I=1,M IF (STR.NE.ARR1(I)) GOTO 190 ARR2(I)=ARR2(I)+1 RETURN 190 CONTINUE IF (M+1.GE.MMAX) STOP 'SAVSTR INCREASE MMAX' M=M+1 ARR1(M)=STR ARR2(M)=1 RETURN !-----------------------------------------------------------------------3456789 ENTRY PRNSTR(UNIT) ! PRINT FREQUENCY OF STRING ! DO 290 K=1,M-1 J=K DO 280 L=K+1,M IF (LLT(ARR1(L),ARR1(J))) J=L 280 CONTINUE IF (J.NE.K) THEN ARR1(MMAX)=ARR1(K) ARR2(MMAX)=ARR2(K) ARR1(K)=ARR1(J) ARR2(K)=ARR2(J) ARR1(J)=ARR1(MMAX) ARR2(J)=ARR2(MMAX) ENDIF 290 CONTINUE WRITE(UNIT,'(A,T70,I9)')(ARR1(I)(4:),ARR2(I),I=1,M) M=0 END !-----------------------------------------------------------------------3456789 FUNCTION IB36(B36,IERR,ILEN) ! CONVERT FROM BASE 36 CHARACTER STRING TO INTEGER IMPLICIT INTEGER (A-Z) CHARACTER (LEN=*) B36,STR PARAMETER(STR='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ') ! IF (ILEN.GE.6) STOP 'IB36' IF (VERIFY(B36,STR).EQ.0) THEN IB36=0 INT=1 DO J=ILEN,1,-1 IB36=IB36+(INDEX(STR,B36(J:J))-1)*INT INT=INT*36 ENDDO ELSE IB36=IERR ENDIF END !-----------------------------------------------------------------------3456789 FUNCTION B36(IB36,ERR,ILEN) ! CONVERT FROM INTEGER TO BASE 36 CHARACTER STRING IMPLICIT INTEGER (A-Z) CHARACTER (LEN=*) B36,STR,ERR PARAMETER(STR='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ') ! IF (ILEN.GE.6) STOP 'B36' IF (IB36.GE.0 .AND. IB36.LE.36**ILEN-1) THEN B36=' ' INT=1 DO J=ILEN,1,-1 B36(J:J)=STR(MOD(IB36/INT,36)+1:) INT=INT*36 ENDDO ELSE B36=ERR ENDIF END !-----------------------------------------------------------------------3456789 SUBROUTINE GETUID(CTRUE) ! GET UNIQUE REPORT ID CHARACTER*6 CTRUE ! OPEN(98,FILE='LAST_UID') READ(98,'(A)')CTRUE CALL B36INC(CTRUE) REWIND(98) WRITE(98,'(A)')CTRUE CLOSE(98) END !-----------------------------------------------------------------------3456789 SUBROUTINE B36INC(B36) ! INCREMENT BASE 36 CHARACTER STRING IMPLICIT INTEGER (A-Z) CHARACTER (LEN=*) B36,STR PARAMETER(STR='0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ') ! IF (VERIFY(B36,STR).EQ.0) THEN DO J=LEN(B36),1,-1 NDX=INDEX(STR,B36(J:J)) IF (NDX.LT.36) THEN B36(J:J)=STR(NDX+1:NDX+1) RETURN ELSE B36(J:J)=STR(1:1) ENDIF ENDDO ENDIF STOP 'B36INC' END !-----------------------------------------------------------------------3456789 SUBROUTINE EAST(ITRUE,FTRUE,FERR) ! CONVERT LONGITUDE TO DEGREES EAST IMPLICIT INTEGER(A-E,G-Z) ! ITRUE=NINT(FTRUE/0.01) IF(ITRUE.GE.-36000 .AND. ITRUE.LE.36000)THEN ITRUE=MOD(ITRUE+36000,36000) FTRUE=ITRUE*0.01 ELSE ITRUE=NINT(FERR) FTRUE=FERR ENDIF END !-----------------------------------------------------------------------3456789 SUBROUTINE SDEG(ITRUE,FTRUE,FERR) ! CONVERT LONGITUDE TO SIGNED DEGREES EAST IMPLICIT INTEGER(A-E,G-Z) ! IF(NINT(FTRUE*100.).GE.-36000 .AND. NINT(FTRUE*100.).LE.36000)THEN IF(NINT(FTRUE*100.).GT.18000)FTRUE=FTRUE-360. ITRUE=NINT(FTRUE*100.) ELSE FTRUE=FERR ITRUE=NINT(FERR) ENDIF END !-----------------------------------------------------------------------3456789 SUBROUTINE ZEROS(CTRUE,ILEN,ABBR,ITYPE,NUM) ! ZERO FILL LEADING BLANKS IMPLICIT INTEGER(A-E,G-Z) CHARACTER*(*) CTRUE,ABBR DIMENSION CTRUE(NUM),ILEN(NUM),ABBR(NUM),ITYPE(NUM) CHARACTER IFMT(18)*8 DATA IFMT/'(I1.1)','(I2.2)','(I3.3)','(I4.4)','(I5.5)','(I6.6)' & &,'(I7.7)','(I8.8)','(I9.9)','(I1.0)','(I2.1)','(I3.2)','(I4.3)' & &,'(I5.4)','(I6.5)','(I7.6)','(I8.7)','(I9.8)'/ SAVE IFMT ! DO 190 I=1,NUM IF (ITYPE(I).EQ.1 & & .AND. ILEN(I).NE.1 & & .AND. ABBR(I).NE.' IM' & & .AND. ABBR(I).NE.' ATTI' & & .AND. ABBR(I).NE.' ATTL') THEN IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'ZEROS LEN CTRUE' IF (CTRUE(I)(:ILEN(I)).EQ.' ') GOTO 190 READ(CTRUE(I)(:ILEN(I)),IFMT(ILEN(I)))ITRUE IF (ITRUE.LT.0) THEN WRITE(CTRUE(I)(:ILEN(I)),IFMT(ILEN(I)+9))ITRUE ELSE WRITE(CTRUE(I)(:ILEN(I)),IFMT(ILEN(I)))ITRUE ENDIF ENDIF 190 CONTINUE END !-----------------------------------------------------------------------3456789 BLOCK DATA BDIMMA ! COMMON BLOCK DATA STATEMENTS IMPLICIT INTEGER(A-E,G-Z) ! ! missing = -999999 ! ILEN = field length ! ABBR = field abbreviation ! FMIN1 = field range minimum (first, or only) ! FMAX1 = field range maximum (first, or only) ! FMIN2 = field range minimum (second, or missing) ! FMAX2 = field range maximum (second, or missing) ! FUNITS = field units (missing, if itype=3) ! ITYPE = 1: numeric: decimal range(s) ! 2: numeric: decimal range(s), transformed to base36 ! 3: character: decimal range(s), transformed to ascii ! RPTID = 1 (IMMA version that the program can read) ! PARAMETER(NUM=245) CHARACTER*8 ABBR,RPTID COMMON /IMMA1/ILEN(NUM),ABBR(NUM),FMIN1(NUM),FMAX1(NUM) & &,FMIN2(NUM),FMAX2(NUM),FUNITS(NUM),ITYPE(NUM),RPTID ! DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=1,18)/ & & 4,' YR', 1600. , 2024. ,-999999.,-999999., 1. , 1, & & 2,' MO', 1. , 12. ,-999999.,-999999., 1. , 1, & & 2,' DY', 1. , 31. ,-999999.,-999999., 1. , 1, & & 4,' HR', 0.00, 23.99,-999999.,-999999., 0.01 , 1, & & 5,' LAT', -90.00, 90.00,-999999.,-999999., 0.01 , 1, & & 6,' LON', 0.00, 359.99, -179.99, 180.00, 0.01 , 1, & & 2,' IM', 0. , 99. ,-999999.,-999999., 1. , 1, & & 1,' ATTC', 0. , 9. ,-999999.,-999999., 1. , 2, & & 1,' TI', 0. , 3. ,-999999.,-999999., 1. , 1, & & 1,' LI', 0. , 6. ,-999999.,-999999., 1. , 1, & & 1,' DS', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' VS', 0. , 9. ,-999999.,-999999., 1. , 1, & & 2,' NID', 0. , 99. ,-999999.,-999999., 1. , 1, & & 2,' II', 0. , 10. ,-999999.,-999999., 1. , 1, & & 9,' ID', 32. , 126. ,-999999.,-999999.,-999999., 3, & & 2,' C1', 48. , 57. , 65. , 90. ,-999999., 3, & & 1,' DI', 0. , 6. ,-999999.,-999999., 1. , 1, & & 3,' D', 1. , 362. ,-999999.,-999999., 1. , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=19,36)/ & & 1,' WI', 0. , 8. ,-999999.,-999999., 1. , 1, & & 3,' W', 0.0 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 1,' VI', 0. , 2. ,-999999.,-999999., 1. , 1, & & 2,' VV', 90. , 99. ,-999999.,-999999., 1. , 1, & & 2,' WW', 0. , 99. ,-999999.,-999999., 1. , 1, & & 1,' W1', 0. , 9. ,-999999.,-999999., 1. , 1, & & 5,' SLP', 870.0 , 1074.6 ,-999999.,-999999., 0.1 , 1, & & 1,' A', 0. , 8. ,-999999.,-999999., 1. , 1, & & 3,' PPP', 0.0 , 51.0 ,-999999.,-999999., 0.1 , 1, & & 1,' IT', 0. , 9. ,-999999.,-999999., 1. , 1, & & 4,' AT', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 1,' WBTI', 0. , 3. ,-999999.,-999999., 1. , 1, & & 4,' WBT', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 1,' DPTI', 0. , 3. ,-999999.,-999999., 1. , 1, & & 4,' DPT', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 2,' SI', 0. , 12. ,-999999.,-999999., 1. , 1, & & 4,' SST', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 1,' N', 0. , 9. ,-999999.,-999999., 1. , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=37,54)/ & & 1,' NH', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' CL', 0. , 10. ,-999999.,-999999., 1. , 2, & & 1,' HI', 0. , 1. ,-999999.,-999999., 1. , 1, & & 1,' H', 0. , 10. ,-999999.,-999999., 1. , 2, & & 1,' CM', 0. , 10. ,-999999.,-999999., 1. , 2, & & 1,' CH', 0. , 10. ,-999999.,-999999., 1. , 2, & & 2,' WD', 0. , 38. ,-999999.,-999999., 1. , 1, & & 2,' WP', 0. , 30. , 99. , 99. , 1. , 1, & & 2,' WH', 0. , 99. ,-999999.,-999999., 1. , 1, & & 2,' SD', 0. , 38. ,-999999.,-999999., 1. , 1, & & 2,' SP', 0. , 30. , 99. , 99. , 1. , 1, & & 2,' SH', 0. , 99. ,-999999.,-999999., 1. , 1, & & 2,' ATTI', 1. , 1. , 1. , 1. , 1. , 1, & & 2,' ATTL', 65. , 65. , 65. , 65. , 1. , 1, & & 1,' BSI',-999999.,-999999.,-999999.,-999999., 1. , 1, & & 3,' B10', 1. , 648. ,-999999.,-999999., 1. , 1, & & 2,' B1', 0. , 99. ,-999999.,-999999., 1. , 1, & & 3,' DCK', 0. , 999. ,-999999.,-999999., 1. , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=55,72)/ & & 3,' SID', 0. , 999. ,-999999.,-999999., 1. , 1, & & 2,' PT', 0. , 21. ,-999999.,-999999., 1. , 1, & & 2,' DUPS', 0. , 14. ,-999999.,-999999., 1. , 1, & & 1,' DUPC', 0. , 2. ,-999999.,-999999., 1. , 1, & & 1,' TC', 0. , 1. ,-999999.,-999999., 1. , 1, & & 1,' PB', 0. , 2. ,-999999.,-999999., 1. , 1, & & 1,' WX', 1. , 1. ,-999999.,-999999., 1. , 1, & & 1,' SX', 1. , 1. ,-999999.,-999999., 1. , 1, & & 2,' C2', 0. , 40. ,-999999.,-999999., 1. , 1, & & 1,' SQZ', 1. , 35. ,-999999.,-999999., 1. , 2, & & 1,' SQA', 1. , 21. ,-999999.,-999999., 1. , 2, & & 1,' AQZ', 1. , 35. ,-999999.,-999999., 1. , 2, & & 1,' AQA', 1. , 21. ,-999999.,-999999., 1. , 2, & & 1,' UQZ', 1. , 35. ,-999999.,-999999., 1. , 2, & & 1,' UQA', 1. , 21. ,-999999.,-999999., 1. , 2, & & 1,' VQZ', 1. , 35. ,-999999.,-999999., 1. , 2, & & 1,' VQA', 1. , 21. ,-999999.,-999999., 1. , 2, & & 1,' PQZ', 1. , 35. ,-999999.,-999999., 1. , 2/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=73,90)/ & & 1,' PQA', 1. , 21. ,-999999.,-999999., 1. , 2, & & 1,' DQZ', 1. , 35. ,-999999.,-999999., 1. , 2, & & 1,' DQA', 1. , 21. ,-999999.,-999999., 1. , 2, & & 1,' ND', 1. , 2. ,-999999.,-999999., 1. , 1, & & 1,' SF', 1. , 15. ,-999999.,-999999., 1. , 2, & & 1,' AF', 1. , 15. ,-999999.,-999999., 1. , 2, & & 1,' UF', 1. , 15. ,-999999.,-999999., 1. , 2, & & 1,' VF', 1. , 15. ,-999999.,-999999., 1. , 2, & & 1,' PF', 1. , 15. ,-999999.,-999999., 1. , 2, & & 1,' RF', 1. , 15. ,-999999.,-999999., 1. , 2, & & 1,' ZNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' WNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' BNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' XNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' YNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' PNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' ANC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' GNC', 1. , 10. ,-999999.,-999999., 1. , 2/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=91,108)/ & & 1,' DNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' SNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' CNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' ENC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' FNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 1,' TNC', 1. , 10. ,-999999.,-999999., 1. , 2, & & 2,' QCE', 0. , 63. ,-999999.,-999999., 1. , 1, & & 1,' LZ', 1. , 1. ,-999999.,-999999., 1. , 1, & & 2,' QCZ', 0. , 31. ,-999999.,-999999., 1. , 1, & & 2,' ATTI', 5. , 5. , 5. , 5. , 1. , 1, & & 2,' ATTL', 94. , 94. , 94. , 94. , 1. , 1, & & 1,' OS', 0. , 6. ,-999999.,-999999., 1. , 1, & & 1,' OP', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' FM', 0. , 35. ,-999999.,-999999., 1. , 2, & & 1,' IMMV', 0. , 35. ,-999999.,-999999., 1. , 2, & & 1,' IX', 1. , 7. ,-999999.,-999999., 1. , 1, & & 1,' W2', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' WMI', 0. , 9. ,-999999.,-999999., 1. , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=109,126)/ & & 2,' SD2', 0. , 38. ,-999999.,-999999., 1. , 1, & & 2,' SP2', 0. , 30. , 99. , 99. , 1. , 1, & & 2,' SH2', 0. , 99. ,-999999.,-999999., 1. , 1, & & 1,' IS', 1. , 5. ,-999999.,-999999., 1. , 1, & & 2,' ES', 0. , 99. ,-999999.,-999999., 1. , 1, & & 1,' RS', 0. , 4. ,-999999.,-999999., 1. , 1, & & 1,' IC1', 0. , 10. ,-999999.,-999999., 1. , 2, & & 1,' IC2', 0. , 10. ,-999999.,-999999., 1. , 2, & & 1,' IC3', 0. , 10. ,-999999.,-999999., 1. , 2, & & 1,' IC4', 0. , 10. ,-999999.,-999999., 1. , 2, & & 1,' IC5', 0. , 10. ,-999999.,-999999., 1. , 2, & & 1,' IR', 0. , 4. ,-999999.,-999999., 1. , 1, & & 3,' RRR', 0. , 999. ,-999999.,-999999., 1. , 1, & & 1,' TR', 1. , 9. ,-999999.,-999999., 1. , 1, & & 1,' NU', 32. , 126. ,-999999.,-999999.,-999999., 3, & & 1,' QCI', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI1', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI2', 0. , 9. ,-999999.,-999999., 1. , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=127,144)/ & & 1,' QI3', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI4', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI5', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI6', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI7', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI8', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI9', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI10', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI11', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI12', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI13', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI14', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI15', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI16', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI17', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI18', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI19', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI20', 0. , 9. ,-999999.,-999999., 1. , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=145,162)/ & & 1,' QI21', 0. , 9. ,-999999.,-999999., 1. , 1, & & 3,' HDG', 0. , 360. ,-999999.,-999999., 1. , 1, & & 3,' COG', 0. , 360. ,-999999.,-999999., 1. , 1, & & 2,' SOG', 0. , 99. ,-999999.,-999999., 1. , 1, & & 2,' SLL', 0. , 99. ,-999999.,-999999., 1. , 1, & & 3,' SLHH', -99. , 99. ,-999999.,-999999., 1. , 1, & & 3,' RWD', 1. , 362. ,-999999.,-999999., 1. , 1, & & 3,' RWS', 0.0 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 1,' QI22', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI23', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI24', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI25', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI26', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI27', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI28', 0. , 9. ,-999999.,-999999., 1. , 1, & & 1,' QI29', 0. , 9. ,-999999.,-999999., 1. , 1, & & 4,' RH', 0.0 , 100.0 ,-999999.,-999999., 0.1 , 1, & & 1,' RHI', 0. , 4. ,-999999.,-999999., 1. , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=163,180)/ & & 1,' AWSI', 0. , 2. ,-999999.,-999999., 1. , 1, & & 7,'IMONO', 0. ,9999999.,-999999.,-999999., 1. , 1, & & 2,' ATTI', 6. , 6. , 6. , 6. , 1. , 1, & & 2,' ATTL', 68. , 68. , 68. , 68. , 1. , 1, & & 4,' CCCC', 65. , 90. ,-999999.,-999999.,-999999., 3, & & 6,' BUID', 48. , 57. , 65. , 90. ,-999999., 3, & & 1,'FBSRC', 0. , 35. ,-999999.,-999999., 1. , 2, & & 5,' BMP', 870.0 , 1074.6 ,-999999.,-999999., 0.1 , 1, & & 4,' BSWU', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 4,' SWU', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 4,' BSWV', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 4,' SWV', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 4,' BSAT', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1, & & 3,' BSRH', 0. , 100. ,-999999.,-999999., 1. , 1, & & 3,' SRH', 0. , 100. ,-999999.,-999999., 1. , 1, & & 5,' BSST', -99.99 , 99.99 ,-999999.,-999999., 0.01 , 1, & & 1,' MST', 0. , 9. ,-999999.,-999999., 1. , 1, & & 4,' MSH', -999. , 9999. ,-999999.,-999999., 1. , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=181,198)/ & & 4,' BY', 0. , 9999. ,-999999.,-999999., 1. , 1, & & 2,' BM', 1. , 12. ,-999999.,-999999., 1. , 1, & & 2,' BD', 1. , 31. ,-999999.,-999999., 1. , 1, & & 2,' BH', 0. , 23. ,-999999.,-999999., 1. , 1, & & 2,' BFL', 0. , 99. ,-999999.,-999999., 1. , 1, & & 2,' ATTI', 7. , 7. , 7. , 7. , 1. , 1, & & 2,' ATTL', 58. , 58. , 58. , 58. , 1. , 1, & & 1,' MDS', 0. , 35. ,-999999.,-999999., 1. , 2, & & 2,' C1M', 65. , 90. ,-999999.,-999999.,-999999., 3, & & 2,' OPM', 0. , 99. ,-999999.,-999999., 1. , 1, & & 2,' KOV', 32. , 126. ,-999999.,-999999.,-999999., 3, & & 2,' COR', 65. , 90. ,-999999.,-999999.,-999999., 3, & & 3,' TOB', 32. , 126. ,-999999.,-999999.,-999999., 3, & & 3,' TOT', 32. , 126. ,-999999.,-999999.,-999999., 3, & & 2,' EOT', 32. , 126. ,-999999.,-999999.,-999999., 3, & & 2,' LOT', 32. , 126. ,-999999.,-999999.,-999999., 3, & & 1,' TOH', 32. , 126. ,-999999.,-999999.,-999999., 3, & & 2,' EOH', 32. , 126. ,-999999.,-999999.,-999999., 3/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=199,216)/ & & 3,' SIM', 32. , 126. ,-999999.,-999999.,-999999., 3, & & 3,' LOV', 0. , 999. ,-999999.,-999999., 1. , 1, & & 2,' DOS', 0. , 99. ,-999999.,-999999., 1. , 1, & & 3,' HOP', 0. , 999. ,-999999.,-999999., 1. , 1, & & 3,' HOT', 0. , 999. ,-999999.,-999999., 1. , 1, & & 3,' HOB', 0. , 999. ,-999999.,-999999., 1. , 1, & & 3,' HOA', 0. , 999. ,-999999.,-999999., 1. , 1, & & 5,' SMF', 0. ,99999. ,-999999.,-999999., 1. , 1, & & 5,' SME', 0. ,99999. ,-999999.,-999999., 1. , 1, & & 2,' SMV', 0. , 99. ,-999999.,-999999., 1. , 1, & & 2,' ATTI', 8. , 8. , 8. , 8. , 1. , 1, & & 2,' ATTL', 104. , 104. , 104. , 104. , 1. , 2, & & 5,' OTV', -3.000, 35.999,-999999.,-999999., 0.001 , 1, & & 4,' OTZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1, & & 5,' OSV', 0.000, 40.999,-999999.,-999999., 0.001 , 1, & & 4,' OSZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1, & & 4,' OOV', 0.00, 12.99,-999999.,-999999., 0.01 , 1, & & 4,' OOZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=217,234)/ & & 4,' OPV', 0.00, 30.99,-999999.,-999999., 0.01 , 1, & & 4,' OPZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1, & & 5,' OSIV', 0.00, 250.99,-999999.,-999999., 0.01 , 1, & & 4,' OSIZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1, & & 5,' ONV', 0.00, 500.99,-999999.,-999999., 0.01 , 1, & & 4,' ONZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1, & & 3,' OPHV', 6.20, 9.20,-999999.,-999999., 0.01 , 1, & & 4,' OPHZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1, & & 4,' OCV', 0.00, 50.99,-999999.,-999999., 0.01 , 1, & & 4,' OCZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1, & & 3,' OAV', 0.00, 3.10,-999999.,-999999., 0.01 , 1, & & 4,' OAZ', 0.00, 10.00,-999999.,-999999., 0.01 , 1, & & 4,' OPCV', 0. , 9999. ,-999999.,-999999., 1. , 1, & & 4,' OPCZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1, & & 4,' ODV', 0. , 9999. ,-999999.,-999999., 1. , 1, & & 4,' ODZ', 0.00, 10.99,-999999.,-999999., 0.01 , 1, & & 10,' PUID', 48. , 57. , 65. , 90. ,-999999., 3, & & 2,' ATTI', 98. , 98. , 98. , 98. , 1. , 1/ DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I) & &,FUNITS(I),ITYPE(I),I=235,245)/ & & 2,' ATTL', 15. , 15. , 15. , 15. , 1. , 1, & & 6,' UID', 48. , 57. , 65. , 90. ,-999999., 3, & & 1,' RN1', 0. , 35. ,-999999.,-999999., 1. , 2, & & 1,' RN2', 0. , 35. ,-999999.,-999999., 1. , 2, & & 1,' RN3', 0. , 35. ,-999999.,-999999., 1. , 2, & & 1,' RSA', 0. , 2. ,-999999.,-999999., 1. , 1, & & 1,' IRF', 0. , 1. ,-999999.,-999999., 1. , 1, & & 2,' ATTI', 99. , 99. , 99. , 99. , 1. , 1, & & 2,' ATTL', 0. , 0. , 0. , 0. , 1. , 1, & & 1,' ATTE', 1. , 1. ,-999999.,-999999., 1. , 1, & &1024,' SUPD', 32. , 126. ,-999999.,-999999.,-999999., 3/ DATA RPTID/' 1'/ END !-----------------------------------------------------------------------3456789 real function fxktms(kt) !-----Convert from knots (kt; with respect to the international nautical ! mile) to meters per second (see {tpktms} for details). !-----Adapted from colib5s.01J function {cvskm} (1984); sdw, 26 Jun 1998. real kt fxktms = kt * 0.51444444444444444444 return end EOR rm a.out gfortran p.f90 #date zcat /data/slubker/dwd4/German_Light_Vessel/fs_*.immt5.gz | ./a.out | gzip > /nas/slubker/dwd4/fs_.immt5.gz