C$$$ MAIN PROGRAM DOCUMENTATION BLOCK C . . . . C Test version with csv style output C . . . . C MAIN PROGRAM: SFCDUMP Dump & tutorial program for MADIS surface C PRGMMR: M. BARTH ORG: FSL DATE: 01-07-31 C C ABSTRACT: Dump MADIS surface station info, observations, and quality C control (QC) information for a single time, based on the user's C selections specified in a text parameter file. The program is also C meant as a tutorial to demonstrate how a user can use the MADIS C library calls to write his or her own programs. C C PROGRAM HISTORY LOG: C 01-07-30 M. BARTH Original version -- MADIS Version 2.0 C 02-02-01 M. BARTH Ver. 2.01: Fixed bug where PCPINT/PCPTYPE C should have been handled as 2-element values C (a la SKYCOVLB). C 02-04-30 M. BARTH V2.1: Increased maximum number of station C records from 10000 to 25000. C 03-05-23 M. BARTH V2.2: Increased maximum number of station C records from 25000 to 50000. C 03-07-02 M. BARTH V2.3 - Changed comment re available datasets C 03-10-02 M. BARTH V2.4 - Changed comment re available datasets C 04-03-24 M. BARTH V2.5 - Added COOP dataset and its max/min C temperature time variables. Don't output C records for character variables that are all C blank (missing). Added subprovider variable. C - Changed comment re available datasets C - Added "Output Options" section to the C parameter file. C - Added MMADISCLOSE call. C 05-06-15 L. BENJAM V2.7 - Changed comment re available datasets C - Added XML output format C - Increased maximum number of station records C from 50000 to 100000. C 05-10-27 L. BENJAMIN V2.9 - Changed comment re available datasets C 05-11-18 L. BENJAMIN V3.0 - Changed comment re available datasets C 06-01-30 M. BARTH V3.1 - Changed maximum number of surface C records from 100000 to 200000. C 06-09-20 L. BENJAMIN V3.2 - Added URBANET dataset to sfc data and C changed COOP variables. C 07-05-15 L. BENJAMIN V3.3 - Add CSV ouptut option. Allowed two C values for missing data: -99999 and C blank. C 07-06-15 L. BENJAMIN V3.4 - Fixed CSV format bug for variables C with all missing data. C 07-07-16 L. BENJAMIN V3.5 - Set subpvdr CSV field length to 11 C characters. Fixed SKYCOVER XML format C bug. Added additional backward C compatibility check. C 07-07-20 L. BENJAMIN V3.5 - In the XML format removed number from C end of T24MAXT, T24MINT, FOT15M, and LOT15M C variable names. Removed the starting C blank space from each xml line. C 07-11-16 L. BENJAMIN V3.6 - Changed the QC 99 option criteria for C chosing the highest level of qc. The RSAS C domain sites are the same as before, while C the non-RSAS domain sites need only match C the 2-screened criteria. C 08-06-25 M. BARTH Added high frequency METAR dataset. C 08-06-26 L. BENJAMIN Fix bug in CSV. The bug was CSV format C returned no data unless mesonet or COOP data C was in the selection criteria. C 08-07-25 L. BENJAMIN V3.7 - Changed comment re available datasets C 08-08-01 L. BENJAMIN Restricted the size of csv string by C length instead of by number of variables. C Changed the max length fo the string to 560 C characters. This should increase the number C of variables that a user can display, unless C they are requesting the large footprint C variables like AUTORMK, OPERRMK, STALOC, C SKYCOV, SKYCVLB, PCPINT, and PCPTYPE' C 08-08-08 L. BENJAMIN Fixed 2nd part of CSV output bug for C non-mesonet. C C USAGE: C INPUT FILES: (for the entire program) C C sfcdump.par Parameter file (in current directory) with C user's selections. C C MADIS initialization files in MADIS_STATIC directory C C MADIS observation files under MADIS_DATA directories C C OUTPUT FILES: C C sfcdump.txt Text output of station info, obs & QC C C standard output Log of what was done, errors C C SUBPROGRAMS CALLED: C LIBRARY: - MADISLIB: MINIT, MSETWIN, MSETSFCPVDR, MSETDOM, C MSETQC, MTRNTIM, MSFCSTA, MGETIJ, MGETVCN, C MGETSFC, MGETSFCC, M_LSTCHR, M_MKFNAM, C MMADISCLOSE, M_FRTCHR, M_LSTCHR C C REMARKS: C C 1) This program can be used to exercise all options included in the C MADIS library for surface data. It is also meant to be used as C a tutorial to demonstrate how a user can write his or her own C programs. C C 2) See the INSTALL.* files in the MADIS doc directory for C instructions on how to install and build the MADIS library and C programs (INSTALL.unix for Unix/Linux, INSTALL.windows for C Windows). C C 3) See the sfcdump_usage.txt file in the MADIS doc directory for C instructions on how to set up a parameter file and run the C program. C C ATTRIBUTES: C LANGUAGE: FORTRAN 77 + EXTENSIONS C MACHINE: UNIX C C$$$ C----------------------------------------------------------------------- C Declarations notes: C C 1) Key constants: C C - 0 successful status return C - 999999.0 missing data flag C - 200000 maximum number of surface stations C C 2) Arrays should be dimensioned to 200000, for the maximum number C of surface station records implicit none integer success_p real miss_p parameter (success_p = 0) parameter (miss_p = 999999.0) real csvmissing parameter (csvmissing = -99999.0) integer maxcsvsz parameter (maxcsvsz = 560) integer maxcsvvar,tmpsz,cursz character*24 mstr integer mstrlen integer nstatot,ivcode,idx,ic integer istatus,i,j,k,line integer nsta,nobs,m_lstchr character*10 stanam(200000) character*5 hmstr character*10 dstr character*9 atime character*6 db logical stnhasdata(200000) character*(maxcsvsz) csvstr(200000) integer csvstrendlen(200000) character*9 timeob(200000) integer wmoid(200000) character*10 provdr(200000) real rdata(200000),lat(200000),lon(200000),elev(200000) character*1 qcd(200000) integer qca(200000),qcr(200000) real skycovlb(6,200000),pcpvar(2,200000) character*1 qcdsky(6,200000),qcdpcp(2,200000) integer qcasky(6,200000),qcrsky(6,200000),qcapcp(2,200000) integer qcrpcp(2,200000) character*7 vcode character*7 vcodes(300) integer numvcodes character*40 header,tmpline integer minbck,minfwd,recwin,qctyp,ipvd,idmtyp,vcn,tform,ctime real dummy,ri(200000),rj(200000) integer idummy,time,ising,ilatlon real rpar(7),ftest integer ipar(2) character*1 vtype character*13 tstr,tstr1,tstr2 character*16 xmltstr character*10 pvdrnam,singsta character*63 twstr(0:4) integer twstrlen(0:4) integer qcas,qcae,qcrs,qcre,itextxml,vce,imissval integer ee,es,lte,lts,lne,lns,pe,ps,se,ss,dve,dvs,M_FRTCHR character*14 celev, clat, clon, cdv, cqca, cqcr character*16 qcstr(0:3) character*25 preswea(200000) character*6 c6(200000) character*51 staloc(200000) character*8 skycover(6,200000) character*51 cdata(200000) character*9 c9(200000) character*11 subpvdr(200000) character*80 remark(200000) equivalence(preswea,c6,staloc,skycover,cdata,c9,subpvdr,remark) equivalence(skycovlb,pcpvar,rdata) equivalence(qcdsky,qcdpcp,qcd) equivalence(qcasky,qcapcp,qca) equivalence(qcrsky,qcrpcp,qcr) data twstr/ 1 'Return all records within the file containing nominal time', 2 'Return one record per fixed station, closest to nominal time', 3'Return one record per fixed station, closest to start of window', 4 'Return one record per fixed station, closest to end of window', 5 'Return all records in window'/ data twstrlen/58,60,63,61,28/ data qcstr/'No Filter','Coarse','Screened','Verified'/ C----------------------------------------------------------------------- C PROGRAM SETUP C ------------- C C Open an output file for this program. open(unit=1,file='sfcdump.txt',status='UNKNOWN') C Open the parameter file that will specify the user's selections. open(unit=2,file='sfcdump.par',status='OLD') C----------------------------------------------------------------------- C MANDATORY MADIS INITIALIZATION C ----------------------------- C C Mandatory initialization which must be done before C any other MADIS library calls. C C Initialize the MADIS surface subsystem C ------------------------------------- C C The user selects the "subsystem" to be initialized by C specifying the following arguments to the MINIT call: C C 1) Name of the subsystem: C C 'SFC' Surface (used here) C 'RAOB' Radiosonde C 'NPN' NOAA Profiler Network C 'ACARS' Aircraft data (ACARS, AMDARS, etc.) C 'ACARSP' Aircraft data profiles at airports C 'MAP' Multi-Agency Profilers C 'HYDRO' Hydro C 'RDMTR' Radiometer C 'SATWND' Satellite wind C 'SATSND' Satellite soundings C 'SATRAD' Satellite radiance C 'SNOW' Snow C 'WISDOM' Wisdom balloon wind C C 2) Name of the database: C C 'FSL' Data obtained from FSL C 'AWIPS' Data obtained from AWIPS C C Note that the list of variables with QC found in the MADIS C documentation applies to the FSL database. For the AWIPS C database, the only QC is on sfc mesonet data. Otherwise, the C QC information returned by API calls will indicate that no C QC has been applied. C C 3) Error handling (.true./.false.): C C If ".true.", then error messages will be written to standard C output. If ".false.", no error messages will be output (but C ISTATUS will still contain an error code). The error codes C can be found in errors.txt in the doc directory. C PAR FILE INPUT: Database ('FSL' or 'AWIPS') C The necessary inputs are found in the parameter file, along with C a number of lines of explanation, section delimiters, etc. meant C to aid readability. Throughout this program, we'll be skipping C non-input lines, reading necessary inputs, and checking for I/O C errors. Otherwise, the validity of most of user's choices will C be tested by the affected MADIS library routines. Invalid choices C will be reported to standard output, and in most cases, the C program will then stop. line = 0 do i = 1, 3 line = line + 1 read(2,*,err=825,end=850) enddo line = line + 1 read(2,145,err=825,end=850)db 145 format(a) write(*,500)'MADIS SFCDUMP Activity Log' 500 format(1x,a) write(*,500)'--------------------------' write(*,501)'Database' 501 format(/,1x,a) write(*,401)db 401 format(3x,a) CALL MINIT('SFC',db,.true.,istatus) if(istatus.ne.success_p)stop C----------------------------------------------------------------------- C OPTIONAL MADIS SETUP CALLS C ------------------------- C C Optional calls to limit which obs MADIS will return. C These can be selected at any time in the code, C and will then take effect upon the next call to C MSFCSTA (see below). The default behavior (what C happens if you don't call the routine) is described C below. C C Select time window C ------------------ C C The user selects the nominal time of the data to be returned C when using MADIS routines to read obs and station information. C Time "windowing" is used so that the MADIS routines will C know how close in time each station's observation time needs C to be to the nominal time in order to be included, and whether C or not duplicate records from the same station that are within C the time window should be included. The time window is C specified with the MSETWIN subroutine, which allows the user C to select the number of minutes before and after the nominal C time to be used for the window, and how duplicates should C be handled. For more details, see msetwin.txt in the doc C directory. C C If MSETWIN is not called, the default will be to return all C records (including multiple reports from the same station) C in the file containing the nominal time. For non-mesonet C stations, this will return observation times between 15 C minutes before the hour and 44 minutes after the hour. For C mesonet stations, data will cover from the hour until 59 C minutes after the hour. C C Surface stations report observation times around the hour, and C many stations report multiple times per hour, so different C time window specifications can produce very different sets C of data. C C The following sample MSETWIN call will return only one record C per station within the specified time window (-30 minutes --> C nominal time --> +30 minutes). If a station has multiple reports C within the time window, only the latest one within the window C will be returned (RECWIN = 3). C C Sample MSETWIN call: C C minbck = -30 C minfwd = 30 C recwin = 3 C CALL MSETWIN(minbck,minfwd,recwin,istatus) C PAR FILE INPUT: Time window parameters (minbck, minfwd, recwin) C [set all to 0 for default] do i = 1, 3 line = line + 1 read(2,*,err=825,end=850) enddo line = line + 1 read(2,*,err=825,end=850)minbck line = line + 1 read(2,*,err=825,end=850)minfwd line = line + 1 read(2,*,err=825,end=850)recwin write(*,501)'Time Window' if(recwin.ge.0.and.recwin.le.4)then write(*,401)twstr(recwin)(1:twstrlen(recwin)) if(minbck.ne.0.or.minfwd.ne.0.or.recwin.ne.0)then write(*,502)'Start minute relative to nominal time ',minbck 502 format(3x,a,i4) write(*,502)'End minute relative to nominal time ',minfwd CALL MSETWIN(minbck,minfwd,recwin,istatus) if(istatus.ne.success_p)stop endif else write(*,500)'SFCDUMP: INVALID WINDOW RECORD TYPE' stop endif C Select a subset of surface datasets C ----------------------------------- C C Surface datasets include many different networks run C by different "providers". The MSETSFCPVDR subroutine C can be used to select only a subset of the total by C specifying which providers are to be included or C excluded. C C If MSETSFCPVDR is not called, the default is to enable C data from all surface providers. C C Here's the list of provider names recognized by MADIS: C C 'ALL-SFC' All surface providers C 'ALL-MESO' All mesonet providers C 'ALL-MTR' All METAR reports C 'ASOS' ASOS METAR reports (NWS & FAA) C 'OTHER-MTR' Non-ASOS METAR reports C 'SAO' SAO reports C 'MARITIME' Buoys, ships, C-MAN stations C 'COOP' Modernized NWS Cooperative Observer stations C 'UrbaNet' Urban network C 'ALL-HFMTR' All high frequency METAR reports C 'ASOS-AFM' ASOS high frequency METAR reports (NWS & FAA) C 'OTHER-AFM' Non-ASOS high frequency METAR reports C C For a list of the provider names for mesonets that are C currently available from FSL, see: C C http://madis.noaa.gov/mesonet_providers.html C C For AWIPS users, the "Data provider" specified for each mesonet C in the /data/fxa/LDAD/data/*.desc files is what's used for C the MADIS provider name. C C Here's an example of how to get only ASOS's. First you C disable everything, then select the one(s) you want. C C CALL MSETSFCPVDR('ALL-SFC',.false.,istatus) C CALL MSETSFCPVDR('ASOS',.true.,istatus) C PAR FILE INPUT: Providers (0 - all providers, C N - N lines of provider names follow) do i = 1, 7 line = line + 1 read(2,*,err=825,end=850) enddo line = line + 1 read(2,*,err=825,end=850)ipvd line = line + 1 read(2,*,err=825,end=850) write(*,501)'Providers' if(ipvd.gt.0)then CALL MSETSFCPVDR('ALL-SFC',.false.,istatus) do i = 1, ipvd line = line + 1 read(2,145,err=825,end=850)pvdrnam CALL MSETSFCPVDR(pvdrnam,.true.,istatus) if(istatus.eq.success_p)write(*,401)pvdrnam C Note that we don't exit if bad status is returned by MSETSFCPVDR. C This is because you might have chosen a provider name from the C MADIS web site that hasn't yet been entered into the internal C table kept by MADIS on your system. The internal table will C be automatically updated with new providers as they appear in C data files obtained from FSL. enddo else if(ipvd.eq.0)then write(*,401)'ALL-SFC' else write(*,500)'SFCDUMP: INVALID PROVIDER SELECTION' stop endif C Select a horizontal domain C -------------------------- C C The horizontal domain can be limited to match one of two map C projections (polar stereographic, Lambert conformal conic) or it C can be limited to a latitude/longitude rectangle. Only stations C within the domain will be returned. If one of the map projections C is selected, any winds (of any form) returned by subsequent C MGETSFC calls will be rotated to match the projection. See C msetdom.txt in the doc directory for an explanation of the C parameters needed to define the domains. C C If MSETDOM is not called, all available stations will be C returned, regardless of their location. C C The example given here is for the CONUS 212 Lambert conformal C conic projection. C C CALL MSETDOM(3,40635.25,12.19,-133.459,-95.0,25.0,25.0,dummy, C 1 185,129,istatus) C PAR FILE INPUT: Domain Filter (0 - don't filter, C 1 - lat/lon corners, C 2 - Polar Stereographic grid, C 3 - Lambert Conformal Conic grid) do i = 1, 3 line = line + 1 read(2,*,err=825,end=850) enddo line = line + 1 read(2,*,err=825,end=850)idmtyp C We'll read in the parameters appropriate for the selected C domain filter, and skip over all of the other lines in the C rest of this section of the parameter file. write(*,501)'Domain Filter' if(idmtyp.eq.1)then do i = 1, 6 line = line + 1 read(2,*,err=825,end=850) enddo do i = 1, 4 line = line + 1 read(2,*,err=825,end=850)rpar(i) enddo do i = 1, 23 line = line + 1 read(2,*,err=825,end=850) enddo write(*,401)'Latitude/Longitude Corners' write(*,402)'SW corner latitude (north) ', 1 rpar(1) 402 format(3x,a,f13.6) write(*,402)'SW corner longitude (east) ', 1 rpar(2) write(*,402)'NE corner latitude (north) ', 1 rpar(3) write(*,402)'NE corner longitude (east) ', 1 rpar(4) CALL MSETDOM(idmtyp,rpar(1),rpar(2),rpar(3),rpar(4),dummy, 1 dummy,dummy,idummy,idummy,istatus) else if(idmtyp.eq.2)then do i = 1, 13 line = line + 1 read(2,*,err=825,end=850) enddo do i = 1, 7 line = line + 1 read(2,*,err=825,end=850)rpar(i) enddo do i = 1, 2 line = line + 1 read(2,*,err=825,end=850)ipar(i) enddo do i = 1, 11 line = line + 1 read(2,*,err=825,end=850) enddo write(*,401)'Polar Stereographic Grid' write(*,402)'Grid box size (meters) ', 1 rpar(1) write(*,402)'Latitude (north) of 1st grid point ', 1 rpar(2) write(*,402)'Longitude (east) of 1st grid point ', 1 rpar(3) write(*,402)'Orientation longitude (east) ', 1 rpar(4) write(*,402)'I-coordinate of pole ', 1 rpar(5) write(*,402)'J-coordinate of pole ', 1 rpar(6) write(*,402)'Latitude (north) at which X-Y scale is true', 1 rpar(7) write(*,403)'Number of grid points (X) ', 1 ipar(1) write(*,403)'Number of grid points (Y) ', 1 ipar(2) 403 format(3x,a,i6) CALL MSETDOM(idmtyp,rpar(1),rpar(2),rpar(3),rpar(4),rpar(5), 1 rpar(6),rpar(7),ipar(1),ipar(2),istatus) else if(idmtyp.eq.3)then do i = 1, 25 line = line + 1 read(2,*,err=825,end=850) enddo do i = 1, 6 line = line + 1 read(2,*,err=825,end=850)rpar(i) enddo do i = 1, 2 line = line + 1 read(2,*,err=825,end=850)ipar(i) enddo write(*,401)'Lambert Conformal Conic Grid' write(*,402)'Grid box size (meters) ', 1 rpar(1) write(*,402)'Latitude (north) of 1st grid point ', 1 rpar(2) write(*,402)'Longitude (east) of 1st grid point ', 1 rpar(3) write(*,402)'Orientation longitude (east) ', 1 rpar(4) write(*,402)'Latitude (north) of 1st tangent ', 1 rpar(5) write(*,402)'Latitude (north) of 2nd tangent ', 1 rpar(6) write(*,403)'Number of grid points (X) ', 1 ipar(1) write(*,403)'Number of grid points (Y) ', 1 ipar(2) CALL MSETDOM(idmtyp,rpar(1),rpar(2),rpar(3),rpar(4),rpar(5), 1 rpar(6),dummy,ipar(1),ipar(2),istatus) else if(idmtyp.eq.0)then write(*,401)'No Filter' do i = 1, 33 line = line + 1 read(2,*,err=825,end=850) enddo else write(*,500)'SFCDUMP: INVALID DOMAIN TYPE' stop endif if(istatus.ne.success_p)stop C Select QC level of data to be returned C -------------------------------------- C C The primary variables in all MADIS datasets have been screened C by automated quality control (QC) checks. Different variables C have different levels of QC, or "stages", applied to them. C For example, temperature may have level 1 checks (validity), C level 2 checks (internal consistency, temporal consistency), C and level 3 checks (spatial consistency). Note that each C level of QC incorporates the previous levels, i.e., an ob C that has passed level 3 has also passed any applicable level C 1 and 2 checks. See sfc_qc_variable_list.txt in the doc C directory for more information. C C Each call to MGETSFC will return obs and associated QC C information. If the user doesn't want to interpret the QC info, C he or she can limit the returned obs to selectable levels of C quality. In that case, obs that don't meet the selected QC level C will be replaced with missing data flags, and the QC information C itself doesn't need to be examined by the calling program. C C If MSETQC is not called, all obs will be returned (along with QC C info). C C There are three ways that the user can request and process the QC C information: C C 1) Don't call MSETQC at all, and examine the QC info before C deciding whether or not to use each observation. This C allows the calling program the maximum amount of control C over what's available. C C 2) If you know ahead of time that the same level of QC is C available for all variables you'll be using, call MSETQC C one time to select the desired QC level. Note that the C level selected by MSETQC will stay in effect until the C next time MSETQC is called. C C 3) To require that all variables pass the highest level C of QC that are specified for them, call MSETQC one time C and select QC level 99. C C User's of MADIS data who want the data filtered by QC results, C but don't want to interpret the QC information themselves, should C call MSETQC one time and select QC level 99. C PAR FILE INPUT: QC level (0-none, 1-coarse, 2-screened, C 3-verified, 99-highest possible) do i = 1, 3 line = line + 1 read(2,*,err=825,end=850) enddo line = line + 1 read(2,*,err=825,end=850)qctyp write(*,501)'QC Filter' if(qctyp.ge.0.and.qctyp.le.3)then write(*,401)qcstr(qctyp) else if(qctyp.eq.99)then write(*,401)'Highest Possible' else write(*,500)'SFCDUMP: INVALID QC TYPE' stop endif if(db(1:5).eq.'AWIPS'.and.qctyp.ne.0) 1 write(*,401)'AWIPS database - QC will only be available on '// 2 'mesonet data' C Select the QC level to be returned. CALL MSETQC(qctyp,istatus) if(istatus.ne.success_p)stop C----------------------------------------------------------------------- C SELECT NOMINAL TIME OF DATA TO BE RETURNED C ------------------------------------------ C C The MADIS library's native time zone and format is Universal C Coordinated Time, using a Julian date, in the form of "YYJJJHHMM", C where: C C YY = 2-digit year (good from 1980 - 2179) C JJJ = Julian date of the year (001-366) C HH = Hour (00-23) C MM = Minute (00-59) C C MADIS also provides support for a "Month/Day" date format, using C "YYYYMMDD_HHMM", where: C C YYYY = 4-digit year (still only good from 1980 - 2179) C MMDD = Month/Day C HHMM = Hour/Minute C C The MADIS library includes a basic set of routines that the caller C can use to: C C - Add & subtract time in the native format. (MCHGTIM) C - Translate the native format to integers representing year, C month, day, hour, and minute. (MINTTIM) C - Translate integers representing year, month, day, hour and C minute into the native format. (MCHRTIM) C - Translate between Julian and Month/Day formats (MTRNTIM) C C See time_routines.txt in the doc directory for details on how C to use these calls. C C Also note that nominal times can be specified at any minute, not C just at the top of the hour (minute 00). C PAR FILE INPUT: Time format to use (0 - Julian, 1 - Month/Day) write(*,501)'Nominal Time' do i = 1, 7 line = line + 1 read(2,*,err=825,end=850) enddo line = line + 1 read(2,*,err=825,end=850)tform if(tform.ne.0.and.tform.ne.1)then write(*,500)'SFCDUMP: INVALID TIME TRANSLATION FORMAT' stop endif C PAR FILE INPUT: Nominal time (0 - specified in par file, C 1 - use current time) line = line + 1 read(2,*,err=825,end=850) line = line + 1 read(2,*,err=825,end=850)ctime line = line + 1 read(2,*,err=825,end=850) C PAR FILE INPUT: Nominal time (in selected format) line = line + 1 read(2,144,err=825,end=850)tstr 144 format(a) C If the user wants to use the current time, get it and translate C that into the chosen format (via our internal formats). C Otherwise we have the chosen format in TSTR right now. if(ctime.eq.1)then i = TIME() i = i - 1325376000 CALL M_MKFNAM(i,atime,istatus) if(tform.eq.1)then CALL MTRNTIM(atime,2,tstr,istatus) else tstr = atime endif endif if(tform.eq.1)then CALL MTRNTIM(tstr,1,atime,istatus) if(istatus.ne.success_p)stop else atime = tstr endif write(*,401)tstr C----------------------------------------------------------------------- C ADDITIONAL DUMP PROGRAM OPTIONS C ------------------------------- C C For most purposes, you'll want to read data for all stations C that meet the criteria already specified above. For dump program C purposes, however, we offer the option to only get one station. write(*,501)'Station Selection' C PAR FILE INPUT: Station Selection (0 - all stations, 1 - single) do i = 1, 3 line = line + 1 read(2,*,err=825,end=850) enddo line = line + 1 read(2,*,err=825,end=850)ising line = line + 1 read(2,*,err=825,end=850) line = line + 1 read(2,144,err=825,end=850)singsta if(ising.eq.1)then write(*,401)singsta else write(*,401)'All stations' endif C To allow backward compatibility for the sfcdump.par files that C users may have developed before the Output Options section of C the parameter file was available, we'll determine which section C we encounter next in the parameter file, then proceed accordingly. line = line + 1 read(2,*,err=825,end=850) line = line + 1 read(2,144,err=825,end=850)header if(index(header,'Output Options').ne.0)then C The latitude and longitude can either be output using two digits C after the decimal point (the original setting prior to adding C this option) or the full 7-digits of possible precision can be C selected. This means latitude will have 5 digits after the C decimal point and longitude 4 digits. C C PAR FILE INPUT: Latitude/longitude format line = line + 1 read(2,*,err=825,end=850) line = line + 1 read(2,*,err=825,end=850)ilatlon if(ilatlon.eq.0)then write(*,501)'Lat/lon with 2 digits after decimal place' else if(ilatlon.eq.1)then write(*,501)'Lat with 5 digits after decimal place, lon', 1 ' with 4 digits' else write(*,500)'SFCDUMP: INVALID LAT/LON OUTPUT TYPE' stop endif do i = 1, 1 line = line + 1 read(2,145,err=825,end=850)tmpline enddo C 1 - CHECK OUTPUT OPTIONS SET BEFORE CHECKING TEXT/XML FORMAT C 2 - CHECK FOR BLANK LINE BEFORE GOING ON C To allow backward compatibility for the sfcdump.par files that C users may have developed before the Output Options section of C the parameter file was available, we'll determine which section C we encounter next in the parameter file, then proceed accordingly. C Decide output format of text or XML. line = line + 1 read(2,145,err=825,end=850)tmpline j = M_LSTCHR(tmpline,LEN(tmpline)) if(j.GT.0)then itextxml = 0 do i = 1, 2 line = line + 1 read(2,*,err=825,end=850) enddo write(*,501)'No text output format, set to text format.' else line = line + 1 read(2,*,err=825,end=850)itextxml if(itextxml.eq.0)then write(*,501)'Text output format (original format)' else if(itextxml.eq.1)then write(*,501)'XML output format' else if(itextxml.eq.2)then write(*,501)'Comma-separated-variable (CSV) '// 1 'text output without QC info' else if(itextxml.eq.3)then write(*,501)'CSV text output with QC data descriptors' else if(itextxml.eq.4)then write(*,501)'CSV text output with full QC information' else write(*,500)'SFCDUMP: INVALID TEXT/XML OUTPUT FORMAT' stop endif C Skip xml output format info line line = line + 1 read(2,*,err=825,end=850) C 1 - CHECK FOR CSV INFO LINES, FORMAT CHANGE C To allow backward compatibility for the sfcdump.par files that C users may have developed before the Output Options section of C the parameter file was enlarged, we'll determine if their are CSV C info lines, then proceed accordingly. line = line + 1 read(2,145,err=825,end=850)tmpline j = index(tmpline,'---------') C First CSV format check, normal par file if(j.EQ.0)then line = line + 1 read(2,*,err=825,end=850) line = line + 1 read(2,*,err=825,end=850) line = line + 1 read(2,145,err=825,end=850)tmpline j = M_LSTCHR(tmpline,LEN(tmpline)) C Variable showed up where we should have a blank line, must C be an old format if(j.EQ.0)then line = line + 1 read(2,*,err=825,end=850)imissval if(itextxml.ge.2.and.itextxml.le.4.)then if(imissval.eq.0)then write(*,501)'Using -99999.000000 for missing '// 1 'fields' else if(imissval.eq.1)then write(*,501)'Using blanks for missing fields' else write(*,500)'SFCDUMP: INVALID CSV MISSING '// 1 'FIELD VALUE' stop endif endif do i = 1, 4 line = line + 1 read(2,*,err=825,end=850) enddo else C We read a variable line, so reset for next section backspace(2) endif else do i = 1, 2 line = line + 1 read(2,*,err=825,end=850) enddo endif endif else ilatlon = 0 line = line + 1 read(2,*,err=825,end=850) endif C----------------------------------------------------------------------- C LOAD IN STATION INFO FOR SELECTED DATA C -------------------------------------- C C Load in the stations for all selected datasets, covering C the selected domain. The MSFCSTA call needs to be done C as the first call when getting data for a new time, or C whenever any of the optional setup calls are used. Thereafter, C MGETSFC and MGETSFCC can be called as many times as desired in C order to read variables. CALL MSFCSTA(atime,nsta,stanam,wmoid,lat,lon,elev,timeob, 1 provdr,istatus) if(istatus.ne.success_p)stop C If one of the map projections has been selected for the horizontal C domain, the station latitude and longitude can be converted to a C floating point grid index into the 2-dimensional grid (RI,RJ). C Note that this works for grids laid out this way: C C NE (I=NX,J=NY) C C SW (I=1,J=1) C C If we're to convert LAT/LON to RI,RJ for the user's grid, do C so. Otherwise, fill in 0's so there'll be something in the C output line that isn't too messy. if(idmtyp.eq.2.or.idmtyp.eq.3)then do i = 1, nsta CALL MGETIJ(lat(i),lon(i),ri(i),rj(i),istatus) enddo else do i = 1, nsta ri(i) = 0 rj(i) = 0 enddo endif C----------------------------------------------------------------------- C LOOP THROUGH DESIRED VARIABLES: C ------------------------------- C C Variables are specified by code names. The list of code names C can be found in the first column of sfc_variable_list.txt in the C doc directory. C C This program will read in one variable code per line in the C parameter file, read it, output it, then move on to the next C variable until the end of the parameter file is reached. write(*,501)'Variables' C Header for XML file if(itextxml.eq.1)then write(1,8005) 8005 format('') endif C C CSV output C if(itextxml.gt.1)goto 34000 C C TEXTXML Option 0 (text) and 1 (xml) C C PAR FILE INPUT: Variable code 100 read(2,145,err=825,end=900)vcode if(vcode.eq.' ')go to 100 C The internal MGETVCN routine is used to determine the type C (numeric or character) of the variable. In general, a user's C MADIS program shouldn't have to make this determination C (as you would know what variables you're reading). CALL MGETVCN(vcode,vcn,vtype,istatus) if(istatus.ne.success_p)go to 900 write(*,505)vcode 505 format(3x,'Processing',5x,a) vce = M_LSTCHR(vcode,LEN(vcode)) C Read the desired variable and QC info. The returned arrays C will match the records in the station info arrays returned C from MSFCSTA. If a QC level has been selected, the obs will C only be returned if they meet or exceed the selected QC C level. if(vtype.eq.'N')then C The MGETSFC routine is used to read all numeric variables. C All variables are returned as Fortran REAL type (RDATA), the C QC data descriptors are always CHARACTER*1 (QCD), and the C bit maps showing the QC checks that were applied (QCA) and C their results (QCR) are always INTEGER. CALL MGETSFC(atime,vcode,nsta,nobs,rdata,qcd,qca,qcr,istatus) if(itextxml.eq.1)then if(istatus.ne.success_p.or.nobs.eq.0)go to 100 else write(1,146)'var ',vcode,' total stns ',nsta, 1 ' # non-missing obs ',nobs 146 format(/,1x,a,a,a,i5,a,i5) if(istatus.ne.success_p.or.nobs.eq.0)go to 100 C Output the station info, the variable and its QC. write(1,*) if(ilatlon.ne.1)then write(1,6001)vcode 6001 format(11x,'Station Elev(m) Lat(N) Lon(E) Grid I', 1 ' Grid J ObTime Provider ',a, 2 ' QCD QCA QCR',/) else write(1,6003)vcode 6003 format(11x,'Station Elev(m) Lat(N) Lon(E) ', 1 'Grid I Grid J ObTime Provider ',a, 2 ' QCD QCA QCR',/) endif endif do 200 i = 1, nsta C If we're getting only one station, make sure this is it. if(ising.eq.1.and.singsta.ne.stanam(i))go to 200 C XML formats if(itextxml.eq.1)then CALL MTRNTIM(timeob(i),2,tstr2,istatus) C XML time format is YYY-MM-DDTHH:MM -- 2004-06-04T16:01 xmltstr = tstr2(1:4)//'-'//tstr2(5:6)//'-'// 1 tstr2(7:8)//'T'//tstr2(10:11)//':'// 2 tstr2(12:13) 147 format(i3) 148 format(f6.1) 149 format(f6.2) 150 format(f7.2) 151 format(f9.4) 152 format(f9.5) 153 format(f7.0) 154 format(f13.6) C Elevation write(celev,150)elev(i) es = M_FRTCHR(celev,LEN(celev)) ee = M_LSTCHR(celev,LEN(celev)) C Provider pe = M_LSTCHR(provdr(i),LEN(provdr(i))) C Station se = M_LSTCHR(stanam(i),LEN(stanam(i))) if(ilatlon.ne.1)then C Latitude write(clat,149)lat(i) lts = M_FRTCHR(clat,LEN(clat)) lte = M_LSTCHR(clat,LEN(clat)) C Longitude write(clon,150)lon(i) lns = M_FRTCHR(clon,LEN(clon)) lne = M_LSTCHR(clon,LEN(clon)) else C Latitude write(clat,152)lat(i) lts = M_FRTCHR(clat,LEN(clat)) lte = M_LSTCHR(clat,LEN(clat)) C Longitude write(clon,151)lon(i) lns = M_FRTCHR(clon,LEN(clon)) lne = M_LSTCHR(clon,LEN(clon)) endif else if(tform.eq.0)then tstr = ' '//timeob(i) else if(tform.eq.1)then CALL MTRNTIM(timeob(i),2,tstr,istatus) endif endif C Only output records for non-missing obs. if(rdata(i).ne.miss_p.and.vcode.ne.'SKYCVLB'.and. 1 vcode.ne.'PCPINT'.and.vcode.ne.'PCPTYPE')then if(itextxml.eq.1)then C Data value write(cdv,154)rdata(i) dvs = M_FRTCHR(cdv,LEN(cdv)) dve = M_LSTCHR(cdv,LEN(cdv)) C QCA write(cqca,147)qca(i) qcas = M_FRTCHR(cqca,LEN(cqca)) qcae = M_LSTCHR(cqca,LEN(cqca)) C QCR write(cqcr,147)qcr(i) qcrs = M_FRTCHR(cqcr,LEN(cqcr)) qcre = M_LSTCHR(cqcr,LEN(cqcr)) write(1,8002)vcode(1:vce),stanam(i)(1:se), 1 celev(es:ee),clat(lts:lte),clon(lns:lne), 2 xmltstr,provdr(i)(1:pe), 3 cdv(dvs:dve),qcd(i),cqca(qcas:qcae), 4 cqcr(qcrs:qcre) 8002 format('') else if(ilatlon.ne.1)then write(1,7001)vcode,stanam(i),elev(i),lat(i),lon(i), 1 ri(i),rj(i),tstr,provdr(i),rdata(i), 2 qcd(i),qca(i),qcr(i) 7001 format(1x,'V-',a,1x,a,1x,f7.2,1x,f6.2,1x,f7.2,1x, 1 2(f8.3,1x),a,1x,a,1x,f13.6,1x,a1,1x,i3,1x,i3) else write(1,7011)vcode,stanam(i),elev(i),lat(i),lon(i), 1 ri(i),rj(i),tstr,provdr(i),rdata(i), 2 qcd(i),qca(i),qcr(i) 7011 format(1x,'V-',a,1x,a,1x,f7.2,1x,f9.5,1x,f9.4,1x, 1 2(f8.3,1x),a,1x,a,1x,f13.6,1x,a1,1x,i3,1x,i3) endif endif C XML OUTPUT SPECIAL CASES SKY... else if(vcode.eq.'SKYCVLB')then do k = 1, 6 if(skycovlb(k,i).ne.miss_p)then if(itextxml.eq.1)then do j=1, 6 if(skycovlb(j,i).ne.999999.)then C Data value write(cdv,153)skycovlb(j,i) dvs = M_FRTCHR(cdv,LEN(cdv)) dve = M_LSTCHR(cdv,LEN(cdv)) C QCA write(cqca,147)qcasky(j,i) qcas = M_FRTCHR(cqca,LEN(cqca)) qcae = M_LSTCHR(cqca,LEN(cqca)) C QCR write(cqcr,147)qcrsky(j,i) qcrs = M_FRTCHR(cqcr,LEN(cqcr)) qcre = M_LSTCHR(cqcr,LEN(cqcr)) write(1,8002)vcode(1:vce)//char(j+48), 1 stanam(i)(1:se),celev(es:ee), 2 clat(lts:lte),clon(lns:lne),xmltstr, 3 provdr(i)(1:pe),cdv(dvs:dve), 4 qcdsky(j,i),cqca(qcas:qcae), 5 cqcr(qcrs:qcre) endif enddo else if(ilatlon.ne.1)then write(1,7003)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 (skycovlb(j,i),qcdsky(j,i), 3 qcasky(j,i),qcrsky(j,i),j=1,6) 7003 format(1x,'V-',a,1x,a,1x,f7.2,1x,f6.2,1x, 1 f7.2,1x,2(f8.3,1x),a,1x,a,6(1x,f7.0,1x, 2 a1,1x,i3,1x,i3)) else write(1,7013)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 (skycovlb(j,i),qcdsky(j,i), 3 qcasky(j,i),qcrsky(j,i),j=1,6) 7013 format(1x,'V-',a,1x,a,1x,f7.2,1x,f9.5,1x, 1 f9.4,1x,2(f8.3,1x),a,1x,a,6(1x,f7.0,1x, 2 a1,1x,i3,1x,i3)) endif endif go to 200 endif enddo else if(vcode.eq.'PCPINT'.or.vcode.eq.'PCPTYPE')then do k = 1, 2 if(pcpvar(k,i).ne.miss_p)then if(itextxml.eq.1)then do j=1, 2 C Data value write(cdv,153)pcpvar(j,i) dvs = M_FRTCHR(cdv,LEN(cdv)) dve = M_LSTCHR(cdv,LEN(cdv)) C QCA write(cqca,147)qcapcp(j,i) qcas = M_FRTCHR(cqca,LEN(cqca)) qcae = M_LSTCHR(cqca,LEN(cqca)) C QCR write(cqcr,147)qcrpcp(j,i) qcrs = M_FRTCHR(cqcr,LEN(cqcr)) qcre = M_LSTCHR(cqcr,LEN(cqcr)) write(1,8002)vcode(1:vce)//char(j+48), 1 stanam(i)(1:se),celev(es:ee), 2 clat(lts:lte),clon(lns:lne),xmltstr, 3 provdr(i)(1:pe),cdv(dvs:dve), 4 qcdpcp(j,i),cqca(qcas:qcae), 5 cqcr(qcrs:qcre) enddo else if(ilatlon.ne.1)then write(1,7004)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 (pcpvar(j,i),qcdpcp(j,i), 3 qcapcp(j,i),qcrpcp(j,i),j=1,2) 7004 format(1x,'V-',a,1x,a,1x,f7.2,1x,f6.2,1x, 1 f7.2,1x,2(f8.3,1x),a,1x,a,2(1x,f7.0,1x, 2 a1,1x,i3,1x,i3)) else write(1,7014)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 (pcpvar(j,i),qcdpcp(j,i), 3 qcapcp(j,i),qcrpcp(j,i),j=1,2) 7014 format(1x,'V-',a,1x,a,1x,f7.2,1x,f9.5,1x, 1 f9.4,1x,2(f8.3,1x),a,1x,a,2(1x,f7.0,1x, 2 a1,1x,i3,1x,i3)) endif endif go to 200 endif enddo endif 200 continue else if(vtype.eq.'C')then C The MGETSFCC routine is used to read character variables. No QC C is currently available for any of these variables. Only two of C the character variables are actually observations (present weather C and sky cover). The other character variables are metadata, e.g., C METAR report types ("METAR", "SPECI", "TEST"). Note that there C are no missing data flags for character data, and therefore no C equivalent of the NOBS argument returned from MGETSFC; instead, C blanks are filled in where no genuine data exist. CALL MGETSFCC(atime,vcode,nsta,cdata,istatus) if(itextxml.ne.1)then write(1,146)'var ',vcode,' total stns ',nsta write(1,*) endif if(istatus.ne.success_p)go to 100 if(itextxml.ne.1)then if(ilatlon.ne.1)then write(1,6002)vcode 6002 format(11x,'Station Elev(m) Lat(N) Lon(E) Grid I', 1 ' Grid J ObTime Provider ',a,/) else write(1,6004)vcode 6004 format(11x,'Station Elev(m) Lat(N) Lon(E) ', 1 'Grid I Grid J ObTime Provider ',a,/) endif endif C Output the station info and variable to the test output file. do 300 i = 1, nsta C If we're getting only one station, make sure this is it. if(ising.eq.1.and.singsta.ne.stanam(i))go to 300 if(itextxml.eq.1)then C XML formats CALL MTRNTIM(timeob(i),2,tstr2,istatus) C XML time format is YYY-MM-DDTHH:MM -- 2004-06-04T16:01 xmltstr = tstr2(1:4)//'-'//tstr2(5:6)//'-'// 1 tstr2(7:8)//'T'//tstr2(10:11)//':'// 2 tstr2(12:13) C Elevation write(celev,150)elev(i) es = M_FRTCHR(celev,LEN(celev)) ee = M_LSTCHR(celev,LEN(celev)) C Provider pe = M_LSTCHR(provdr(i),LEN(provdr(i))) C Station se = M_LSTCHR(stanam(i),LEN(stanam(i))) if(ilatlon.ne.1)then C Latitude write(clat,149)lat(i) lts = M_FRTCHR(clat,LEN(clat)) lte = M_LSTCHR(clat,LEN(clat)) C Longitude write(clon,150)lon(i) lns = M_FRTCHR(clon,LEN(clon)) lne = M_LSTCHR(clon,LEN(clon)) else C Latitude write(clat,152)lat(i) lts = M_FRTCHR(clat,LEN(clat)) lte = M_LSTCHR(clat,LEN(clat)) C Longitude write(clon,151)lon(i) lns = M_FRTCHR(clon,LEN(clon)) lne = M_LSTCHR(clon,LEN(clon)) endif else C Use the time output format desired by the user. if(tform.eq.0)then tstr = ' '//timeob(i) else if(tform.eq.1)then CALL MTRNTIM(timeob(i),2,tstr,istatus) endif endif C Only output records where the string isn't all blank (missing). if(vcode.eq.'AUTOTYP'.or.vcode.eq.'REPTYPE')then if(M_LSTCHR(c6(i),6).ne.0)then if(itextxml.eq.1)then C Data value dvs = M_FRTCHR(c6(i),LEN(c6(i))) dve = M_LSTCHR(c6(i),LEN(c6(i))) write(1,8003)vcode(1:vce), 1 stanam(i)(1:se),celev(es:ee), 2 clat(lts:lte),clon(lns:lne),xmltstr, 3 provdr(i)(1:pe),c6(i)(dvs:dve) 8003 format('') else if(ilatlon.ne.1)then write(1,7002)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i),c6(i) 7002 format(1x,'V-',a,1x,a,1x,f7.2,1x,f6.2,1x,f7.2, 1 1x,2(f8.3,1x),a,1x,a,6(1x,a)) else write(1,7012)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i),c6(i) 7012 format(1x,'V-',a,1x,a,1x,f7.2,1x,f9.5,1x,f9.4, 1 1x,2(f8.3,1x),a,1x,a,6(1x,a)) endif endif endif else if(vcode.eq.'PRESWEA')then dve = M_LSTCHR(preswea(i),LEN(preswea(i))) if(dve.ne.0)then if(itextxml.eq.1)then C Data value dvs = M_FRTCHR(preswea(i),LEN(preswea(i))) if(preswea(i)(dvs:dve) .ne. '-') 1 write(1,8003)vcode(1:vce), 2 stanam(i)(1:se),celev(es:ee), 3 clat(lts:lte),clon(lns:lne),xmltstr, 4 provdr(i)(1:pe),preswea(i)(dvs:dve) else if(ilatlon.ne.1)then write(1,7002)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 preswea(i) else write(1,7012)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 preswea(i) endif endif endif else if(vcode.eq.'AUTORMK'.or.vcode.eq.'OPERRMK')then dve = M_LSTCHR(remark(i),LEN(remark(i))) if(dve.ne.0)then if(itextxml.eq.1)then C Data value dvs = M_FRTCHR(remark(i),LEN(remark(i))) write(1,8003)vcode(1:vce), 1 stanam(i)(1:se),celev(es:ee), 2 clat(lts:lte),clon(lns:lne),xmltstr, 3 provdr(i)(1:pe),remark(i)(dvs:dve) else if(ilatlon.ne.1)then write(1,7002)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 remark(i) else write(1,7012)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 remark(i) endif endif endif else if(vcode.eq.'STALOC')then if(M_LSTCHR(staloc(i),51).ne.0)then if(itextxml.eq.1)then C Data value dvs = M_FRTCHR(staloc(i),LEN(staloc(i))) dve = M_LSTCHR(staloc(i),LEN(staloc(i))) write(1,8003)vcode(1:vce), 1 stanam(i)(1:se),celev(es:ee), 2 clat(lts:lte),clon(lns:lne),xmltstr, 3 provdr(i)(1:pe),staloc(i)(dvs:dve) else if(ilatlon.ne.1)then write(1,7002)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i),staloc(i) else write(1,7012)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i),staloc(i) endif endif endif else if(vcode.eq.'SUBPVDR')then if(M_LSTCHR(subpvdr(i),11).ne.0)then if(itextxml.eq.1)then C Data value dvs = M_FRTCHR(subpvdr(i),LEN(subpvdr(i))) dve = M_LSTCHR(subpvdr(i),LEN(subpvdr(i))) write(1,8003)vcode(1:vce), 1 stanam(i)(1:se),celev(es:ee), 2 clat(lts:lte),clon(lns:lne),xmltstr, 3 provdr(i)(1:pe),subpvdr(i)(dvs:dve) else if(ilatlon.ne.1)then write(1,7002)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 subpvdr(i) else write(1,7012)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 subpvdr(i) endif endif endif else if(vcode.eq.'SKYCOV ')then if(M_LSTCHR(skycover(1,i),48).ne.0)then if(itextxml.eq.1)then do j=1, 6 C Data value cdv = skycover(j,i) dvs = M_FRTCHR(cdv,LEN(cdv)) dve = M_LSTCHR(cdv,LEN(cdv)) if(dve.ge.dvs)then write(1,8003)vcode(1:vce)//char(j+48), 1 stanam(i)(1:se),celev(es:ee), 2 clat(lts:lte),clon(lns:lne),xmltstr, 3 provdr(i)(1:pe),cdv(dvs:dve) endif enddo else if(ilatlon.ne.1)then write(1,7002)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 (skycover(j,i),j=1,6) else write(1,7012)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i), 2 (skycover(j,i),j=1,6) endif endif endif else if(vcode.eq.'T24MAXT'.or.vcode.eq.'T24MINT')then C Use the time output format desired by the user. if(tform.eq.0)then tstr1 = ' '//c9(i) else if(tform.eq.1)then CALL MTRNTIM(c9(i),2,tstr1,istatus) endif if(tstr1.ne.' ')then if(itextxml.eq.1)then C Data value dvs = M_FRTCHR(tstr1,LEN(tstr1)) dve = M_LSTCHR(tstr1,LEN(tstr1)) write(1,8003)vcode(1:vce), 1 stanam(i)(1:se),celev(es:ee),clat(lts:lte), 2 clon(lns:lne),xmltstr,provdr(i)(1:pe), 3 tstr1(dvs:dve) else if(ilatlon.ne.1)then write(1,7002)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i),tstr1 else write(1,7012)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i),tstr1 endif endif endif else if(vcode.eq.'FOT15M'.or.vcode.eq.'LOT15M')then C Use the time output format desired by the user. if(tform.eq.0)then tstr1 = ' '//c9(i) else if(tform.eq.1)then CALL MTRNTIM(c9(i),2,tstr1,istatus) endif if(tstr1.ne.' ')then if(itextxml.eq.1)then C Data value dvs = M_FRTCHR(tstr1,LEN(tstr1)) dve = M_LSTCHR(tstr1,LEN(tstr1)) write(1,8003)vcode(1:vce), 1 stanam(i)(1:se),celev(es:ee),clat(lts:lte), 2 clon(lns:lne),xmltstr,provdr(i)(1:pe), 3 tstr1(dvs:dve) else if(ilatlon.ne.1)then write(1,7002)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i),tstr1 else write(1,7012)vcode,stanam(i),elev(i),lat(i), 1 lon(i),ri(i),rj(i),tstr,provdr(i),tstr1 endif endif endif endif 300 continue endif C Process the next variable. go to 100 C C CSV output formats C options 3,4,5,6 for csv format with qc options 34000 continue C C Save sub-provider for common description segment C "nstatot" totals should not be used, they are only for C data selections that include a mesonet site. C CALL MGETSFCC(atime,'SUBPVDR',nstatot,cdata,istatus) if(istatus.ne.success_p)then do i = 1,nsta subpvdr(i) = ' ' enddo endif 8011 format(',',f13.6) 8012 format(',',f13.6,',',a1) 8014 format(',',f13.6,',',a1,',',i3,',',i3) 9010 format(a,',',a,',',a,',',a,',',a) 9051 format(',',a) 9052 format(6(',',a)) 9053 format(2(',',a)) numvcodes = 0 701 read(2,145,err=955,end=950)vcode if(vcode.eq.' ')go to 701 numvcodes = numvcodes + 1 vcodes(numvcodes) = vcode go to 701 955 continue write(*,*)'Error reading vcode number: ',numvcodes+1 goto 825 950 continue if(numvcodes.eq.0)then write(*,*)'Error - No vcodes found. ' goto 825 endif C The size of the string limits the number of vcodes C Init size for name/data tmpsz = 50 do ivcode = 1, numvcodes vcode = vcodes(ivcode) cursz = 0 if(vcode.eq.'SKYCVLB')then if(itextxml.eq.2)then cursz = 14*6 else if(itextxml.eq.3)then cursz = (14+2)*6 else if(itextxml.eq.4)then cursz = (14+10)*6 endif else if(vcode.eq.'PCPINT'.or.vcode.eq.'PCPTYPE')then if(itextxml.eq.2)then cursz = 14*2 else if(itextxml.eq.3)then cursz = (14+2)*2 else if(itextxml.eq.4)then cursz = (14+10)*2 endif else if(vcode.eq.'AUTOTYP'.or.vcode.eq.'REPTYPE')then cursz = 7 else if(vcode.eq.'PRESWEA')then cursz = 26 else if(vcode.eq.'AUTORMK'.or.vcode.eq.'OPERRMK')then cursz = 81 else if(vcode.eq.'STALOC')then cursz = 52 else if(vcode.eq.'SUBPVDR')then cursz = 12 else if(vcode.eq.'SKYCOV')then cursz = 52 else if(vcode.eq.'T24MAXT'.or.vcode.eq.'T24MINT')then cursz = 14 else if(vcode.eq.'FOT15M'.or.vcode.eq.'LOT15M')then cursz = 14 C Only number are left else if(itextxml.eq.2)then cursz = 14 else if(itextxml.eq.3)then cursz = 14+2 else if(itextxml.eq.4)then cursz = 14+10 endif endif if(tmpsz+cursz.le.maxcsvsz)then maxcsvvar = ivcode tmpsz = tmpsz+cursz else C We are out of room to add any more variables go to 801 endif enddo 801 continue if(numvcodes.gt.maxcsvvar)then write(*,*)'Warn - CSV Variables limited to a line length of ', 1 maxcsvsz,' This limits the variables to the first', 1 maxcsvvar write(*,*)'Note -- Full QC information takes more space '// 1 'than just QC data descriptors alone. Also some '// 2 ' variables need extra room like like AUTORMK, OPERRMK, ' 3 //'STALOC, SKYCOV, SKYCVLB, PCPINT, and PCPTYPE' numvcodes = maxcsvvar endif C Missing string length if(imissval.eq.1)then mstr = ', ' mstrlen = 14 if(itextxml.eq.3)then mstr = ', ,Z' mstrlen = 16 else if(itextxml.eq.4)then mstr = ', ,Z, 0, 0' mstrlen = 24 endif else mstr = ',-99999.000000' mstrlen = 14 if(itextxml.eq.3)then mstr = ',-99999.000000,Z' mstrlen = 16 else if(itextxml.eq.4)then mstr = ',-99999.000000,Z, 0, 0' mstrlen = 24 endif endif do 601 i = 1,nsta csvstrendlen(i) = 0 C If we're getting only one station, make sure this is it. if(ising.eq.1.and.singsta.ne.stanam(i))go to 601 C Write station default info CALL MTRNTIM(timeob(i),2,tstr2,istatus) C XML time format is YYY-MM-DDTHH:MM -- 2004-06-04T16:01 dstr = tstr2(5:6)//'/'//tstr2(7:8)//'/'//tstr2(1:4) hmstr = tstr2(10:11)//':'//tstr2(12:13) write(csvstr(i),9010)stanam(i),dstr,hmstr,provdr(i), 1 subpvdr(i) stnhasdata(i) = .false. csvstrendlen(i) = 50 601 continue C loop vcodes do 101 ivcode = 1, numvcodes vcode = vcodes(ivcode) write(*,505)vcode C The internal MGETVCN routine is used to determine the type C (numeric or character) of the variable. In general, a user's C MADIS program shouldn't have to make this determination C (as you would know what variables you're reading). CALL MGETVCN(vcode,vcn,vtype,istatus) if(istatus.ne.success_p)go to 900 C Read the desired variable and QC info. The returned arrays C will match the records in the station info arrays returned C from MSFCSTA. If a QC level has been selected, the obs will C only be returned if they meet or exceed the selected QC C level. if(vtype.eq.'N')then C The MGETSFC routine is used to read all numeric variables. C All variables are returned as Fortran REAL type (RDATA), the C QC data descriptors are always CHARACTER*1 (QCD), and the C bit maps showing the QC checks that were applied (QCA) and C their results (QCR) are always INTEGER. CALL MGETSFC(atime,vcode,nsta,nobs,rdata,qcd,qca,qcr, 1 istatus) C No Data issue if(istatus.ne.success_p.or.nobs.eq.0)then do 1002 i = 1,nsta if(ising.eq.1.and.singsta.ne.stanam(i))go to 1002 idx = csvstrendlen(i)+1 csvstr(i)(idx:idx+mstrlen-1) = mstr(1:mstrlen) csvstrendlen(i) = csvstrendlen(i) + mstrlen 1002 continue go to 101 endif do 201 i = 1,nsta C If we're getting only one station, make sure this is it. if(ising.eq.1.and.singsta.ne.stanam(i))go to 201 C Output records idx = csvstrendlen(i)+1 if(vcode.ne.'SKYCVLB'.and. 1 vcode.ne.'PCPINT'.and.vcode.ne.'PCPTYPE')then if(rdata(i).eq.miss_p)then csvstr(i)(idx:idx+mstrlen-1) = mstr(1:mstrlen) csvstrendlen(i) = csvstrendlen(i) + mstrlen else stnhasdata(i) = .true. if(itextxml.eq.2)then write(csvstr(i)(idx:idx+13),8011) 1 rdata(i) csvstrendlen(i) = csvstrendlen(i) + 14 else if(itextxml.eq.3)then write(csvstr(i)(idx:idx+15),8012) 2 rdata(i),qcd(i) csvstrendlen(i) = csvstrendlen(i) + 14+2 else if(itextxml.eq.4)then write(csvstr(i)(idx:idx+23),8014) 2 rdata(i),qcd(i),qca(i), 3 qcr(i) csvstrendlen(i) = csvstrendlen(i) + 14+10 endif endif C XML OUTPUT SPECIAL CASES SKY... else if(vcode.eq.'SKYCVLB')then do j=1,6 idx = csvstrendlen(i)+1 if(skycovlb(j,i).eq.999999.)then csvstr(i)(idx:idx+mstrlen-1) = 1 mstr(1:mstrlen) csvstrendlen(i) = csvstrendlen(i) + mstrlen else if(itextxml.eq.2)then write(csvstr(i)(idx:idx+13),8011) 1 skycovlb(j,i) csvstrendlen(i) = csvstrendlen(i) + 14 else if(itextxml.eq.3)then write(csvstr(i)(idx:idx+15),8012) 2 skycovlb(j,i),qcdsky(j,i) csvstrendlen(i) = csvstrendlen(i) + (14+2) else if(itextxml.eq.4)then write(csvstr(i)(idx:idx+23),8014) 2 skycovlb(j,i),qcdsky(j,i), 3 qcapcp(j,i),qcrpcp(j,i) csvstrendlen(i) = csvstrendlen(i) + (14+10) endif stnhasdata(i) = .true. endif enddo else if(vcode.eq.'PCPINT'.or.vcode.eq.'PCPTYPE')then do j=1,2 idx = csvstrendlen(i)+1 if(pcpvar(j,i).eq.miss_p)then csvstr(i)(idx:idx+mstrlen-1) = 1 mstr(1:mstrlen) csvstrendlen(i) = csvstrendlen(i) + 1 mstrlen else if(itextxml.eq.2)then write(csvstr(i)(idx:idx+13),8011) 2 pcpvar(j,i) csvstrendlen(i) = csvstrendlen(i) + 14 else if(itextxml.eq.3)then write(csvstr(i)(idx:idx+15),8012) 2 pcpvar(j,i),qcdpcp(j,i) csvstrendlen(i) = csvstrendlen(i) + (14+2) else if(itextxml.eq.4)then write(csvstr(i)(idx:idx+23),8014) 2 pcpvar(j,i),qcdpcp(j,i), 3 qcapcp(j,i),qcrpcp(j,i) csvstrendlen(i) = csvstrendlen(i) + (14+10) endif stnhasdata(i) = .true. endif enddo endif 201 continue else if(vtype.eq.'C')then C The MGETSFCC routine is used to read character variables. No QC C is currently available for any of these variables. Only two of C the character variables are actually observations (present weather C and sky cover). The other character variables are metadata, e.g., C METAR report types ("METAR", "SPECI", "TEST"). Note that there C are no missing data flags for character data, and therefore no C equivalent of the NOBS argument returned from MGETSFC; instead, C blanks are filled in where no genuine data exist. CALL MGETSFCC(atime,vcode,nsta,cdata,istatus) C Output the station info and variable to the test output file. do 301 i = 1,nsta C If we're getting only one station, make sure this is it. if(ising.eq.1.and.singsta.ne.stanam(i))go to 301 idx = csvstrendlen(i)+1 C Only output records where the string isn't all blank (missing). if(vcode.eq.'AUTOTYP'.or.vcode.eq.'REPTYPE')then if(istatus.eq.success_p.and. 1 M_LSTCHR(c6(i),6).ne.0)then write(csvstr(i)(idx:idx+6),9051) 2 c6(i) stnhasdata(i) = .true. else csvstr(i)(idx:idx+6) = 2 ', ' endif csvstrendlen(i) = csvstrendlen(i) + 7 else if(vcode.eq.'PRESWEA')then if(istatus.eq.success_p)then dve = M_LSTCHR(preswea(i),LEN(preswea(i))) if(dve.ne.0)then write(csvstr(i)(idx:idx+25),9051) 2 preswea(i) stnhasdata(i) = .true. else csvstr(i)(idx:idx+25) = 2 ', ' endif else csvstr(i)(idx:idx+25) = 2 ', ' endif csvstrendlen(i) = csvstrendlen(i) + 26 else if(vcode.eq.'AUTORMK'.or.vcode.eq.'OPERRMK')then if(istatus.eq.success_p)then dve = M_LSTCHR(remark(i),LEN(remark(i))) if(dve.ne.0)then write(csvstr(i)(idx:idx+80),9051) 2 remark(i) stnhasdata(i) = .true. else csvstr(i)(idx:idx+80) = ', ' endif else csvstr(i)(idx:idx+80) = ', ' endif csvstrendlen(i) = csvstrendlen(i) + 81 else if(vcode.eq.'STALOC')then C C Check for "," and replace with " " C if(istatus.ne.success_p)then csvstr(i)(idx:idx+51) = 2 ', ' else 191 if(index(staloc(i),',').ne.0)then ic = index(staloc(i),',') staloc(i)(ic:ic) = ' ' go to 191 endif if(M_LSTCHR(staloc(i),51).ne.0)then write(csvstr(i)(idx:idx+51),9051) 2 staloc(i) stnhasdata(i) = .true. else csvstr(i)(idx:idx+51) = 2 ', ' endif endif csvstrendlen(i) = csvstrendlen(i) + 52 else if(vcode.eq.'SUBPVDR')then if(istatus.eq.success_p.and. 1 M_LSTCHR(subpvdr(i),11).ne.0)then write(csvstr(i)(idx:idx+11),9051) 2 subpvdr(i) stnhasdata(i) = .true. else csvstr(i)(idx:idx+11) = 2 ', ' endif csvstrendlen(i) = csvstrendlen(i) + 12 else if(vcode.eq.'SKYCOV')then if(istatus.eq.success_p.and. 1 M_LSTCHR(skycover(1,i),48).ne.0)then write(csvstr(i)(idx:idx+53),9052) 2 (skycover(j,i),j=1,6) stnhasdata(i) = .true. else write(csvstr(i)(idx:idx+53),9052) 2 (' ',j=1,6) endif csvstrendlen(i) = csvstrendlen(i) + 54 else if(vcode.eq.'T24MAXT'.or.vcode.eq.'T24MINT')then C Use the time output format desired by the user. if(istatus.ne.success_p)then tstr1 = ' ' else if(tform.eq.0)then tstr1 = ' '//c9(i) else if(tform.eq.1)then CALL MTRNTIM(c9(i),2,tstr1,istatus) endif endif if(tstr1.ne.' ')stnhasdata(i) = .true. write(csvstr(i)(idx:idx+13),9051) 2 tstr1 csvstrendlen(i) = csvstrendlen(i) + 14 else if(vcode.eq.'FOT15M'.or.vcode.eq.'LOT15M')then C Use the time output format desired by the user. if(istatus.ne.success_p)then tstr1 = ' ' else if(tform.eq.0)then tstr1 = ' '//c9(i) else if(tform.eq.1)then CALL MTRNTIM(c9(i),2,tstr1,istatus) endif endif if(tstr1.ne.' ')stnhasdata(i) = .true. write(csvstr(i)(idx:idx+13),9051) 2 tstr1 csvstrendlen(i) = csvstrendlen(i) + 14 endif 301 continue endif C Process the next variable. 101 continue 168 format(a,',') do i = 1,nsta if(stnhasdata(i)) 1 write(1,168)csvstr(i)(1:csvstrendlen(i)) enddo goto 900 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C----------------------------------------------------------------------- C PROGRAM EXIT C ------------ C C The call to MMADISCLOSE is only needed for use on the MADIS web C server. Users who write their own programs don't need to do this. C Error exits. 825 write(*,503)'SFCDUMP: READ ERROR IN PARAMETER FILE AT LINE ',line 503 format(1x,a,i4) CALL MMADISCLOSE stop 850 write(*,500)'SFCDUMP: PREMATURE END OF PARAMETER FILE' C Normal exit. 900 continue C Footer for XML file if(itextxml.eq.1)then write(1,8004) 8004 format('') endif CALL MMADISCLOSE stop end C**--------------------------------------------------------------------- C**REQUIRED STANDARD FSL DISCLAIMER (NOVEMBER 2000) C**--------------------------------------------------------------------- C** OPEN SOURCE LICENSE/DISCLAIMER, FORECAST SYSTEMS LABORATORY C** NOAA/OAR/FSL, 325 BROADWAY BOULDER, CO 80305 C** C** THIS SOFTWARE IS DISTRIBUTED UNDER THE OPEN SOURCE DEFINITION, C** WHICH MAY BE FOUND AT http://www.opensource.org/osd.html. C** C** IN PARTICULAR, REDISTRIBUTION AND USE IN SOURCE AND BINARY FORMS, C** WITH OR WITHOUT MODIFICATION, ARE PERMITTED PROVIDED THAT THE C** FOLLOWING CONDITIONS ARE MET: C** C** - REDISTRIBUTIONS OF SOURCE CODE MUST RETAIN THIS NOTICE, THIS LIST C** OF CONDITIONS AND THE FOLLOWING DISCLAIMER. C** C** - REDISTRIBUTIONS IN BINARY FORM MUST PROVIDE ACCESS TO THIS C** NOTICE, THIS LIST OF CONDITIONS AND THE FOLLOWING DISCLAIMER, AND C** THE UNDERLYING SOURCE CODE. C** C** - ALL MODIFICATIONS TO THIS SOFTWARE MUST BE CLEARLY DOCUMENTED, C** AND ARE SOLELY THE RESPONSIBILITY OF THE AGENT MAKING THE C** MODIFICATIONS. C** C** - IF SIGNIFICANT MODIFICATIONS OR ENHANCEMENTS ARE MADE TO THIS C** SOFTWARE, THE FSL SOFTWARE POLICY MANAGER C** (softwaremgr.fsl@noaa.gov) BE NOTIFIED. C** C** THIS SOFTWARE AND ITS DOCUMENTATION ARE IN THE PUBLIC DOMAIN AND C** ARE FURNISHED "AS IS." THE AUTHORS, THE UNITED STATES GOVERNMENT, C** ITS INSTRUMENTALITIES, OFFICERS, EMPLOYEES, AND AGENTS MAKE NO C** WARRANTY, EXPRESS OR IMPLIED, AS TO THE USEFULNESS OF THE SOFTWARE C** AND DOCUMENTATION FOR ANY PURPOSE. THEY ASSUME NO RESPONSIBILITY C** (1) FOR THE USE OF THE SOFTWARE AND DOCUMENTATION; OR (2) TO C** PROVIDE TECHNICAL SUPPORT TO USERS. C**---------------------------------------------------------------------