cat > p.f <<\EOR
C=============================================================================C
C International Comprehensive Ocean-Atmosphere Data Set (ICOADS) 29 Jun 2005 C
C Filename:level: rdimma0:01H Fortran 77 program+shell C
C Purpose: Read and print/write IMMA Author: S.Lubker C
C=============================================================================C
C Software Revision Information (previous version: 18 May 2005, level 01G):
C PROGID properly updated, and revisions of comments about writing IMMA.
C-----------------------------------------------------------------------3456789
C Software documentation for the (modifiable) example program {rdimma} and for
C the (invariant) user-interface routines {prnskp,prnhdr,getrpt,east,init,
C minmax,savsum,putrpt,prnrpt,prnsum}.
C
C As provided {rdimma}: (a) Prints PROGID (the program name and level). Also,
C {prnhdr} prints a 4-line header for the unabbreviated record type (i.e., core
C plus all currently defined attms: 1-4 and 99). (b) Reads a report (from
C standard input) via a formatted read and calls {getrpt} to extract the fields
C and convert them from characters to numeric values. This makes the fields
C available in three parallel arrays:
C CTRUE: characters (each length 1024) blank for missing data
C ITRUE: integers NINT(FMISS) for missing data
C FTRUE: true (floating point) values FMISS for missing data
C Additional parallel arrays available within common block IMMA0 provide
C metadata defining the properties of currently defined fields. These include
C each field's length (ILEN), abbreviation (ABBR), allowable range(s), units
C (FUNITS; missing for character data) and type (ITYPE; 1=numeric, 2=base36,
C 3=character) (see {bdimma} for details). (c) For the core and attms, a
C PARAMETER statement relates each field abbreviation to an FTRUE (CTRUE,
C ITRUE, etc.) array location; this facilitates usage such as FDY = FTRUE(DY),
C to obtain the floating point value for day. Each element of CTRUE is a
C 1024-character string, but the field length can be used to control printing,
C e.g., PRINT *,CTRUE(DY)(:ILEN(DY)). (d) Prints the original report, RPT,
C under the aforementioned field headings (constructed using ABBR). (e) The
C program iterates (to step b) reading and printing reports until end-of-file
C (EOF) is encountered. Caution: IMPLICIT INTEGER(A-E,G-Z) is used; users may
C need to explicitly type additional variables when modifying this program.
C
C The following optional features are initially deactivated in the Fortran
C code; they may be activated by changing the appropriate Fortran comment
C lines to executable statements, i.e., remove the letter "C" from column 1:
C
C (a) Activate one or more calls to {prnskp} to suppress printing of the core
C and/or selected attms; {prnskp} is designed to work with the default calls
C to {prnhdr} and {prnrpt} for a reduced-width printout. Or (b): Deactivate
C the default calls to {prnhdr} and {prnrpt}, and activate one (or more) of
C the alternative calls to {prnhdr} and {prnrpt}. This provides flexibility
C so that the core or an attm can be printed individually (if only one pair
C of {prnhdr,prnrpt} is activated; alternatively, this can be accomplished by
C activating all but one call to {prnskp}). Activating multiple alternative
C calls to {prnhdr} and {prnrpt} can be used to arrange the core and attms
C vertically (i.e., core and attms on multiple lines, for a single report).
C Moreover, any contiguous portion of the headers and reports can be printed
C by adjusting the fields that appear in the subroutine calls, e.g., activating
C CALL PRNHDR(ILEN,ABBR,YR,HR) and CALL PRNRPT(ILEN,CTRUE,YR,HR) prints just
C year, month, day, and hour. Features (a) and (b) provide flexibility to
C print selected portions of the data; however, note that those two features
C were not designed to be used together (e.g., activating {prnskp} to skip
C the core, and {prnhdr,prnrpt} to print the core, will produce blank lines).
C
C Additional notes on using {prnrpt}: To minimize data volume, IMMA data may
C have a "sparse" record structure, such that attms without any extant data are
C omitted, and the attm structure can vary from report to report. Sparse data
C printed via the default calls to {prnhdr, prnrpt}, are expanded out into the
C complete IMMA structure. Or, using {prnskp}, sparse reports are expanded out
C into a reduced print structure. Alternatively, IMMA data may have a "fixed"
C record structure, such that a fixed number of attms is always present. In
C either case, it can be determined whether an attm was originally present in
C the input data from ATTI and ATTL: these are printed by {prnrpt} if the attm
C was extant, or blank if it was missing. ATTC will always reflect the number
C of attms originally present (e.g., regardless how many are omitted from
C printing through the use of {prnskp}).
C
C (c) Activating {east} will transform longitudes stored according to the NCDC
C convention -179.99 (W) to 180.00 (E), into the ICOADS convention 0-359.99 E.
C This action is applied only to the numeric data (ITRUE, FTRUE), and does not
C take effect on the printed data, unless feature (d) is also activated.
C
C (d) Activating {putrpt} will convert all the true values (e.g., longitudes
C transformed via {east}) back into characters for printing and/or writing.
C Specifically, if changes have been made to FTRUE, {putrpt} puts them also
C into ITRUE, CTRUE, and RPT. Then the changes can be printed, by leaving
C {prnrpt} statement(s) in operation, or written, by activating (instead of
C {prnrpt}) the adjacent WRITE statement. If both {prnrpt} and the WRITE
C statement are activated, each report will be output twice, possibly with
C differences in format (which provides a means to see how the two different
C output methods work). For example, note that {prnskp} has no effect on the
C WRITE statement, in contrast to its effect on {prnrpt}. Reports with a
C sparse record structure will be output when {putrpt} and the WRITE statement
C are used, and ATTC will reflect the output attm count. Reports with a fixed
C record structure can be correctly output when {prnrpt} is used, with these
C caveats: (1) ATTI and ATTL must be set, when the attm data are entirely
C missing, or they will be printed blank; (2) ATTC will be set incorrectly if
C {prnskp} is used, but any of the attm data are extant.
C
C (e) Activate calls: to {minmax}, to set any "extreme" true values to error
C value FERR (by default equal to the missing value FMISS); to {savsum}, to
C save summary information for each field; and to {prnsum}, to print the
C following summary information on unit 10 (using field abbreviations, ABBR):
C -- A summary of the numbers (and percentages) of each field that are
C extant, missing, or erroneous. Erroneous data are also counted
C as a subset of the missing category. Any field (or attm) entirely
C missing in the input data is omitted from the summary.
C -- A summary of any erroneous fields encountered in the input data,
C with each unique pattern and its frequency listed.
C
C (f) The test for NREC greater than or equal to 50 can be activated to stop
C before reading/printing the entire file. Regarding feature (e), note that
C the {prnsum} summary will only be output if statement 900 is reached.
C
C (g) With more extensive modifications, {rdimma0} can be adapted to write
C IMMA data, using non-IMMA data as input. In this case it is important to
C note that a maintenance issue will arise as updates are made to {rdimma0}.
C Therefore, we recommend that code added for this purpose be isolated (e.g.,
C into separate routines) as much as possible. To adapt {rdimma0}, the READ
C statement should be replaced by statements to read non-IMMA data, and
C {getrpt} deactivated. Prior to reading the non-IMMA data, {init} should
C be called to properly initialize the data structures:
C CALL INIT(CTRUE,ITRUE,FTRUE,FMISS,ILEN,NUM)
C Then the input data need to be transformed into the appropriate IMMA units,
C loaded into FTRUE (for numeric fields) or into CTRUE (for character fields),
C {putrpt} called, and the WRITE statement activated. For writing character
C fields into IMMA, {minmax} (see feature (e)), must also be called to signal
C to the program when character data are present in CTRUE. This also ensures
C that any data (numeric or character) not compliant with the format are not
C output (we also recommend that the other parts of feature (e), {savsum} and
C {prnsum}, be called). As discussed in Data Representation note (2) below,
C base36 data (ITYPE=3) need to be stored in FTRUE as the corresponding numeric
C value (e.g., 9=9.0, A=10.0). Data of ITYPE=3 must be stored left-justified
C in CTRUE (see {bdimma} for field types and constraints).
C
C Data representation notes:
C (1) Printed data: In the header, the field abbreviations (from ABBR) are
C listed vertically. The abbreviations are 1-4 characters in length, so
C the header always occupies four lines (even if a selected subset of
C fields includes no 4-character abbreviations). All decimal points are
C omitted for printing (i.e., each FTRUE value is divided by its FUNITS;
C e.g., LON=33.80/0.01 = 3380 printed). Missing data (FTRUE=FMISS) are
C printed as blank, as are erroneous data, unless the default for FERR is
C changed (see note 3).
C (2) Stored data (FTRUE, ITRUE, and CTRUE): Some 1-character fields (i.e.,
C those with ITYPE=2) have alphabetic base36 values defined (and printed)
C as part of the legal range. In ITRUE and FTRUE, these are stored as
C the corresponding numeric values: A=10, B=11, ..., Z=35. For character
C (ITYPE=3) fields, note that ITRUE and CTRUE contain the ICHAR of the
C first character of the field (e.g., if ID=WHRN, ITRUE(ID)=87). This
C simplifies the implementation of the program, but users should be aware
C of the data type in processing character fields.
C (3) Erroneous data: Erroneous data can be detected in two ways: (i) Data
C that could not be read properly (e.g., a numeric field containing a
C special character). (ii) "Extreme" data, which read properly, but failed
C to adhere to the ranges defined in {bdimma} (e.g., a numeric temperature
C outside of -99.9 to 99.9). Data of the first type are always set to
C FERR, but data of the second type are only set to FERR if {minmax} is
C called. FERR equals FMISS by default. If FERR is set to a non-default
C value such as -888888., the printed output will contain all asterisks in
C fields that contained erroneous data. The non-default setting is also
C used for quality control applications that need to distinguish between
C actual missing data and data that were extant but erroneous.
C
C Machine dependencies: None known. Non-ANSI features: common block
C containing both character and non-character variables, and specification
C statements after data statements.
C For more information: See <imma> and <soft_info> (electronic documents).
C-----------------------------------------------------------------------3456789
PROGRAM RDIMMA
IMPLICIT INTEGER(A-E,G-Z)
C
CHARACTER*10 PROGID
DATA PROGID/'RDIMMA.01H'/
C
C 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)
C
C 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)
C
C IMMT-2/FM13 ATTACHMENT
PARAMETER(ATTI2=100,ATTL2=101,OS=102,OP=103,FM=104,IX=105,W2=106
+,SGN=107,SGT=108,SGH=109,WMI=110,SD2=111,SP2=112,SH2=113,IS=114
+,ES=115,RS=116,IC1=117,IC2=118,IC3=119,IC4=120,IC5=121,IR=122
+,RRR=123,TR=124,QCI=125,QI1=126,QI2=127,QI3=128,QI4=129,QI5=130
+,QI6=131,QI7=132,QI8=133,QI9=134,QI10=135,QI11=136,QI12=137
+,QI13=138,QI14=139,QI15=140,QI16=141,QI17=142,QI18=143,QI19=144
+,QI20=145,QI21=146,HDG=147,COG=148,SOG=149,SLL=150,SLHH=151
+,RWD=152,RWS=153)
C
C MODEL QUALITY CONTROL ATTACHMENT
PARAMETER(ATTI3=154,ATTL3=155,CCCC=156,BUID=157,BMP=158,BSWU=159
+,SWU=160,BSWV=161,SWV=162,BSAT=163,BSRH=164,SRH=165,SIX=166
+,BSST=167,MST=168,MSH=169,BY=170,BM=171,BD=172,BH=173,BFL=174)
C
C SHIP METADATA ATTACHMENT
PARAMETER(ATTI4=175,ATTL4=176,C1M=177,OPM=178,KOV=179,COR=180
+,TOB=181,TOT=182,EOT=183,LOT=184,TOH=185,EOH=186,SIM=187,LOV=188
+,DOS=189,HOP=190,HOT=191,HOB=192,HOA=193,SMF=194,SME=195,SMV=196)
C
C HISTORICAL ATTACHMENT
C
C SUPPLEMENTAL DATA ATTACHMENT
PARAMETER(ATTI99=197,ATTL99=198,ATTE=199,SUPD=200)
C
PARAMETER(NUM=200)
CHARACTER*4 ABBR,RPTID
COMMON /IMMA0/ILEN(NUM),ABBR(NUM),FMIN1(NUM),FMAX1(NUM)
+,FMIN2(NUM),FMAX2(NUM),FUNITS(NUM),ITYPE(NUM),RPTID
C
CHARACTER*1024 RPT,CTRUE
DIMENSION CTRUE(NUM),ITRUE(NUM),FTRUE(NUM)
DATA CTRUE/NUM*' '/,ITRUE/NUM*-999999/,FTRUE/NUM*-999999./
+,FMISS/-999999./,FERR/-999999./,UNIT/10/
real dwpt
C
C PRINT PROGRAM HEADER
c PRINT *,PROGID
C DO NOT PRINT CORE HEADER OR CORE
C CALL PRNSKP(YR,SH)
C DO NOT PRINT ATTACHMENT HEADER OR ATTACHMENT
C CALL PRNSKP(ATTI1,QCZ)
C CALL PRNSKP(ATTI2,RWS)
C CALL PRNSKP(ATTI3,BFL)
C CALL PRNSKP(ATTI4,SMV)
C CALL PRNSKP(ATTI99,SUPD)
C
C PRINT REPORT HEADER
c CALL PRNHDR(ILEN,ABBR,YR,SUPD)
C PRINT CORE HEADER
C CALL PRNHDR(ILEN,ABBR,YR,SH)
C PRINT ATTACHMENT HEADER
C CALL PRNHDR(ILEN,ABBR,ATTI1,QCZ)
C CALL PRNHDR(ILEN,ABBR,ATTI2,RWS)
C CALL PRNHDR(ILEN,ABBR,ATTI3,BFL)
C CALL PRNHDR(ILEN,ABBR,ATTI4,SMV)
C CALL PRNHDR(ILEN,ABBR,ATTI99,SUPD)
C INITIALIZE NUMBER OF REPORTS READ
NREC=0
ftrue(dck)=714.
ftrue(sid)=63.
C
C READ REPORT
100 CONTINUE
c-----------------------------------------------------------------------
c Identifier = WMO Buoy number
c Odate = Observation date (yyyymmdd)
c Otime = Observation time (hhmm)
c Lat = Latitude (positive North)
c Lon = Longitude (positive West)
c QC_POS = Quality control flag for position**
c PDT = Position date ( yyyymmdd)
c PTM = Position time (hhmm)
c Drogue = Drogue depth (m)
c SST = Sea surface temperature (degrees C)
c QC_SST = Quality control flag for SST**
c Airtemp = Air temperature (degrees C)
c QC_AirT = Quality control flag for Air temp**
c Pressure = Air Pressure at sea level (hecto Pascals)
c QC_Pr = Quality control flag for pressure**
c WSp = Wind speed (m/s)
c QC_Wsp = Quality control flag for Wind Speed**
c WDir = Wind direction relative to true North (degrees)
c QC_WD = Quality control flag for Wind direction**
c RelHum = Relative humidity (%)
c QC_RH = Quality control flag for relative humidity**
c
c **Quality Control flags:
c 0=not checked 1=good 3=doubtful 4=bad
c
c Notes about Drogue Depth:
c 9999.9 indicates that the drogue is detached
c A blank value usually means that the buoy was not drogued
c
c
c Identifier,Odate,OTime,Lat,Lon,QC_POS,PDT,PTM,Drogue,SST,QC_SST,Airtemp,QC_AirT,Pressure,QC_Pr,WSp,QC_WS,WDir,QC_WD,RelHum,QC_RH
c-----------------------------------------------------------------------
READ(*,'(A123)',END=900)ctrue(supd)
read(ctrue(supd),'(2a5,2a2,a5,a10,a12,9x,5x,8x,6a10)')
+ ctrue(id)(:5),ctrue(yr)(:5),ctrue(mo)(:2),ctrue(dy)(:2)
+,ctrue(hr)(:5),ctrue(lat)(:10),ctrue(lon)(:12),ctrue(sst)(:10)
+,ctrue(at)(:10),ctrue(slp)(:10),ctrue(w)(:10),ctrue(d)(:10)
+,ctrue(dpt)(:10)
read(ctrue(id) ,'( f5.0)',iostat=ios)ftrue(id)
read(ctrue(yr) ,'(1x,f4.0)',iostat=ios)ftrue(yr)
read(ctrue(mo) ,'( f2.0)',iostat=ios)ftrue(mo)
read(ctrue(dy) ,'( f2.0)',iostat=ios)ftrue(dy)
read(ctrue(hr) ,'(1x,f4.0)',iostat=ios)ftrue(hr)
read(ctrue(lat),'(1x,f9.4)',iostat=ios)ftrue(lat)
read(ctrue(lon),'(1x,f9.4)',iostat=ios)ftrue(lon)
read(ctrue(sst),'(1x,f7.2)',iostat=ios)ftrue(sst)
read(ctrue(at) ,'(1x,f7.2)',iostat=ios)ftrue(at)
read(ctrue(slp),'(1x,f7.2)',iostat=ios)ftrue(slp)
read(ctrue(w) ,'(1x,f7.2)',iostat=ios)ftrue(w)
read(ctrue(d) ,'(1x,f7.2)',iostat=ios)ftrue(d)
read(ctrue(dpt),'(1x,f7.2)',iostat=ios)ftrue(dpt)
if (ctrue(id) ( :5 ).eq.' ') ftrue(id) =fmiss
if (ctrue(yr) (2:4+1).eq.' ') ftrue(yr) =fmiss
if (ctrue(mo) ( :2 ).eq.' ') ftrue(mo) =fmiss
if (ctrue(dy) ( :2 ).eq.' ') ftrue(dy) =fmiss
if (ctrue(hr) (2:4+1).eq.' ') ftrue(hr) =fmiss
if (ctrue(lat)(2:9+1).eq.' ') ftrue(lat)=fmiss
if (ctrue(lon)(2:9+1).eq.' ') ftrue(lon)=fmiss
if (ctrue(sst)(2:7+1).eq.' ') ftrue(sst)=fmiss
if (ctrue(at) (2:7+1).eq.' ') ftrue(at) =fmiss
if (ctrue(slp)(2:7+1).eq.' ') ftrue(slp)=fmiss
if (ctrue(w) (2:7+1).eq.' ') ftrue(w) =fmiss
if (ctrue(d) (2:7+1).eq.' ') ftrue(d) =fmiss
if (ctrue(dpt)(2:7+1).eq.' ') ftrue(dpt)=fmiss
if (index('34',ctrue(lon)(12:12)).ne.0) goto 100
if (index('34',ctrue(sst)(10:10)).ne.0) ftrue(sst)=fmiss
if (index('34',ctrue(at) (10:10)).ne.0) ftrue(at) =fmiss
if (index('34',ctrue(slp)(10:10)).ne.0) ftrue(slp)=fmiss
if (index('34',ctrue(w) (10:10)).ne.0) ftrue(w) =fmiss
if (index('34',ctrue(d) (10:10)).ne.0) ftrue(d) =fmiss
if (index('34',ctrue(dpt)(10:10)).ne.0) ftrue(dpt)=fmiss
if (ftrue(hr).ne.fmiss) then
if (mod(nint(ftrue(hr)),100).ge.60) then
ftrue(hr)=fmiss
else
ftrue(hr)=nint(ftrue(hr))/100+mod(nint(ftrue(hr)),100)/60.
endif
endif
if (ftrue(lon).ne.fmiss) ftrue(lon)=nint(-ftrue(lon)*100.)/100.
if (ftrue(d).ne.fmiss) then
if (mod(nint(ftrue(d)*100.),1000).ne.0) then
ftrue(d)=fmiss
else if (nint(ftrue(d)).eq.0) then
ftrue(d)=361.
endif
endif
if (ftrue(dpt).ne.fmiss) then
if (ftrue(at).eq.fmiss) then
ftrue(dpt)=fmiss
else
ftrue(dpt)=dwpt(ftrue(at),ftrue(dpt))
endif
endif
C INCREMENT NUMBER OF REPORTS READ
NREC=NREC+1
C
C CONVERT CHARACTERS TO FLOATING POINT VALUES
c CALL GETRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR
c +,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM)
C
C CONVERT LONGITUDE TO DEGREES EAST
CALL EAST(ITRUE(LON),FTRUE(LON),FERR)
C SET EXTREME FLOATING POINT VALUES TO ERROR VALUE
CALL MINMAX(CTRUE,ITRUE,FTRUE,FMISS,FERR
+,ILEN,FMIN1,FMAX1,FMIN2,FMAX2,FUNITS,ITYPE,NUM)
ctrue(ti)(:1)=' '
ctrue(li)(:1)=' '
ctrue(di)(:1)=' '
ctrue(wi)(:1)=' '
ctrue(it)(:1)=' '
ftrue(ti)=ftrue(hr)
ftrue(li)=max(ftrue(lat),ftrue(lon))
ftrue(di)=ftrue(d)
ftrue(wi)=ftrue(w)
ftrue(it)=max(ftrue(sst),ftrue(at),ftrue(dpt))
if (ftrue(ti).ne.fmiss) ftrue(ti)=2.
if (ftrue(li).ne.fmiss) ftrue(li)=5.
if (ftrue(di).ne.fmiss) ftrue(di)=0.
if (ftrue(wi).ne.fmiss) ftrue(wi)=8.
if (ftrue(it).ne.fmiss) ftrue(it)=3.
C SAVE SUMMARY INFORMATION
CALL SAVSUM(CTRUE,FTRUE,FMISS,FERR
+,ILEN,ABBR,NUM)
C
C CONVERT FLOATING POINT VALUES TO CHARACTERS
CALL PUTRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR
+,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM)
C WRITE REPORT
WRITE(*,'(A)')RPT(:LENTRM(RPT))
C
C PRINT REPORT
c CALL PRNRPT(ILEN,CTRUE,YR,SUPD)
C PRINT CORE
C CALL PRNRPT(ILEN,CTRUE,YR,SH)
C PRINT ATTACHMENT
C CALL PRNRPT(ILEN,CTRUE,ATTI1,QCZ)
C CALL PRNRPT(ILEN,CTRUE,ATTI2,RWS)
C CALL PRNRPT(ILEN,CTRUE,ATTI3,BFL)
C CALL PRNRPT(ILEN,CTRUE,ATTI4,SMV)
C CALL PRNRPT(ILEN,CTRUE,ATTI99,SUPD)
C
C STOP AFTER SEVERAL REPORTS HAVE BEEN READ
C IF (NREC.GE.50) STOP 'REMOVE STOP TO READ ALL REPORTS'
GOTO 100
C
C END OF FILE
900 CONTINUE
c PRINT *,'REPORTS ',NREC
C
C PRINT SUMMARY INFORMATION TO UNIT
CALL PRNSUM(UNIT,PROGID,ABBR,NUM)
END
c-----------------------------------------------------------------------
FUNCTION DWPT(T,RH)
C INCLUDE 'LIB_DEV:[GUDOC]EDFVAXBOX.FOR/LIST'
C Baker, Schlatter 17-MAY-1982 Original version.
C THIS FUNCTION RETURNS THE DEW POINT (CELSIUS) GIVEN THE TEMPERATURE
C (CELSIUS) AND RELATIVE HUMIDITY (%). THE FORMULA IS USED IN THE
C PROCESSING OF U.S. RAWINSONDE DATA AND IS REFERENCED IN PARRY, H.
C DEAN, 1969: "THE SEMIAUTOMATIC COMPUTATION OF RAWINSONDES,"
C TECHNICAL MEMORANDUM WBTM EDL 10, U.S. DEPARTMENT OF COMMERCE,
C ENVIRONMENTAL SCIENCE SERVICES ADMINISTRATION, WEATHER BUREAU,
C OFFICE OF SYSTEMS DEVELOPMENT, EQUIPMENT DEVELOPMENT LABORATORY,
C SILVER SPRING, MD (OCTOBER), PAGE 9 AND PAGE II-4, LINE 460.
X = 1.-0.01*RH
C COMPUTE DEW POINT DEPRESSION.
DPD =(14.55+0.114*T)*X+((2.5+0.007*T)*X)**3+(15.9+0.117*T)*X**14
DWPT = T-DPD
RETURN
END
C=============================================================================C
C WARNING: Code beyond this point should not require any modification. C
C=============================================================================C
C-----------------------------------------------------------------------3456789
SUBROUTINE INIT(CTRUE,ITRUE,FTRUE,FMISS,ILEN,NUM)
C INITIALIZE CTRUE, ITRUE, AND FTRUE
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*(*) CTRUE
DIMENSION CTRUE(NUM),ITRUE(NUM),FTRUE(NUM),ILEN(NUM)
C
DO 190 I=1,NUM
IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'INIT CTRUE LENGTH'
CTRUE(I)(:ILEN(I))=' '
ITRUE(I)=NINT(FMISS)
FTRUE(I)=FMISS
190 CONTINUE
END
C-----------------------------------------------------------------------3456789
SUBROUTINE EAST(ITRUE,FTRUE,FERR)
C CONVERT LONGITUDE TO DEGREES EAST
IMPLICIT INTEGER(A-E,G-Z)
C
IF(NINT(FTRUE*100.).GE.-36000 .AND. NINT(FTRUE*100.).LE.36000)THEN
FTRUE=MOD(FTRUE+360.,360.)
ITRUE=NINT(FTRUE*100.)
ELSE
FTRUE=FERR
ITRUE=NINT(FERR)
ENDIF
END
C-----------------------------------------------------------------------3456789
SUBROUTINE PRNSKP(BEG,END)
C DO NOT PRINT REPORT HEADER OR REPORT
IMPLICIT INTEGER(A-E,G-Z)
CHARACTER*(*) ABBR,CTRUE
DIMENSION ILEN(*),ABBR(*),CTRUE(*)
CHARACTER*1024 HDR,RPT*2048
EQUIVALENCE(HDR,RPT)
DIMENSION SKP(1024)
DATA SKP/1024*0/
SAVE SKP
C
DO 190 I=BEG,END
SKP(I)=1
190 CONTINUE
RETURN
C-----------------------------------------------------------------------3456789
ENTRY PRNHDR(ILEN,ABBR,BEG,END)
C PRINT REPORT HEADER
C
DO 295 J=1,4
HDR=' '
PTR=0
DO 290 I=BEG,END
IF (SKP(I).EQ.0) THEN
IF (ILEN(I).EQ.1024) THEN
PTR=PTR+1
ELSE
PTR=PTR+ILEN(I)
ENDIF
HDR(PTR:PTR)=ABBR(I)(J:J)
ENDIF
290 CONTINUE
PRINT '(A)',HDR(:PTR)
295 CONTINUE
RETURN
C-----------------------------------------------------------------------3456789
ENTRY PRNRPT(ILEN,CTRUE,BEG,END)
C PRINT REPORT
C
RPT=' '
PTR=0
DO 390 I=BEG,END
IF (SKP(I).EQ.0) THEN
IF (ILEN(I).EQ.1024) THEN
IF (PTR+1.GT.LEN(RPT)) STOP 'PRNRPT RPT LENGTH'
RPT(PTR+1:)=CTRUE(I)
IF (RPT(PTR+1:).NE.CTRUE(I)) STOP 'PRNRPT OVERFLOW'
PTR=LENTRM(RPT)
ELSE
IF (PTR+ILEN(I).GT.LEN(RPT)) STOP 'PRNRPT RPT LENGTH'
IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'PRNRPT CTRUE LENGTH'
RPT(PTR+1:PTR+ILEN(I))=CTRUE(I)(:ILEN(I))
PTR=PTR+ILEN(I)
ENDIF
ENDIF
390 CONTINUE
PRINT '(A)',RPT(:PTR)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE GETRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR
+,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM)
C 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,IFMT(9)*8,STR*2048
DATA IFMT/'(BZ,I1)','(BZ,I2)','(BZ,I3)','(BZ,I4)'
+,'(BZ,I5)','(BZ,I6)','(BZ,I7)','(BZ,I8)','(BZ,I9)'/
SAVE IFMT
C
PTR=0
RST=0
ATTC=1000
DO 180 I=1,NUM
IF (ABBR(I).EQ.'ATTI') THEN
ATTC=MOD(ATTC,1000)
ATTI=NINT(FMIN1(I))
ATTL=NINT(FMIN1(I+1))
IF (RST+4.GT.LEN(STR)) STOP 'GETRPT STR LENGTH'
IF (PTR+4.GT.LEN(RPT)) THEN
STR(RST+1:)=' '
RST=LEN(STR)
GOTO 185
ENDIF
WRITE(STR(RST+1:RST+4),'(2I2)')ATTI,ATTL
IF (ATTL.EQ.0) THEN
IF (RPT(PTR+1:PTR+4).EQ.STR(RST+1:RST+4)) THEN
STR(RST+1:)=RPT(PTR+1:)
IF (STR(RST+1:).NE.RPT(PTR+1:)) STOP 'GETRPT OVERFLOW'
PTR=LEN(RPT)
ELSE
STR(RST+1:)=' '
ENDIF
RST=LEN(STR)
GOTO 185
ELSE
IF (RST+ATTL.GT.LEN(STR)) STOP 'GETRPT STR LENGTH'
IF (RPT(PTR+1:PTR+4).EQ.STR(RST+1:RST+4)) THEN
IF (PTR+ATTL.GT.LEN(RPT)) STOP 'GETRPT RPT LENGTH'
STR(RST+1:RST+ATTL)=RPT(PTR+1:PTR+ATTL)
PTR=PTR+ATTL
ELSE
STR(RST+1:RST+ATTL)=' '
ENDIF
ENDIF
ELSE
IF (ATTC.GE.1000) THEN
IF (RST+ILEN(I).GT.LEN(STR)) STOP 'GETRPT STR LENGTH'
IF (PTR+ILEN(I).GT.LEN(RPT)) STOP 'GETRPT RPT LENGTH'
STR(RST+1:RST+ILEN(I))=RPT(PTR+1:PTR+ILEN(I))
IF (ABBR(I).EQ.' IM') THEN
IF (RPT(PTR+1:PTR+2).NE.RPTID) STOP 'IMMA VERSION INVALID'
ENDIF
PTR=PTR+ILEN(I)
ENDIF
ENDIF
RST=RST+ILEN(I)
180 CONTINUE
185 IF (PTR.LT.LEN(RPT)) THEN
IF (RPT(PTR+1:).NE.' ') STOP 'GETRPT INCOMPLETE'
ENDIF
C
IF (RST.LT.LEN(STR)) STR(RST+1:)=' '
RST=0
DO 190 I=1,NUM
IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'GETRPT CTRUE LENGTH'
C
IF (ILEN(I).EQ.1024) THEN
IF (RST+1.GT.LEN(STR)) STOP 'GETRPT STR LENGTH'
CTRUE(I)=STR(RST+1:)
IF (CTRUE(I).NE.STR(RST+1:)) STOP 'GETRPT OVERFLOW'
RST=LEN(STR)
ELSE
IF (RST+ILEN(I).GT.LEN(STR)) STOP 'GETRPT STR LENGTH'
CTRUE(I)(:ILEN(I))=STR(RST+1:RST+ILEN(I))
RST=RST+ILEN(I)
ENDIF
C
IF (CTRUE(I)(:ILEN(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))
ELSE
ITRUE(I)=ICHAR(CTRUE(I)(:1))
ENDIF
C
IF (ITRUE(I).NE.NINT(FMISS) .AND. ITRUE(I).NE.NINT(FERR)
+ .AND. ITYPE(I).LE.2) THEN
FTRUE(I)=ITRUE(I)*FUNITS(I)
ELSE
FTRUE(I)=ITRUE(I)
ENDIF
190 CONTINUE
RETURN
C-----------------------------------------------------------------------3456789
ENTRY PUTRPT(RPT,CTRUE,ITRUE,FTRUE,FMISS,FERR
+,ILEN,ABBR,FMIN1,FUNITS,ITYPE,RPTID,NUM)
C CONVERT FLOATING POINT VALUES TO CHARACTERS
C
RST=0
DO 280 I=1,NUM
IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'PUTRPT CTRUE LENGTH'
C
IF (FTRUE(I).NE.FMISS .AND. FTRUE(I).NE.FERR
+ .AND. ITYPE(I).LE.2) THEN
ITRUE(I)=NINT(FTRUE(I)/FUNITS(I))
ELSE
ITRUE(I)=NINT(FTRUE(I))
ENDIF
C
IF (ITRUE(I).EQ.NINT(FMISS)) THEN
CTRUE(I)(:ILEN(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),'*')
ELSE
C CTRUE(I)(:1)=CHAR(ITRUE(I))
ENDIF
C
IF (ILEN(I).EQ.1024) THEN
IF (RST+1.GT.LEN(STR)) STOP 'PUTRPT STR LENGTH'
STR(RST+1:)=CTRUE(I)
IF (STR(RST+1:).NE.CTRUE(I)) STOP 'PUTRPT OVERFLOW'
RST=LEN(STR)
ELSE
IF (RST+ILEN(I).GT.LEN(STR)) STOP 'PUTRPT STR LENGTH'
STR(RST+1:RST+ILEN(I))=CTRUE(I)(:ILEN(I))
RST=RST+ILEN(I)
ENDIF
280 CONTINUE
IF (RST.LT.LEN(STR)) STR(RST+1:)=' '
C
PTR=0
RST=0
ATTC=1000
DO 290 I=1,NUM
IF (ABBR(I).EQ.'ATTI') THEN
ATTC=MOD(ATTC,1000)
ATTI=NINT(FMIN1(I))
ATTL=NINT(FMIN1(I+1))
IF (RST+4.GT.LEN(STR)) STOP 'PUTRPT STR LENGTH'
IF (PTR+4.GT.LEN(RPT)) THEN
IF (STR(RST+1:).NE.' ') STOP 'PUTRPT INCOMPLETE'
RST=LEN(STR)
GOTO 295
ENDIF
WRITE(STR(RST+1:RST+4),'(2I2)')ATTI,ATTL
IF (ATTL.EQ.0) THEN
IF (STR(RST+5:).NE.' ') THEN
RPT(PTR+1:)=STR(RST+1:)
IF (RPT(PTR+1:).NE.STR(RST+1:)) STOP 'PUTRPT OVERFLOW'
PTR=LEN(RPT)
ATTC=ATTC+1
ENDIF
RST=LEN(STR)
GOTO 295
ELSE
IF (RST+ATTL.GT.LEN(STR)) STOP 'PUTRPT STR LENGTH'
IF (STR(RST+5:RST+ATTL).NE.' ') THEN
IF (PTR+ATTL.GT.LEN(RPT)) STOP 'PUTRPT RPT LENGTH'
RPT(PTR+1:PTR+ATTL)=STR(RST+1:RST+ATTL)
PTR=PTR+ATTL
ATTC=ATTC+1
ENDIF
ENDIF
ELSE
IF (ATTC.GE.1000) THEN
IF (RST+ILEN(I).GT.LEN(STR)) STOP 'PUTRPT STR LENGTH'
IF (PTR+ILEN(I).GT.LEN(RPT)) STOP 'PUTRPT RPT LENGTH'
RPT(PTR+1:PTR+ILEN(I))=STR(RST+1:RST+ILEN(I))
IF (ABBR(I).EQ.' IM') THEN
RPT(PTR+1:PTR+2)=RPTID
ELSE IF (ABBR(I).EQ.'ATTC') THEN
ATTC=1000+RST*10
ENDIF
PTR=PTR+ILEN(I)
ENDIF
ENDIF
RST=RST+ILEN(I)
290 CONTINUE
295 IF (PTR.LT.LEN(RPT)) RPT(PTR+1:)=' '
ATTC=MOD(ATTC,1000)
IF (ATTC/10.GT.0)
+WRITE(RPT(ATTC/10+1:ATTC/10+1),'(I1)')MOD(ATTC,10)
END
C-----------------------------------------------------------------------3456789
SUBROUTINE MINMAX(CTRUE,ITRUE,FTRUE,FMISS,FERR
+,ILEN,FMIN1,FMAX1,FMIN2,FMAX2,FUNITS,ITYPE,NUM)
C 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)
C
DO 190 I=1,NUM
IF (ITYPE(I).GT.2) THEN
IF (ILEN(I).GT.LEN(CTRUE(I))) STOP 'MINMAX CTRUE LENGTH'
IF (CTRUE(I)(:ILEN(I)).EQ.' ') THEN
ITRUE(I)=NINT(FMISS)
ELSE
ITRUE(I)=ICHAR(CTRUE(I)(:1))
ENDIF
FTRUE(I)=ITRUE(I)
ENDIF
IF (FTRUE(I).NE.FMISS .AND. FTRUE(I).NE.FERR) THEN
IF (ITYPE(I).LE.2) THEN
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. 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
DO 180 J=1,ILEN(I)
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
ENDIF
190 CONTINUE
END
C-----------------------------------------------------------------------3456789
SUBROUTINE SAVSUM(CTRUE,FTRUE,FMISS,FERR
+,ILEN,ABBR,NUM)
C 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))
C
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 (ILEN(I).GT.LEN(CTRUE(I))) STOP 'SAVSUM CTRUE LENGTH'
IF (CTRUE(I)(:ILEN(I)).NE.' ') THEN
SUM3(I)=SUM3(I)+1
WRITE(STR,'(I3,A6,2X,A53)')I,ABBR(I),CTRUE(I)
CALL SAVSTR(STR)
ENDIF
ENDIF
190 CONTINUE
RETURN
C-----------------------------------------------------------------------3456789
ENTRY PRNSUM(UNIT,PROGID,ABBR,NUM)
C PRINT SUMMARY INFORMATION TO UNIT
C
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,'(A6,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
C-----------------------------------------------------------------------3456789
SUBROUTINE SAVSTR(STR)
C SAVE FREQUENCY OF STRING
IMPLICIT INTEGER(A-E,G-Z)
PARAMETER(MMAX=100000)
CHARACTER*64 STR,ARR1
DIMENSION ARR1(MMAX),ARR2(MMAX)
DATA M/0/
SAVE
C
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 'INCREASE MMAX'
M=M+1
ARR1(M)=STR
ARR2(M)=1
RETURN
C-----------------------------------------------------------------------3456789
ENTRY PRNSTR(UNIT)
C PRINT FREQUENCY OF STRING
C
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
C-----------------------------------------------------------------------3456789
INTEGER FUNCTION IB36(B36,IERR)
C CONVERT BASE36 CHARACTER TO INTEGER
CHARACTER B36
INTEGER IERR
CHARACTER*36 STR
DATA STR/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
SAVE STR
C
IB36=INDEX(STR,B36)
IF (IB36.NE.0) THEN
IB36=IB36-1
ELSE
IB36=IERR
ENDIF
END
C-----------------------------------------------------------------------3456789
CHARACTER FUNCTION B36(IB36,ERR)
C CONVERT INTEGER TO BASE36 CHARACTER
INTEGER IB36
CHARACTER ERR
CHARACTER*36 STR
DATA STR/'0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
SAVE STR
C
IF (IB36.GE.0 .AND. IB36.LE.35) THEN
B36=STR(IB36+1:)
ELSE
B36=ERR
ENDIF
END
C-----------------------------------------------------------------------3456789
FUNCTION LENTRM(STR)
C LENGTH OF A STRING MINUS TRAILING BLANKS
CHARACTER STR*(*)
DO 190 LENTRM=LEN(STR),1,-1
IF (STR(LENTRM:LENTRM).NE.' ') RETURN
190 CONTINUE
END
C-----------------------------------------------------------------------3456789
SUBROUTINE SDEG(ITRUE,FTRUE,FERR)
C CONVERT LONGITUDE TO SIGNED DEGREES EAST
IMPLICIT INTEGER(A-E,G-Z)
C
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
C-----------------------------------------------------------------------3456789
SUBROUTINE ZEROS(CTRUE,ILEN,ABBR,ITYPE,NUM)
C 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)'/
C
DO 190 I=1,NUM
IF (CTRUE(I)(:ILEN(I)).NE.' '
+ .AND. ILEN(I).NE.1
+ .AND. ABBR(I).NE.' IM'
+ .AND. ABBR(I).NE.'ATTI'
+ .AND. ABBR(I).NE.'ATTL'
+ .AND. ITYPE(I).EQ.1) THEN
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
C-----------------------------------------------------------------------3456789
BLOCK DATA BDIMMA
C COMMON BLOCK DATA STATEMENTS
IMPLICIT INTEGER(A-E,G-Z)
C
C missing = -999999
C ILEN = field length
C ABBR = field abbreviation
C FMIN1 = field range minimum (first, or only)
C FMAX1 = field range maximum (first, or only)
C FMIN2 = field range minimum (second, or missing)
C FMAX2 = field range maximum (second, or missing)
C FUNITS = field units (missing, if itype=3)
C ITYPE = 1: numeric: decimal range(s)
C 2: numeric: decimal range(s), transformed to base36
C 3: character: decimal range(s), transformed to ascii
C RPTID = 0 (IMMA version that the program can read)
C
PARAMETER(NUM=200)
CHARACTER*4 ABBR,RPTID
COMMON /IMMA0/ILEN(NUM),ABBR(NUM),FMIN1(NUM),FMAX1(NUM)
+,FMIN2(NUM),FMAX2(NUM),FUNITS(NUM),ITYPE(NUM),RPTID
C
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. , 1,
+ 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. ,-999999.,-999999., 1. , 1,
+ 2, 'ATTL', 65. , 65. ,-999999.,-999999., 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. , 15. ,-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', 2. , 2. ,-999999.,-999999., 1. , 1,
+ 2, 'ATTL', 76. , 76. ,-999999.,-999999., 1. , 1,
+ 1, ' OS', 0. , 6. ,-999999.,-999999., 1. , 1,
+ 1, ' OP', 0. , 9. ,-999999.,-999999., 1. , 1,
+ 2, ' FM', 0. , 8. ,-999999.,-999999., 1. , 1,
+ 1, ' IX', 1. , 7. ,-999999.,-999999., 1. , 1,
+ 1, ' W2', 0. , 9. ,-999999.,-999999., 1. , 1,
+ 1, ' SGN', 0. , 9. ,-999999.,-999999., 1. , 1,
+ 1, ' SGT', 0. , 10. ,-999999.,-999999., 1. , 2/
DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I)
+,FUNITS(I),ITYPE(I),I=109,126)/
+ 2, ' SGH', 0. , 50. , 56. , 99. , 1. , 1,
+ 1, ' WMI', 0. , 9. ,-999999.,-999999., 1. , 1,
+ 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, ' QCI', 0. , 9. ,-999999.,-999999., 1. , 1,
+ 1, ' QI1', 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, ' QI2', 0. , 9. ,-999999.,-999999., 1. , 1,
+ 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/
DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I)
+,FUNITS(I),ITYPE(I),I=145,162)/
+ 1, 'QI20', 0. , 9. ,-999999.,-999999., 1. , 1,
+ 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,
+ 2, 'ATTI', 3. , 3. ,-999999.,-999999., 1. , 1,
+ 2, 'ATTL', 66. , 66. ,-999999.,-999999., 1. , 1,
+ 4, 'CCCC', 65. , 90. ,-999999.,-999999.,-999999., 3,
+ 6, 'BUID', 48. , 57. , 65. , 90. ,-999999., 3,
+ 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/
DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I)
+,FUNITS(I),ITYPE(I),I=163,180)/
+ 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,
+ 1, ' SIX', 2. , 3. ,-999999.,-999999., 1. , 1,
+ 4, 'BSST', -99.9 , 99.9 ,-999999.,-999999., 0.1 , 1,
+ 1, ' MST', 0. , 9. ,-999999.,-999999., 1. , 1,
+ 3, ' MSH', 0. , 999. ,-999999.,-999999., 1. , 1,
+ 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', 4. , 4. ,-999999.,-999999., 1. , 1,
+ 2, 'ATTL', 57. , 57. ,-999999.,-999999., 1. , 1,
+ 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/
DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I)
+,FUNITS(I),ITYPE(I),I=181,198)/
+ 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,
+ 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', 99. , 99. ,-999999.,-999999., 1. , 1,
+ 2, 'ATTL', 0. , 0. ,-999999.,-999999., 1. , 1/
DATA (ILEN(I),ABBR(I),FMIN1(I),FMAX1(I),FMIN2(I),FMAX2(I)
+,FUNITS(I),ITYPE(I),I=199,200)/
+ 1, 'ATTE',-999999.,-999999.,-999999.,-999999., 1. , 1,
+1024, 'SUPD', 32. , 126. ,-999999.,-999999.,-999999., 3/
DATA RPTID/' 0'/
END
EOR
rm a.out
f77 p.f
#date
./a.out