c----------------------------------------------------------------------
c --- METSERIES -- Meteorological/AQ Time-Series Extractor
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203          MAIN
c
c     Copyright (c) 2014 by TRC Environmental Corporation
c
c --- Written by:  Zhong-Xiang Wu and Joseph Scire (WDEXTRA,WDCOMP)
c                  David Strimaitis (METSERIES)
c
c --- PURPOSE:
c       Extract meteorological time series (winds, temperature,
c       water vapor) from 3D.DAT, CALMET.DAT, SURF.DAT, CALMM4.DAT
c       and UP.DAT .
c       (Developed from WDEXTRA Version 2.0, Level 060601)
c       Produce frequency tables for windroses
c       (Developed from WDCOMP Version 2.0, Level 060605)
c
c **********************************************************************
c --- Exponent, Inc. Updates:
c **********************************************************************
c --- Version 1.81, Level: 110308 to Version 1.9.0, Level: 121203
c         1. Output CALMET surface pressure (when OTHER=1)
c            Note:  MXVARS in PARAMS.SER must be at least 13
c            Modified: CLMEXT, OUTPUTCAL, HDTSFOUT
c         2. Add switch to control the time convention used for
c            midnight when writing a TSF file.  Some subs call the
c            MIDNITE subroutine in CALUTILS to change 24 to 0, others
c            do not, allowing native dataset convention to pass.
c            Add call to all TSF output subs, with default set to "00h"
c            Add new variables for the end-time subject to the MIDNITE
c            adjustment to ensure that all logic that uses the end-time
c            operates without change.  Only make a midnight adjustment
c            to 24h convention if seconds=0000 (e.g. 0015 not 2415)
c            Modified: CTRL.SER
c                      BLOCK DATA, READCF, MM5EXT, 
c                      SRFEXT, UPEXT, SEAEXT,
c                      CLMEXT, CPFEXT, M2DEXT,
c                      AMMNETCEXT, AMMNETWEXT,
c                      AERMSFCEXT, AERMPFLEXT
c         3. Move local parameter statements for MXSTN and MX2D into
c            the parameter include file, and add checks for these
c            Modified: PARAMS.SER
c                      SRFEXT, M2DEXT, SEAEXT
c         4. Revise read-statements for AERMET SURFACE and PROFILE
c            data files.  These changed and must be read free-format
c            in order to adapt to future changes (and older versions).
c            Trap missing height (wind, T) and set to target since
c            heights are missing if data are missing in AERMET surface
c            file, and align missing values for M-OL, precip, and
c            clouds with header documentation
c            Modified: AERMSFCEXT, AERMPFLEXT
c         5. Assign local variable NLIM to 1 for calls to ALLCAP
c            Modified: SETUPSEA
c         6. Add PRECIP.DAT processing (extract precipitation)
c            New:      SETUPPRC, PRCEXT
c            Modified: (main), READCF, HDTSFOUT
c         7. Add extraction option for WRF 2D.DAT.
c            New:      SCAN2D
c            Modified: M2DEXT, OOUTPUTM2D, HDTSFOUT
c         8. Bug fix in WDFREQ (prevents undue stop when missing data
c            in SURF.DAT)
c            Modified: WDFREQ
c **********************************************************************
c
c --- UPDATES:
c
c --- Version 1.8, Level: 110301 to Version 1.81, Level: 110308 (CEC)
c         1. Roughness length was extracted instead of Monin-Obukhov
c            lenght. it is now corrected
c            Modified: AERMSFCEXT
c
c --- Version 1.79, Level: 100721 to Version 1.8, Level: 110301 (DGS)
c        1.  Add CALPUFF output Dataset v2.2
c            Modified: CPUF.SER
c                      GETHEAD_CP, CPFEXT
c        2.  Updated CALUTILS.FOR to version v2.58 (110225)
c            Add control file variable type 5 (character array) and
c            retain commas in string returned so that array of
c            variable values can be parsed
c            Modified: READIN, ALTONU, SETVAR
c
c --- Version 1.78, Level 100624 to Version 1.79, Level: 100721 (JSS)
c      - Correct wind direction conversion to true North
c        1.  Subr. SETUPCLM - fix reads of origin LCC lat/long in v2.0
c            and v2.1 CALMET.DAT dataset versions
c        2.  Subr. CLMEXT - standardize convention and correct reads
c            of origin lat/long
c        3.  Subr. ROTATE - pass correct longitude with E long. positive
c            and standardize notaton
c        4.  /MAPINFO/ common block in include file: METSERIES.SER
c             Add 'relon0m' variable to common block (E long is positive)
c            and include comments explaining common block variables
c        5.  Fix missing version & level numbers from various routines
c            -- set level to 100721 when no level existed in code for
c            that subroutine.
c
c --- Version 1.77, level 100615 to Version 1.78, level 100624 (CEC)
c        1. Put back the error checking for AERMOD SURFACE if 
c           wind elevation in file is different from the one asked 
c           in the control file.
c        2. Put back the error checking for AERMOD SURFACE if 
c           temperature elevation in file is different from the one 
c           asked in the control file.
c           Modified: AERMSFCEXT
c        3. If wind or temperature were not requested from AERMOD PROFIL,
c           both were not processed and no data were output - this has 
c           been fixed.
c           Modified: INTERPPFL
c
c --- Version 1.76, level 100222 to Version 1.77, level 100615 (CEC)
c        1. Add possibility to deal with missing data / date in the
c           middle of the file for MONITOR/AMMNET format
c           Modified: AMMNETWEXT, AMMNETCEXT
c        2. Fix a bug in the header format of .FRQ files
c           Number of comment lines when many stations
c            are extracted in a same run were wrong
c           Modified: WINDROSE, POLLROSE
c        3. Add the option to extract data from a sea.dat format
c           Added: SETUPSEA, SEAEXT, OUTPUTSEA
c           Modified:MAIN, HDTSFOUT, READCF
c --- Version 1.75, level 100108 to Version 1.76, level 100222 (DGS)
c        1. Allow wind direction bins for pollutant roses to be
c           selected (e.g. 1, 5, 10, or 22.5 degrees)
c        2. Allow concentration bins for pollutant FRQ roses to be set
c           from the concentration distribution or set via user inputs
c           Modified: CTRL.SER
c                     BLOCK DATA, READCF, MAXAV_POLL, SCAT_POLL
c --- Version 1.74, level 091026 to Version 1.75, level 100108 (CEC)
c        1. Fix problem in Validity code format for AMMNET format
c           A character in non standard ASCII is used for "space".
c           Fix is to accept as VALID any FLAGS characters which are not
c           unvalid
c           Modified: VALD_PAR
c        2. Allow two types of format for AMMNETC file header:
c           either species defined as SO2, H2S, CO,... or 
c           AVESO2, AVEH2S, AVECO
c           Modified: SETUPAMMNETC,READHDP
c        3. Change the validity check for AMMNET concentrations:
c           use VGET320 instead of VALD_PAR.
c           New: VGET320
c --- Version 1.73, level 091022 to Version 1.74, level 091026 (CEC)
c        1. Put frequency file and tab file in output time zone 
c           (ABTZ = izonec) - Records are read in TSF time zone (atzone8) 
c           and change to ABTZ. Time Zone information is added in both 
c           files beside the beg and end dates (in the header). Update
c           WIND.FRQ data version to 2.3.
c           Modified: WINDROSE
c
c --- Version 1.72, level 091015 to Version 1.73, level 091022 (IWL)
c        1. Fix error in true wind calculation for CALMET dataset
c           versions 2.0 and greater. Variable CONECM is used in
c           Subroutine ROTATE and while it exists and is read from
c           the header of CALMET dataset versions < 2.0, it needs to
c           be computed for CALMET dataset versions >= 2.0. This was
c           missing and has been added.
c           Modified: CLMEXT
c
c --- Version 1.71, level 090928 to Version 1.72, level 091015 (CEC)
c        1. Add the possibility to read the date AMMNET format as
c           m/d/yyyy h:mm
c           Modified: AMMNETWEXT, AMMNETCEXT
c        2. Transform time as hour 24 to hour 00 next day for comparison
c           of date stamp of the two files (MET and AQ).
c           Modified: POLLROSE
c
c --- Version 1.7, level 090818 to Version 1.71, level 090928 (IWL)
c       1.  Modify TSF header line to write extraction location in
c           both X/Y and I/J for M3D, M2D, and CALMET.
c           Modified: HDTSFOUT
c
c --- Version 1.661, level 090817 to Version 1.7, level 090818 (DGS)
c       1.  Include all 2D.DAT variables with the OTHER switch, but 
c           format the 10m wind, 2m T, and 2m Q (when available) as
c           if they are requested from the 3D.DAT file, using standard
c           names and the documented heights.  For example, the U,V
c           at 10m is converted to WSPEED,WDIR and the user height
c           for 'OTHER' is replaced with 10.
c           Modified: METSERIES.SER
c                     M2DEXT, HDTSFOUT, OUTPUTM2D
c       2.  Replace the general height provided by the user for OTHER
c           variables with specific heights when obvious (typically
c           use 0.0 for surface data).
c           Modified: HDTSFOUT
c
c --- Version 1.66, level 090731 to Version 1.661, level 090817 (DGS)
c       1.  Enlarge format of Monin-Obukhov column (CALMET) since
c           very large positive and negative values exceed f10.3
c           Modified: OUTPUTCAL
c
c --- Version 1.65, level 090526 to Version 1.66, level 090731
c  (CEC)1.  Fix typo in READCF where the variable LCFILES was declared
c           as integer instead of logical
c           Modified: READCF
c  (DGS)2.  Rename subroutine INTERPHCLM => INTERPHUV and
c                             INTERPHMM5 => INTERPHSD
c           and change treatment of calms in INTERPHSD to be consistent
c           with INTERPHUV (CALMET treatment)
c           Removed:  INTERPHCLM, INTERPHMM5
c           New:      INTERPHUV,  INTERPHSD
c           Modified: CLMEXT, MM5EXT
c  (DGS)3.  Add spatial interpolation method for met data (METSIM) to
c           allow nearest grid point or bilinear interpolation
c           New:      INEAREST, RNEAREST
c           Modified: CTRL.SER, METSERIES.SER
c                     BLOCK DATA, READCF, INTERPH, INTERPHUV, INTERPHUV
c                     MM5EXT, CLMEXT, M2DEXT, HDTSFOUT
c  (DGS)4.  Replace subroutine GETCLOSE (has error) with INEAREST
c           Removed:  GETCLOSE
c           Modified: CLMEXT
c  (DGS)5.  Fix error in GLOBE1 call placement introduced in 090411 to
c           convert nearest CALPUFF receptor location into user
c           coordinate system
c           Modified: CPFEXT
c  (DGS)6.  Time step (s) interval written to TSF header changed from
c           i5.5 format to i5.4 format.  This handles intervals up
c           to 27 hours, but forces 4-digits rather than 5-digits.
c           Modified: HDTDFOUT
c  (CEC)7.  Add extraction of Relative Humidity for:
c		- 3D.DAT first level as Surface Relative Humidity if 
c                 LOTHER is selected
c               - SURF.DAT format
c               - CALMET.DAT format
c               - AMMNETW format
c           Modified: MM5EXT, HDTSFOUT, OUTPUTmm5, SRFEXT, OUTPUTsrf,
c                     CLMEXT, OUTPUTcal, AMMNETWEXT, OUTPUTw
c  (CEC)8.  Add the possibility to read the date AMMNET format as
c           mm/dd/yyyy hh:mm or m/dd/yyyy h:mm or any combination
c           Modified: AMMNETWEXT, AMMNETCEXT
c  (DGS)9.  Refinements to M2D processing
c           Remove bad print statement format reference (M2DEXT);
c           Initialize seconds to zero (M2DEXT);
c           Set and QA OTHER selection required for M2D (SETUPM2D);
c           Modified: SETUPM2D, M2DEXT
c  (DGS)10. Remove declared variables that are not used
c           Modified: (main), WROSEINP, WDFREQ, WDFREQC, SETUPMM5,
c                     SETUPM2D, SETUPAMMNETW, SETUPAMMNETC, SETUPUP,
c                     SETUPFL, SETUPCLM, SETUSRF, SETUSFC, SETUPOST,
c                     MM5EXT, M2DEXT, AERMSFCEXT, AMMNETWEXT, 
c                     AMMNETCEXT, POSTEXT, UPEXT, AERMPFLEXT,
c                     RDHD2D, WINDROSE, POLLROSE
c  (CEC)11. Add the possibility for the generic file to be called either
c           AMMNET or MONITOR
c           Modified:(main), AMMNETCEXT, AMMNETWEXT, HDTSFOUT, SETUPAMMNETC
c                    SETUPAMMNETW, READCF
c
c --- Version 1.64, level 090424 to Version 1.65, level 090526   (F.Robe)
c       1.  Add option to ouput 2D mixing height fields of 2D.DAT 
c           (weight interpolated).
c           Modified: READCF
c           New Subroutine: SETUPM2D, M2DEXT, OUTPUTM2D
c --- Version 1.63, level 090415 to Version 1.64, level 090424 (CEC)
c       1.  Fix typo in MM5ext for weighting factor computation:
c           "nx" changed to "knx".
c           Modified: MM5EXT
c --- Version 1.62, level 090411 to Version 1.63, level 090415 (DGS)
c       1.  Fix typo in TIMESTAMP call made in several EXT subs
c           (current year did not update at New Years, halting run)
c           Modified: SRFEXT, AERSFCEXT, AMMNETWEXT, AMMNETCEXT, POSTEXT
c       2.  Replace old calls to Y2K() with YR4().  The y2k sub had been
c           removed, but the replacement sub uses a common /y2k/ which
c           caused the compiler to ignore this omission.  When the call
c           to y2k is executed, the program halts with a memory fault.
c           Modified: MM5EXT, SRFEXT, AERMSFCEXT, AMMNETWEXT, AMMNETCEXT
c                     POSTEXT, CLMEXT
c
c --- Version 1.61, level 090330 to Version 1.62, level 090411
c  (DGS)1.  RNLON0C should be RELON0C in CPFEXT - this causes the
c           longitude of the projection origin to be 0.0 (PCs)
c  (CEC)2.  Add a check that the wind is requested when FLAG for not 
c           finding wind column is called for AMMNETW format
c           READHDM
c  (CEC)3.  Add printing error messages in the output list files for
c           error messages printed only in DOS windows. Whole file
c           has been scanned
c  (CEC)4.  Time step format changed from (3x,i4.4) to (2x,i5.5) in 
c           output .TSF file
c           HDTDFOUT
c  (CEC)5.  Fixed an error when CALMET extraction on the edge of domain
c           and 3D.DAT extraction on the edge of domain
c           CLMEXT, MM5EXT
c  (CEC)6.  Add a check on WD, WS and Pressure for SURF.DAT format if 
c           missing different than 9999.
c           SRFEXT
c  (CEC)7.  Horizontal interpolation of Monin-Obukhov length is done
c           by weighting 1/X rather than X for CALMET.DAT format
c           CLMEXT
c  (CEC)8.  Add additional lines in .TSF header when extracted from
c           CALPUFF.  Recompute the receptor location in user-specified
c           INPUT format to use it for pollutant location
c           CPFEXT, HDTSFOUT
c  (DGS)9.  Add additional lines in .TSF header for other gridded data
c           sources
c           CPEXT, HDTSFOUT
c (CEC)10. Change header format of .FRQ files to dataset version 2.1
c           POLLROSE, WINDROSE, SETUPPOST, POSTEXT
c (DGS)11. Trap case of ZERO concentrations in pollutant rose plots
c           MAXAV_POLL, POLLROSE
c
c --- Version 1.6, level 090318 to Version 1.61, level 090330 (DGS)
c       1.  Change units designation for precip code from NO UNITS
c           to NO_UNITS to maintain the string convention
c           Modified: HDTSFOUT
c
c --- Version 1.5, level 090203 to Version 1.6, level 090318 (DGS)
c       1.  Recast inputs to standard control-file structures
c       2.  Include files given extension .SER in place of .CMN
c       3.  Use standard CALUTILS include-file
c       4.  Data type MM5 changed to M3D
c       5.  Update to TSF Dataset Version 1.3
c CEC   6.  Add possibility to read AERMET data (PROFILES .PFL files)
c                New subroutines: SETUPPFL, AERMPFLEXT 
c CEC   7.  The ground temperature read for STANDARD and METSTAT-like 
c           profiling methods has been changed from 2m-temp to SST
c           (ground temperature)
c                Modified: MM5EXT
c CEC   8.  Data in .SCA files (for Pollutant roses application) are
c           output sorted from smallest to largest
c                Modified: SCAT_POLL
c CEC   9.  An error was found when no temperature was required from
c           CALMET.DAT files. It is now fixed.
c           Add an error check so no temperature can be extracted below 
c           the first level of CALMET.
c                Modified: CLMEXT
c      10.  Implement CALPUFF CONC.DAT file processing
c      11.  Retain local time zone when extracting data to TSF files
c           unless data are in GMT (3D.DAT, UP.DAT).
c           -  Stop with message if control file timezone differs
c              from local time.
c           -  Use control file timezone if dataset timezone is missing.
c      12.  Remove xext,yext from /LOCINFO/ and use the xloc,yloc arrays
c           instead.  Move ROTATE call in CLMEXT processing to loop over
c           requested locations and change the direction rotation to an
c           array.  This corrects CLMEXT processing in which an LCC
c           wind direction shift from ROTATE used the last requested
c           location for all requested locations.
c           Also remove hext from /LOCINFO/ (not used).
c      13.  Recast all date-hour integers to be YYYYJJJHH as in CALUTILS
c           subroutines.  Use of DELTSEC (starting METSERIES v1.5)
c           created conflicts with YYYYMMDDHH integers.  Retain GETDATE
c           to decode YYYYMMDDHH integers, but change TIMESTAMP to
c           create YYYYJJJHH integers (DEDAT in CALUTILS decodes these).
c      14.  Allow NONE map projection, and force coordinate values in
c           output TSF file headers to be (0.0,0.0).
c      15.  Use SLATEC sort in SCAT_POLL (SPSORT)
c      16.  Allow just AQ processing for AMMNETC data if NMETINP=0, and
c           turn off rose output (MROSE=0).
c      17.  Add a correction when vertical interpolation is computed for 3D.DAT
c           - done only if wind or temp are required
c      18.  Processing sub-hourly time steps for 3D.DAT and SURF.DAT format has been 
c           updated.
c                Modified: MM5EXT
c      19.  Update all format so no missing are allowed at the beginning
c           or the end of the file is period requested do not match the
c           data availability
c                Modified: MM5EXT, AMMNETWEXT,AMMNETCEXT,
c                          AERMSFCEXT,AERMPFLEXT,PSTEXT
c      20.  M3D processing using I,J method for location should IGNORE
c           control file map and datum, and report actual X,Y in the
c           model map and datum.  Similarly, X,Y method with map=NONE
c           uses model map and datum.
c           READCF, MM5EXT
c           Also, RNLON0C should be RELON0C in MM5EXT
c      21.  Initialize map logicals to FALSE
c           BLOCKDATA
c      22.  Fix logic in READCF for processing multiple MET and/or
c           multiple AQ files (files are processed in sequence, not
c           in parallel)
c           READCF
c      23.  Add MXYPOLL, XPOLL, YPOLL to provide option for over-riding
c           the reference location of the AQ site when creating pollutant-
c           rose plots.
c           CTRL.SER, BLOCK DATA, READCF, SCAT_POLL, MXAV_POLL
c      24.  Add coordinate transformation for extraction locations for
c           CALMET data processing (also fix lat/lon names)
c           READCF, CLMEXT
c      25.  XTRACTLL call is needed for control file lat/lon inputs
c           READCF
c      26.  Activate the FRQ and TAB outputs for pollutant roses,
c           using auto scaling from concentration percentiles
c           (main), POLLROSE, SCAT_POLL
c      27.  Refine requirements for METSTAT profiling option
c           MM5EXT
c      28.  Allow LOCMET and LOCAQ entries to be blank
c           READCF
c      29.  Place commas between month names for season strings
c           BLOCK DATA, WROSEINP
c      30.  Call HDTSFOUT once per TSF output file (fix) and skip
c           remaining files in list if period requested is completed
c           MM5EXT, CLMEXT
c      31.  Add NONE map projection processing branch for CALPUFF file
c      32.  Add a check on vertical interpolation of wind when wind is 
c           not requested - for CALMET format
c           CLMEXT
c      33.  Add Extraction of precipitation code for SURF.DAT
c           SRFEXT,  HDTSFOUT, OUTPUTSRF
c
c --- Version 1.46, Level 080822 to Version 1.5, level 090203 (CEC)
c       1.  The subroutine mapg2l and mapg2p is replaced by GLOBE and 
c           GLOBE1 from coordlib.for (which include datum) and allow to
c           have LCC with two standard parallels equal to each other.
c           the projection transformation now use same system as other
c           codes in CALPUFF system
c       2.  Add a third projection for MM5 outputs: Equatorial Mercator (EM)
c       3.  Add the possibility to read meteorological AMMNET data format
c           called AMMNETW
c                New Subroutines: SETUPAMMNETW, AMMNETWEXT
c       4.  Add the possibility to read pollutant AMMNET data format with
c           meteorological AMMNET format to create pollutant wind/pollutant time series
c           and compute frequency files
c           Extract pollutant time series for SO2,NO, NO2, NOx, CO, O3, H2S, PM10 and PM2.5
c                New Subroutines: SETUPAMMNETC, AMMNETCEXT, OUTPUTC
c       5.  Add subroutine to create Pollutant Roses (pollutants as function of wind 
c           direction
c                New subroutines: POLLROSE, WDFREQC, FREQOUTC 
c       6.  Add possibility to choose threshold for low wind or low concentration
c           and range of wind speed or concentrations
c                Modified: WINDROSE, WROSEINP, POLLROSE
c       7.  Add validity check for AMMNET observations both for meteorological data
c           and pollutant concentrations
c                Modified :AMMNETWEXT, AMMNETCEXT
c       8.  Change time series file extension from '.dat' to '.tsf'
c       9.  Add additional pollutant rose outputs:
c           BNA files with maximum and average concentrations
c                New subroutines: MAXAV_POLL, SCAT_POLL
c      10.  Add possibility to ouput 2D fields of CALMET.DAT (mixing height, precipitation,
c           fricition velocity, Monin-Obukhov length, stability classes, convective velocity scale,
c           and short wave radiation) - All of them are weight interpolated at the given point
c           except for the stability class which is extracted at the closest grid point.
c           and ouptut 2D fields of 3D.DAT (sea level pressure, precipitation, short-wave radiation
c           and SST) - All of them are weight interpolated.
c                New Subroutines: OUTPUTMM5, OUTPUTCAL
c      11.  Add possibility to outputs other variables in SURF.DAT (ceiling height, cloud cover 
c           and pressure) 
c                New Subroutine: OUTPUTSRF
c      12.  Add possibility to read AERMET data (SURFACE)
c                New subroutines: SETUPSFC, AERMSFCEXT                
c      13.  Add possibility to read TIME SERIES OUTPUT OF CALPOST
c                New subroutines: SETUPPOST, POSTEXT
c      14.  Add unit choice for concentration (AMMNETC and POSTIME option)
c(DGS) 15.  Remove excess INTERPUP debug writes for zsw,zw
c                Modified:  INTERPUP
c           Fix end-of-period checks in UPEXT (last-time processing)
c                Modified:  UPEXT
c           Update subroutines UTCBASR, BASRUTC from CALUTILS
c                Modified:  UTCBASR, BASRUTC
c           Add extra check in testing requested wind and temperature
c           heights for AERMET SURFACE file to exclude "-1.0" entries
c           that are flags for dropping measure from output file;
c           Remove stop if heights are not equal and report missing
c           since heights can change in file. 
c                Modified:  AERMSFCEXT
c           Revise warning text about windrose subsets not being
c           computed (pollutant rose also)
c                Modified:  WDFREQ, WDFREQC
c(DGS) 16.  Add option to define seasons from control file
c                Modified:  METSERIES.INP, WNDROSE.CMN
c                Modified:  BLOCK DATA, WROSEINP, WINDROSE
c(DGS) 17.  Allow control file inputs for relative and absolute size
c           of pollutant BNA images (CONC_SCALE,ROSE_RADIUS)
c                Modified:  METSERIES.INP, WNDROSE.CMN
c                Modified:  BLOCK DATA, WROSEINP, WINDROSE
c(DGS) 18.  Restructure control file inputs to facilitate wind rose and
c           pollutant rose plots from existing TSF (METSERIES) files.
c                Modified:  METSERIES.PAR, METSERIES.INP,
c           Rename output timeseries DATASET name to TIMESERIES.TSF
c                Modified:  (main)
c           Move profile method to data-format section, and only for
c           MM5, UP, and CALMET;  Only 1 choice is valid for UP, CALMET.
c      19.  Remove last line of comments about Height, the Height information
c           is already provided earlier in the header
c      20.  Add process of additional meterological fields in AMMNETW format
c                Modified: SETUPAMMNETW, AMMNETWEXT, READHDM
c      21.  Add vertical interpolation of temperature for CALMET.DAT format
c                Modified: CLMEXT
c      22.  Add possibility to process sub-hourly time steps for CALMET.DAT format
c                Modified: CLMEXT
c      23.  Remove the reading of ground temperature from the 2D.DAT
c           format for STANDARD and METSTAT-like profiling methods
c           The Ground temperature is now read from the 3D.DAT format
c           on the 2D info line.
c                Modified: MM5EXT
c      24.  Add the possibility to read the latest 3D.DAT format,
c           which include a format with begining time and ending time
c           and seconds
c                Modified: MM5EXT
c           
c --- Version 1.45, Level 080627 to Version 1.46, Level 080822 (DGS)
c       1.  Set profiled variables initially to the neutral result
c           and then recalculate them as needed for other profiling
c           options.  All are assigned to arrays regardless of whether
c           they are used.  This intialization satisfies compiler
c           checks for unassigned variables, and does not change results.
c           Modified:  MM5EXT
c       (CEC)
c       2.  For ivs3=0 (assumed to be a MM5.DAT file format
c           it is now reading nzsub for the number of level record #5
c           and add nz=nzsub (like it is done for ivs3=1!) - done 080516
c       3.  Add a check that DIRECT option can not be done when
c           format is ivs3=0 (assume MM5.DAT format) - 2D data not
c           available in 3D.DAT file - done 080516
c       4.  Remove the reading in 3D.DAT of mixing ratios of Cloud, Rain,
c           Ice, Snow and Graupel when available because not needed in 
c           METSERIES outputs - done 080520
c
c --- Version 1.44, Level 080205 to version 1.45, Level 080627 (FRR)
c       1.  Add a new option for use with UP.DAT files
c           Winds and Temperatures can be extracted from UP.DAT
c           and are vertically interpolated as per CALMET (i.e. 
c           linear interpolation between non-missing values)
c           New subroutines: setupup,upext,interpup,ws2uvr,uv2wsr,YR4
c           Modified:metseries, metseries.inp, metseries.cmn
c           !!! WARNING!!!
c           Metseries extracts all records in the requested period.
c           Since there is no fixed record frequency in UP.DAT,
c           there might be periods with lots of records
c           (e.g. 10 minute updates) and periods with only twice daily
c           records, leading to artificially skewed wind roses if
c           processed all together 
c
c --- Version 1.43, Level 080102 to Version 1.44, Level 080205 (CEC)
c       1.  Add a new option (set as 'DIRECT' profile) for use with 
c           RUC data to read 2m-T, 2m-q, 10m-W directly from M3D file.
c           ldirect logical added
c       2.  Make a correction in mm5ext for reading temperature from 
c           the M2D files only when for profile = STANDARD or METSTAT
c       3.  Wind direction of 10m wind for Direct access is read as a REAL
c           instead of an Integer
c           modification in SETUPMM5, MM5EXT
c
c --- Version 1.42, Level 071221 to Version 1.43, Level 080102 (IWL)
c       1.  Fix bug in GETFMT where idvar was undefined by initializing
c           the array with 0s.
c
c --- Version 1.41, Level 070425 to Version 1.42, Level 071221 (IWL)
c       1.  Add '.dat' to the output time series filename so that
c           frequency file output is '.frq' and not ex. '.dat.frq'
c
c --- Version 1.4, Level 070315 to Version 1.41, Level 070425 (IWL)
c       1.  Allow input SURF.DAT filename to contain spaces and
c           increase max length to 132 characters in subroutine
c           SETUPSRF
c
c --- Version 1.31, Level 070207 to Version 1.4, Level 070315 (DGS)
c       1.  Add windrose frequency table output -- may be invoked
c           with either new or existing timeseries files.
c       2.  Hide STANDARD and ALL profile options in control file
c       3.  Do not produce windrose frequency tables when the ALL
c           profiling option is selected
c
c --- Version 1.3, Level 060823 to Version 1.31, Level 070207 (DGS)
c       1.  Add command line entry of control file name
c           New:      COMLINE (from CALUTILS)
c
c --- Version 1.2, Level 060707 to Version 1.3, Level 060823 (DGS)
c       1.  Begin time for 'version 5' CALMET was not fully coded
c           (caused runtime error).
c       2.  Replace NOBLANK with F95 LEN_TRIM function
c
c --- Version 1.1, Level 060620 to Version 1.2, Level 060707 (DGS)
c       1.  Add time zone to header records to create DataSet 1.1
c           of the MET_TS.DAT file.
c
c --- Version 1.0, Level 060615 to Version 1.1, Level 060620 (DGS)
c       1.  Add wind and temperature profiling based on Louis (1979) to
c           obtain values at the indicated measurement heights from the
c           3D.DAT MM5 file.  This requires the 2D as well as the 3D
c           files.
c       2.  Allow selection of profile method for 3D.DAT
c           STANDARD
c           - Wind and temperature profiling based on Louis (1979) for
c             heights below first level (interpolate above)
c           - Profile subroutine adapted from CALGRID
c           - Minimum wind speed = 0.01
c           - Specific humidity is set to level 1 (interpolate above)
c           METSTAT
c           - Same as STANDARD with following EXCEPTIONS ----
c           - Disables virtual temperature treatment
c           - Theta-star uses Prandtl number = 1/1.35
c           - Average potential temperature replaces that at surface
c             for g/T factor in bulk Richardson number
c           - Disables iterative search for z0h (temperature roughness)
c             and sets z0h=z0m
c           NEUTRAL
c           - Wind profiling uses neutral log relation for
c             heights below first level (interpolate above)
c           - Temperature is set to level 1 (interpolate above)
c           - Specific humidity is set to level 1 (interpolate above)
c----------------------------------------------------------------------
      program metseries

      include 'params.ser'
      include 'qa.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'wndrose.ser'
      include 'metinp.ser'

      character*132 fo


c --- Title strings
      character*12 sdate,stime

c --- Time stamp
      integer ihrstep,nhrext,nbsecext,isecstep

c --- Set processor data
      ver='1.9.0'
      level='121203      '

c --- Get system timestamp
      call NOW(sdate,stime)

c --- Make creation string stored in /QA/
      nv=LEN_TRIM(ver)
      nl=LEN_TRIM(level)
      nd=LEN_TRIM(sdate)
      nt=LEN_TRIM(stime)
      create80='Created by METSERIES (Version '//ver(1:nv)//
     &         ', Level '//level(1:nl)//') on '//sdate(1:nd)//
     &         ' at '//stime(1:nt)

c --- Process control file
c ------------------------
      call READCF

c --- Control file finished
      write(ilog,'(/,1x,a//)')'Finished Control File Processing'
      write(*,'(/,1x,a//)')'Finished Control File Processing'

c --- Create starting time integers "YYYYJJJHH SSSS"
      nsecext=ibsecc
      call TIMESTAMP(ibyrc,ibjdc,ibhrc,ndateext)
      ndatekeep=ndateext

c --- Number of periods to be extracted, step (in seconds)
      nbsecext=nstepc
      isecstep=nsecdtc

c --- Setup for different input file formats
c --- (081120 - CEC) - For now, only AMMNETC, AMMNETW, CALMET and 3D.DAT 
c      allow a time step lower than hours
c      if(mdata.eq.'M3D'.or.mdata.eq.'CALMET'.or.mdata.eq.'SURF'
       if(mdata.eq.'UP'.or.mdata.eq.'AERMSFC'
     &    .or.mdata.eq.'AERMPFL'.or.mdata.eq.'POSTIME') then
       if(isecstep.lt.3600) then
        write(ilog,*)' '
      write(ilog,*)'ERROR- Time step needs to be equal to 1hr or larger'
      write(ilog,*)'ERROR- Time step needs to be in seconds - 1hr=3600s'
        write(*,*)'ERROR - Time step needs to be equal to 1hr or larger'
        write(*,*)'ERROR - Time step needs to be in seconds - 1hr=3600s'
        stop
       endif
       ihrstep=int(isecstep/3600)
       nhrext=nbsecext
      endif
c
      if(mdata.eq.'M3D')     call SETUPMM5
      if(mdata.eq.'M2D')     call SETUPM2D
c     if(mdata.eq.'CALMM4')  call SETUPMM4   ! not finished yet
      if(mdata.eq.'CALMET')  call SETUPCLM
      if(mdata.eq.'SURF')    call SETUPSRF
      if(mdata.eq.'UP')      call SETUPUP
      if(mdata.eq.'AMMNETW'.or.mdata.eq.'MONITORW') call SETUPAMMNETW
      if(mdata.eq.'AMMNETC'.or.mdata.eq.'MONITORC') call SETUPAMMNETC
      if(mdata.eq.'AERMSFC') call SETUPSFC
      if(mdata.eq.'AERMPFL') call SETUPPFL 
      if(mdata.eq.'POSTIME') call SETUPPOST
      if(mdata.eq.'CALPUFF') call SETUPCPF
      if(mdata.eq.'SEA')     call SETUPSEA
c --- V1.9.0, Level 121203
      if(mdata.eq.'PRECIP')  call SETUPPRC
c --- TSF data input format determines MTSF switch
      if(mdata.eq.'TSF') then
         call SETUPTSF
      else
         mtsf=0
      endif

c --- Process wind/pollutant rose configuration records
      call WROSEINP

      if(LALLPROF) then
c ---    Create subdirectories for METSTAT and NEUTRAL versions
         call SYSTEM('mkdir METSTAT')
         call SYSTEM('mkdir NEUTRAL')
      endif

c --- Reconsider if windrose frequency tables are produced
      if(LALLPROF.AND.(mrose.GT.0))mrose=0

c --- QA timeseries extraction and windrose processing configuration
      if(ntsfout.EQ.0 .AND. mtsf.EQ.0) then
         write(ilog,*)
         write(ilog,*)'-----------------------------------------------'
         write(ilog,*)'Invalid Timeseries/Windrose selection!'
         write(ilog,*)'-----------------------------------------------'
         write(ilog,*)'No timeseries extraction locations found.'
         write(ilog,*)'This may only occur when EXISTING timeseries'
         write(ilog,*)'files are used to create windroses.'
         write(ilog,*)'Expected TSF input Option 1-2, Found ',mtsf
         write(ilog,*)'-----------------------------------------------'
         write(ilog,*)
         stop 'HALTED -- See list file for ERRORS'
      endif

c --- Setup Phase finished
      write(*,'(/,1x,a)')'Finished Setup Phase'

c --- Open output files
c --- Prepare 3 sets of output files when lall=.TRUE.
      if(LALLPROF) then
         ndirs=3
      else
         ndirs=1
      endif

c --- Branch to windrose processing if NO timeseries extraction
      if(mtsf.GT.0) goto 6000

c --- Open all output timeseries files
      write(ilog,*)
      do iloc=1,ntsfout
c ---    20071221: Add '.dat' to time series file name
c ---    20081205: Change '.dat' extension to '.tsf'
         fo=TRIM(ADJUSTL(ftsf(iloc)))//'.tsf'
         nt=index(fo,' ')-1
         write(ilog,1021)iloc,fo(1:nt)
         write(ilog,*)
 1021    format('Output Timeseries File ',i3.3,': ',a)

c ---    Loop over directories
         do n=1,ndirs
            io=iout+iloc+(n-1)*ntsfout
            if(n.EQ.1) then
               open(io,file=fo,status='unknown')
            elseif(n.EQ.2) then
c              open(io,file='METSTAT\'//fo,status='unknown')
c --- (080912 - CEC - how to write in UNIX)
               open(io,file='METSTAT/'//fo,status='unknown')
            elseif(n.EQ.3) then
c               open(io,file='NEUTRAL\'//fo,status='unknown')
c --- (080912 - CEC - how to write in UNIX)
               open(io,file='NEUTRAL/'//fo,status='unknown')
            endif
         enddo
      enddo


c --- Extract time series at specified locations
      ndateext=ndatekeep
      if(mdata.eq.'M3D') then
         call mm5ext
      elseif(mdata.eq.'M2D') then
         call m2dext
      elseif(mdata.eq.'CALMET') then
         ifrmt=1
         call clmext
      elseif(mdata.eq.'SURF') then
         call srfext
      elseif(mdata.eq.'UP') then
         call upext
      elseif(mdata.eq.'AMMNETW'.or.mdata.eq.'MONITORW') then
         call ammnetwext
      elseif(mdata.eq.'AMMNETC'.or.mdata.eq.'MONITORC') then
         call ammnetcext
      elseif(mdata.eq.'AERMSFC') then
         call aermsfcext
      elseif(mdata.eq.'AERMPFL') then
         call aermpflext                         
      elseif(mdata.eq.'POSTIME') then
         call postext
      elseif(mdata.eq.'CALPUFF') then
         call cpfext
      elseif(mdata.eq.'SEA') then
         call seaext
c --- V1.9.0, Level 121203
      elseif(mdata.eq.'PRECIP') then
         call PRCEXT
      else
         print *,'Illegal Data Format:',mdata
         write(ilog,*)'Illegal Data Format:',mdata
         stop
      endif

c --- Report progress
      write(*,'(/a32)')'Finished Time-Series Files     '
      write(ilog,'(/a32)')'Finished Time-Series Files     '

c --- Close files
      do iloc=1,ntsfout
         do n=1,ndirs
            io=iout+iloc+(n-1)*ntsfout
            close(io)
         enddo
      enddo

c --- Wind Rose or Pollutant Rose Processing
c ------------------------
6000  if(mrose.GT.0 .AND. mtsf.EQ.0) then
c ---    Loop over the extracted timeseries files
         do iloc=1,ntsfout
            open(in,file=TRIM(ADJUSTL(ftsf(iloc)))//'.tsf',
     &           status='old')
c ---       Open the frequency tabulation files
            klast=LEN_TRIM(ftsf(iloc))
            io1=iout+1
            open(io1,file=ftsf(iloc)(1:klast)//'.frq',
     &           status='unknown')
            io2=iout+2
            open(io2,file=ftsf(iloc)(1:klast)//'.tab',
     &           status='unknown')
            if(mrose.EQ.1) then
               call WINDROSE(io1,io2)
            elseif(mrose.EQ.2) then
               call POLLROSE(io1,io2,iloc)
            endif
            close(in)
            close(io1)
            close(io2)
         enddo

      elseif(mrose.GT.0 .AND. mtsf.GT.0) then
c ---    Loop over the existing timeseries files
c ---    (1 if wind rose; 1 or 2 if pollutant rose)
         if(mtsf.EQ.1) then
            open(in,file=fmet(1),status='old')
         elseif(mtsf.EQ.2) then
            open(in,file=fmet(1),status='old')
            open(in2,file=faq(1),status='old')
         endif
c ---    Open the frequency tabulation files
         klast=LEN_TRIM(frose)
         io1=iout+1
         open(io1,file=frose(1:klast)//'.frq',
     &        status='unknown')
         io2=iout+2
         open(io2,file=frose(1:klast)//'.tab',
     &        status='unknown')
         if(mrose.EQ.1) then
            call WINDROSE(io1,io2)
         elseif(mrose.EQ.2) then
            iloc=1
            call POLLROSE(io1,io2,iloc)
         endif
         close(in)
         close(io1)
         close(io2)
         if(mtsf.EQ.2) close(in2)
      endif

      close(ilog)

c --- Report progress
      write(*,'(/a24)')'Finished All Processing'

      stop
      end

c----------------------------------------------------------------------
      BLOCK DATA
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203    BLOCK DATA
c                D. Strimaitis
c
c----------------------------------------------------------------------

c --- Include parameter statements
      include 'params.ser'

c --- Include common blocks
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'wndrose.ser'
      include 'map.ser'
      include 'aqinput.ser'
      include 'metinp.ser'

c --- /CONTROL/ common block (ctrl.ser)
      data FLOG/'METSERIES.LST'/
      data FROSE/'ROSEPLOT'/
      data LCFILES/.FALSE./
      data MROSEc/0/
      data NSECDTc/3600/
      data NSPEC/0/
      data METSIMc/1/
c --- V1.9.0, Level 121203
      data IMIDNITE/1/
      data DATUMc/'NWS-84  '/
      data PMAPc/'UTM     '/
      data UTMHEMc/'N   '/
      data IUTMZNc/-999/
      data FEASTc/0.0/, FNORTHc/0.0/
      data MCELL/0/, NLU3D/25/
      data XYCELL1/0.,0./, DXYCELL/0.,0./
      data WSBIN/0.5, 1.8, 3.3, 5.4, 8.5, 10.8/
      data NSEASN/4/, NTPDc/0/, NWSPc/0/
      data MSNc/1,1,2,2,2,3,3,3,4,4,4,1/
      data RROSE/20./, CROSE/-1./
      data MXYPOLL/0/, XPOLL/0.0/, YPOLL/0.0/
      data MWDBINTYP/1/, MCBINTYP/0/, CBIN/6*0.0/
      data ZAQ/mxloc*0.0/
      data lnomap/.FALSE./, lgeo/.FALSE./, lutm/.FALSE./
      data llcc/.FALSE./, lps/.FALSE./, lem/.FALSE./
      data llaza/.FALSE./, lttm/.FALSE./

c --- /EXTINFO/ common block (metseries.ser)
      data lallprof/.FALSE./, lstandard/.FALSE./, lmetstat/.FALSE./
      data lneutral/.FALSE./, ldirect/.FALSE./
      data llinear/.FALSE./, lnone/.FALSE./

c --- /WNDROSE/ common block
c --- Default range for wind field (wscls) or concentration field (wccls)
      data wscls/1.8,3.3,5.4,8.5,10.8,100.0/
      data wccls/0.005,0.010,0.020,0.050,0.100,20.000/
c --- Default for low wind field threshold (wscalm) and low concentration threshold (wclow)
      data wscalm/0.5/
      data wclow/0.001/
c --- Pollutant rose scale factors
      data conc_scale/-1./, rose_radius/20./

      data sdir/'N','NNE','NE','ENE','E','ESE','SE','SSE',
     &          'S','SSW','SW','WSW','W','WNW','NW','NNW','SUM'/
      data (sname(i),i=1,5)/'Annual(Jan to Dec)','Winter(Dec,Jan,Feb)',
     &      'Spring(Mar,Apr,May)','Summer(Jun,Jul,Aug)',
     &      'Autumn(Sep,Oct,Nov)'/
      data ((sname2(i,j),i=1,5),j=1,2)/'Annual','Winter','Spring',
     &     'Summer','Autumn','(Jan to Dec)','(Dec,Jan,Feb)',
     &     '(Mar,Apr,May)','(Jun,Jul,Aug)','(Sep,Oct,Nov)'/

      data msn/1,1,2,2,2,3,3,3,4,4,4,1/

c --- (CEC - 080911 - added when COORDLIB is added)
      data datum3d/'NWS-84  '/
      data pmap/'UTM     '/
      data datum/'NWS-84  '/
      data utmhem/'N   '/
      data iutmzn/-999/
      data feast/0.0/, fnorth/0.0/

c --- /METINP/ common block
      data col_dtm/'DATETIME'/
      data col_avg/'DATAAVID'/
      data col_stn/'STNCODE'/
      data col_vald/'VALID'/
      data col_spd/'        '/
      data col_dir/'        '/
      data col_t2/'        '/
      data col_t10/'        '/
      data col_rh/'        '/
      data col_pres/'        '/
      data col_sol/'        '/
      data col_prc/'        '/

c --- V1.9.0, Level 121203
c --- /M2DINFO2/ common block
      data n2dout/13/
      data id_rain,id_rainc,id_rainnc/1,1,1/
      data (mm5names(i),i=1,16)/'RAIN','RAIN CON','RAIN NON'
     &   ,'SNOWCOVR','GROUND T','PBL HGT','SHFLUX','LHFLUX'
     &   ,'UST','SWDOWN','LWDOWN','T2','Q2','WD10','WS10'
     &   ,'TSEASFC'/
      data (mm5units(i),i=1,16)/'mm','mm','mm'
     &  ,'NONE','K','m','W m-2','W m-2'
     &  ,'m s-1','W m-2','W m-2','K','g kg-1','degree','m s-1'
     &  ,'K'/
      data (wrfnames(i),i=1,17)/'PSFC','RAIN','SNOWC','SWDOWN'
     &  ,'GLW','T2','Q2','WD10','WS10','SST','TSK','PBLH'
     &  ,'HFX','LH','UST','RAINC','RAINNC'/
      data (wrfunits(i),i=1,17)/'hpa','mm','NONE','W m-2'
     &  ,'W m-2','K','g kg-1','degree','m s-1','K','K','m'
     &  ,'W m-2','W m-2','m s-1','mm','mm'/
      data (c2dout_mm5(i),i=1,13)/
     &    'GROUND T','PBL HGT','UST'
     &   ,'SWDOWN','LWDOWN','T2','Q2','U10','V10'
     &   ,'TSEASFC','RAIN','RAIN CON','RAIN NON'/
      data (c2dout_wrf(i),i=1,13)/
     &    'TSK','PBLH','UST'
     &   ,'SWDOWN','GLW','T2','Q2','WD10','WS10'
     &   ,'SST','RAIN','RAINC','RAINNC'/

      end

c----------------------------------------------------------------------
c --- BRING IN CALPUFF SYSTEM UTILITY SUBROUTINES
      include 'calutils.for'
      include 'coordlib.for'
c --- BRING IN SLATEC SUBROUTINES
      include 'slatec.for'
c----------------------------------------------------------------------

c ---------------------------------------------------------------------
      Subroutine setupmm5
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Setup for 3D.DAT
c
c --- UPDATES:
c
c --- Version 1.6, level 090318 to Version 1.66, level 090731 (DGS)
c      1. Remove BUFF and IDLAT (not used)
c --- Version 1.5, level 090203 to Version 1.6, level 090318 (DGS)
c      1. Control file inputs from /CONTROL/
c      2. Explicitly set AZONEMET,IZONEMET of input data to GMT
c      3. Set IFRMT for location from map and MCELL
c --- Version 1.44, level 080205 to Version 1.5, level 090203 (DGS)
c      1. Move time period range out of data format section
c      2. Use UTC+nnnn string for time zone and set on separate line
c      3. Move profile method into this section
c --- Version 1.2, level: 060707 to Version 1.44, level 080205 (CEC)
c      1. Add a test to make sure DIRECT profil is used only to
c         extract 10m-W, 2m-T, 2m-Q for MM5 output
c --- Version 1.1, Level: 060615 to Version 1.2, Level: 060707  (DGS)
c      1. Convert integer time zone to character time zone
c
c ---------------------------------------------------------------------

C     Setup for MM5 format

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

      character*16 cprof16(6)
      data cprof16/'STANDARD        ','METSTAT         ',
     &             'NEUTRAL         ','DIRECT          ',
     &             'LINEAR          ','NONE            '/

c --- All data in 3D.DAT files are for GMT (UTC+0000)
      izonemet=0
      azonemet='UTC+0000'

c --- Profile method for estimating values at specified elevations
      cprofile=cprof16(mprof)

c --- Land use
      nland=nlu3d

c     Not used for MM53D files. They are read in from MM53D files
      xsw=xycell1(1)
      ysw=xycell1(2)
      dxm=dxycell(1)
      dym=dxycell(2)

c --- Set location type
c --- Assume x,y
      ifrmt=1
c --- Unless projection is lat/lon
      if(LGEO) ifrmt=2
c --- Or, unless user selects cell i,j
      if(mcell.EQ.1) ifrmt=3

c --- Each output file for 1 location
      nloc=ntsfout

c --- Station location (X/Y, LON/LAT, I/J)
      do i=1,nloc
         xloc(i)=xmet(i)
         yloc(i)=ymet(i)

c ---    Set logicals for output variables
         lwind(i)=.TRUE.
         if(zwind(i).LT.0.0) lwind(i)=.FALSE.
         ltmpk(i)=.TRUE.
         if(ztmpk(i).LT.0.0) ltmpk(i)=.FALSE.
         lshum(i)=.TRUE.
         if(zshum(i).LT.0.0) lshum(i)=.FALSE.
         lother(i)=.TRUE.
         if(zother(i).LT.0.0) lother(i)=.FALSE.

c --- (CEC - 080205 - Add a test to make sure DIRECT profile is used
c ---    only with MM5 and wind at 10m, T at 2m, Q at 2m)
         if(cprofile.eq.'DIRECT') then
           if(lwind(i).and.zwind(i).ne.10) then
             write(ilog,*)'Direct Access profile with MM5'
             write(ilog,*)'only for 10m wind or 2m temp or 2m Q'
             write(ilog,*)'zwind',zwind(i)
             print *,'Direct Access profile with MM5'
             print *,'only for 10m wind or 2m temp or 2m q'
             print *,'zwind',zwind(i)
             stop 
           endif
           if(ltmpk(i).and.ztmpk(i).ne.2)then
             write(ilog,*)'Direct Access profile with MM5'
             write(ilog,*)'only for 10m wind or 2m temp or 2m Q'
             write(ilog,*)'ztmpk',ztmpk(i)
             print *,'Direct Access profile with MM5'
             print *,'only for 10m wind or 2m temp or 2m q'
             print *,'ztmpk',ztmpk(i)
             stop 
           endif
           if(lshum(i).and.zshum(i).ne.2) then
             write(ilog,*)'Direct Access profile with MM5'
             write(ilog,*)'only for 10m wind or 2m temp or 2m Q'
             write(ilog,*)'zshum',zshum(i)
             print *,'Direct Access profile with MM5'
             print *,'only for 10m wind or 2m temp or 2m q'
             print *,'zshum',zshum(i)
             stop 
           endif
         endif
      enddo

c --- Process profile method selection
c --- (CEC - 080205 - profil direct added (ldirect))
      if(cprofile.EQ.'STANDARD') then
         lstandard=.TRUE.
      elseif(cprofile.EQ.'METSTAT') then
         lmetstat=.TRUE.
      elseif(cprofile.EQ.'NEUTRAL') then
         lneutral=.TRUE.
      elseif(cprofile.EQ.'DIRECT') then
         ldirect=.TRUE.
      elseif(cprofile.EQ.'ALL') then
         lstandard=.TRUE.
         lneutral=.TRUE.
         lmetstat=.TRUE.
         lallprof=.TRUE.
      else
         write(ilog,*)
         write(ilog,*)'-----------------------------------------------'
         write(ilog,*)'Invalid Profile Method: ',cprofile
         write(ilog,*)'-----------------------------------------------'
         write(ilog,*)'Expected one of the following --'
         write(ilog,*)'STANDARD, METSTAT, NEUTRAL, DIRECT, ALL'
         write(ilog,*)'(input must be upper case)'
         write(ilog,*)'-----------------------------------------------'
         write(ilog,*)
         stop 'HALTED -- See list file for ERRORS'
      endif

      write(ilog,'(a)')'M3D file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupmm4
c ---------------------------------------------------------------------
c 
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Setup for MM4.DAT 

      include 'params.ser'
      include 'metseries.ser'

      write(ilog,*)'Setup CALMM5/MM4 format not coded'
      print *,'Setup CALMM5/MM4 format not coded'
      stop

c     return
      end

c ---------------------------------------------------------------------
      Subroutine setupclm
c ---------------------------------------------------------------------
c --- METSERIES  Version: 1.9.0         Level: 100721
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Setup for CALMET.DAT 
c
c --- UPDATES:
c
c --- Version 1.79, Level 100721 from Level 090731 (JSS)
c     1.  Fix reads of LCC origin lat/long in v2.0 and v2.1 CALMET.DAT 
c         dataset versions and compute old variables (rlat0m, rlon0m)
c     2.  Note:  new /MAPINFO/ common block required w/ 'relon0m'
c         variable
c --- Version 1.6, level 090318 to Version 1.66, level 090731 (DGS)
c      1. Remove BUFF declaration (not used)
c --- Version 1.5, level 090203 to Version 1.6, level 090318 (DGS)
c      1. Control file inputs from /CONTROL/
c      2. Halt if CALMET time zone is not the zone in the control file
c --- Version 1.4, Level: 070315 to Version 1.5, level 090203 (DGS)
c      1. Move time period range out of data format section
c      2. Move profile method into this section (NEUTRAL only)
c --- Version 1.2, Level: 060707 to Version 1.4, Level: 070315  (DGS)
c      1. Input files are timeseries files if no extraction locations
c         are provided, so CALMET header processing is conditional.
c --- Version 1.1, Level: 060615 to Version 1.2, Level: 060707  (DGS)
c      1. Read time zone from header of first CALMET file and pass
c         as both integer and character.
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- Local Variables (Old calmet header) 
      character*80 titclm(3)
      character*8 vermet,levmet
      logical*4 lcalgrd

c --- Local Variables (New calmet header - V5.5 L030402) 
      character*16 dataset,dataver
      character*64 datamod
      character*132 comment1
      character*4 utmhem
      character*8 datum,pmap
      character*12 daten
c --- Dataset 2.1
      character*8 axbtz

c --- Profile method for estimating values at specified elevations
      lneutral=.TRUE.
      cprofile='NEUTRAL         '

c --- Number of locations = number of TSF files
      nloc=ntsfout

      do i=1,nloc
         xloc(i)=xmet(i)
         yloc(i)=ymet(i)
c ---    Set logicals for output variables
         lwind(i)=.TRUE.
         if(zwind(i).LT.0.0) lwind(i)=.FALSE.
         ltmpk(i)=.TRUE.
         if(ztmpk(i).LT.0.0) ltmpk(i)=.FALSE.
         lshum(i)=.TRUE.
         if(zshum(i).LT.0.0) lshum(i)=.FALSE.
         lother(i)=.TRUE.
         if(zother(i).LT.0.0) lother(i)=.FALSE.
      enddo

c --- Open first file to get time zone from header
c ------------------------------------------------
      open(in,file=fmet(1),status='old',form='unformatted',
     &     action='read')

c --- Read and test first record to determine header format
c --- Record #1 - File Declaration -- 24 words
      read(in) dataset,dataver,datamod
      ifilver=0
      i2dmet=0
      itime=0 
      ibsec=0
      iesec=0
      if(dataset.EQ.'CALMET.DAT') then
         ifilver=1
         i2dmet=1
         if(dataver.EQ.'2.1') itime=1
      endif
      REWIND(in)

c --- Read header records needed for time zone

      if(ifilver.EQ.1) then  ! CALMET Dataset 2.0 and later

c ---    Record #1 - File Declaration -- 24 words
         read(in) dataset,dataver,datamod

c ---    Record #2 - Number of comment lines -- 1 word
         read(in) ncom

c ---    Loop over comment records
         do i=1,ncom
            read(in) comment1
         enddo

         if(itime.EQ.0) then
c ---       CALMET.DAT - v2.0 dataset version
c ---       record #NCOM+3 - run control parameters -- 33 words
            read(in)ibyr,ibmo,ibdy,ibhr,ibtz,irlg,irtype,
     &      nx, ny, nz, dgrid, xorigr, yorigr, iwfcod, nssta,
     &      nusta, npsta, nowsta, nlu, iwat1, iwat2, lcalgrd,
     &      pmap,datum,daten,feast,fnorth,utmhem,iutmzn,
     &      rnlat0m,relon0m,xlat1m,xlat2m
            izonemet=ibtz
            zone=FLOAT(izonemet)
            call BASRUTC(zone,azonemet)
c ---       Convert original latitude/longitude to common block variable names
            rlat0m=rnlat0m
c ---       rlon0m is longitude w/ W long. positive; relon0m is long. w/ E long. positive
            rlon0m=-relon0m
         else
c ---       CALMET.DAT - v2.1 dataset version
c ---       record #NCOM+3 - run control parameters -- 39 words
            read(in) ibyr,ibmo,ibdy,ibhr,ibsec,
     1               ieyr,iemo,iedy,iehr,iesec,
     2               axbtz,irlg,irtype,
     3      nx, ny, nz, dgrid, xorigr, yorigr, iwfcod, nssta,
     4      nusta, npsta, nowsta, nlu, iwat1, iwat2, lcalgrd,
     5      pmap,datum,daten,feast,fnorth,utmhem,iutmzn,
     6      rnlat0m,relon0m,xlat1m,xlat2m
            azonemet=axbtz
            call UTCBASR(azonemet,zone)
            izonemet=NINT(zone)
c ---       Convert original latitude/longitude to common block variable names
            rlat0m=rnlat0m
c ---       rlon0m is longitude w/ W long. positive; relon0m is long. w/ E long. positive
            rlon0m=-relon0m
         endif

      endif

      if(ifilver.EQ.0) then  ! Old CALMET

c ---    record #1 - run title -- 60 words
         read(in)titclm

c ---    record #2 - run control parameters -- 26 words
c ---    (vermet, levmet are both 8 bytes)
         read(in)vermet,levmet,ibyr,ibmo,ibdy,ibhr,ibtz,irlg,
     &   irtype,nx,ny,nz,dgrid,xorigr,yorigr,iutmzn,iwfcod,nssta,
     &   nusta,npsta,nowsta,nlu,iwat1,iwat2,lcalgrd
         izonemet=ibtz
         zone=FLOAT(izonemet)
         call BASRUTC(zone,azonemet)

      endif

      CLOSE(in)

c --- Trap time-zone difference
      if(izonemet.NE.izonec) then
         write(ilog,*)
         write(ilog,*)' Error processing CALMET.DAT file'
         write(ilog,*)'          Data are in time zone: ',azonemet
         write(ilog,*)'     Extraction is in time zone: ',azonec
         write(ilog,*)' Times zones must match'
         stop 'Halted in SETUPCLM --- See log file'
      endif

900   write(ilog,'(a)')'CALMET file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupsrf
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731      SETUPSRF
c --- Zhong-Xiang Wu           

c --- PURPOSE: Setup for SURF.DAT 
c
c --- UPDATES:
c
c --- Version 1.6, level 090318 to Version 1.66, level 090731 (DGS)
c       1. Remove BUFF, BUFF1, UTMHEM declaration (not used)
c --- Version 1.5, level 090203 to Version 1.6, level 090318 (DGS)
c       1. Control file inputs from /CONTROL/
c       2. Halt if CALMET time zone is not the zone in the control file
c --- Version 1.41, Level 070425 to Version 1.5, level 090203 (DGS)
c       1. Move time period range out of data format section
c       2. Set profile logical LNONE true
c --- Version 1.4, Level 070315 to Version 1.41, Level 070425 (IWL)
c       1.  Allow input SURF.DAT filename to contain spaces and
c           increase max length to 132 characters in subroutine
c           SETUPSRF
c --- Version 1.2, Level: 060707 to Version 1.4, Level: 070315  (DGS)
c      1. Input files are timeseries files if no extraction locations
c         are provided, so CALMET header processing is conditional.
c --- Version 1.1, Level: 060615 to Version 1.2, Level: 060707  (DGS)
c      1. Read time zone from header of first SURF file and pass
c         as both integer and character.
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- Local Header Variables
      character*16 dataset,dataver
      character*64 datamod
      character*4 xyunit
      character*8 datum,pmap
      character*12 daten
      character*8 axtz

c --- No profiling is done for SURF.DAT
      lnone=.TRUE.
      cprofile='NONE            '

c --- Number of locations = number of TSF files
      nloc=ntsfout

      do i=1,nloc 
         idloc(i)=idmet(i)
c ---    Set logicals for output variables
         lwind(i)=.TRUE.
         if(zwind(i).LT.0.0) lwind(i)=.FALSE.
         ltmpk(i)=.TRUE.
         if(ztmpk(i).LT.0.0) ltmpk(i)=.FALSE.
         lshum(i)=.TRUE.
         if(zshum(i).LT.0.0) lshum(i)=.FALSE.
         lother(i)=.TRUE.
         if(zother(i).LT.0.0) lother(i)=.FALSE.
      enddo

c --- Open first file to get time zone from header
c ------------------------------------------------
      open(in,file=fmet(1),status='old',action='read')

c --- Read header information
      read(in,'(2a16,a64)') dataset,dataver,datamod
      ifilver=0
      itime=0
      if(dataset.EQ.'SURF.DAT') then
         ifilver=1
c ---    Set time structure flag
         if(dataver.EQ.'2.0') then
c ---       Dataset 2.0 with comment records
            itime=0
         else
c ---       Dataset with comment records and begin/end times
            itime=1
         endif
      endif
      REWIND(in)

      if(ifilver.eq.1) then
         read(in,'(2a16,a64)') dataset,dataver,datamod
         read(in,*)ncom
         do i=1,ncom
            read(in,*)
         enddo
         read(in,'(a8)')pmap

         if(pmap.EQ.'NONE    ') then
            if(itime.EQ.1) then
c ---          Explicit time convention -
c ---          UTC time zone
               read(in,'(a8)') axtz
               azonemet=axtz
               call UTCBASR(azonemet,zone)
               izonemet=NINT(zone)
            else
c ---          hour-ending dataset 
               read(in,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,izonemet,nstn
               zone=FLOAT(izonemet)
               call BASRUTC(zone,azonemet)
            endif
         elseif(pmap.EQ.'LL      ') then
            read(in,'(a8,a10)') datum,daten
            read(in,'(a4)') xyunit
            if(itime.EQ.1) then
c ---          explicit time with seconds
               read(in,'(a8)') axtz
               azonemet=axtz
               call UTCBASR(azonemet,zone)
               izonemet=NINT(zone)
            else
c ---          hour-ending dataset 
               read(in,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,izonemet,nstn
               zone=FLOAT(izonemet)
               call BASRUTC(zone,azonemet)
            endif
         else
            write(ilog,*)
            write(ilog,*) 'Invalid projection found'
            write(ilog,*) 'Projection found    = ',pmap
            write(ilog,*) 'Projection expected = NONE or LL'
            stop 'Halted: Invalid projection found'
         endif

      endif

      CLOSE(in)

c --- Trap time-zone difference
      if(izonemet.NE.izonec) then
         write(ilog,*)
         write(ilog,*)' Error processing SURF.DAT file'
         write(ilog,*)'          Data are in time zone: ',azonemet
         write(ilog,*)'     Extraction is in time zone: ',azonec
         write(ilog,*)' Times zones must match'
         stop 'Halted in SETUPSRF --- See log file'
      endif

900   write(ilog,'(a)')'SURF.DAT file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupsfc
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Christelle Escoffier-Czaja           
c
c --- PURPOSE: Setup for AERMOD.SFC 
c
c --- UPDATES:
c
c --- Version 1.6, level 090318 to Version 1.66, level 090731 (DGS)
c       1. Remove BUFF1 declaration (not used)
c --- Version 1.5, level 090203 to Version 1.6, level 090318 (DGS)
c       1. Control file inputs from /CONTROL/
c       2. Explicitly set data time zone to that in the control file
c          because this information is not available in AERMOD.SFC
c
c ---------------------------------------------------------------------
      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'metinp.ser'

      character*132 buff
      character*1 latNS, lonEW
      character*5 idup,idsfc
      integer idupp,idsfcc

c --- No profiling is done for AERMOD.SFC
      lnone=.TRUE.
      cprofile='NONE            '

c --- Impose time zone from user
      izonemet=izonec
      azonemet=azonec

c --- Use array variables even though file contains 1 location
      if(ntsfout.NE.1) then
         write(ilog,*)'SETUPSFC:  Too many output TSF files'
         write(ilog,*)'  Expected NTSFOUT = 1'
         write(ilog,*)'     Found NTSFOUT = ',ntsfout
         stop
      endif
      nloc=ntsfout
      i=nloc

c --- Read extracted station ID and configuration
      idloc(i)=idmet(i)
      xloc(i)=xmet(i)
      yloc(i)=ymet(i)

c --- Set logicals for output variables
      lwind(i)=.TRUE.
      if(zwind(i).LT.0.0) lwind(i)=.FALSE.
      ltmpk(i)=.TRUE.
      if(ztmpk(i).LT.0.0) ltmpk(i)=.FALSE.
      lshum(i)=.TRUE.
      if(zshum(i).LT.0.0) lshum(i)=.FALSE.
      lother(i)=.TRUE.
      if(zother(i).LT.0.0) lother(i)=.FALSE.

c --- Check the header that it is an AERMOD.SFC file
c ------------------------------------------------

      do iloc=1,nloc
      open(in,file=fmet(iloc),status='old',action='read')

c --- Read header information
      read(in,'(a)')buff
      read(buff(3:9),'(f6.3)')xlat11
      read(buff(10:10),'(a)')latNS
      read(buff(13:19),'(f7.3)')xlon11
      read(buff(20:20),'(a)')lonEW
      read(buff(31:35),'(5a)')idup
      read(buff(40:45),'(i6)')idupp
      read(buff(48:52),'(5a)')idsfc
      read(buff(57:62),'(i6)')idsfcc

c --- Check AERMOD format
      if(idup.ne.'UA_ID'.and.idsfc.ne.'SF_ID') then
         write(ilog,*)' '
         write(ilog,*)'file is not in AERMOD format'
         write(*,*)'file is not in AERMOD format'
         stop
      endif
c --- Check ID surface station
      if(idsfcc.ne.idloc(iloc)) then
         write(ilog,*)' '
         write(ilog,*)'ID station number different than in AERMOD file'
         write(ilog,*)'ID in AERMOD file =', idsfcc
         write(ilog,*)'ID provided =',idloc(iloc)
         write(*,*)'ID station number different than in AERMOD file'
         write(*,*)'ID in AERMOD file =', idsfcc
         write(*,*)'ID provided =',idloc(iloc)
         stop
      endif

      CLOSE(in)
      enddo

900   write(ilog,'(a)')'AERMOD.SFC file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupammnetw
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Christelle Escoffier-Czaja           
c
c --- PURPOSE: Setup for AMMNETW.CSV or MONITORW.CSV
c
c --- UPDATES:
c
c --- Version 1.6, Level: 090318 to Version 1.66, Level: 090731 (DGS)
c        - Remove BUFF, BUFF1 (not used)
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c        - Control file information from /CONTROL/
c        - Explicitly set data time zone to that in the control file
c          because this information is not available in AMMNETW.CSV
c --- Version 1.5, Level: 090128 to Version 1.5, Level: 090203 (CEC)
c         - Add option to extract other fields than wind,temp and rel. humd.
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'metinp.ser'

c --- No profiling is done for AMMNETW.CSV
      lnone=.TRUE.
      cprofile='NONE            '

c --- Impose time zone from user
      izonemet=izonec
      azonemet=azonec

c --- Number of locations = number of TSF files
      nloc=ntsfout

      do i=1,nloc 
         idloc(i)=idmet(i)
         xloc(i)=xmet(i)
         yloc(i)=ymet(i)
c ---    Set logicals for output variables
         lwind(i)=.TRUE.
         if(zwind(i).LT.0.0) then
            lwind(i)=.FALSE.
         else
            col_spd='MEANWSMS'
            col_dir='MEANWDIR'
         endif
         ltmpk(i)=.TRUE.
         if(ztmpk(i).LT.0.0) then
            ltmpk(i)=.FALSE.
         elseif(ztmpk(i).eq.2.0.or.ztmpk(i).eq.10.0) then
            col_t2='AVTEMP2MC'
            col_t10='AVTEMP10MC'
         else
            write(ilog,*)' '
         write(ilog,*)'error - Temperature available only at 2m or 10m'
            write(*,*)'error - Temperature available only at 2m or 10m'
            stop
         endif
         lshum(i)=.TRUE.
         if(zshum(i).LT.0.0) then
            lshum(i)=.FALSE.
         else
            col_rh='AVRELHUMIDITYPC'
            col_pres='AVBRMPRESSMB'
         endif
         lother(i)=.TRUE.
         if(zother(i).lt.0.0) then
            lother(i)=.FALSE.
         else
            col_pres='AVBRMPRESSMB'
            col_sol='AVSOLRRADWM2'
            col_prc='TOTALPRECIPMM'
         endif
      enddo

c --- Check the header that it is an AMMNETW.CSV file
c ------------------------------------------------
      open(in,file=fmet(1),status='old',action='read')

c --- Read header information
      call READHDM(IN)

      CLOSE(in)
      
900   if(mdata.eq.'AMMNETW') then
      write(ilog,'(a)')'AMMNETW.CSV file setup phase completed'
      elseif(mdata.eq.'MONITORW') then
      write(ilog,'(a)')'MONITORW.CSV file setup phase completed'
      endif
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupammnetc
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100107
c --- Christelle Escoffier-Czaja           
c
c --- PURPOSE: Setup for AMMNETW.CSV & AMMNETC.CSV for pollutant
c              wind roseprocess
c
c --- UPDATES:
c
c --- Version 1.66, level: 090731 to Version 1.75, Level: 100107 (CEC)
c        - Allow two format for cspec:
c        -  cspec1=cspeci(1) and cspec2=cspeco(1)
c --- Version 1.6, Level: 090318 to Version 1.66, Level: 090731 (DGS)
c        - Remove C320, BUFF, BUFF1 (not used)
c        - Add variable name MONITOR which can be used instead of AMMNET
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c        - Control file information from /CONTROL/
c        - Explicitly set data time zone to that in the control file
c          because this information is not available in AMMNET_.CSV
c        - Allow NMETINP=0 if MROSE=0
c ---------------------------------------------------------------------

      include 'params.ser'
c --- (Pollutant arrays set for MXSPEC=9)
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'aqinput.ser'
      include 'metinp.ser'

      character*12 aunit2,specdb(3,mxspec)

      integer ipoll(mxspec)

c --- Molar Mass
      real xMdb(mxspec)

c --- Species info (control-file : AMMNETC name : AMMNETC Units)
      data specdb/'SO2         ','AVESO2      ','PPM         ',
     1            'NO          ','AVENO       ','PPM         ',
     2            'NO2         ','AVENO2      ','PPM         ',
     3            'NOX         ','AVENOX      ','PPM         ',
     4            'CO          ','AVECO       ','PPM         ',
     5            'O3          ','AVEO3       ','PPM         ',
     6            'H2S         ','AVEH2S      ','PPM         ',
     7            'PM10        ','AVEPM10     ','UG/M3       ',
     8            'PM2.5       ','AVEPM2_5    ','UG/M3       '/

c --- Molecular weights for these species
      data xMdb/64.0,30.0,46.0,46.0,28.0,48.0,34.0,-1.0,-1.0/

c --- No profiling is done for AMMNETW.CSV & AMMNETC.CSV
      lnone=.TRUE.
      cprofile='NONE            '

c --- Impose time zone from user
      izonemet=izonec
      azonemet=azonec
      izoneaq=izonec
      azoneaq=azonec

c --- Initialization
      do i=1,mxspec
         rscalex(i)=1.0
         ipoll(i)=0
      enddo
      col_spd='MEANWSMS'
      col_dir='MEANWDIR'
      lso2(1)=.FALSE.
      lno(1)=.FALSE.
      lno2(1)=.FALSE.
      lnox(1)=.FALSE.
      lco(1)=.FALSE.
      lo3(1)=.FALSE.
      lh2s(1)=.FALSE.
      lpm10(1)=.FALSE.
      lpm25(1)=.FALSE.

c --- Number of locations = number of TSF files
      nloc=ntsfout
      do i=1,nloc
c ---    Assign AQ station location info
         idloc(i)=idaq(i)
         xloc(i)=xaq(i)
         yloc(i)=yaq(i)
c ---    Wind
         lwind(i)=.TRUE.
         if(zwind(i).LT.0.0) lwind(i)=.FALSE.
         if(nmetinp.EQ.0) lwind(i)=.FALSE.
      enddo

c --- Pollutant Concentration (1 species supported)
      npoll=nspec
      if(npoll.NE.1) then
         write(ilog,*) 'Only 1 pollutant can be selected at a time'
         stop 'Halted in SETUPAMMNETC:  see log file'
      endif
      write(ilog,*)
      write(ilog,*)'Number of pollutant species: ',npoll
      write(ilog,*)'Input Spec/Units, Output Spec/Units, Scale'
      do i=1,npoll
         do k=1,mxspec
            if(cfspec(i).EQ.specdb(1,k)) ipoll(i)=k
         enddo
         if(ipoll(i).EQ.0) then
            write(ilog,*) 'Invalid pollutant species name: ',cfspec(i)
            stop 'Halted in SETUPAMMNETC:  see log file'
         endif
c ---    Assign species name used in input and output files
         cspeci(i)=specdb(2,ipoll(i))
         cspeco(i)=specdb(1,ipoll(i))
c ---    Choice of units for output concentrations
c ---    (g/m3; mg/m3; ug/m3; ng/m3; ppm; ppb )
         unitoutx(i)=ADJUSTL(cunito(i))
c ---    Compute scaling factor
         xM=xMdb(ipoll(i))
         aunit2=specdb(3,ipoll(i))
         call SCALE(ilog,unitoutx(i),aunit2,xM,rscalex(i))
         write(ilog,*)cspeci(i),aunit2,cspeco(i),unitoutx(i),rscalex(i)
      enddo
c --- Set logicals for identifying species (each station is same)
      do i=1,npoll
         if(specdb(1,ipoll(i)).EQ.'SO2         ') lso2(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'NO          ') lno(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'NO2         ') lno2(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'NOX         ') lnox(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'CO          ') lco(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'O3          ') lo3(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'H2S         ') lh2s(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'PM10        ') lpm10(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'PM2.5       ') lpm25(1)=.TRUE.
      enddo
c --- Distribute across stations
      do k=2,nloc
         lso2(k) =lso2(1)
         lno(k)  =lno(1)
         lno2(k) =lno2(1)
         lnox(k) =lnox(1)
         lco(k)  =lco(1)
         lo3(k)  =lo3(1)
         lh2s(k) =lh2s(1)
         lpm10(k)=lpm10(1)
         lpm25(k)=lpm25(1)
      enddo

c --- *** Code needs to be generalized for multiple species ***
c ---     Assign 1st array values to scalar variables
      cspec1=cspeci(1)
      cspec2=cspeco(1)
      unitout=unitoutx(1)
      rscale=rscalex(1)


c --- Check the header that it is an AMMNETW.CSV file
c ------------------------------------------------
      if(nmetinp.GT.0) then
         open(in,file=fmet(1),status='old',action='read')
c ---    Read header information
         call READHDM(IN)
         CLOSE(in)
      endif
c
c --- Check the header that it is an AMMNETC.CSV file
c ------------------------------------------------

      open(in,file=faq(1),status='old',action='read')
c --- Read header information
      call READHDP(IN)
      CLOSE(in)

900   if(mdata.eq.'AMMNETC') then
      write(ilog,'(a)')'AMMNETC.CSV file setup phase completed'
      elseif(mdata.eq.'MONITORC') then
      write(ilog,'(a)')'MONITORC.CSV file setup phase completed'
      endif
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setuppost
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Christelle Escoffier-Czaja           
c
c --- PURPOSE: Setup for TIMESERIES & CALMET for pollutant wind rose
c              process
c
c --- UPDATES:
c --- Version 1.62, Level: 090411 to Version 1.66, level 090731 (DGS)
c       1. Remove C320, BUFF1, BUFF2, AWD, AWS declaration (not used)
c --- Version 1.6, Level: 090318 to Version 1.62, Level: 090411 (CEC)
c         - All header lines in description will be written instead
c           of the two first lines
c --- Version 1.5, Level 090203 to Version 1.6, Level 090318 (DGS)
c       1.  Control variables from /CONTROL/
c       2.  Track time zones individually (MET/AQ)
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'aqinput.ser'
      include 'metinp.ser'

      character*320 buff,hdr(50)
      character*12 aunit2,specdb(3,mxspec)
      character*18 headtime
      character*15 asplv
      character*8 pmap8

      character*16 tsernam,tserver
      character*64 tsermod
      character*80 comment
      character*12 avar(mxvars),aunits(mxvars)

      real xloc1,yloc1

      integer ipoll(mxspec)

c --- Molar Mass
      real xMdb(mxspec)

c --- Species info (control-file : CALPOST name : CALPOST Units)
      data specdb/'SO2         ','SO2         ','(notused   )',
     1            'NO          ','NO          ','(notused   )',
     2            'NO2         ','NO2         ','(notused   )',
     3            'NOX         ','NOX         ','(notused   )',
     4            'CO          ','CO          ','(notused   )',
     5            'O3          ','O3          ','(notused   )',
     6            'H2S         ','H2S         ','(notused   )',
     7            'PM10        ','PM10        ','(notused   )',
     8            'PM2.5       ','PM2_5       ','(notused   )'/

c --- Molecular weights for these species
      data xMdb/64.0,30.0,46.0,46.0,28.0,48.0,34.0,-1.0,-1.0/

c --- No profiling is done
      lnone=.TRUE.
      cprofile='NONE            '

c --- Impose time zone from user on AQ data
      izoneaq=izonec
      azoneaq=azonec

c --- Initialization
      do i=1,mxspec
         rscalex(i)=1.0
         ipoll(i)=0
      enddo
      lso2(1)=.FALSE.
      lno(1)=.FALSE.
      lno2(1)=.FALSE.
      lnox(1)=.FALSE.
      lco(1)=.FALSE.
      lo3(1)=.FALSE.
      lh2s(1)=.FALSE.
      lpm10(1)=.FALSE.
      lpm25(1)=.FALSE.
         
c --- Number of locations = number of TSF files
c --- 1 station can be selected
      if(ntsfout.NE.1) then
         write(ilog,*)'SETUPSFC:  Too many output TSF files'
         write(ilog,*)'  Expected NTSFOUT = 1'
         write(ilog,*)'     Found NTSFOUT = ',ntsfout
         stop
      endif
      nloc=ntsfout

c --- Assign location info from AQ file
c --- Read extracted station ID and configuration
      do i=1,nloc
         idloc(i)=idaq(i)
         xloc(i)=xaq(i)
         yloc(i)=yaq(i)
c ---    Wind
         lwind(i)=.TRUE.
      enddo

c --- Pollutant Concentration (1 species supported)
      npoll=nspec
      if(npoll.NE.1) then
         write(ilog,*) 'Only 1 pollutant can be selected at a time'
         stop 'Halted in SETUPPOST:  see log file'
      endif
      write(ilog,*)'Number of pollutant species: ',npoll
      do i=1,npoll
         do k=1,mxspec
            if(cfspec(i).EQ.specdb(1,k)) ipoll(i)=k
         enddo
         if(ipoll(i).EQ.0) then
            write(ilog,*) 'Invalid pollutant species name: ',cfspec(i)
            stop 'Halted in SETUPPOST:  see log file'
         endif
c ---    Assign species name used in input and output files
         cspeci(i)=specdb(2,ipoll(i))
         cspeco(i)=specdb(1,ipoll(i))
c ---    Choice of units for output concentrations
c ---    (g/m3; mg/m3; ug/m3; ng/m3; ppm; ppb )
         unitoutx(i)=ADJUSTL(cunito(i))
c ---    Compute scaling factor after getting units from file header
      enddo

c --- Set logicals for identifying species (each station is same)
      do i=1,npoll
         if(specdb(1,ipoll(i)).EQ.'SO2         ') lso2(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'NO          ') lno(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'NO2         ') lno2(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'NOX         ') lnox(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'CO          ') lco(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'O3          ') lo3(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'H2S         ') lh2s(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'PM10        ') lpm10(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'PM2.5       ') lpm25(1)=.TRUE.
      enddo
c --- Distribute across stations
      do k=2,nloc
         lso2(k) =lso2(1)
         lno(k)  =lno(1)
         lno2(k) =lno2(1)
         lnox(k) =lnox(1)
         lco(k)  =lco(1)
         lo3(k)  =lo3(1)
         lh2s(k) =lh2s(1)
         lpm10(k)=lpm10(1)
         lpm25(k)=lpm25(1)
      enddo

c --- *** Code needs to be generalized for multiple species ***
c ---     Assign 1st array values to scalar variables
      cspec=cspeci(1)
      unitout=unitoutx(1)
      xM=xMdb(ipoll(1))


c --- Check the MET header that it is a TIMESERIES.TSF output file
c --- with correct location and extraction elevation
c --------------------------------------------------
      open(in,file=fmet(1),status='old',action='read')

c ---  read header information from meteorological data file
c ---  Test first header record to determine dataset version
       read(in,'(2a16,a64)') tsernam,tserver,tsermod
        if(tsernam.EQ.'TIMESERIES.TSF  ') then
c ---       Read comment records
            read(in,*) ncomm
            do n=1,ncomm
               read(in,'(a80)') comment
            enddo
        else
            write(ilog,*)'Invalid timeseries format!'
            write(ilog,*)'Found ',tsernam
            write(ilog,*)'Expected TIMESERIES.TSF'
            stop 'Halted in SETUPPOST --- See log file'
        endif

c ---       Set a default map projection to NONE
            pmap8='NONE    '

c ---       Read header section before data description
            if(tserver.EQ.'1.0             ') then
               read(in,*) nvars
            elseif(tserver.NE.'1.3             ') then
               read(in,*) azonemet
               read(in,*) nvars
            elseif(tserver.EQ.'1.3             ') then
               read(in,*) ntitles
               if(ntitles.LT.2) then
                  write(ilog,*)' '
                  write(ilog,*)'Wrong number of title lines in file'
                  write(ilog,*)'Found    ',ntitles
                  write(*,*)'Needed 2'
                  write(*,*)'Wrong number of title lines in file'
                  write(*,*)'Found    ',ntitles
                  write(*,*)'Needed 2'
                  stop
               endif
c
c ---          (CEC - 090411 - Store all lines from the description lines
c               read(in,'(a)')hdr1
c               read(in,'(a)')hdr2
c               do k=3,ntitles
                do k=1,ntitles
c                  read(in,'(a)')hdr3
                   read(in,'(a)')hdr(k)
               enddo
               read(in,*) pmap8
               if(pmap8.EQ.'NONE    ') then
                  nskip=0
               elseif(pmap8.EQ.'LL      ') then
                  nskip=2
               elseif(pmap8.EQ.'UTM     ') then
                  nskip=3
               else
                  nskip=4
               endif
               do n=1,nskip
                  read(in,*)
               enddo
               read(in,*) azonemet
               read(in,*)
               read(in,*)
               read(in,*) nvars
            endif

c --- Trap time-zone difference in TIMESERIES.TSF file (MET)
      call UTCBASR(azonemet,zone)
      izonemet=NINT(zone)
      if(izonemet.NE.izonec) then
         write(ilog,*)
         write(ilog,*)' Error processing meteorological TSF file'
         write(ilog,*)'          Data are in time zone: ',azonemet
         write(ilog,*)'     Extraction is in time zone: ',azonec
         write(ilog,*)' Times zones must match'
         stop 'Halted in SETUPPOST --- See log file'
      endif

c --- Read data description records
      if(nvars.GT.mxvars) then
          write(ilog,*)' '
          write(ilog,*)'Too many timeseries variables are in file'
          write(ilog,*)'for size of arrays'
          write(ilog,*)'Found NVARS  = ',nvars
          write(ilog,*)'Array MXVARS = ',mxvars
          write(*,*)'Too many timeseries variables are in file'
          write(*,*)'for size of arrays'
          write(*,*)'Found NVARS  = ',nvars
          write(*,*)'Array MXVARS = ',mxvars
          stop
      endif
      do n=1,nvars
          zwind(1)=0.0
          xloc1=0.0
          yloc1=0.0
          if(tserver.NE.'1.3             ') then
              read(in,'(2a12,2f12.3)') avar(n),aunits(n),
     &                                     xmissval,zwind(1)
          else
              read(in,'(2a12,5f12.3)') avar(n),aunits(n),xmwt,
     &                                     xmissval,zwind(1),xloc1,yloc1
          endif
          if(avar(n)(1:4).eq.'WDIR') z2=zwind(1)
          if(avar(n)(1:6).eq.'WSPEED') then
              if(z2.eq.zwind(1)) then
                  hgt=zwind(1)
              else
                  write(ilog,*)'Error- wind speed ht not provided'
                  stop
              endif
          endif
       enddo

c ---  Final section of datasets before v1.3
c ---  Expect 2 fixed header records for title information
       if(tserver.NE.'1.3             ') then
           read(in,*) ntitles
           if(ntitles.LT.2) then
               write(ilog,*)'Wrong number of title lines in file'
               write(ilog,*)'Found    ',ntitles
               write(ilog,*)'Needed 2'
               write(*,*)'Wrong number of title lines in file'
               write(*,*)'Found    ',ntitles
               write(*,*)'Needed 2'
               stop
            endif
c ---          (CEC - 090411 - Store all lines from the description lines
c               read(in,'(a)')hdr1
c               read(in,'(a)')hdr2
c               do k=3,ntitles
                do k=1,ntitles
c                  read(in,'(a)')hdr3
                   read(in,'(a)')hdr(k)
               enddo
       endif

      CLOSE(in)
c
c --- Check that AQ file header is a TIMESERIES.DAT file and that
c --- pollutant and location requested match the input file
c ---------------------------------------------------------------
      open(in,file=faq(1),status='old',action='read')

c --- Read header information
      read(in,'(a320)')buff
      read(buff(2:19),'(a18)')headtime
      if(headtime.ne.'TIME-SERIES Output') then
       write(ilog,*)'ERROR - File not CALPOST OUTPUT TIME SERIES FORMAT'
        write(*,*)'ERROR - File not CALPOST OUTPUT TIME SERIES FORMAT'
        stop
      endif
      read(buff(32:46),'(a15)')asplv
      if(asplv(1:12).ne.cspec(1:12)) then
       write(ilog,*)'ERROR - species required by user not in TIMESERIES'
        write(ilog,*)'Timeseries file  =',asplv(1:12)
        write(ilog,*)'Species required =',cspec
        write(ilog,*) buff
        write(*,*)'ERROR - species required by user not in TIMESERIES'
        write(*,*)'Timeseries file  =',asplv(1:12)
        write(*,*)'Species required =',cspec
        write(*,*) buff
        stop
      endif

      read(in,'(a)')buff
      read(in,'(a)')buff                               
      read(buff(6:9),'(i4)')iperiod
      read(buff(10:16),'(a7)')itypper
      read(buff(72:83),'(a12)')aunit2

c --- Compute scaling factor
      call SCALE(ilog,unitout,aunit2,xM,rscale)   
      write(ilog,*)'Input Spec/Units, Output Spec/Units, Scale'
      write(ilog,*)cspeci(1),aunit2,cspeco(1),unitout,rscale
c
      do i=1,5
         read(in,'(a)')buff
      enddo
      read(in,'(a)')buff
      read(buff(18:32),'(e14.6)')xloc1
      read(in,'(a)')buff
      read(buff(18:32),'(e14.6)')yloc1
      if(xloc1.ne.xaq(1).and.yloc1.ne.yaq(1)) then
        write(ilog,*)'ERROR - X,Y location requested in control file'
        write(ilog,*)'differs from that in the air quality file'
        write(ilog,*)'Control File x,y = ',xaq(1),yaq(1)
        write(ilog,*)'MET File     x,y = ',xloc1,yloc1
        write(*,*)'ERROR - X,Y location requested in control file'
        write(*,*)'differs from that in the air quality file'
        write(*,*)'Control File x,y = ',xaq(1),yaq(1)
        write(*,*)'MET File     x,y = ',xloc1,yloc1
        stop
      endif
           
      CLOSE(in)

900   write(ilog,'(a)')'CALPOST TIMSERIES file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setuptsf
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090318      SETUPTSF
c
c --- PURPOSE: Setup for TIMESERIES.TSF input for pollutant wind rose
c              and pollutant rose output for an existing TSF file
c
c --- UPDATES:
c --- Version 1.5, Level 090203 to Version 1.6, Level 090318 (DGS)
c       -  Control variables from /CONTROL/
c       -  2 TSF files may be used for pollutant rose applications
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'wndrose.ser'

      character*320 buff
      character*132 c132a,c132b

c --- No profiling is done for TIMESERIES.TSF
      lnone=.TRUE.
      cprofile='NONE            '

c --- Must have 1 MET file
      if(nmetinp.NE.1) then
         write(ilog,*)'SETUPTSF:  Invalid number of input files'
         write(ilog,*)'There must be 1 MET file'
         write(ilog,*)'Found NMETINP, NAQINP = ',nmetinp,naqinp
         stop 'Halted in SETUPTSF -- see list file'
      endif

c --- Might also have 1 AQ file
      if(naqinp.GT.1 .OR. naqinp.LT.0) then
         write(ilog,*)'SETUPTSF:  Invalid number of input files'
         write(ilog,*)'There may be 0 or 1 AQ file'
         write(ilog,*)'Found NMETINP, NAQINP = ',nmetinp,naqinp
         stop 'Halted in SETUPTSF -- see list file'
      endif

c --- Determine number of TSF input files to open
      mtsf=1
      if(naqinp.GT.0) then
c ---    Test filenames (use 1 file if same)
         c132a=ADJUSTL(fmet(1))
         na=LEN_TRIM(c132a)
         c132b=ADJUSTL(faq(1))
         nb=LEN_TRIM(c132b)
         if(c132a(1:na).NE.c132b(1:nb)) mtsf=2
      endif

c --- Set up for ONE location
      nloc=1

c --- Verify input TIMESERIES.TSF file(s)
c --- First file
      open(in,file=fmet(1),status='old',action='read')
c --- Read top of header
      read(in,'(a320)')buff
      if(buff(1:14).NE.'TIMESERIES.TSF') then
         klast=LEN_TRIM(buff)
         write(ilog,*)'ERRROR - not correct data file:'
         write(ilog,*) buff(1:klast)
         write(ilog,*)'A METSERIES OUTPUT DATA file is expected'
         write(*,*)'ERRROR - not correct data file:'
         write(*,*) buff(1:klast)
         write(*,*)'A METSERIES OUTPUT DATA file is expected'
         stop
      endif
      CLOSE(in)

c --- Second file
      if(mtsf.EQ.2) then
         open(in,file=faq(1),status='old',action='read')
c ---    Read top of header
         read(in,'(a320)')buff
         if(buff(1:14).NE.'TIMESERIES.TSF') then
            klast=LEN_TRIM(buff)
            write(ilog,*)'ERRROR - not correct data file:'
            write(ilog,*) buff(1:klast)
            write(ilog,*)'A METSERIES OUTPUT DATA file is expected'
            write(*,*)'ERRROR - not correct data file:'
            write(*,*) buff(1:klast)
            write(*,*)'A METSERIES OUTPUT DATA file is expected'
            stop
         endif
         CLOSE(in)
      endif

      write(ilog,'(a)')'TIMESERIES.TSF file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine scale(io,aunit,aunit1,xM,rscale)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090203
c --- C Escoffier-Czaja
c
c --- PURPOSE: compute scaling factor for concentration
c              between units of concentration in file and units
c              requested by user
c
c --- UPDATES:
c
c ---------------------------------------------------------------------

       character*12 aunit,aunit1
       integer io
       real rscale
c
c --- parameters needed for transformation ppm/ppb into g/m3; mg/m3; ng/m3; ug/m3....
c      concentration is transformed in ppb using Cppm = Cug/m3 * xparam
c      xparam = 8.31412E-2 * T) / (P * Ma)
c      T in K; P in mb; Ma is the molar mass
c      Approximation for standard conditions: 
c      AtmP= xP= 1013.25mb; T= 15C= 288.15K (reference: ISA (international Standard Atmosphere);
c      ISO 13443; EEA (European Environment Agency)
c      1ppm = 1E03 ppb
c -----
       Xp=1013.25
       xT=288.15
       xparam=(8.31412E-2*xT)/(xP*xM)
c
c --- Initialisation of ierr (error message)
      ierr=0
c
         if(aunit(1:6).eq.'G/M**3'.or.aunit(1:6).eq.'g/m**3'.or.
     &      aunit(1:4).eq.'g/m3'.or.aunit(1:4).eq.'G/M3') then
         iiunitt=1
         elseif(aunit(1:7).eq.'MG/M**3'.or.aunit(1:7).eq.'mg/m**3'
     &      .or.aunit(1:5).eq.'mg/m3'.or.aunit(1:5).eq.'MG/M3') then
         iiunitt=2
         elseif(aunit(1:7).eq.'UG/M**3'.or.aunit(1:7).eq.'ug/m**3'
     &      .or.aunit(1:5).eq.'ug/m3'.or.aunit(1:5).eq.'UG/M3') then
         iiunitt=3
         elseif(aunit(1:7).eq.'NG/M**3'.or.aunit(1:7).eq.'ng/m**3'
     &      .or.aunit(1:5).eq.'ng/m3'.or.aunit(1:5).eq.'NG/M3') then
         iiunitt=4
         elseif(aunit(1:3).eq.'PPM'.or.aunit(1:3).eq.'ppm') then
         iiunitt=5
         elseif(aunit(1:3).eq.'PPB'.or.aunit(1:3).eq.'ppb') then
         iiunitt=6
         else
	 write(io,*)'ERROR - wrong unit requested'
         write(io,*)'UNITS in code:g/m3;mg/m3;ng/m3;ug/m3;ppm and ppb'
         write(io,*)'unit requested by user ',aunit
         stop
         endif
c
c --- Check the unit in MODEL OUTPUTS file or OBSERVATIONS file
         if(aunit1(1:6).eq.'G/M**3'.or.aunit1(1:6).eq.'g/m**3'.or.
     &      aunit1(1:4).eq.'g/m3'.or.aunit1(1:4).eq.'G/M3') then
         iiunitt2=1
         elseif(aunit1(1:7).eq.'MG/M**3'.or.aunit1(1:7).eq.'mg/m**3'
     &      .or.aunit1(1:5).eq.'mg/m3'.or.aunit1(1:5).eq.'MG/M3') then
         iiunitt2=2
         elseif(aunit1(1:7).eq.'UG/M**3'.or.aunit1(1:7).eq.'ug/m**3'
     &      .or.aunit1(1:5).eq.'ug/m3'.or.aunit1(1:5).eq.'UG/M3') then
         iiunitt2=3
         elseif(aunit1(1:7).eq.'NG/M**3'.or.aunit1(1:7).eq.'ng/m**3'
     &      .or.aunit1(1:5).eq.'ng/m3'.or.aunit1(1:5).eq.'NG/M3') then
         iiunitt2=4
         elseif(aunit1(1:3).eq.'PPM'.or.aunit1(1:3).eq.'ppm') then
         iiunitt2=5
         elseif(aunit1(1:3).eq.'PPB'.or.aunit1(1:3).eq.'ppb') then
         iiunitt2=6
         else
	 write(io,*)'ERROR - wrong unit in TIMSERIES file'
         write(io,*)'UNITS in code:g/m3;mg/m3;ng/m3;ug/m3;ppm and ppb'
         write(io,*)'unit in file = ',aunit1
         stop
         endif
c
c ---  Same units
        if(iiunitt.eq.iiunitt2) then
         rscale=1.0
c --- iiunitt=g/m3 (in control input file= output unit)
        elseif(iiunitt.eq.1.and.iiunitt2.eq.2) then
         rscale=1.0E-03                                                
        elseif(iiunitt.eq.1.and.iiunitt2.eq.3) then
         rscale=1.0E-06                        
        elseif(iiunitt.eq.1.and.iiunitt2.eq.4) then
         rscale=1.0E-09                        
        elseif(iiunitt.eq.1.and.iiunitt2.eq.5) then
         if(xM.gt.0) then
         rscale=1.0E-06/xparam 		
         else
         ierr=1
         endif		
        elseif(iiunitt.eq.1.and.iiunitt2.eq.6) then
         if(xM.gt.0) then
         rscale=1.0E-03/xparam		
         else
         ierr=1
         endif
c --- iiunitt=mg/m3 (in control input file= output unit)				
        elseif(iiunitt.eq.2.and.iiunitt2.eq.1) then
         rscale=1.0E03                         
        elseif(iiunitt.eq.2.and.iiunitt2.eq.3) then
         rscale=1.0E-03                        
        elseif(iiunitt.eq.2.and.iiunitt2.eq.4) then
         rscale=1.0E-06                        
        elseif(iiunitt.eq.2.and.iiunitt2.eq.5) then
         if(xM.gt.0) then
         rscale=1.0E-03/xparam	
         else
         ierr=1
         endif		
        elseif(iiunitt.eq.2.and.iiunitt2.eq.6) then
         if(xM.gt.0) then
         rscale=1.0/xparam
         else
         ierr=1
         endif	
c --- iiunitt=ug/m3 (in control input file= output unit)				
        elseif(iiunitt.eq.3.and.iiunitt2.eq.1) then
         rscale=1.0E06                         
        elseif(iiunitt.eq.3.and.iiunitt2.eq.2) then
         rscale=1.0E03                         
        elseif(iiunitt.eq.3.and.iiunitt2.eq.4) then
         rscale=1.0E-03                        
        elseif(iiunitt.eq.3.and.iiunitt2.eq.5) then
         if(xM.gt.0) then
         rscale=1.0/xparam
         else
         ierr=1
         endif					
        elseif(iiunitt.eq.3.and.iiunitt2.eq.6) then
         if(xM.gt.0) then
         rscale=1.0E03/xparam
         else
         ierr=1
         endif
c --- iiunitt=ng/m3 (in control input file= output unit)			
        elseif(iiunitt.eq.4.and.iiunitt2.eq.1) then
         rscale=1.0E09                        
        elseif(iiunitt.eq.4.and.iiunitt2.eq.2) then
         rscale=1.0E06                        
        elseif(iiunitt.eq.4.and.iiunitt2.eq.3) then
         rscale=1.0E03                        
        elseif(iiunitt.eq.4.and.iiunitt2.eq.5) then
         if(xM.gt.0) then
         rscale=1.0E03/xparam	
         else
         ierr=1
         endif		
        elseif(iiunitt.eq.4.and.iiunitt2.eq.6) then
         if(xM.gt.0) then
         rscale=1.0E06/xparam
         else
         ierr=1
         endif 
c --- iiunitt=ppm (in control input file= output unit)			
        elseif(iiunitt.eq.5.and.iiunitt2.eq.1) then
         if(xM.gt.0) then
         rscale=xparam*1.0E06 
         else
         ierr=2
         endif                           
        elseif(iiunitt.eq.5.and.iiunitt2.eq.2) then
         if(xM.gt.0) then
         rscale=xparam*1.0E03  
         else
         ierr=2
         endif                                  
        elseif(iiunitt.eq.5.and.iiunitt2.eq.3) then
         if(xM.gt.0) then
         rscale=xparam   
         else
         ierr=2
         endif                              
        elseif(iiunitt.eq.5.and.iiunitt2.eq.4) then
         if(xM.gt.0) then
         rscale=xparam*1.0E-03	
         else
         ierr=2
         endif         			
        elseif(iiunitt.eq.5.and.iiunitt2.eq.6) then
         rscale=1.0E-03
c --- iiunitt=ppb (in control input file= output unit)			
        elseif(iiunitt.eq.6.and.iiunitt2.eq.1) then
         if(xM.gt.0) then
         rscale=xparam*1.0E03 	
         else
         ierr=2
         endif                                       
        elseif(iiunitt.eq.6.and.iiunitt2.eq.2) then
         if(xM.gt.0) then
         rscale=xparam  	
         else
         ierr=2
         endif                                      
        elseif(iiunitt.eq.6.and.iiunitt2.eq.3) then
         if(xM.gt.0) then
         rscale=xparam*1.0E-03 	
         else
         ierr=2
         endif                              
        elseif(iiunitt.eq.6.and.iiunitt2.eq.4) then
         if(xM.gt.0) then
         rscale=xparam*1.0E-06
         else
         ierr=2
         endif         			
        elseif(iiunitt.eq.6.and.iiunitt2.eq.5) then
         rscale=1.0E03			
        endif
c
        if(ierr.eq.1) then
        write(io,*)'ERROR - scaling from ppm or ppb to g/m3,...ng/m3'
        write(io,*)'can not be done'
        stop
        endif
c
        if(ierr.eq.2) then
        write(io,*)'ERROR - scaling from g/m3,...ng/m3 to ppm or ppb'
        write(io,*)'can not be done'
        stop
        endif
c
	write(io,100)'scaling factor = ',rscale,
     &   ' to transform ',aunit1,' into ',aunit
100     format(a17,E12.6E2,a14,a12,a6,a12)        

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupup
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Francoise Robe           
c
c --- PURPOSE: Setup for UP.DAT 
c
c --- UPDATES:
c --- Version 1.6, Level: 090318 to Version 1.66, Level: 090731 (DGS)
c        - Remove BUFF, BUFF1 (not used)
c --- Version 1.45, Level 080627 to Version 1.6, Level 090318 (DGS)
c       -  Control variables from /CONTROL/
c       -  Assign data time zone to GMT
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- Time zone is GMT
      azonemet='UTC+0000'
      izonemet=0

c --- Profile method for estimating values at specified elevations
      llinear=.TRUE.
      cprofile='LINEAR          '

c --- There is only 1 station in the UP.DAT file
      idstnup=idmet(1)

      nloc=ntsfout
      do i=1,nloc
         idloc(i)=idmet(i)
         xloc(i)=xmet(i)
         yloc(i)=ymet(i)
c ---    Set logicals for output variables
         lwind(i)=.TRUE.
         if(zwind(i).LT.0.0) lwind(i)=.FALSE.
         ltmpk(i)=.TRUE.
         if(ztmpk(i).LT.0.0) ltmpk(i)=.FALSE.
c ---    No RH in UP.DAT
         lshum(i)=.FALSE.
      enddo

900   write(ilog,'(a)')'UP.DAT file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setuppfl
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Christelle Escoffier-Czaja           
c
c --- PURPOSE: Setup for AERMET.PFL 
c
c --- UPDATES:
c --- Version 1.6, Level: 090318 to Version 1.66, Level: 090731 (DGS)
c        - Remove BUFF, BUFF1 (not used)
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- Profile method for estimating values at specified elevations
      llinear=.TRUE.
      cprofile='LINEAR          '

c --- Impose time zone from user
      izonemet=izonec
      azonemet=azonec

c --- There is only 1 station in the AERMET.PFL file
      idstnup=idmet(1)

      nloc=ntsfout
      do i=1,nloc
         idloc(i)=idmet(i)
         xloc(i)=xmet(i)
         yloc(i)=ymet(i)
c ---    Set logicals for output variables
         lwind(i)=.TRUE.
         if(zwind(i).LT.0.0) lwind(i)=.FALSE.
         ltmpk(i)=.TRUE.
         if(ztmpk(i).LT.0.0) ltmpk(i)=.FALSE.
c ---    No RH in UP.DAT
         lshum(i)=.FALSE.
      enddo

900   write(ilog,'(a)')'AERMET.PFL file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      subroutine mm5ext
c ---------------------------------------------------------------------
c 
c --- METSERIES  Version: 1.9.0         Level: 121203        MM5EXT
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Extract time series from 3D.DAT/2D.DAT pair
c              Data include wind, temperature, and vapor mixing ratio
c
c --- UPDATES:
c
c --- Version 1.66, Level 090731 to Version 1.9.0, Level 121203
c         - Add call to MIDNITE for selected time convention
c         - Add new variables for end-time output
c         - Restrict 24h to seconds=0000
c
c --- Version 1.64, Level 090424 to Version 1.66, Level 090731
c       1.  Rename INTERPHMM5 to INTERPHSD
c       2.  Update calls to INTERPH* subs with METSIMC flag
c       3.  Revise location reported with nearest grid cell option
c       4.  Add the extraction of first level RH with other variables
c           for surface relative humidity
c           new variables: xhrtot, xirhintps(4,mxloc),xirhinpt(4),xrhfin
c       5.  Remove T2DSFC, X2D, BUFF3, CKEY, CKEYS, AVAR8 (not used)
c --- Version 1.63, level 090415 to Version 1.64, Level 090424
c       1.  Fix typo in MM5ext for weighting factor computation:
c           "nx" changed to "knx".
c --- Version 1.62, Level 090411 to Version 1.63, Level 090415
c       1.   Replace old calls to Y2K() with YR4()
c --- Version 1.6, Level 090318 to Version 1.62, Level 090411
c       1.   Add begining date equal to ending date for 3D.DAT version
c            earlier than ivs3=3
c       2.   Fixed problem when extraction was on the edge of domain
c --- Version 1.5, Level 090203 to Version 1.6, Level 090318 (DGS)
c       1.  Control variables from /CONTROL/
c       2.  Increase file name strings from 80 to 132
c       3.  Place output TSF header calls into HDTSFOUT
c CEC   4.  The ground temperature read for STANDARD and METSTAT-like 
c           profiling methods has been changed from 2m-temp to SST
c           (ground temperature)
c       5.  Change to Julian Date-hour integer YYYYJJJHH
c CEC   6.  Processing sub-hourly time steps for 3D.DAT format has been 
c           updated.
c CEC   7.  Update so no missing are allowed at the beginning
c           or the end of the file is period requested do not match the
c           data availability
c --- Version 1.5, Level 080912 to Version 1.5, Level 090203 (CEC
c       1.  Remove the reading of ground temperature from the 2D.DAT
c           format for STANDARD and METSTAT-like profiling methods
c           The Ground temperature is now read from the 3D.DAT format
c           on the 2D info line.
c       2.  Add the possibility to read the latest 3D.DAT format,
c           which include a format with begining time and ending time
c           and seconds
c --- Version 1.46, Level 080822 to Version 1.5, level 080912 (CEC)
c       1.  The subroutine mapg2l and mapg2p is replaced by GLOBE and 
c           GLOBE1 from coordlib.for (which include datum) and allow to
c           have LCC with two standard parallels equal to each other.
c           the projection transformation now use same system as other
c           codes in CALPUFF system
c       2.  Add 3d projection for MM5 outputs: Equatorial Mercator (EM)
c       3.  Add the possibility to extract 2D data (sea level pressure, 
c           precipitation rate, sst and solar radiation
c
c --- Version 1.44, Level 080205 to Version 1.46, Level 080822 (DGS)
c       1.  Set profiled variables initially to the neutral result
c           and then recalculate them as needed for other profiling
c           options.  All are assigned to arrays regardless of whether
c           they are used.  This intialization satisfies compiler
c           checks for unassigned variables, and does not change results.
c
c --- Version 1.1, level 060620 to Version 1.44, Level 080205 (CEC)
c       1.  Add a DIRECT profile method to extract wind, T and Q from 
c           3D.DAT directly provided by prognostic model:
c           Can happen only to extract wind at 10m, T at 2m and Q at 2m
c           Q=specific humidity
c       2.  10m-Wind direction is read as a real not an integer
c
c --- Version 1.0, Level 060615 to Version 1.1, Level 060620 (DGS)
c       1.  Add wind and temperature profiling based on Louis (1979) to
c           obtain values at the indicated measurement heights from the
c           3D.DAT MM5 file.  This requires the 2D as well as the 3D
c           files.
c       2.  Allow selection of profile method for 3D.DAT
c           STANDARD
c           - Wind and temperature profiling based on Louis (1979) for
c             heights below first level (interpolate above)
c           - Profile subroutine adapted from CALGRID
c           - Minimum wind speed = 0.01
c           - Specific humidity is set to level 1 (interpolate above)
c           METSTAT
c           - Same as NORMAL with following EXCEPTIONS ----
c           - Disables virtual temperature treatment
c           - Theta-star uses Prandtl number = 1/1.35
c           - Average potential temperature replaces that at surface
c             for g/T factor in bulk Richardson number
c           - Disables iterative search for z0h (temperature roughness)
c             and sets z0h=z0m
c           NEUTRAL
c           - Wind profiling uses neutral log relation for
c             heights below first level (interpolate above)
c           - Temperature is set to level 1 (interpolate above)
c           - Specific humidity is set to level 1 (interpolate above)
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'map.ser'

      parameter (nvar_out=8)
      parameter (iecho=0,iecho_3d=0)   
      dimension idvar(nvar_out)
      dimension ipres(mxnz),iht(mxnz),tk(mxnz),iwd(mxnz)
      dimension ws(mxnz),ww(mxnz),irh(mxnz),qr(mxnz)
      dimension u(mxnz),v(mxnz),zht(mxnz)
      dimension xx(nvar_out,mxnz)

c      dimension t2dsfc(mxnx,mxny),x2d(mxnx,mxny)

      dimension wsintps(4,mxloc),wdintps(4,mxloc),wgts(4,mxloc)
      dimension wsintps1(4,mxloc),wdintps1(4,mxloc)
      dimension wsintps2(4,mxloc),wdintps2(4,mxloc)
      dimension wsintp(4),wdintp(4),wgt(4)

      dimension tkintps(4,mxloc),qqintps(4,mxloc)
      dimension tkintps1(4,mxloc),qqintps1(4,mxloc)
      dimension tkintps2(4,mxloc),qqintps2(4,mxloc)
      dimension tkintp(4),qqintp(4)

      dimension slvpintps(4,mxloc),xprcintps(4,mxloc)
      dimension shwintps(4,mxloc),sstintps(4,mxloc)
      dimension slvpintp(4),xprcintp(4),shwintp(4),sstintp(4)
      dimension xirhintps(4,mxloc),xirhintp(4)

      dimension icell(4),jcell(4)
      dimension i1exts(mxloc),i2exts(mxloc),j1exts(mxloc),j2exts(mxloc)
      dimension ngrds(mxloc)
      character*132 fl,f2D
      character*80 frmt
      character*64 datamod
      character*132 buff1,buff2
c      character*12 ckeys(6),ckey
c      character*8 avar8
      character*4 cmap

c --- (CEC - 080911 - added when COORDLIB is added)
c --- For coordinate transformations
      character*8 cmapi,cmapo
      character*12 caction, cactionb
      character*4 c4hem
      real*8 vecti(9),vecto(9), vectib(9),vectob(9)

c      data ckeys/'MM53D.DAT','mm53d.dat','3D.DAT','3d.dat'
c     &          ,'M3D.DAT','m3d.dat'/

      data iseven/10000000/

c --- Set the local i,j steps that define the 4 corners of a cell
c --- associated the the weighting arrays
      data icell/0,1,0,1/
      data jcell/0,0,1,1/

c --- (CEC - 080205 - Initialization of wstot,wdtot,tktot,qqtot-
c ---    counting missing 10m-wind, 2m-t, or 2m-q, sealevelP,precip,shortW,SST
         wstot=0
         wdtot=0
         tktot=0
         qqtot=0
         slvptot=0
         xprctot=0
         shwtot=0
         ssttot=0
         xrhtot=0
c
c
c     Note: Time in MM5 data is GMT, while it is LST (or user input Time) in output time series
c 
c     Convert ndateext from LST (or User input time) to GMT
c      call getdate(ndateext,iyr,imon,iday,ihour)
c      call chgtim(iyr,imon,iday,ihour,izonec)
c      call timestamp(iyr,imon,iday,ihour,ndateext)
      call DEDAT(ndateext,iyr,jday,ihour)
      call INCR(ilog,iyr,jday,ihour,izonec)
      call TIMESTAMP(iyr,jday,ihour,ndateext)
      call GRDAY(ilog,iyr,jday,imon,iday)

c --- Loop over files
      ihr=0
      iskip=0
      do 6000 ifile=1,nmetinp

c ---    Skip remaining files if period has already been extracted
         if(ihr.GE.nbsecext) goto 6000

         fl=fmet(ifile)
         f2D=fmet(ifile)
c         nt=index(fl,' ')-1
         nt=LEN_TRIM(fl)

c --- (CEC - 090209 - remove - Ground Temperature field (2m) will be read from 3D.DAT file
c ---    Set 2D filename from 3D filename (.m3d --> .m2d)
c         f2D=fmod(ifile)
c         ic=nt-1
c         f2d(ic:ic)='2'
c
c --- (CEC - 080205 - M2D file is processed only if PROFILE=METSTAT or STANDARD)
c         if(LSTANDARD .OR. LMETSTAT) then
c         print *,'Processing File:',ifile,' ',fl(1:nt),' ',f2D(1:nt)
c         write(ilog,1088)ifile,fl(1:nt),' ',f2D(1:nt)
c         else
         write(ilog,1008)ifile,fl(1:nt)
         print *,'Processing File:',ifile,' ',fl(1:nt)
c         endif
 1008    format(i3,2x,(a))
 1088    format(i3,2x,(a),1x,(a))

         open(in,file=fl,status='old',action='read')

c ---    Read header information from 3D
c --------------------------------------
c --- Read first two records to determine  file format 
c ---   ivs3 = 0 for MM5.DAT file structure
c ---   ivs3 = 1 for 3D.DAT file structure prior to Version 2.0
c ---   ivs3 = 2 for 3D.DAT file structure, Version 2.x
c ---   ivs3 = 3 for 3D.DAT file structure, version 3.0 or later
         read(in,101,end=6500)buff1
         read(in,101,end=6500)buff2
 101     format(a)

         call getver(buff1,buff2,ivs3)
c
         if(ivs3.eq.0) then   ! V2 format
c           Record #1     
            read(buff1,1009,end=6500)title,cver,clev 
 1009       format(a80,2a12)
c           Record #2
            read(buff2,1011)ioutw,ioutq,ioutc,iouti,ioutg
 1011       format(6i3)

c           Record #3. Projection parameters
            read(in,1060)rlatc,rlonc,truelat1,truelat2  
 1060       format(9x,f6.2,7x,f8.2,8x,f6.1,8x,f6.1)

c           Record #4. MPHYSICS
            read(in,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &           ifddaan,ifddaob
 1061       format (30i3)

c           Record #5
c --- cec (080516) - change reading of nz into reading of nzsub
c            read(in,1062)idatebeg,nhours,nxsub,nysub,nz
            read(in,1062)idatebeg,nhours,nxsub,nysub,nzsub
 1062       format(i8,i5,3i4)
c --- cec (080516) - add nz=nzsub, like for ivs3=1!
            nz=nzsub   ! only nzsub layers in data
	    
c           Record #6
            read(in,1063)nx1,ny1,nx2,ny2,rxmin,rxmax,rymin,rymax
 1063       format(4i4,4(f8.2))

C           Echo to log file and eliminate compiling message for LF77
            if(iecho.eq.1) then
            write(ilog,1009)title,cver,clev 
            write(ilog,1011)ioutw,ioutq,ioutc,iouti,ioutg
            write(ilog,1060)rlatc,rlonc,truelat1,truelat2  
            write(ilog,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &           ifddaan,ifddaob
            write(ilog,1062)idatebeg,nhours,nxsub,nysub,nz
            write(ilog,1063)nx1,ny1,nx2,ny2,rxmin,rxmax,rymin,rymax
            endif
         elseif(ivs3.gt.0) then  ! V3 formats
            if(ivs3.eq.1) then ! V3 format (no comment lines)
c              Record #1,Record #2
               read(buff1,1009,end=6500)title
               read(buff2,1109)cset3d,cver,clev
 1109          format(3a12)
            elseif(ivs3.eq.2) then
               read(buff1,1119,end=6500)cset3d,cver,datamod
 1119          format(2(a12,4x),a64)
               read(buff2,*)ncomm
               do i=1,ncomm
                  read(in,*)
               enddo
            else
               write(ilog,*)'Format not set:',ivs3
               print *,'Format not set:',ivs3
               stop
            endif

c           Record #3
            read(in,1011)ioutw,ioutq,ioutc,iouti,ioutg,iosrf
c           Record #4
            read(in,1113)cmap,rlatc,rlonc,truelat1,truelat2,
     &           xsw,ysw,dxm,nx,ny,nz
 1113       format(a4,f9.4,f10.4,2f7.2,2f10.3,f8.3,2i4,i3)

            dym=dxm

c           Record #5 - physical options
            read(in,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &           ifddaan,ifddaob,igrdt,ipbl,ishf,ilhf,iustr,iswdn,
     &           ilwdn,ist1,ist2,ist3,ist4,ist5,ist6
	
c           Record #6 - Extracted domain Stamp 1
            read(in,1115)idatebeg,nhours,nxsub,nysub,nzsub
 1115       format(i10,i5,3i4)

c           header record #7: - Extracted domain Stamp 2 (output later
            read(in,1116)nx1,ny1,nx2,ny2,nz1,nz2,
     &           rxmin,rxmax,rymin,rymax
 1116       format(6i4,2f10.4,2f9.4)

            nz=nzsub   ! only nzsub layers in data
            if(nz.ne.(nz2-nz1+1)) then
               write(ilog,*)'Error in vertical layers:'
               write(ilog,*)nzsub,nz1,nz2
               print *,'Error in vertical layers:'
               print *,nzsub,nz1,nz2
               stop
            endif

C           Echo to log file and eliminate compiling message for LF77
            if(iecho.eq.1) then
              write(ilog,1009)title
              write(ilog,1109)cset3d,cver,clev
              write(ilog,1011)ioutw,ioutq,ioutc,iouti,ioutg,iosrf
              write(ilog,1113)cmap,rlatc,rlonc,truelat1,truelat2,
     &             xsw,ysw,dxm,nx,ny,nz
              write(ilog,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &             ifddaan,ifddaob,igrdt,ipbl,ishf,ilhf,iustr,iswdn,
     &             ilwdn,ist1,ist2,ist3,ist4,ist5,ist6
              write(ilog,1115)idatebeg,nhours,nxsub,nysub,nzsub
              write(ilog,1116)nx1,ny1,nx2,ny2,nz1,nz2,
     &             rxmin,rxmax,rymin,rymax
            endif
         endif

c ---    Recast idatebeg from YYYYMMDDHH to YYYYJJHH
         call GETDATE(idatebeg,kyr,kmon,kday,khour)
         call JULDAY(ilog,kyr,kmon,kday,kjul)
         call TIMESTAMP(kyr,kjul,khour,idatebeg)

c        Convert YYYY date format in ndateext to YY format if idatebeg 
c              in YY format. 
         if(idatebeg.lt.iseven .and. ifile.eq.1) then
            nn=ndateext/iseven
            ndateext=ndateext-nn*iseven
         endif

         if(ihr.eq.0) idate0=ndateext

c        Sigma levels
         do i=1,nz
            read(in,1064)sigma
            if(iecho.eq.1) write(ilog,1064)sigma
 1064       format(f6.3)	       
         enddo

c        Lat/long locations
         do j=ny1,ny2           
            do i=nx1,nx2
               if(ivs3.eq.0) then
                  read(in,1065)ii,jj,flat,flong,ihh,iland,
     &                 flatcrs,flongcrs
 1065             format(2i3,f7.3,f8.3,i5,i3,1x,f7.3,f8.3)
               else
                  read(in,1165)ii,jj,flat,flong,ihh,iland,
     &                 flatcrs,flongcrs
 1165             format(2i4,f9.4,f10.4,i5,i3,1x,f9.4,f10.4)
               endif
               if(ifile.eq.1) then
                  ielev(i,j)=ihh
                  land(i,j)=iland
               endif
               if(iecho.eq.1) write(ilog,1165)ii,jj,flat,flong
     &            ,ihh,iland,flatcrs,flongcrs
            Enddo
         enddo

         if(ifile.ne.1) goto 6100

c        Get input data format

         call getfmt(ioutw,ioutq,ioutc,iouti,ioutg,idvar,frmt,nvar)

c        Check domain info
         if(dxm.le.0) then
            write(ilog,*)'No grid config info in 3D.DAT file'
            print *,'No grid config info in 3D.DAT file'
            if(ifrmt.ne.3) then
               write(ilog,*)'Error in site location format:',ifrmt
               write(ilog,*)'Site location must be set in I/J format'
               print *,'Error in site location format:',ifrmt
               print *,'Site location must be set in I/J format'
               stop
            endif
         endif

         x1dom=xsw+(nx1-1)*dxm
         x2dom=xsw+(nx2-1)*dxm
         y1dom=ysw+(ny1-1)*dym
         y2dom=ysw+(ny2-1)*dym

         Write(ilog,*)'Model Domain:',x1dom,x2dom,y1dom,y2dom
         Write(*,*)'Model Domain:',x1dom,x2dom,y1dom,y2dom

c ---    Set translation vectors going to M3D projection (x,y)km
c ---    Scale factor for Tangential TM projection
         tmsone=1.00000
c ---    Set output projection from M3D header
         iutmo=iutmzn
         if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
         cmapo='        '
         cmapo(1:4)=cmap
         if(cmap.eq.'LCC ' .or. cmap.eq.'lcc ' .or.
     &      cmap.eq.'LLC ' .or. cmap.eq.'llc ' .or.
     &      cmap.eq.'LC  ') then
            cmapo='LCC     '
         elseif(cmap.eq.'PST ' .or. cmap.eq.'pst ') then
            cmapo='PS      '
         elseif(cmap.eq.'EM  ' .or. cmap.eq.'em  ') then
            cmapo='EM      '
         endif
         if(cmapo.EQ.'TTM     ') cmapo='TM      '

c ---    Reset output map and datum to model map and datum if the
c ---    map requested is NONE, or if the location is provided as
c ---    a cell index
         if(ifrmt.EQ.3 .OR. LNOMAP) then
c ---       Reset input map/datum to model system (from header)
c ---       Datum
            datumc=datum3d
c ---       Map Projection
            pmapc=cmapo
            iutmznc=iutmzn
            utmhemc=utmhem
            rnlat1c=truelat1
            rnlat2c=truelat2
            rnlat0c=rlatc
            relon0c=rlonc
            feastc=feast
            fnorthc=fnorth
            call LLMAKE(ilog,'LON ',relon0c,clon0c)
            call LLMAKE(ilog,'LAT ',rnlat0c,clat0c)
            call LLMAKE(ilog,'LAT ',rnlat1c,clat1c)
            call LLMAKE(ilog,'LAT ',rnlat2c,clat2c)
c ---       Projection logicals
            lnomap=.FALSE.
            lgeo=.FALSE.
            lutm=.FALSE.
            llcc=.FALSE.
            lps=.FALSE.
            lem=.FALSE.
            llaza=.FALSE.
            lttm=.FALSE.
            if(pmapc.EQ.'NONE') then
               lnomap=.TRUE.
            elseif(pmapc.EQ.'LL') then
               lgeo=.TRUE.
            elseif(pmapc.EQ.'UTM') then
               lutm=.TRUE.
            elseif(pmapc.EQ.'LCC') then
               llcc=.TRUE.
            elseif(pmapc.EQ.'PS') then
               lps=.TRUE.
            elseif(pmapc.EQ.'EM') then
               lem=.TRUE.
            elseif(pmapc.EQ.'LAZA') then
               llaza=.TRUE.
            elseif(pmapc.EQ.'TTM') then
               lttm=.TRUE.
            endif
         endif

c ---    Condition input projection
         cmapi=pmapc
         if(cmapi.EQ.'TTM     ') cmapi='TM      '
         iutmi=iutmznc
         if(utmhemc.EQ.'S   ' .AND. iutmznc.LT.900) iutmi=-iutmi

c ---    Set forward-transformation to M3D projection
         call GLOBE1(cmapi,iutmi,tmsone,rnlat1c,rnlat2c,
     &               rnlat0c,relon0c,feastc,fnorthc,
     &               cmapo,iutmo,tmsone,truelat1,truelat2,
     &               rlatc,rlonc,feast,fnorth,
     &               caction,vecti,vecto)

c ---    Set back-transformation from M3D projection
         call GLOBE1(cmapo,iutmo,tmsone,truelat1,truelat2,
     &               rlatc,rlonc,feast,fnorth,
     &               cmapi,iutmi,tmsone,rnlat1c,rnlat2c,
     &               rnlat0c,relon0c,feastc,fnorthc,
     &               cactionb,vectib,vectob)

         if(ifrmt.EQ.3) then
c ---       Cell ri/rj format for site locations
c ---       ------------------------------------
c ---       Identify surrounding points and compute weights directly
            do iloc=1,ntsfout
               fnx=xloc(iloc)
               fny=yloc(iloc)
               knx=int(fnx)
               kny=int(fny)

               if(fnx.lt.nx1 .or. fnx.gt.nx2 .or.
     &            fny.lt.ny1 .or. fny.gt.ny2) then
                  print *,'Site outside of data domain:',fnx,fny
                  print *,'nx1/nx2,ny1/ny2:',nx1,nx2,ny1,ny2
                  write(ilog,*)'Site outside of data domain:',fnx,fny
                  write(ilog,*)'nx1/nx2,ny1/ny2:',nx1,nx2,ny1,ny2
                  stop
               endif

               if(knx.lt.nx2.and.kny.lt.ny2) then
               i1exts(iloc)=knx
               i2exts(iloc)=knx+1
               j1exts(iloc)=kny
               j2exts(iloc)=kny+1

               wgts(1,iloc)=1-(fnx-knx)
               wgts(2,iloc)=fnx-knx
               wgts(3,iloc)=1-(fny-kny)
               wgts(4,iloc)=fny-kny
              
               elseif(knx.eq.nx2.and.kny.lt.ny2) then
               i1exts(iloc)=knx-1
               i2exts(iloc)=knx
               j1exts(iloc)=kny
               j2exts(iloc)=kny+1

               wgts(1,iloc)=0
               wgts(2,iloc)=1.
               wgts(3,iloc)=1-(fny-kny)
               wgts(4,iloc)=fny-kny
              
               elseif(knx.lt.nx2.and.kny.eq.ny2) then
               i1exts(iloc)=knx
               i2exts(iloc)=knx+1
               j1exts(iloc)=kny-1
               j2exts(iloc)=kny

               wgts(1,iloc)=1-(fnx-knx)
               wgts(2,iloc)=fnx-knx
               wgts(3,iloc)=0
               wgts(4,iloc)=1.

               elseif(knx.eq.nx2.and.kny.eq.ny2) then
               i1exts(iloc)=knx-1
               i2exts(iloc)=knx
               j1exts(iloc)=kny-1
               j2exts(iloc)=kny

               wgts(1,iloc)=0
               wgts(2,iloc)=1.
               wgts(3,iloc)=0
               wgts(4,iloc)=1.
               endif

               write(ilog,301)iloc,fnx,fny,(wgts(j,iloc),j=1,4)
 301           format(' Site/Wgt: ',i5,6f8.3)
               print 301,iloc,fnx,fny,(wgts(j,iloc),j=1,4)

               io=iout+iloc

               if(metsimc.EQ.2) then
c ---             I,J used for nearest grid cell option
                  call INEAREST(icell,wgts(1,iloc),ii)
                  call INEAREST(jcell,wgts(1,iloc),jj)
                  ii=knx+ii
                  jj=kny+jj
c ---             Save location requested by user
                  xuloc(iloc)=xloc(iloc)
                  yuloc(iloc)=yloc(iloc)
c ---             New location (nearest grid point)
                  xloc(iloc)=FLOAT(ii)
                  yloc(iloc)=FLOAT(jj)
                  write(ilog,1022) xloc(iloc),yloc(iloc)
                  print 1052,ii,jj,zwind(iloc),
     &                       ztmpk(iloc),zshum(iloc)
               else
c ---             I,J used for interpolation
                  write(ilog,1022)fnx,fny
                  print 1052,INT(fnx),INT(fny),zwind(iloc),
     &                       ztmpk(iloc),zshum(iloc)
               endif

c ---          Set model (x,y)km into stored met coordinates
               xmet(iloc)=xsw+dxm*(xloc(iloc)-1.)
               ymet(iloc)=ysw+dym*(yloc(iloc)-1.)

 1022          format('3D.DAT:  (I,J) = (',f7.2,',',f7.2,')')
 1052          format(' 3D.DAT - [I/J/Z: ',2i5,3f10.3,' m]')
            enddo

         elseif(ifrmt.LE.2) then
c ---       X/Y or Lon/Lat format for site locations
c ---       ----------------------------------------
c ---       Convert extraction locations to model x,y system
            do iloc=1,ntsfout
               xin=xloc(iloc)
               yin=yloc(iloc)
               call GLOBE(ilog,caction,datumc,vecti,datum3d,vecto,
     &                    xin,yin,xext,yext,idum,c4hem)
               xloc(iloc)=xext
               yloc(iloc)=yext

               write(ilog,1023)xext,yext,xin,yin
               print 1053,xext,yext,xin,yin,
     &                    zwind(iloc),ztmpk(iloc),zshum(iloc)
 1023          format('3D.DAT:  (X,Y) = (',f9.3,'km,',f9.3,
     &                'km);  (XLON/YLAT) = (',f7.3,',',f9.3,')')
 1053          format(' 3D.DAT - [X/Y: ',2(f9.3,'km'),'] [XLON/YLAT: '
     &                ,f7.3,f9.3,'] [Z: ',3f8.3,' m]')

               io=iout+iloc

c ---          Test location
               if(xext.lt.x1dom .or. xext.gt.x2dom) then
                  write(ilog,1066)xext,x1dom,x2dom
                  write(*,*)xext,x1dom,x2dom
 1066             format('Extraction site out of domain - X:',3f12.3)
                  stop 'HALTED: See error message in list file'
               endif
               if(yext.lt.y1dom .or. yext.gt.y2dom) then
                  write(ilog,1067)yext,y1dom,y2dom
                  write(*,1067)yext,y1dom,y2dom
 1067             format('Extraction site out of domain - Y:',3f12.3)
                  stop 'HALTED: See error message in list file'
               endif
         
c ---          Find the nearest 4 grids for extraction site
               sdx=xext-xsw
               sdy=yext-ysw

               fnx=sdx/dxm+1
               fny=sdy/dym+1
               knx=int(fnx)
               kny=int(fny)

               if(knx.lt.nx2.and.kny.lt.ny2) then
               i1exts(iloc)=knx
               i2exts(iloc)=knx+1
               j1exts(iloc)=kny
               j2exts(iloc)=kny+1

               wgts(1,iloc)=1-(fnx-knx)
               wgts(2,iloc)=fnx-knx
               wgts(3,iloc)=1-(fny-kny)
               wgts(4,iloc)=fny-kny
              
               elseif(knx.eq.nx2.and.kny.lt.ny2) then
               i1exts(iloc)=knx-1
               i2exts(iloc)=knx
               j1exts(iloc)=kny
               j2exts(iloc)=kny+1

               wgts(1,iloc)=0
               wgts(2,iloc)=1.
               wgts(3,iloc)=1-(fny-kny)
               wgts(4,iloc)=fny-kny
              
               elseif(knx.lt.nx2.and.kny.eq.ny2) then
               i1exts(iloc)=knx
               i2exts(iloc)=knx+1
               j1exts(iloc)=kny-1
               j2exts(iloc)=kny

               wgts(1,iloc)=1-(fnx-knx)
               wgts(2,iloc)=fnx-knx
               wgts(3,iloc)=0
               wgts(4,iloc)=1.

               elseif(knx.eq.nx2.and.kny.eq.ny2) then
               i1exts(iloc)=knx-1
               i2exts(iloc)=knx
               j1exts(iloc)=kny-1
               j2exts(iloc)=kny

               wgts(1,iloc)=0
               wgts(2,iloc)=1.
               wgts(3,iloc)=0
               wgts(4,iloc)=1.
               endif

               write(ilog,301)iloc,fnx,fny,(wgts(j,iloc),j=1,4)
               print 301,iloc,fnx,fny,(wgts(j,iloc),j=1,4)

               if(metsimc.EQ.2) then
c ---             Nearest grid cell option
                  call INEAREST(icell,wgts(1,iloc),ii)
                  call INEAREST(jcell,wgts(1,iloc),jj)
                  ii=knx+ii
                  jj=kny+jj
c ---             Save location requested by user
                  xuloc(iloc)=xin
                  yuloc(iloc)=yin
c ---             New location (nearest grid point)
                  xloc(iloc)=xsw+dxm*(ii-1)
                  yloc(iloc)=ysw+dym*(jj-1)
c ---             Transform from M3D projection
                  call GLOBE(ilog,cactionb,datum3d,vectib,datumc,vectob,
     &                       xloc(iloc),yloc(iloc),xin2,yin2,idum,c4hem)
                  xmet(iloc)=xin2
                  ymet(iloc)=yin2

                  write(ilog,*)'Modified for Nearest Grid Point:'
                  write(ilog,1023)xloc(iloc),yloc(iloc),xin2,yin2
                  write(*,*)'Modified for Nearest Grid Point:'
                  print 1053,xloc(iloc),yloc(iloc),xin2,yin2,
     &                       zwind(iloc),ztmpk(iloc),zshum(iloc)
               endif

            enddo
         endif
 6100    continue

c --- (CEC - 090209 - remove the following - Ground Temperature field (2m) will be read from 3D.DAT file)
c ---    Corresponding 2D file
c         if(LSTANDARD .OR. LMETSTAT) then
c            open(in2,file=f2d,status='old',action='read')
c ---       Skip header
c            call RDHD2D(in2,ilog,iecho,ieof)
c            if(ieof.NE.0) goto 6500
c ---       Look at 2D output switches from 3D.DAT header
c ---       Number of 2D vars available
c            n2dvar=igrdt+ipbl+ishf+ilhf+iustr+iswdn+ilwdn+
c     &             ist1+ist2+ist3+ist4+ist5
c --        Need ground temperature (other options may be added)
c            if(igrdt.NE.1) then
c               write(*,*)
c               write(*,*)'ERROR:  No surface temperature in 2D.DAT'
c               write(*,*)'STANDARD and METSTAT profile options can'
c               write(*,*)'not be applied -- use NEUTRAL option'
c               stop
c            endif
c         endif

c ---    Write header for TSF output file(s)
         if(LALLPROF) then
            ndirs=3
         else
            ndirs=1
         endif
         if(ifile.EQ.1) then
c ---       First data file processed -- top of output files
            do iloc=1,ntsfout
               do nn=1,ndirs
                  io=iout+iloc+(nn-1)*ntsfout
                  call HDTSFOUT(io,iloc)
               enddo
            enddo
         endif

c ---    Data records
c -------------------
         write(*,*)

 6200    do iloc=1,ntsfout
            ngrds(iloc)=0
         enddo

c --- (CEC - 090209 - remove the following - Ground Temperature field (2m) will be read from 3D.DAT file
c         if(LSTANDARD .OR. LMETSTAT) then
c ---       Obtain surface temperature from 2D.DAT file
c ---       (first variable in output)
c            read(in2,'(i4,3i2,2x,a8)',end=6500)iyr,imon,iday,ihour,
c     &                                         avar8
c            if(avar8.NE.'GROUND T') then
c               write(*,*)
c               write(*,*)'ERROR:  Bad surface temperature name '
c               write(*,*)'        Expected: GROUND T'
c               write(*,*)'           Found: ',avar8
c               stop
c            endif
c            do j=ny2,ny1,-1
c               read(in2,'(8f10.3)') (t2dsfc(i,j),i=nx1,nx2)
c            enddo
c            call timestamp(iyr,imon,iday,ihour,idate2)
c ---       Read through remaining vars this period 
c            do k=2,n2dvar
c               read(in2,'(i4,3i2,2x,a8)',end=6500)iyr,imon,iday,ihour,
c     &                                            avar8
c               do j=ny2,ny1,-1
c                  read(in2,'(8f10.3)') (x2d(i,j),i=nx1,nx2)
c               enddo
c            enddo
c
c ---       Test time period
c            if(idate2.gt.idate0) then
c               write(ilog,*)' Error: Required date too early:'
c               write(ilog,*)'        Required Date:           ',idate0
c               write(ilog,*)'        Beginning Date in 2D.DAT:',idate2
c               print *,' Error: Required date too early:'
c               print *,'        Required Date:           ',idate0
c               print *,'        Beginning Date in 2D.DAT:',idate2
c               stop
c            endif
c         endif

c ---    Initialization of isec
         isec=0
c
c ---    Read profile from 3D.DAT file at each cell and store each
c ---    location needed for interpolation
         do 10 j=ny1,ny2
         do 10 i=nx1,nx2
            if(ivs3.eq.0) then
               read(in,1068,end=6500)iyr,imon,iday,ihour,
     &              ii,jj,xpp,xpre,isnow
 1068          format(4i2,2i3,f7.1,f5.2,i2)
               if(iecho.eq.1) write(ilog,1068)iyr,imon
     &              ,iday,ihour,ii,jj,xpp,xpre,isnow
c            else
c --- (CEC - 080205) - Add reading of T-2m, Q-2m, W-10m
c               read(in,1168,end=6500)iyr,imon,iday,ihour,
c     &              ii,jj,pp,pre,isnow,radsw,radlw
c 1168          format(i4,3i2,2i3,f7.1,f5.2,i2,2f8.1)
c               if(iecho.eq.1) write(ilog,1168)iyr,imon
c     &              ,iday,ihour,ii,jj,pp,pre,isnow,radsw,radlw
             elseif(ivs3.eq.2.or.ivs3.eq.1) then
               read(in,1168,end=6500)iyr,imon,iday,ihour,
     &         ii,jj,xpp,xpre,isnow,radsw,radlw,xtp2,xq2,xwd10,xws10,sst
 1168          format(i4,3i2,2i3,f7.1,f5.2,i2,3f8.1,f8.2,3f8.1)
               if(iecho.eq.1) write(ilog,1168)iyr,imon
     &            ,iday,ihour,ii,jj,xpp,xpre,isnow,radsw,radlw,xtp2,xq2
     &              ,xwd10,xws10,sst
             elseif(ivs3.eq.3) then
             read(in,1268,end=6500) iyrb,imonb,idayb,ihourb,isecb,
     &                    iyr,imon,iday,ihour,isec,ii,jj,
     &             xpp,xpre,isnow,radsw,radlw,xtp2,xq2,xwd10,xws10,sst
 1268   format(i4,3i2,i4,i5,3i2,i4,i4,i3,f7.1,f5.2,i2,3f8.1,f8.2,3f8.1)
            if(iecho.eq.1)write(ilog,1268)iyrb,imonb,idayb,ihourb,isecb,
     &                    iyr,imon,iday,ihour,isec,ii,jj,
     &             xpp,xpre,isnow,radsw,radlw,xtp2,xq2,xwd10,xws10,sst
            endif
c
            call JULDAY(ilog,iyr,imon,iday,jday)
           if(i.eq.nx1 .and. j.eq.ny1) then        
               call TIMESTAMP(iyr,jday,ihour,idate) 
c
c --- (CEC -090304 - Add a check to make sure it is instant record data - not period averaged
           if(ihr.eq.0) then
c --- (CEC - 090304 - since instant record, number of period to be extracted for 3D.DAT 
c                     need to be 1 extra step to match begining and ending date in header)
              if(iskip.eq.0) nbsecext=nbsecext+1
               iskip=iskip+1
               if(ivs3.eq.3) then
               call JULDAY(ilog,iyrb,imonb,idayb,jdayb)
               call TIMESTAMP(iyrb,jdayb,ihourb,idate)
               call DELTSEC(idateb,isecb,idate,isec,ndelsec)
               if(ndelsec.ne.0) then
        write(ilog,*)'ERROR- 3D.DAT data are assumed to be instant data'
         write(ilog,*)'recorded data in 3D.DAT show an averaging period'
	   write(ilog,*)'from ',idateb,isecb
           write(ilog,*)'to ',idate,isec
           write(*,*)'ERROR- 3D.DAT data are assumed to be instant data'
           write(*,*)'recorded data in 3D.DAT show an averaging period'
	   write(*,*)'from ',idateb,isecb
           write(*,*)'to ',idate,isec
           stop
               endif
               endif
           endif
           endif
   
            do iz=1,nz    
               read(in,frmt)ipres(iz),iht(iz),tk(iz),iwd(iz),
     &              ws(iz),ww(iz),irh(iz),(xx(ij,iz),ij=3,nvar)
               if(iecho_3d.eq.1) write(ilog,frmt)ipres(iz)
     &            ,iht(iz),tk(iz),iwd(iz),ws(iz),ww(iz)
     &            ,irh(iz),(xx(ij,iz),ij=3,nvar)

            enddo

            if(idate.gt.idate0) then
               write(ilog,*)' Error: Required date too early:'
               write(ilog,*)'        Required Date:           ',idate0
               write(ilog,*)'        Current Date in 3D.DAT:  ',idate
               write(ilog,*)'If not at first hour, check time step'
               print *,' Error: Required date too early:'
               print *,'        Required Date:           ',idate0
               print *,'        Current Date in 3D.DAT:  ',idate
               print *,'If not at first hour, check time step'
               stop

            endif

            if(idate.ne.idate0) goto 10

            do iloc=1,ntsfout
               igrd=0
               i1ext=i1exts(iloc)
               i2ext=i2exts(iloc)
               j1ext=j1exts(iloc)
               j2ext=j2exts(iloc)

               zw=zwind(iloc)
               zt=ztmpk(iloc)
               zq=zshum(iloc)

               if(i.eq.i1ext .and. j.eq.j1ext) then
                  igrd=1
               elseif(i.eq.i2ext .and. j.eq.j1ext) then
                  igrd=2
               elseif(i.eq.i1ext .and. j.eq.j2ext) then
                  igrd=3
               elseif(i.eq.i2ext .and. j.eq.j2ext) then
                  igrd=4
               endif

c ---          Vertical interpolation if grid cell is in range
               if(igrd.ne.0) then
                  ngrds(iloc)=ngrds(iloc)+1

                  hsrf=ielev(i,j)
                  landuse=land(i,j)
c --- (CEC - 080205 - t2dsfc is extracted from 2D-data only for LSTANDARD or LMETSTAT)
c --- (CEC - 090209 - change the following - Ground Temperature field will be read from 3D.DAT file)
                if(LSTANDARD .OR. LMETSTAT) then
c ---             Surface temperature from 2D.DAT array
c                  tk0=t2dsfc(i,j)
                  if(ivs3.gt.1.and.sst.ne.0.0) then
c --- (CEC -090211 - Ground Temperature field is the last records of the 2D data line, what is called sst)
c                  tk0=xtp2
                   tk0=sst
                  else
                  write(ilog,*)'ERROR - STANDARD or METSTAT profiling'
                  write(ilog,*)'cannot be applied - Ground temperature'
                  write(ilog,*)'is not available in this format'
                  write(*,*)'ERROR - STANDARD or METSTAT profiling'
                  write(*,*)'cannot be applied - Ground temperature'
                  write(*,*)'is not available in this format'
                  stop
                  endif
                endif
c ---             Use level 1 pressure for surface pressure
                  pmb0=ipres(1)
                  pmb1=ipres(1)

                  call getmm5z0(landuse,imon,iday,nland,z00)
                  call ws2uv(iwd,ws,u,v,nzsub)
c
c --- (CEC - 081219 - get 2D data if Lother is true) - Note: precipitation in cm for an hour is scaled to get mm/hr
                if(LOTHER(iloc)) then
                  if(ivs3.gt.0) then
                  slvpintps(igrd,iloc)=xpp
                  xprcintps(igrd,iloc)=xpre*10
                  shwintps(igrd,iloc)=radsw
                  sstintps(igrd,iloc)=sst
                  xirhintps(igrd,iloc)=float(irh(1))
                  else
c ---  Add a check that 2D field can not be extracted when
c ---  format ivs3=0 (assume MM5.DAT format) - 2D data not
c ---  available in this 3D.DAT file
                  write(ilog,*)'2D data - sea level pressure, '
                  write(ilog,*)'precipitation, short wave radiation '
                  write(ilog,*)'and SST not available in this 3D file'
                  stop 'HALTED: 2D data not avaiable in this 3D file'
                  endif
                endif
c                  
c --- (CEC - 080205 - setup 10m wind, 2m temp and 2m specific humidity
c ---                 for horizontal interpolation)
                if(LDIRECT) then
                   if(ivs3.gt.0) then
                   wsintps2(igrd,iloc)=xws10
                   wdintps2(igrd,iloc)=xwd10
                   tkintps2(igrd,iloc)=xtp2
                   qqintps2(igrd,iloc)=xq2
                   else
c --- CEC - 080516 - add a check that DIRECT option can not be done when
c ---                 format is ivs3=0 (assume MM5.DAT format) - 2D data not
c ---                 available in this 3D.DAT file
                   write(ilog,*)'2D data - 10m wind, 2m temperature and'
                   write(ilog,*)'2m specific humidity not available in'
                   write(ilog,*)'this MM5.DAT file'
                   stop 'HALTED: format not correct for DIRECT profile'
                   endif
                else
c
c ---             Set levels as height above the surface
                  do k=1,nzsub
                     zht(k)=FLOAT(iht(k))-hsrf
                     if(zht(k).LT.0.0) then
                        write(ilog,*)' '
                        write(ilog,*)'Negative height above ground'
                        write(ilog,*)'k,zht(k),hsrf: ',k,zht(k),hsrf
                        write(ilog,*)'for date/time in YYYYJJJHH ',idate
                        write(ilog,*)'for grid point ',i,j
                        stop 'HALTED: Negative height above ground'
                     endif
c ---                Also put mixing ratio (g/g) into 1D array
                     qr(k)=0.001*xx(3,k)
                  enddo

c ---             Perform "NEUTRAL" profiling first to get the linear
c ---             interpolation used by all methods above level 1

c ---             Wind
                  if(lwind(iloc) .AND. zw.GT.0.0) then
                     call interpv(zht,u,z00,zw,nzsub,uext)
                     call interpv(zht,v,z00,zw,nzsub,vext)
                  else
c ---                Use layer 1
                     uext=u(1)
                     vext=v(1)
                  endif
                  call uv2ws(uext,vext,iwdext,wsext)

c ---             Temperature
                  if(ltmpk(iloc) .AND. zt.GT.zht(1)) then
c ---                Use linear interpolation
                     call interpv(zht,tk,z00,zt,nzsub,text)
                  else
c ---                Use layer 1
                     text=tk(1)
                  endif

c ---             Specific Humidity
                  if(lshum(iloc) .AND. zq.GT.zht(1)) then
c ---                Use linear interpolation
                     call interpv(zht,qr,z00,zq,nzsub,qext)
                  else
c ---                Use layer 1
                     qext=qr(1)
                  endif
c ---             Convert mix ratio to spec humidity (g/kg)
                  qext=1000.*(qext/(1.0+qext))

                  if(LNEUTRAL) then
c ---                Always place EXT results into arrays regardless of
c ---                output request logicals
c                     if (lwind(iloc)) wsintps2(igrd,iloc)=wsext
c                     if (lwind(iloc)) wdintps2(igrd,iloc)=iwdext
c                     if (ltmpk(iloc)) tkintps2(igrd,iloc)=text
c                     if (lshum(iloc)) qqintps2(igrd,iloc)=qext
                     wsintps2(igrd,iloc)=wsext
                     wdintps2(igrd,iloc)=iwdext
                     tkintps2(igrd,iloc)=text
                     qqintps2(igrd,iloc)=qext
                  endif

                  if(LSTANDARD .OR. LMETSTAT) then
c ---                Check timestamp from 2D file
c --- (CEC - 090209 - remove not needed anymore - Ground Temperature field (2m) will be read from 3D.DAT file
c                     if(idate.NE.idate2) then
c                        write(ilog,*)' Error: Date problem in files'
c                        write(ilog,*)'        2D.DAT Date: ',idate2
c                        write(ilog,*)'        3D.DAT Date: ',idate
c                        print *,' Error: Date pproblem in files'
c                        print *,'        2D.DAT Date: ',idate2
c                        print *,'        3D.DAT Date: ',idate
c                        stop
c                     endif
c ---                Initially set to linear interpolation
                     wsintps(igrd,iloc)=wsext
                     wdintps(igrd,iloc)=iwdext
                     tkintps(igrd,iloc)=text
                     qqintps(igrd,iloc)=qext
                     wsintps1(igrd,iloc)=wsext
                     wdintps1(igrd,iloc)=iwdext
                     tkintps1(igrd,iloc)=text
                     qqintps1(igrd,iloc)=qext
c ---                Explicitly assign to local profile variants
                     s_m0=wsext
                     s_m1=wsext
                     t_m0=text
                     t_m1=text
c ---                PBL scaling if requested height is in first layer
c ---                Set alternate heights to manage z=-1. "flags"
                     zw_a=zht(1)
                     if(lwind(iloc)) zw_a=zw
                     zt_a=zht(1)
                     if(ltmpk(iloc)) zt_a=zt

                     if(zw_a.LT.zht(1) .OR. zt_a.LT.zht(1))then
                        q1=1000.*qr(1)/(1.0+qr(1))
                        if(LSTANDARD) then
                           m0=0
                           call PBLSCALE(m0,z00,zht(1),ws(1),tk(1),
     &                                   pmb1,q1,tk0,pmb0,zw_a,zt_a,
     &                                   s_m0,t_m0,p_m0)
                        endif
                        if(LMETSTAT) then
                           m1=1
                           call PBLSCALE(m1,z00,zht(1),ws(1),tk(1),
     &                                   pmb1,q1,tk0,pmb0,zw_a,zt_a,
     &                                   s_m1,t_m1,p_m1)
                        endif
c (debug)
c                   if(iloc.EQ.1) then
c                     write(*,*)'LOC 1: tk0,tk(1),t_m1= ',
c     &                          tk0,tk(1),t_m1
c                   endif
c
                        if(zw_a.LT.zht(1)) then
                           wsintps(igrd,iloc)=s_m0
                           wdintps(igrd,iloc)=FLOAT(iwd(1))
                           wsintps1(igrd,iloc)=s_m1
                           wdintps1(igrd,iloc)=FLOAT(iwd(1))
                        endif
                        if(zt_a.LT.zht(1)) then
                           tkintps(igrd,iloc)=t_m0
                           tkintps1(igrd,iloc)=t_m1
                        endif
                     endif
                  endif
c --- (CEC - 080205 - endif of "if or ifnot ldirect")
                endif
               endif
            enddo
 10      continue

c ---    All cells have been read for this hour
c ---    Check for proper timestamp from 2D/3D files
         if(idate.ne.idate0) goto 6200

c ---    Horizontal interpolation of extracted data 
         do iloc=1,ntsfout
            ngrd=ngrds(iloc)
c            write(*,*)'ngrd ',ngrd
            if(ngrd.ne.4) then
             if(wgts(1,iloc).ne.1.or.wgts(3,iloc).ne.1) then
               write(ilog,*)'Error: 4 grids are needed for interp' 
               write(ilog,*)'Grids found: ',iloc,ngrd
               stop 08
             endif
            endif
         enddo

         iloc=1

 2030    continue

c ---    Output vertically and horizontally interpolated wind
c ---    In Local Stand Time (Y2K form) 
         if(iloc.eq.1) then
            iyrext=iyr
            call YR4(ilog,iyrext,ierr)
            if(ierr.NE.0) stop 'Halted in MM5EXT - Y2K'
            jdayl=jday
            ihourl=ihour
            idt=-izonec
            call INCR(ilog,iyrext,jdayl,ihourl,idt)
            call GRDAY(ilog,iyrext,jdayl,imonl,idayl)

c --- V1.9.0, Level 121203
c ---       Swap output date and time into variables for output
            iyout=iyrext
            imout=imonl
            idout=idayl
            jdout=jdayl
            ihout=ihourl
c ---       Apply Midnight Convention to time
            if(imidnite.EQ.1 .AND. ihout.EQ.24) then
              ihout=0
              call MIDNITE(ilog,'TO 00h',iyrext,imonl,idayl,jdayl,
     &                                   iyout,imout,idout,jdout)
            elseif(imidnite.EQ.2 .AND. ihout.EQ.0 .AND. isec.EQ.0) then
              ihout=24
              call MIDNITE(ilog,'TO 24h',iyrext,imonl,idayl,jdayl,
     &                                   iyout,imout,idout,jdout)
            endif

         endif

	   if(LOTHER(iloc)) then
c --- Write gridded point if exact point is provided
             if(wgts(1,iloc).eq.1.and.wgts(3,iloc).eq.1) then
               slvpfin=slvpintps(1,iloc)
               xprcfin=xprcintps(1,iloc)
               shwfin=shwintps(1,iloc)
               sstfin=sstintps(1,iloc)
               xrhfin=xirhintps(1,iloc)
             else             
               do igrd=1,4
                  slvpintp(igrd)=slvpintps(igrd,iloc)
                  xprcintp(igrd)=xprcintps(igrd,iloc)
                  wgt(igrd)=wgts(igrd,iloc)
                  shwintp(igrd)=shwintps(igrd,iloc)
                  sstintp(igrd)=sstintps(igrd,iloc)
                  xirhintp(igrd)=xirhintps(igrd,iloc)
               enddo
               call interph(metsimc,slvpintp,wgt,slvpfin)
               call interph(metsimc,xprcintp,wgt,xprcfin)
               call interph(metsimc,shwintp,wgt,shwfin)
               call interph(metsimc,sstintp,wgt,sstfin) 
               call interph(metsimc,xirhintp,wgt,xrhfin) 
             endif
           endif

         if(LALLPROF) then
c ---       STANDARD results go to working directory; METSTAT and
c ---       NEUTRAL go to subdirectories

c ---       (WORKING)
            io=iout+iloc
c --- Write exact gridded point if exact point is provided
             if(wgts(1,iloc).eq.1.and.wgts(3,iloc).eq.1) then
               wsfin=wsintps(1,iloc)
               wdfin=wdintps(1,iloc)
               tkfin=tkintps(1,iloc)
               qqfin=qqintps(1,iloc)
             else
            do igrd=1,4
               wsintp(igrd)=wsintps(igrd,iloc)
               wdintp(igrd)=wdintps(igrd,iloc)
               wgt(igrd)=wgts(igrd,iloc)
               tkintp(igrd)=tkintps(igrd,iloc)
               qqintp(igrd)=qqintps(igrd,iloc)
            enddo
            call interphsd(metsimc,wsintp,wdintp,wgt,wsfin,wdfin)
            call interph(metsimc,tkintp,wgt,tkfin)
            call interph(metsimc,qqintp,wgt,qqfin)
             endif
c ---       Dataset 2.0:  write SNAPSHOT begin/end time
            isec=0

c --- V1.9.0, Level 121203
            call OUTPUTmm5(io,iyout,imout,idout,ihout,isec,
     &          iyout,imout,idout,ihout,isec,
     &          wdfin,wsfin,tkfin,qqfin,slvpfin,xprcfin,shwfin,sstfin,
     &          xrhfin,lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))

c ---       (/METSTAT)
            io=iout+iloc+ntsfout
c --- Write exact gridded point if exact point is provided
             if(wgts(1,iloc).eq.1.and.wgts(3,iloc).eq.1) then
               wsfin=wsintps1(1,iloc)
               wdfin=wdintps1(1,iloc)
               tkfin=tkintps1(1,iloc)
               qqfin=qqintps1(1,iloc)
             else
            do igrd=1,4
               wsintp(igrd)=wsintps1(igrd,iloc)
               wdintp(igrd)=wdintps1(igrd,iloc)
               wgt(igrd)=wgts(igrd,iloc)
               tkintp(igrd)=tkintps1(igrd,iloc)
               qqintp(igrd)=qqintps1(igrd,iloc)
            enddo
            call interphsd(metsimc,wsintp,wdintp,wgt,wsfin,wdfin)
            call interph(metsimc,tkintp,wgt,tkfin)
            call interph(metsimc,qqintp,wgt,qqfin)
              endif
c ---       Dataset 2.0:  write SNAPSHOT begin/end time
            isec=0

c --- V1.9.0, Level 121203
            call OUTPUTmm5(io,iyout,imout,idout,ihout,isec,
     &          iyout,imout,idout,ihout,isec,
     &          wdfin,wsfin,tkfin,qqfin,slvpfin,xprcfin,shwfin,sstfin,
     &          xrhfin,lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))

c ---       (/NEUTRAL)
            io=iout+iloc+ntsfout+ntsfout
c --- Write exact gridded point if exact point is provided
             if(wgts(1,iloc).eq.1.and.wgts(3,iloc).eq.1) then
               wsfin=wsintps2(1,iloc)
               wdfin=wdintps2(1,iloc)
               tkfin=tkintps2(1,iloc)
               qqfin=qqintps2(1,iloc)
             else
            do igrd=1,4
               wsintp(igrd)=wsintps2(igrd,iloc)
               wdintp(igrd)=wdintps2(igrd,iloc)
               wgt(igrd)=wgts(igrd,iloc)
               tkintp(igrd)=tkintps2(igrd,iloc)
               qqintp(igrd)=qqintps2(igrd,iloc)
            enddo
            call interphsd(metsimc,wsintp,wdintp,wgt,wsfin,wdfin)
            call interph(metsimc,tkintp,wgt,tkfin)
            call interph(metsimc,qqintp,wgt,qqfin)
             endif
c ---       Dataset 2.0:  write SNAPSHOT begin/end time
            isec=0

c --- V1.9.0, Level 121203
            call OUTPUTmm5(io,iyout,imout,idout,ihout,isec,
     &          iyout,imout,idout,ihout,isec,
     &          wdfin,wsfin,tkfin,qqfin,slvpfin,xprcfin,shwfin,sstfin,
     &          xrhfin,lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))

         else
c ---       Results for one profile method go to working directory
            io=iout+iloc
            if(LSTANDARD) then
c --- Write exact gridded point if exact point is provided
             if(wgts(1,iloc).eq.1.and.wgts(3,iloc).eq.1) then
               wsfin=wsintps(1,iloc)
               wdfin=wdintps(1,iloc)
               tkfin=tkintps(1,iloc)
               qqfin=qqintps(1,iloc)
             else
               do igrd=1,4
                  wsintp(igrd)=wsintps(igrd,iloc)
                  wdintp(igrd)=wdintps(igrd,iloc)
                  wgt(igrd)=wgts(igrd,iloc)
                  tkintp(igrd)=tkintps(igrd,iloc)
                  qqintp(igrd)=qqintps(igrd,iloc)
               enddo
               call interphsd(metsimc,wsintp,wdintp,wgt,wsfin,wdfin)
               call interph(metsimc,tkintp,wgt,tkfin)
               call interph(metsimc,qqintp,wgt,qqfin)
             endif
            elseif(LMETSTAT) then
c --- Write exact gridded point if exact point is provided
             if(wgts(1,iloc).eq.1.and.wgts(3,iloc).eq.1) then
               wsfin=wsintps1(1,iloc)
               wdfin=wdintps1(1,iloc)
               tkfin=tkintps1(1,iloc)
               qqfin=qqintps1(1,iloc)
             else
               do igrd=1,4
                  wsintp(igrd)=wsintps1(igrd,iloc)
                  wdintp(igrd)=wdintps1(igrd,iloc)
                  wgt(igrd)=wgts(igrd,iloc)
                  tkintp(igrd)=tkintps1(igrd,iloc)
                  qqintp(igrd)=qqintps1(igrd,iloc)
               enddo
               call interphsd(metsimc,wsintp,wdintp,wgt,wsfin,wdfin)
               call interph(metsimc,tkintp,wgt,tkfin)
               call interph(metsimc,qqintp,wgt,qqfin)
             endif
            elseif(LNEUTRAL) then
c --- Write exact gridded point if exact point is provided
             if(wgts(1,iloc).eq.1.and.wgts(3,iloc).eq.1) then
               wsfin=wsintps2(1,iloc)
               wdfin=wdintps2(1,iloc)
               tkfin=tkintps2(1,iloc)
               qqfin=qqintps2(1,iloc)
             else
               do igrd=1,4
                  wsintp(igrd)=wsintps2(igrd,iloc)
                  wdintp(igrd)=wdintps2(igrd,iloc)
                  wgt(igrd)=wgts(igrd,iloc)
                  tkintp(igrd)=tkintps2(igrd,iloc)
                  qqintp(igrd)=qqintps2(igrd,iloc)
               enddo
               call interphsd(metsimc,wsintp,wdintp,wgt,wsfin,wdfin)
               call interph(metsimc,tkintp,wgt,tkfin)
               call interph(metsimc,qqintp,wgt,qqfin)
             endif
c --- (CEC - 080205 - Add the DIRECT profile option)
            elseif(LDIRECT) then
c --- Write exact gridded point if exact point is provided
             if(wgts(1,iloc).eq.1.and.wgts(3,iloc).eq.1) then
               wsfin=wsintps2(1,iloc)
               wdfin=wdintps2(1,iloc)
               tkfin=tkintps2(1,iloc)
               qqfin=qqintps2(1,iloc)
             else
               do igrd=1,4
                  wsintp(igrd)=wsintps2(igrd,iloc)
                  wdintp(igrd)=wdintps2(igrd,iloc)
                  wgt(igrd)=wgts(igrd,iloc)
                  tkintp(igrd)=tkintps2(igrd,iloc)
                  qqintp(igrd)=qqintps2(igrd,iloc)
               enddo
               call interphsd(metsimc,wsintp,wdintp,wgt,wsfin,wdfin)
               call interph(metsimc,tkintp,wgt,tkfin)
               call interph(metsimc,qqintp,wgt,qqfin)
             endif
            endif
c
c --- (CEC - 080205 - check that WIND10m, T2m and Q2m are not all missing)
            if(LDIRECT) then
            wstot=wstot+wsfin
            wdtot=wdtot+wdfin
            tktot=tktot+tkfin
            qqtot=qqtot+qqfin
            endif  

c --- (CEC - 081219 - check that 2D fields to outputs are not all missing)
            if(LOTHER(iloc)) then
            slvptot=slvptot+slvpfin
            xprctot=xprctot+xprcfin
            shwtot=shwtot+shwfin
            ssttot=ssttot+sstfin
            xrhtot=xrhtot+xrhfin
            endif                   
c
c ---       Dataset 2.0:  write SNAPSHOT begin/end time
            isec=0

c --- V1.9.0, Level 121203
            call OUTPUTmm5(io,iyout,imout,idout,ihout,isec,
     &          iyout,imout,idout,ihout,isec,
     &          wdfin,wsfin,tkfin,qqfin,slvpfin,xprcfin,shwfin,sstfin,
     &          xrhfin,lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))

         endif

c ---    Next location
         iloc=iloc+1
         if(iloc.le.ntsfout) goto 2030
         ihr=ihr+1
c        write(ilog,1070)iyr,imon,iday,jday,ihour,isec,idate0,ihr
 1070    format(5i5,i5.4,i12,i5)
         print 1071,ihr,iyr,imon,iday,jday,ihour,isec
 1071    format('+',6i5,i5.4)

c --- (CEC - 090304 - get timestamp for last date/time extracted in LST)
         call TIMESTAMP(iyrext,jdayl,ihourl,idatel)

c ---    Figure out next time stamp
         call INCRS(ilog,iyr,jday,ihour,isec,isecstep)
         call GRDAY(ilog,iyr,jday,imon,iday)
         call TIMESTAMP(iyr,jday,ihour,idate)
         idate0=idate
         if(ihr.lt.nbsecext) goto 6200
         write(*,*)

 6500    close(in)
c --- (CEC - 090209 - remove - not needed anymore - Ground Temperature field (2m) will be read from 3D.DAT file
c         if(LSTANDARD .OR. LMETSTAT) close(in2)

 6000 continue

C --- (CEC - 080205 - Add ERROR message if wind-10m, Temp-2m and Q-2m always 0.0)
      if(LDIRECT) then
        if(wstot.eq.0.and.wdtot.eq.0) then
          write(ilog,*)'Error: Wind-10m always 0.0 '
          print *,'Error: Wind-10m always 0.0 '
        endif
        if(tktot.eq.0) then
          write(ilog,*)'Error: Temp-2m always 0.0 '
          print *,'Error: Temp-2m always 0.0 '
        endif
        if(qqtot.eq.0) then
          write(ilog,*)'Error: Hum. Spec-2m always 0.0 '
          print *,'Error: Hum. Spec-2m always 0.0 '
        endif
      endif
c
C --- (CEC - 080205 - Add ERROR message if wind-10m, Temp-2m and Q-2m always 0.0)
      do i=1,ntsfout
      if(LOTHER(i)) then
        if(slvptot.eq.0.) then
          write(ilog,*)'Error: Sea level Pressure always 0.0 '
          print *,'Error: Sea level Pressure always 0.0 '
        endif
        if(shwtot.eq.0.) then
          write(ilog,*)'Error: Solar Radiation always 0.0 '
          print *,'Error: Solar Radiation always 0.0 '
        endif
        if(ssttot.eq.0.) then
          write(ilog,*)'Error: SST always 0.0 '
          print *,'Error: SST always 0.0 '
        if(xrhtot.eq.0.) then
          write(ilog,*)'Error: RELATIVE HUMIDITY always 0.0 '
          print *,'Error: RH always 0.0 '
        endif
        endif
      endif
      enddo
c
      if(ihr.lt.nbsecext) then
         write(ilog,*)'ERROR: Not all hours were extracted'
      write(ilog,*)'Header Ending date do not match last record of data'
         write(ilog,*)'Hours Extracted: ',ihr
         write(ilog,*)'Hours Needed: ',nbsecext
         write(ilog,*)'Last time extracted (LST): ',idatel,isec
         write(ilog,*)'Last time needed (LST): ',iedathrc,iesecc
         print *,'ERROR: Not all hours were extracted'
         print *,'Header Ending date do not match last record of data'
         print *,'Hours Extracted: ',ihr
         print *,'Hours Needed: ',nbsecext
         print *,'Last time extracted (LST): ',idatel,isec
         print *,'Last time needed (LST): ',iedathrc,iesecc
      else
         write(ilog,'(a)')'MM5 data extraction completed'
      endif
     
      return
      end

c ---------------------------------------------------------------------
      subroutine srfext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Extract wind time series from SURF.DAT
c
c --- UPDATES:
c
c --- Version 1.66, Level 090731 to Version 1.9.0, Level 121203
c         - Add call to MIDNITE for selected time convention
c         - Move MXSTN to PARAMS.SER
c         - Add check for NSTN > MXSTN
c         - Add new variables for end-time output
c         - Restrict 24h to seconds=0000
c
c --- Version 1.63, level 090415 to Version 1.66, level 090731 (CEC
c         - Add the possibility to output relative humidity in % with
c           the other species.
c --- Version 1.62, level 090411 to Version 1.63, level 090415 (DGS)
c         - Fix typo IYR to IYRX in TIMESTAMP call 
c           (current year did not update at New Years, halting run)
c         - Replace old calls to Y2K() with YR4()
c --- Version 1.6, Level: 090318 to Version 1.62, Level: 090411 (CEC)
c         - add check on WD, WS and Pressure for SURF.DAT format if missing 
c           different than 9999.
c --- Version 1.0, Level: 060615 to Version 1.6, Level: 090318 (DGS)
c         - Control information from /CONTROL/
c         - Filename changed from 80 to 132
c         - Place output TSF header calls into HDTSFOUT
c         - Change to Julian Date-hour integer YYYYJJJHH
c         - Processing sub-hourly time steps has been updated.
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- V1.9.0, Level 121203
      parameter (iecho=0)

      dimension iwmo(mxstn),idpk(mxstn),xx(8,mxstn)
      character*132 fl

      character*16 dataset,dataver
      character*64 datamod
      character*8 datum,pmap, axtz
      character*10 daten
      character*4 xyunit
      character*4 cname(mxstn),cnam,ctemp
      character*16 clat(mxstn),clon(mxstn)

      real anem(mxstn)

c --- Extractions are currently done by station ID, so there
c --- are no modifications to header information
c --- Write header for TSF output file(s)
      do iloc=1,ntsfout
         io=iout+iloc
         call HDTSFOUT(io,iloc)
      enddo

c read header information of processed Surf.dat data
      ihr=0
      idate=0

      do 6000 ifile=1,nmetinp

c ---    Skip remaining files if period has already been extracted
         if(ihr.GE.nbsecext) goto 6000

         fl=fmet(ifile)
c         nt=index(fl,' ')-1
         nt=LEN_TRIM(fl)
         print *,'Processing File:',ifile,' ',fl(1:nt)
         write(ilog,1008)ifile,fl(1:nt)
 1008    format(i3,2x,a)

         open(in,file=fl,status='old',action='read')

c        read header information
         read(in,101) dataset,dataver,datamod
 101     format(2a16,a64)

         ifilver=0
         itime=0
         if(dataset.EQ.'SURF.DAT') then
            ifilver=1
c ---       Set time structure flag
            if(dataver.EQ.'2.0') then
c ---          Dataset 2.0 with comment records
               itime=0
            else
c ---          Dataset with comment records and begin/end times
               itime=1
            endif
         endif
         REWIND(in)

         if(ifilver.eq.1) then
            read(in,101) dataset,dataver,datamod
            read(in,*)ncom
            do i=1,ncom
               read(in,*)
            enddo
            read(in,'(a8)')pmap
            if(iecho.eq.1) write(ilog,'(a8)') pmap

            if(pmap.EQ.'NONE    ') then
               if(itime.EQ.1) then
c ---             Explicit time convention -
c ---             UTC time zone
                  read(in,'(a8)') axtz
                  read(in,*)ibyr,ibjul,ibhr,ibsec,
     &                      ieyr,iejul,iehr,iesec,nstn
                  if(iecho.eq.1) then
                     write(ilog,'(a8)') axtz
                     write(ilog,'(8i5,i12)')ibyr,ibjul,ibhr,ibsec,
     &                                      ieyr,iejul,iehr,iesec,
     &                                      nstn
                  endif
               else
c ---             hour-ending dataset 
                  read(in,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,izone,nstn
                  if(iecho.eq.1) then
                     write(ilog,'(7i5,i12)')ibyr,ibjul,ibhr,
     &                                      ieyr,iejul,iehr,izone,nstn
                  endif
               endif

c --- V1.9.0, Level 121203
c ---          Test number of stations
               if(nstn.GT.mxstn) goto 9001

               read(in,*)(iwmo(n),n=1,nstn)
               if(iecho.eq.1) then
                  do n=1,nstn
                     write(ilog,'(i8)') iwmo(n)
                  enddo
               endif
            elseif(pmap.EQ.'LL      ') then
               read(in,'(a8,a10)') datum,daten
               read(in,'(a4)') xyunit
               if(iecho.eq.1) then
                  write(ilog,'(a8,a10)') datum,daten
                  write(ilog,'(a4)') xyunit
               endif
               if(itime.EQ.1) then
c ---             explicit time with seconds
                  read(in,'(a8)') axtz
                  read(in,*)ibyr,ibjul,ibhr,ibsec,
     :                      ieyr,iejul,iehr,iesec,nstn
                  if(iecho.eq.1) then
                     write(ilog,'(a8)') axtz
                     write(ilog,'(8i5,i12)')ibyr,ibjul,ibhr,ibsec,
     :                         ieyr,iejul,iehr,iesec,nstn
                  endif
               else
c ---             hour-ending dataset 
                  read(in,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,izone,nstn
                  if(iecho.eq.1) then
                     write(ilog,'(7i5,i12)')ibyr,ibjul,ibhr,
     &                                      ieyr,iejul,iehr,izone,nstn
                  endif
               endif

c --- V1.9.0, Level 121203
c ---          Test number of stations
               if(nstn.GT.mxstn) goto 9001

               do n=1,nstn
                 read(in,*)iwmo(n),cname(n),clat(n),clon(n),anem(n)
c ---            Remove leading blanks from CNAME
                 cnam=cname(n)
                 do kk=1,4
                    ctemp='    '
                    if(cnam(1:1).EQ.' ') then
                       ctemp(1:3)=cnam(2:4)
                       cnam=ctemp
                    endif
                 enddo
                 cname(n)=cnam
                 write(ilog,*)iwmo(n),cname(n),clat(n),clon(n),anem(n)
               enddo
            else
               write(ilog,*)
               write(ilog,*) 'Invalid projection found'
               write(ilog,*) 'Projection found    = ',pmap
               write(ilog,*) 'Projection expected = NONE or LL'
               stop 'Halted: Invalid projection found'
            endif

         endif

         ip=0
         do iloc=1,ntsfout
            idstn=idmet(iloc)
            do istn=1,nstn
               if(iwmo(istn).eq.idstn) then
                  idpk(iloc)=istn
                  ip=ip+1
               endif
            enddo
         enddo

         if(ip.ne.ntsfout) then
            write(ilog,*)'Error: Not found all required stations'
            write(ilog,*)'Required/Found:',ntsfout,ip
            print *,'Error: Not found all required stations'
            print *,'Required/Found:',ntsfout,ip
            stop
         endif

c --- ndateext = begining time of first time/date = ndatenew - begining seconds = nsecext=nsecnew
      ndatenew = ndateext
      isecx = nsecext
      call DEDAT(ndatenew,iyrx,jdayx,ihourx)
      call GRDAY(ilog,iyrx,jdayx,imonx,idayx)

 2000    continue

         isec=0
         if(itime.EQ.0) then
            read(in,*,end=3000)iyr,jday,ihour,
     &          ((xx(i,istn),i=1,8),istn=1,nstn)
c ---       Create time at beginning of current period
              nsec=-isecstep
              iyrb=iyr
              jdayb=jday
              ihourb=ihour
              isecb=isec
              call INCRS(ilog,iyrb,jdayb,ihourb,isecb,nsec)
         else
            read(in,*,end=3000)iyrb,jdayb,ihourb,isecb,
     &                         iyr,jday,ihour,isec,
     &          ((xx(i,istn),i=1,8),istn=1,nstn)
         endif
         
         call YR4(ilog,iyrb,ierrb)
         call YR4(ilog,iyr,ierr)
         if(ierr.NE.0 .OR. ierrb.NE.0) stop 'Halted in SRFEXT - Y2K'

c ---    Increment hour if second = 3600
         nhrinc=1
         if(isec.EQ.3600) then
            isec=0
            call INCR(ilog,iyr,jday,ihour,nhrinc)
         endif
         if(isecb.EQ.3600) then
            isecb=0
            call INCR(ilog,iyrb,jdayb,ihourb,nhrinc)
         endif

c ---    Get month/day
         call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
         call GRDAY(ilog,iyr,jday,imon,iday)

c ---    Create timestamp with time at beginning
         call TIMESTAMP(iyrb,jdayb,ihourb,idate)

c ---    Compute difference in seconds between two dates
             call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)

         if(ndelsec.gt.0) then
              goto 2000
         elseif(ndelsec.lt.0) then
c --- date requested is too early
c --- (CEC - 090304 - make the run stops if begining date requested by user is earlier
c                     than data availability)
          write(ilog,*)'ERROR- beginning date/time requested is earlier'
             write(ilog,*)'than data in SURF.DAT file'
	     write(ilog,*)'date requested = ',ndatenew,isecx
             write(ilog,*)'beginning date in file = ',idate,isecb
             write(*,*)'ERROR- beginning date/time requested is earlier'
             write(*,*)'than data in SURF.DAT file'
	     write(*,*)'date requested = ',ndatenew,isecx
             write(*,*)'beginning date in file = ',idate,isecb
             stop
         endif

c --- V1.9.0, Level 121203
c ---    Swap date and end-time into variables for output
         iyout=iyr
         imout=imon
         idout=iday
         jdout=jday
         ihout=ihour
c ---    Apply Midnight Convention to end-time
         if(imidnite.EQ.1 .AND. ihout.EQ.24) then
           ihout=0
           call MIDNITE(ilog,'TO 00h',iyr,imon,iday,jday,
     &                                iyout,imout,idout,jdout)
         elseif(imidnite.EQ.2 .AND. ihout.EQ.0 .AND. isec.EQ.0) then
           ihout=24
           call MIDNITE(ilog,'TO 24h',iyr,imon,iday,jday,
     &                                iyout,imout,idout,jdout)
         endif

c        Output
         do iloc=1,ntsfout
            istn=idpk(iloc)
            wd=xx(2,istn)
            ws=xx(1,istn)
            tk=xx(5,istn)
            rh=xx(6,istn)
            pmb=xx(7,istn)
            iccv=xx(3,istn)
            ipcode=xx(8,istn)
c --- if iccv=999 means clear sky
       if(iccv.eq.999)icc=0
            iceilh=xx(4,istn)
c
            if(tk.LT.9000.0 .AND. rh.LT.9000.0 .AND.
     &                           pmb.LT.9000.0) then
c ---          Water vapor mixing ratio (g h2o/g air)
               call VSAT(tk,psat,qsat)
               if(pmb.ne.psat) then
               qr=0.622*(0.01*rh*psat)/(pmb-psat)
c ---          Convert to spec. hum (g/kg)
               qq=1000.0*(qr/(1.0+qr))
               else
               write(*,*)'ERROR - pmb = psat'
               stop
               endif
            else
               qq=9999.0
            endif
            if(wd.GT.9000.0 .AND. ws.GT.9000.0) then
            wd=9999.
            ws=9999.
            endif
            if(pmb.GT.9000.0) then
            pmb=9999.
            endif
            if(rh.GT.9000.0) then
            rh=9999.
            endif
            if(tk.GT.9000.0) then
            tk=9999.
            endif
            if(iccv.GT.9000) then
            iccv=9999
            endif
            if(ipcode.GT.9000) then
            ipcode=9999
            endif
            if(iceilh.GT.9000) then
            iceilh=9999
            endif
            irh=int(rh)

            io=iout+iloc

c --- V1.9.0, Level 121203
            call Outputsrf(io,iyrb,imonb,idayb,ihourb,isecb,
     &                 iyout,imout,idout,ihout,isec,
     &                 wd,ws,tk,qq,iccv,iceilh,pmb,ipcode,irh,
     &                 lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))

c 181        format(i4,3i2.2,3f7.1)
         enddo

c --- (CEC - 090304 - get Time stamp for last date/time extracted)
            call TIMESTAMP(iyr,jday,ihour,idatel)

c ---    Update period counter (may not be hours)
          ihr=ihr+1
          nsec=isecstep
          call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
          call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
          call TIMESTAMP(iyrx,jdayx,ihourx,ndatenew)
          if(ihr.lt.nbsecext)  goto 2000

 3000    close(in)

 6000 continue
      if(ihr.eq.0) then
      write(ilog,*)'Error: No data were extracted:'
      write(ilog,*)'checked data file and control input file'
      write(ilog,*)'station requested ',idloc(iloc)
      print *,'Error: No data were extracted:'
      print *,'checked data file and control input file'
      print *,'station requested ',idloc(iloc)
      stop
      elseif(ihr.lt.nbsecext) then
      write(ilog,*)'ERROR: Not all periods were extracted'
      write(ilog,*)'Header Ending date do not match last record of data'
      write(ilog,*)'Periods Extracted: ',ihr
      write(ilog,*)'Periods Requested: ',nbsecext
      write(ilog,*)'Last time extracted (LST): ',idatel,isec
      write(ilog,*)'Last time needed (LST): ',iedathrc,iesecc
      print *,'ERROR: Not all periods were extracted'
      print *,'Periods Extracted: ',ihr
      print *,'Periods Requested: ',nbsecext
      print *,'Last time extracted (LST): ',idatel,isec
      print *,'Last time needed (LST): ',iedathrc,iesecc
      else
      write(ilog,'(a)')'SURF.DAT data extraction completed'
      endif

      return

c --- V1.9.0, Level 121203
c --- Too many stations
9001  write(ilog,*)
      write(ilog,*) 'Too many surface stations found'
      write(ilog,*) 'Number found = ',nstn
      write(ilog,*) 'MXSTN limit  = ',mxstn
      write(ilog,*) 'Increase MXSTN in PARAMS.SER and recompile'
      stop 'Halted in SRFEXT -- see list file'

      end

c ---------------------------------------------------------------------
      subroutine aermsfcext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c --- Christelle Escoffier-Czaja           
c
c --- PURPOSE: Extract wind time series from AERMOD.SFC
c
c --- UPDATES:
c
c --- Version 1.81, level 110308 to Version 1.9.0, Level 121203
c         - Revise call to MIDNITE for selected time convention
c         - Change data record input from fixed to free format to
c           adapt to changes in the file format
c         - Trap missing height (wind, T) and set to target since
c           heights are missing if data are missing
c         - Align missing values for M-OL, precip, and clouds with
c           header documentation
c         - Add new variables for end-time output
c         - Restrict 24h to seconds=0000
c
c --- Version 1.80, level 110301 to Version 1.81, level 110308 (CEC)
c         - Roughness length was extracted instead of Monin-Obukhov
c           lenght. It is now corrected - missing is set as -9999.
c --- Version 1.66, level 090731 to Version 1.78, level 100624 (CEC)
c         - Put back the error checking if wind elevation in file is
c           different from what asked in the control file.
c         - Put back the error checking if temperature elevation in file
c           is different from what asked in the control file.
c --- Version 1.63, level 090415 to Version 1.66, level 090731 (DGS)
c         - Remove IWMO, IDPK, ANEM declaration (not used)
c         - Assign IHR before first use
c --- Version 1.6, Level: 090318 to Version 1.63, level 090415 (DGS)
c         - Fix typo IYR to IYRX in TIMESTAMP call 
c           (current year did not update at New Years, halting run)
c         - Replace old calls to Y2K() with YR4()
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c         - Control information from /CONTROL/
c         - Filename changed from 80 to 132
c         - Place output TSF header calls into HDTSFOUT
c         - Change to Julian Date-hour integer YYYYJJJHH
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'metinp.ser'

      parameter (iecho=0)
c      parameter (mxstn=300,iecho=0)
c      dimension iwmo(mxstn),idpk(mxstn)
      character*132 fl
      character*6 ctrans

c      real anem(mxstn)

c --- Local variables
      character*320 char320,blnk320

      do i=1,320
         blnk320(i:i)=' '
      enddo

c --- Write header for TSF output file
      do iloc=1,ntsfout
         io=iout+iloc
         call HDTSFOUT(io,iloc)
      enddo

      ihr=0

c read header information of processed AERMOD.SFC data

      do 6000 ifile=1,nmetinp

c ---    Skip remaining files if period has already been extracted
         if(ihr.GE.nbsecext) goto 6000

         fl=fmet(ifile)
c         nt=index(fl,' ')-1
         nt=LEN_TRIM(fl)
         print *,'Processing File:',ifile,' ',fl(1:nt)
         write(ilog,1008)ifile,fl(1:nt)
 1008    format(i3,2x,a)

         open(in,file=fl,status='old',action='read')

      do 3001 iloc=1,ntsfout
      rewind(in)
c --- Read header information
      read(in,*) char320
      ihr=0
      idate=0
      io=iout+iloc
c --- ndateext = begining time of first time/date = ndatenew - begining seconds = nsecext=nsecnew
      ndatenew = ndateext
      isecx = nsecext
c      call getdate(ndatenew,iyrx,imonx,idayx,ihourx)
c      call julday(ilog,iyrx,imonx,idayx,jdayx)
      call DEDAT(ndatenew,iyrx,jdayx,ihourx)
      call GRDAY(ilog,iyrx,jdayx,imonx,idayx)

2000     continue 

c ---    Read line
20       char320=blnk320
         read(in,'(a320)',end=3000) char320

c --- V1.9.0, Level 121203
c ---    Trim off characters introduced in AERMET 11059
         ilen=LEN_TRIM(char320)
         itrim=MAX(INDEX(char320,'NAD'),INDEX(char320,'ADJ'))
         if(itrim.GT.0) ilen=itrim
c ---    Try to read full set of variables
         read(char320(1:ilen),*,iostat=ios) iyr,imo,iday,jday,ihour,
     &      xsens,ustar,wstar,VPTGZI,zicnv,zimch,xmol,xrghness,BOWEN,
     &      ALBEDO,ws,wd,xmwds,tk,xmtk,IPCODE,xprec,rh,
     &      pmb,icc
         if(ios.NE.0) then
c ---       Read reduced set with deposition-related variables
            read(char320(1:ilen),*) iyr,imo,iday,jday,ihour,
     &         xsens,ustar,wstar,VPTGZI,zicnv,zimch,xmol,xrghness,
     &         BOWEN,ALBEDO,ws,wd,xmwds,tk,xmtk
            xprec=9999.
            rh=9999.
            pmb=9999.
            icc=9999
         endif

c
c ---    Step through meteorological fields - first - date stamp
c --------------------------
         isecb=0
         isec=0
c ---    Date-Time
         call YR4(ilog,iyr,ierr)
         if(ierr.NE.0) stop 'Halted in AERMSFCEXT - Y2K'
         isec=0
c ---    Skip blank record (based on date)
         if(iyr.EQ.0 .OR. imo.EQ.0 .OR. iday.EQ.0) goto 20
         call JULDAY(ilog,iyr,imo,iday,jday)

c --- Change day N hour = 24 to day N+1 hour =0
         if(ihour.eq.24) then
           ihour=0
           ctrans='TO 00h'
           jday=-1
           call MIDNITE(ilog,ctrans,iyr,imo,iday,jday,
     &                              iyr,imo,iday,jday)
         endif
c
c ---       Create time at beginning of current hour
c --- (CEC - 081106 - Create time at begining of current time step - 60s time step = isecstep
              nsec=-isecstep
              iyrb=iyr
              jdayb=jday
              ihourb=ihour
              isecb=isec
              call INCRS(ilog,iyrb,jdayb,ihourb,isecb,nsec)
c         
             call YR4(ilog,iyrb,ierrb)
             call YR4(ilog,iyr,ierr)
             if(ierr.NE.0 .OR.
     &         ierrb.NE.0) stop 'Halted in AERMSFCEXT - Y2K'

c ---    Increment hour if second = 3600
         nhrinc=1
             if(isec.EQ.3600) then
              isec=0
              call INCR(ilog,iyr,jday,ihour,nhrinc)
             endif
             if(isecb.EQ.3600) then
              isecb=0
              call INCR(ilog,iyrb,jdayb,ihourb,nhrinc)
             endif

c ---    Get month/day
             call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
             call GRDAY(ilog,iyr,jday,imon,iday)

c ---    Create timestamp with time at begining
             call TIMESTAMP(iyrb,jdayb,ihourb,idate)
c
c ---    Compute difference in seconds between two dates
             call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)

c --- V1.9.0, Level 121203
c ---    Swap date and end-time into variables for output
         iyout=iyr
         imout=imon
         idout=iday
         jdout=jday
         ihout=ihour
c ---    Apply Midnight Convention
         if(imidnite.EQ.1 .AND. ihout.EQ.24) then
           ihout=0
           ctrans='TO 00h'
           call MIDNITE(ilog,ctrans,iyr,imon,iday,jday,
     &                              iyout,imout,idout,jdout)
         elseif(imidnite.EQ.2 .AND. ihout.EQ.0 .AND. isec.EQ.0) then
           ihout=24
           ctrans='TO 24h'
           call MIDNITE(ilog,ctrans,iyr,imon,iday,jday,
     &                              iyout,imout,idout,jdout)
         endif

2002         if(ndelsec.gt.0) then
              goto 2000
             elseif(ndelsec.lt.0) then
c --- missing data at the begining of the file or in the middle of the file
c --- (CEC - 090304 - make the run stops if begining date requested by user is earlier
c                     than data availability)
             write(ilog,*)'ERROR- date/time requested is earlier'
             write(ilog,*)'than data in AERMET.SFC file'
	     write(ilog,*)'date requested = ',ndatenew,isecx
             write(ilog,*)'date in file = ',idate,isecb
             write(ilog,*)'Missings at begining or in middle of file'
             write(*,*)'ERROR- date/time requested is earlier'
             write(*,*)'than data in AERMET.SFC file'
	     write(*,*)'date requested = ',ndatenew,isecx
             write(*,*)'date in file = ',idate,isecb
             write(*,*)'Missings at begining or in middle of file'
             stop
             endif
c              wd=9999.
c              ws=9999.
c              tk=9999.
c              qq=9999.
c              zicnv=-9999.
c              zimch=-9999.
c              xprec=9999.
c              ustar=9999.
c              xmol=9999.
c              wstar=9999.
c              xsens=9999.
c              icc=9999
c              call DEDAT(ndatenew,iyrx,jdayx,ihourx)
c              call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
c ---       Create time at ending of current hour
c --- (080611 - Create time at ending of current period
c               nsec=isecstep
c              iyrex=iyrx
c              jdayex=jdayx
c              ihourex=ihourx
c              isecex=isecx
c              call INCRS(ilog,iyrex,jdayex,ihourex,isecex,nsec)
c              call GRDAY(ilog,iyrex,jdayex,imonex,idayex)
c              call Outputsfc(io,iyrb,imonb,idayb,ihourb,isecb,
c     &        iyr,imon,iday,ihour,isec,
c     &        wd,ws,tk,qq,zicnv,zimch,xprec,ustar,xmol,wstar,xsens,icc,
c     &        lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))
c ---    Update period counter (may not be hours)
c              ihr=ihr+1
c --- increase ndatenew by 1 hour - to check if any missing hour in the AMMNET file
c --- increase ndatenew by 1 time step isecstep = 60s = 1mn - to check if any missing hours in the AMMNET file
c              nsec=isecstep
c              call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
c              call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
c              call TIMESTAMP(iyr,jdayx,ihourx,ndatenew)
c              call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)
c             if(ndelsec.lt.0.and.ihr.lt.nbsecext) goto 2002
c             endif
c
c ---    Step through meteorological fields - second - parameters
c ---------------
c --- Wind Speed, Wind direction, Temperature 10m, Relative Humidity

c --- V1.9.0, Level 121203
       if(ws.eq.999.)ws=9999.
       if(wd.eq.999.)wd=9999.
c --- Place requested height into variable if missing
      if(xmwds.LT.0.0) xmwds=zwind(iloc)

c ---  Add user filter on elevation check -- LWIND
       if(LWIND(iloc) .AND. (xmwds.ne.zwind(iloc))) then
c         ws=9999.
c         wd=9999.
        write(*,*)'Error - wind extraction elevation requested'
        write(*,*)' different than in AERMOD.SFC'
        write(*,*)' Height Requested: ',zwind(iloc)
        write(*,*)'     Height Found: ',xmwds
        write(ilog,*)'Error - wind extraction elevation requested'
        write(ilog,*)' different than in AERMOD.SFC'
        write(ilog,*)' Height Requested: ',zwind(iloc)
        write(ilog,*)'     Height Found: ',xmwds
        stop
       endif

c --- V1.9.0, Level 121203
       if(tk.eq.999.)tk=9999.
c --- Place requested height into variable if missing
      if(xmtk.LT.0.0) xmtk=ztmpk(iloc)

c ---  Add user filter on elevation check -- LTMPK
       if(LTMPK(iloc) .AND. (xmtk.ne.ztmpk(iloc))) then
c         tk=9999.
        write(*,*)'Error - temperature extraction elevation requested'
        write(*,*)' different than in AERMOD.SFC'
        write(*,*)' Height Requested: ',ztmpk(iloc)
        write(*,*)'     Height Found: ',xmtk
        write(ilog,*)'Error -temperature extraction elevation requested'
        write(ilog,*)' different than in AERMOD.SFC'
        write(ilog,*)' Height Requested: ',ztmpk(iloc)
        write(ilog,*)'     Height Found: ',xmtk
        stop
       endif

c --- V1.9.0, Level 121203
       if(rh.eq.999.)rh=9999.
       if(pmb.eq.9999.)pmb=9999. 
c
c --- Additional variables
       if(zicnv.eq.-999.) zicnv=-9999.
       if(zimch.eq.-999.) zimch=-9999.
       if(xprec.LT.-8.) xprec=9999.
       if(ustar.eq.-9.) ustar=9999.
       if(xmol.eq.-9999.) then
       write(*,*)'ERROR - Monin-Obukhov length equal to -9999.'
       write(*,*)'Check if it can be a possible value'
       stop
       endif
       if(xmol.LT.-99000.) xmol=9999.
c      read(char320(66:71),'(f6.3)')xrghness
       if(wstar.eq.-9.) wstar=9999.
       if(xsens.eq.-999.) xsens=9999.
       if(icc.LT.0 .OR. icc.GT.10) icc=9999

c
c        Output
            istn=idloc(iloc)
            if(tk.LT.9000.0 .AND. rh.LT.9000.0 .AND.
     &                           pmb.LT.9000.0) then
c ---          Water vapor mixing ratio (g h2o/g air)
               call VSAT(tk,psat,qsat)
               if(pmb.ne.psat) then
               qr=0.622*(0.01*rh*psat)/(pmb-psat)
c ---          Convert to spec. hum (g/kg)
               qq=1000.0*(qr/(1.0+qr))
               else
               write(*,*)'ERROR - pmb = psat'
               stop
               endif
            else
               qq=9999.0
            endif
c
c --- V1.9.0, Level 121203
            call Outputsfc(io,iyrb,imonb,idayb,ihourb,isecb,
     &        iyout,imout,idout,ihout,isec,
     &        wd,ws,tk,qq,zicnv,zimch,xprec,ustar,xmol,wstar,xsens,icc,
     &        lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))

c 181        format(i4,3i2.2,3f7.1)
         
c --- (CEC - 090304 - get timestamp for last date/time extracted in LST)
         call TIMESTAMP(iyrx,jdayx,ihourx,idatel)

c ---    Update period counter (may not be hours)
            ihr=ihr+1
c            nhrinc=1
            nsec=isecstep
c            call INCR(ilog,iyrx,jdayx,ihourx,nhrinc)
            call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
            call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
            call TIMESTAMP(iyrx,jdayx,ihourx,ndatenew)
c            call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)
c            if(ihr.lt.nhrext) goto 2000
            if(ihr.lt.nbsecext) then          
               goto 2000
            endif
c
c        else
c         goto 2000
c        endif

 3000  if(ihr.eq.0) then
       write(ilog,*)'ERROR: No data were extracted:'
       write(ilog,*)'checked data file and control input file'
       write(ilog,*)'station requested ',idloc(iloc)
       print *,'ERROR: No data were extracted:'
       print *,'checked data file and control input file'
       print *,'station requested ',idloc(iloc)
       stop
       elseif(ihr.lt.nhrext) then
       write(ilog,*)'ERROR: Not all periods were extracted'
      write(ilog,*)'Header Ending date do not match last record of data'
       write(ilog,*)'Periods Extracted: ',ihr
       write(ilog,*)'Periods Requested: ',nbsecext
       write(ilog,*)'Last time extracted (LST): ',idatel
       write(ilog,*)'Last time needed (LST): ',iedathrc
       print *,'ERROR: Not all periods were extracted'
       print *,'Periods Extracted: ',ihr
       print *,'Periods Requested: ',nbsecext
       print *,'Last time extracted (LST): ',idatel
       print *,'Last time needed (LST): ',iedathrc
       else
       write(ilog,'(a)')'AERMOD.SFC data extraction completed'
       endif
 3001   continue
c
         close(in)
c
 6000    continue

      return
      end

c ---------------------------------------------------------------------
      subroutine ammnetwext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c --- Christelle Escoffier-Czaja           
c
c --- PURPOSE: Extract wind time series from AMMNETW.DAT
c
c --- UPDATES:
c
c --- Version 1.77, level 100611 to Version 1.9.0, Level 121203
c         - Add call to MIDNITE for selected time convention
c         - Add new variables for end-time output
c         - Restrict 24h to seconds=0000
c
c --- Version 1.72, level 091015 to Version 1.77, level 100611 (CEC)
c         - Add possibility to deal with missing data / date in the
c           middle of the file
c --- Version 1.66, level 090731 to Version 1.72, level 091015 (CEC)
c         - Add the possibility to read the date of AMMNET format as
c           m/d/yyyy h:mm
c --- Version 1.63, level 090415 to Version 1.66, level 090731 (CEC)
c         - Add the possibility to read the date of AMMNET format as
c           mm/dd/yyyy hh:mm or m/dd/yyyy h:mm or any combination
c         - Add the extraction and output of relative humidity 
c         - Remove IWMO, IDPK, ANEM declaration (not used)
c         - Assign IHR before first use
c         - Add variable MONITOR which can be used instead of AMMNET 
c --- Version 1.6, Level: 090318 to Version 1.63, level 090415 (DGS)
c         - Fix typo IYR to IYRX in TIMESTAMP call 
c           (current year did not update at New Years, halting run)
c         - Replace old calls to Y2K() with YR4()
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c         - Control information from /CONTROL/
c         - Place output TSF header calls into HDTSFOUT
c         - Change to Julian Date-hour integer YYYYJJJHH
c --- Version 1.5, Level: 090128 to Version 1.5, Level: 090203 (CEC)
c         - Add option to extract other fields than wind,temp and rel. humd.
c         - Filename changed from 80 to 132
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'metinp.ser'

      parameter (iecho=0)
c      parameter (mxstn=300,iecho=0)
c      dimension iwmo(mxstn),idpk(mxstn)
      character*132 fl

      character*1 vld

c      real anem(mxstn)

c --- Local variables
      integer icommas(0:99)
      logical lerror
      character*1 cm,dq
      character*16 datm
      character*320 char320,blnk320

      data cm/','/
      data dq/'"'/
      data lerror/.FALSE./

      do i=1,320
         blnk320(i:i)=' '
      enddo

      ihr=0

c --- Write header for TSF output file
      do iloc=1,ntsfout
         io=iout+iloc
         call HDTSFOUT(io,iloc)
      enddo

c read header information of processed AMMNETW.dat data

      do 6000 ifile=1,nmetinp

c ---    Skip remaining files if period has already been extracted
         if(ihr.GE.nbsecext) goto 6000

         fl=fmet(ifile)
c         nt=index(fl,' ')-1
         nt=LEN_TRIM(fl)
         print *,'Processing File:',ifile,' ',fl(1:nt)
         write(ilog,1008)'MET File: ',ifile,fl(1:nt)
 1008    format(a,i3,2x,a)

         open(in,file=fl,status='old',action='read')

      do 3001 iloc=1,ntsfout
      rewind(in)
c ---  read header information
      read(in,*) char320
      ihr=0
      idate=0
      io=iout+iloc
c --- ndateext = begining time of first time/date = ndatenew - begining seconds = nsecext=nsecnew
      ndatenew = ndateext
      isecx = nsecext
c      call getdate(ndatenew,iyrx,imonx,idayx,ihourx)
c      call julday(ilog,iyrx,imonx,idayx,jdayx)
      call DEDAT(ndatenew,iyrx,jdayx,ihourx)
      call GRDAY(ilog,iyrx,jdayx,imonx,idayx)

2000     continue 

c --- initialization of variables
          ws=9999.
          wd=9999.
          tk=9999.
          rh=9999.
          xpmb=9999.
          swrad=9999.
          xprc=9999.   
          qq=9999. 

c ---    Read line
20       char320=blnk320
         read(in,'(a320)',end=3000) char320

c ---    Test line for at least 1 comma to screen out empty lines
         itest=INDEX(char320,cm)
         if(itest.EQ.0) goto 20

c ---    Remove this shift since validity flags are case-sensitive
cc ---    Create upper-case version of line
c         klast=LEN_TRIM(char320)
c         call CASE320('UPPER',char320,klast)

c ---    Drop any double quotes from line
         call OMIT320(dq,char320)

c ---    Identify column ranges
         klast=LEN_TRIM(char320)
         call COLUMN320(char320,klast,cm,nmvars,ncommas,icommas)

c ---    Step through meteorological fields - first - date stamp
c --------------------------
         isecb=0
         isec=0
c ---    Date-Time
         datm='mm/dd/yyyy hh:mm'
         call IRANGE(imcoldatm,icommas,ncommas,i1,i2)
         datm=char320(i1:i2)

c --- (CEC - 091015 - modified the extraction of date/time)
         call readate_mon(i1,i2,datm,imo,iday,iyr,ihour,irmn)
         isec=irmn*60

c ---    Skip blank record (based on date)
         if(iyr.EQ.0 .OR. imo.EQ.0 .OR. iday.EQ.0) goto 20
         call JULDAY(ilog,iyr,imo,iday,jday)

c ---    Averaging Time
         call IRANGE(imcolavg,icommas,ncommas,i1,i2)
         read(char320(i1:i2),'(i)') iavg
         iavg=iavg*60

c ---    Station Code
         call IRANGE(imcolstn,icommas,ncommas,i1,i2)
         read(char320(i1:i2),'(i)') idmeta
         if(idmeta.eq.idmet(iloc)) then
c
c ---       Create time at beginning of current hour
c --- (CEC - 081106 - Create time at begining of current time step - 60s time step = isecstep
              nsec=-isecstep
c             nhrinc=-1
              iyrb=iyr
              jdayb=jday
              ihourb=ihour
              isecb=isec
c             call INCR(ilog,iyrb,jdayb,ihourb,nhrinc)
              call INCRS(ilog,iyrb,jdayb,ihourb,isecb,nsec)
c         
             call YR4(ilog,iyrb,ierrb)
             call YR4(ilog,iyr,ierr)
             if(ierr.NE.0 .OR.
     &         ierrb.NE.0) stop 'Halted in AMMNETWEXT - Y2K'

c ---    Increment hour if second = 3600
         nhrinc=1
             if(isec.EQ.3600) then
              isec=0
              call INCR(ilog,iyr,jday,ihour,nhrinc)
             endif
             if(isecb.EQ.3600) then
              isecb=0
              call INCR(ilog,iyrb,jdayb,ihourb,nhrinc)
             endif

c ---    Get month/day
             call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
             call GRDAY(ilog,iyr,jday,imon,iday)

c ---    Create timestamp with time at begining
             call TIMESTAMP(iyrb,jdayb,ihourb,idate)
c
c ---    Compute difference in seconds between two dates
2002         call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)

c --- V1.9.0, Level 121203
c ---        Swap date and end-time into variables for output
             iyout=iyr
             imout=imon
             idout=iday
             jdout=jday
             ihout=ihour
c ---        Apply Midnight Convention to end-time
             if(imidnite.EQ.1 .AND. ihout.EQ.24) then
                ihout=0
                call MIDNITE(ilog,'TO 00h',iyr,imon,iday,jday,
     &                                     iyout,imout,idout,jdout)
             elseif(imidnite.EQ.2 .AND. ihout.EQ.0
     &                            .AND. isec.EQ.0) then
                ihout=24
                call MIDNITE(ilog,'TO 24h',iyr,imon,iday,jday,
     &                                     iyout,imout,idout,jdout)
             endif

             if(ndelsec.gt.0) then
              goto 2000
             elseif(ndelsec.lt.0.and.ihr.eq.0) then
c --- missing data at the begining of the file
c --- (CEC - 090304 - make the run stops if begining date requested by user is earlier
c                     than data availability)
          if(mdata.eq.'AMMNETW') then
          write(ilog,*)'ERROR- beginning date/time requested is earlier'
             write(ilog,*)'than data in AMMNET file'
	     write(ilog,*)'date requested = ',ndatenew,isecx
             write(ilog,*)'beginning date in file = ',idate,isecb
             write(*,*)'ERROR- beginning date/time requested is earlier'
             write(*,*)'than data in AMMNET file'
	     write(*,*)'date requested = ',ndatenew,isecx
             write(*,*)'beginning date in file = ',idate,isecb
          elseif(mdata.eq.'MONITORW') then
          write(ilog,*)'ERROR- beginning date/time requested is earlier'
             write(ilog,*)'than data in MONITOR file'
	     write(ilog,*)'date requested = ',ndatenew,isecx
             write(ilog,*)'beginning date in file = ',idate,isecb
             write(*,*)'ERROR- beginning date/time requested is earlier'
             write(*,*)'than data in MONITOR file'
	     write(*,*)'date requested = ',ndatenew,isecx
             write(*,*)'beginning date in file = ',idate,isecb
          endif
             stop
             elseif(ndelsec.lt.0.and.ihr.ne.0) then
c --- missing date/data in the middle of the file
c               wd=9999.
c               ws=9999.
c               tk=9999.
c               qq=9999.
c               xpmb=9999.
c               swrad=9999.
c               xprc=9999. 
c               rh=9999
c
               nsec=isecstep
               iyrxe=iyrx
               jdayxe=jdayx
               ihourxe=ihourx
               isecxe=isecx
              call INCRS(ilog,iyrxe,jdayxe,ihourxe,isecxe,nsec)
              call GRDAY(ilog,iyrxe,jdayxe,imonxe,idayxe)
c         
c --- V1.9.0, Level 121203
c ---         Swap date and x-time into variables for output
              iyoutx=iyrxe
              imoutx=imonxe
              idoutx=idayxe
              jdoutx=jdayxe
              ihoutx=ihourxe
c ---         Apply Midnight Convention to end-time
              if(imidnite.EQ.1 .AND. ihoutx.EQ.24) then
                ihoutx=0
                call MIDNITE(ilog,'TO 00h',iyrxe,imonxe,idayxe,jdayxe,
     &                                     iyoutx,imoutx,idoutx,jdoutx)
              elseif(imidnite.EQ.2 .AND. ihoutx.EQ.0
     &                             .AND. isecxe.EQ.0) then
                ihoutx=24
                call MIDNITE(ilog,'TO 24h',iyrxe,imonxe,idayxe,jdayxe,
     &                                     iyoutx,imoutx,idoutx,jdoutx)
              endif
              call Outputw(io,iyrx,imonx,idayx,ihourx,isecx,
     &               iyoutx,imoutx,idoutx,ihoutx,isecxe,
     &               wd,ws,tk,qq,xpmb,swrad,xprc,rh,
     &               lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))
c
            call TIMESTAMP(iyrx,jdayx,ihourx,idatel)

c ---    Update period counter (may not be hours)
            ihr=ihr+1
            nsec=isecstep
            call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
            call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
            call TIMESTAMP(iyrx,jdayx,ihourx,ndatenew)
            if(ihr.lt.nbsecext) then          
               goto 2002
            endif
             endif
c
c ---    Step through meteorological fields - second - parameters
c ---------------
c --- Wind Speed
      call IRANGE(imcolwspd,icommas,ncommas,i1,i2)
      call RGET320(char320,i1,i2,wmspd)

c --- Wind Direction
      call IRANGE(imcolwdir,icommas,ncommas,i1,i2)
      call RGET320(char320,i1,i2,wmdir)

c --- Temperature 2m
      if(ztmpk(iloc).eq.2.0)then
      call IRANGE(imcolt2,icommas,ncommas,i1,i2)
      call RGET320(char320,i1,i2,xt2d)
      endif

c --- Temperature 10m
      if(ztmpk(iloc).eq.10.0)then
      call IRANGE(imcolt10,icommas,ncommas,i1,i2)
      call RGET320(char320,i1,i2,xt10d)
      endif

c --- Specific Humidity
      if(zshum(iloc).gt.0.0)then
      call IRANGE(imcolrh,icommas,ncommas,i1,i2)
      call RGET320(char320,i1,i2,x_rh)
      endif

c --- Pressure
      if(zshum(iloc).gt.0.0.or.zother(iloc).gt.0.0)then
      call IRANGE(imcolpres,icommas,ncommas,i1,i2)
      call RGET320(char320,i1,i2,xpres)
      endif

c --- Solar Radiation
      if(zother(iloc).gt.0.0.and.imcolsw.ne.0)then
      call IRANGE(imcolsw,icommas,ncommas,i1,i2)
      call RGET320(char320,i1,i2,xsol)
      endif

c --- Precipitation
      if(zother(iloc).gt.0.0.and.imcolprc.ne.0)then
      call IRANGE(imcolprc,icommas,ncommas,i1,i2)
      call RGET320(char320,i1,i2,xpmm)
      endif

c --- Relative Humidity
      if(zother(iloc).gt.0.0.and.imcolrh.ne.0)then
      call IRANGE(imcolrh,icommas,ncommas,i1,i2)
      call RGET320(char320,i1,i2,x_rh)
      endif

c --- read validity parameter 
c ---    Validity Parameter
         if(imcolvld.ne.0) then
           call IRANGE(imcolvld,icommas,ncommas,i1,i2)
            if(imcolwspd.ne.0) then
             i3=imcolwspd-3
             ic=i1+i3-1
             read(char320(ic:ic),'(a1)')vld
             call VALD_PAR(vld,wmspd,ws)
            endif
            if(imcolwdir.ne.0) then
             i3=imcolwdir-3
             ic=i1+i3-1
             read(char320(ic:ic),'(a1)')vld
             call VALD_PAR(vld,wmdir,wd)
            endif
            if(imcolt2.ne.0) then
             i3=imcolt2-3
             ic=i1+i3-1
             read(char320(ic:ic),'(a1)')vld
             call VALD_PAR(vld,xt2d,tk)
             if(tk.lt.9999.) then
              tk=tk+273.16
             endif
            elseif(imcolt10.ne.0) then
             i3=imcolt10-3
             ic=i1+i3-1
             read(char320(ic:ic),'(a1)')vld
             call VALD_PAR(vld,xt10d,tk)
             if(tk.lt.9999.) then
              tk=tk+273.16
             endif
            endif
            if(imcolrh.ne.0) then
             i3=imcolrh-3
             ic=i1+i3-1
             read(char320(ic:ic),'(a1)')vld
             call VALD_PAR(vld,x_rh,rh)
            endif
            if(imcolpres.ne.0) then
             i3=imcolpres-3
             ic=i1+i3-1
             read(char320(ic:ic),'(a1)')vld
             call VALD_PAR(vld,xpres,xpmb)
            endif
            if(imcolsw.ne.0) then
             i3=imcolsw-3
             ic=i1+i3-1
             read(char320(ic:ic),'(a1)')vld
             call VALD_PAR(vld,xsol,swrad)
            endif
            if(imcolprc.ne.0) then
             i3=imcolprc-3
             ic=i1+i3-1
             read(char320(ic:ic),'(a1)')vld
             call VALD_PAR(vld,xpmm,xprc)
            endif
          else
           ws=wmspd
           wd=wmdir
           if(ztmpk(iloc).eq.2.0) then
             if(xt2d.lt.9999.) then
             tk=xt2d+273.16
             else
             tk=9999.
             endif
           elseif(ztmpk(iloc).eq.10.0) then
             if(xt10d.lt.9999.) then
             tk=xt10d+273.16
             else
             tk=9999.
             endif
           else
             tk=9999.
           endif
           if(x_rh.ge.9999.) then
           rh=9999.
           else
           rh=x_rh
           endif
           if(xpres.ge.9999.) then
           xpmb=9999.
           else
           xpmb=xpres
           endif
           if(xsol.ge.9999.) then
           swrad=9999.
           else
           swrad=xsol
           endif
           xprc=xpmm
          endif
c
c        Output
            istn=idloc(iloc)
            if(tk.LT.9000.0 .AND. rh.LT.9000.0 .AND.
     &                           xpmb.LT.9000.0) then
c ---          Water vapor mixing ratio (g h2o/g air)
               call VSAT(tk,psat,qsat)
               if(xpmb.ne.psat) then
               qr=0.622*(0.01*rh*psat)/(xpmb-psat)
c ---          Convert to spec. hum (g/kg)
               qq=1000.0*(qr/(1.0+qr))
               else
               write(*,*)'ERROR - xpmb = psat'
               stop
               endif
            else
               qq=9999.0
            endif
c
c --- V1.9.0, Level 121203
            call Outputw(io,iyrb,imonb,idayb,ihourb,isecb,
     &               iyout,imout,idout,ihout,isec,
     &               wd,ws,tk,qq,xpmb,swrad,xprc,rh,
     &               lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))

c 181        format(i4,3i2.2,3f7.1)
         
c --- (CEC - 090304 - get Time stamp for last date/time extracted)
            call TIMESTAMP(iyr,jday,ihour,idatel)

c ---    Update period counter (may not be hours)
            ihr=ihr+1
            nsec=isecstep
            call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
            call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
            call TIMESTAMP(iyrx,jdayx,ihourx,ndatenew)
c            call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)
c            if(ihr.lt.nhrext) goto 2000
            if(ihr.lt.nbsecext) then          
               goto 2000
            endif
c
        else
         goto 2000
        endif

 3000  if(ihr.eq.0) then
       write(ilog,*)'Error: No data were extracted:'
       write(ilog,*)'checked data file and control input file'
       write(ilog,*)'station requested ',idloc(iloc)
       print *,'Error: No data were extracted:'
       print *,'checked data file and control input file'
       print *,'station requested ',idloc(iloc)
       stop
       elseif(ihr.lt.nbsecext) then
       write(ilog,*)'ERROR: Not all periods were extracted'
      write(ilog,*)'Header Ending date do not match last record of data'
       write(ilog,*)'Periods Extracted: ',ihr
       write(ilog,*)'Periods Requested: ',nbsecext
       write(ilog,*)'Last time extracted (LST): ',idatel
       write(ilog,*)'Last time needed (LST): ',iedathrc
       print *,'ERROR: Not all periods were extracted'
       print *,'Header Ending date do not match last record of data'
       print *,'Periods Extracted: ',ihr
       print *,'Periods Requested: ',nbsecext
       print *,'Last time extracted (LST): ',idatel
       print *,'Last time needed (LST): ',iedathrc
       else
        if(mdata.eq.'AMMNETW') then
        write(ilog,'(a)')'AMMNETW.DAT data extraction completed'
        elseif(mdata.eq.'MONITORW') then
        write(ilog,'(a)')'MONITORW.DAT data extraction completed'
        endif
       endif
 3001    continue
c
         close(in)
c
 6000    continue

      return
      end

c ---------------------------------------------------------------------
      subroutine ammnetcext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c --- C. Escoffier-Czaja           
c
c --- PURPOSE: Extract pollutant time series from AMMNETC.DAT
c
c --- UPDATES:
c
c --- Version 1.77, level 100611 to Version 1.9.0, Level 121203
c         - Add call to MIDNITE for selected time convention
c         - Add new variables for end-time output
c         - Restrict 24h to seconds=0000
c
c --- Version 1.75, level 100107 to Version 1.77, level 100611 (CEC)
c         - Add possibility to deal with missing data / date in the
c           middle of the file
c --- Version 1.72, Level 091015 to Version 1.75, level 100107 (CEC)
c         - Change the validity check for AMMNET concentrations:
c           now use VGET320 instead of VALD_PAR.
c           New: VGET320
c --- Version 1.66, level 090731 to Version 1.72, level 091015 (CEC)
c         - Add the possibility to read the date of AMMNET format as
c           m/d/yyyy h:mm
c --- Version 1.63, level 090415 to Version 1.66, level 090731 (CEC)
c         - Add the possibility to read the date AMMNET format as
c           mm/dd/yyyy hh:mm or m/dd/yyyy h:mm or any combination
c         - Remove IWMO, IDPK, ANEM declaration (not used)
c         - Add variable MONITOR which can be used instead of AMMNET
c --- Version 1.6, Level: 090318 to Version 1.63, level 090415 (DGS)
c         - Fix typo IYR to IYRX in TIMESTAMP call 
c           (current year did not update at New Years, halting run)
c         - Replace old calls to Y2K() with YR4()
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c         - Control information from /CONTROL/
c         - Filename changed from 80 to 132
c         - Place output TSF header calls into HDTSFOUT
c         - Change to Julian Date-hour integer YYYYJJJHH
c         - Wind data are optional (NMETINP=0)
c ---------------------------------------------------------------------
      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'metinp.ser'
      include 'aqinput.ser'

      parameter (iecho=0)
c      parameter (mxstn=300,iecho=0)
c      dimension iwmo(mxstn),idpk(mxstn)
      character*132 fl,fl1

      character*1 vld

c      real anem(mxstn)

c --- Local variables
      integer imcommas(0:99),ipcommas(0:99)
      logical lerror
      integer ioffset
      logical lvalid
      character*1 cm,dq
      character*16 datm
      character*320 char320m,char320p,blnk320

      data cm/','/
      data dq/'"'/
      data lerror/.FALSE./

c --- Data column offset for interpreting validity code
c --- Validity codes are placed into a string using 1 character per
c --- data column (1st character in string is for first data), but
c --- no information in file identifies the first column of data.
c --- Example file places 1st data in column 4.
      data ioffset/3/
c
      do i=1,320
         blnk320(i:i)=' '
      enddo

c --- Write header for TSF output file
      do iloc=1,ntsfout
         io=iout+iloc
         call HDTSFOUT(io,iloc)
      enddo

c read header information of processed AMMNETC.dat data
      ihr=0
      idate=0
      nfile=2
c      write(*,*)'nfile',nfile
      do 6000 ifile=1,nfile-1

c ---    Open meteorological data file (when requested)
         if(nmetinp.GT.0) then
           fl=fmet(ifile)
           nt=LEN_TRIM(fl) 
           print *,'Processing File:',ifile,' ',fl(1:nt)
           write(ilog,1008)ifile,fl(1:nt)
 1008      format(i3,2x,a)
           open(in,file=fl,status='old',action='read')
         endif
c
c ---    Open pollutant data file
         fl1=faq(ifile)
         nt=LEN_TRIM(fl1) 
         print *,'Processing File:',ifile,' ',fl1(1:nt)
         write(ilog,1009)ifile,fl1(1:nt)
 1009    format(i3,2x,a)
         open(in2,file=fl1,status='old',action='read')

      do 3002 iloc=1,ntsfout
c ---    Read header information
         rewind(in2)
         read(in2,*) char320p
         if(nmetinp.GT.0) then
            rewind(in)
            read(in,*) char320m
         endif
         ihr=0
         idate=0
         io=iout+iloc
c ---    ndateext = begining time of first time/date =
c ---    ndatenew - begining seconds = nsecext=nsecnew
         ndatenew = ndateext
         isecx = nsecext
c         call getdate(ndatenew,iyrx,imonx,idayx,ihourx)
c         call julday(ilog,iyrx,imonx,idayx,jdayx)
         call DEDAT(ndatenew,iyrx,jdayx,ihourx)
         call GRDAY(ilog,iyrx,jdayx,imonx,idayx)

2000     continue 
               wd=9999.
               ws=9999.
               wc=9999.
c
c ---    Step through meteorological fields (when requested)
c ---------------------------------------------------------
c ---    Skip if no met extraction
         if(nmetinp.EQ.0) goto 3000

c ---    Read line
20       char320m=blnk320
         read(in,'(a320)',end=3000) char320m

c ---    Test line for at least 1 comma to screen out empty lines
         itest=INDEX(char320m,cm)
         if(itest.EQ.0) goto 20

c ---    Remove this shift since validity flags are case-sensitive
cc ---    Create upper-case version of line
c         klast=LEN_TRIM(char320m)
c         call CASE320('UPPER',char320m,klast)

c ---    Drop any double quotes from line
         call OMIT320(dq,char320m)

c ---    Identify column ranges
         kmlast=LEN_TRIM(char320m)
         call COLUMN320(char320m,kmlast,cm,nmvars,nmcommas,imcommas)

c ---    Date-Time
         datm='mm/dd/yyyy hh:mm'
         call IRANGE(imcoldatm,imcommas,nmcommas,i1,i2)
         datm=char320m(i1:i2)

c --- (CEC - 091015 - modified the extraction of date/time)
         call readate_mon(i1,i2,datm,imo1,iday1,iyr1,ihour1,irmn1)
         isec1=irmn1*60

c ---    Skip blank record (based on date)
         if(iyr1.EQ.0 .OR. imo1.EQ.0 .OR. iday1.EQ.0) goto 20
         call JULDAY(ilog,iyr1,imo1,iday1,jday1)

c ---    Averaging Time
         call IRANGE(imcolavg,imcommas,nmcommas,i1,i2)
         read(char320m(i1:i2),'(i)') iavg1
         iavg1=iavg1*60

c ---    Station Code
         call IRANGE(imcolstn,imcommas,nmcommas,i1,i2)
         read(char320m(i1:i2),'(i)') idmeta1
c
c ---    Step through concentration fields - first - time stamp
c ----------------------------------------
c ---    Read line
3000     char320p=blnk320
         read(in2,'(a320)',end=3001) char320p

c ---    Test line for at least 1 comma to screen out empty lines
         itest=INDEX(char320p,cm)
         if(itest.EQ.0) goto 3000

c ---    Remove this shift since validity flags are case-sensitive
cc ---    Create upper-case version of line
c         klast=LEN_TRIM(char320p)
c         call CASE320('UPPER',char320p,klast)

c ---    Drop any double quotes from line
         call OMIT320(dq,char320p)

c ---    Identify column ranges
         kplast=LEN_TRIM(char320p)
         call COLUMN320(char320p,kplast,cm,npvars,npcommas,ipcommas)
c
c ---    Date-Time
         datm='mm/dd/yyyy hh:mm'
         call IRANGE(ipcoldatm,ipcommas,npcommas,i1,i2)
         datm=char320p(i1:i2)

c --- (CEC - 091015 - modified the extraction of date/time)
         call readate_mon(i1,i2,datm,imo,iday,iyr,ihour,irmn)
         isec=irmn*60

c ---    Skip blank record (based on date)
         if(iyr.EQ.0 .OR. imo.EQ.0 .OR. iday.EQ.0) goto 3000
         call JULDAY(ilog,iyr,imo,iday,jday)

c ---    Averaging Time
         call IRANGE(ipcolavg,ipcommas,npcommas,i1,i2)
         read(char320p(i1:i2),'(i)') iavg
         iavg=iavg*60

c ---    Station Code
         call IRANGE(ipcolstn,ipcommas,npcommas,i1,i2)
         read(char320p(i1:i2),'(i)') idmeta2
         if(idmeta2.eq.idaq(iloc)) then
c
c ---       Match AQ with MET when present
            if(nmetinp.GT.0) then
               if(imo.ne.imo1.or.iday.ne.iday1.or.iyr.ne.iyr1.or.
     &            ihour.ne.ihour1.or.isec.ne.isec1) then
                  write(ilog,*)'ERROR: Not same periods in '
                  write(ilog,*)'meteorological file :',
     &                          imo1,iday1,iyr1,ihour1,isec1
                  write(ilog,*)'and in pollutant file: ',
     &                          imo,iday,iyr,ihour,isec
                  print *,'ERROR: Not same periods in '
                  print *,'meteorological file :',
     &                     imo1,iday1,iyr1,ihour1,isec1
                  print *,'and in pollutant file: ',
     &                     imo,iday,iyr,ihour,isec
                  stop
               endif
               if(idmeta2.ne.idmeta1) then
                  write(ilog,*)'ERROR: Not same station in '
                  write(ilog,*)'meteorological file :',idmeta1
                  write(ilog,*)'and in pollutant file: ',idmeta2
                  print *,'ERROR: Not same station in '
                  print *,'meteorological file :',idmeta1
                  print *,'and in pollutant file: ',idmeta2
                  stop
               endif
            endif
c            
c ---       Create time at beginning of current hour
c --- (CEC - 081106 - Create time at begining of current time step - 60s time step = isecstep
            nsec=-isecstep
            iyrb=iyr
            jdayb=jday
            ihourb=ihour
            isecb=isec
            call INCRS(ilog,iyrb,jdayb,ihourb,isecb,nsec)

            call YR4(ilog,iyrb,ierrb)
            call YR4(ilog,iyr,ierr)
            if(ierr.NE.0 .OR.
     &        ierrb.NE.0) stop 'Halted in AMMNETCEXT - Y2K'

c ---       Increment hour if second = 3600
            nhrinc=1
            if(isec.EQ.3600) then
               isec=0
               call INCR(ilog,iyr,jday,ihour,nhrinc)
            endif
            if(isecb.EQ.3600) then
               isecb=0
               call INCR(ilog,iyrb,jdayb,ihourb,nhrinc)
            endif

c ---       Get month/day
            call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
            call GRDAY(ilog,iyr,jday,imon,iday)

c ---       Create timestamp with time at beginning
            call TIMESTAMP(iyrb,jdayb,ihourb,idate)

c ---       Compute difference in seconds between two dates
2002        call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)

c --- V1.9.0, Level 121203
c ---        Swap date and end-time into variables for output
             iyout=iyr
             imout=imon
             idout=iday
             jdout=jday
             ihout=ihour
c ---        Apply Midnight Convention to end-time
             if(imidnite.EQ.1 .AND. ihout.EQ.24) then
                ihout=0
                call MIDNITE(ilog,'TO 00h',iyr,imon,iday,jday,
     &                                     iyout,imout,idout,jdout)
             elseif(imidnite.EQ.2 .AND. ihout.EQ.0
     &                            .AND. isec.EQ.0) then
                ihout=24
                call MIDNITE(ilog,'TO 24h',iyr,imon,iday,jday,
     &                                     iyout,imout,idout,jdout)
             endif

            if(ndelsec.gt.0) then
               goto 2000
            elseif(ndelsec.lt.0.and.ihr.eq.0) then
c --- (CEC - 090304 - make the run stops if begining date requested by user is earlier
c                     than data availability)
          if(mdata.eq.'AMMNETC') then
          write(ilog,*)'ERROR- beginning date/time requested is earlier'
             write(ilog,*)'than data in AMMNET file'
	     write(ilog,*)'date requested = ',ndatenew,isecx
             write(ilog,*)'beginning date in file = ',idate,isecb
             write(*,*)'ERROR- beginning date/time requested is earlier'
             write(*,*)'than data in AMMNET file'
	     write(*,*)'date requested = ',ndatenew,isecx
             write(*,*)'beginning date in file = ',idate,isecb
          elseif(mdata.eq.'MONITORC') then
          write(ilog,*)'ERROR- beginning date/time requested is earlier'
             write(ilog,*)'than data in MONITOR file'
	     write(ilog,*)'date requested = ',ndatenew,isecx
             write(ilog,*)'beginning date in file = ',idate,isecb
             write(*,*)'ERROR- beginning date/time requested is earlier'
             write(*,*)'than data in MONITOR file'
	     write(*,*)'date requested = ',ndatenew,isecx
             write(*,*)'beginning date in file = ',idate,isecb
          endif
             stop
             elseif(ndelsec.lt.0.and.ihr.ne.0) then
c --- missing date/data in the middle of the file
c               wd=9999.
c               ws=9999.
c               wc=9999.
c
               nsec=isecstep
               iyrxe=iyrx
               jdayxe=jdayx
               ihourxe=ihourx
               isecxe=isecx
              call INCRS(ilog,iyrxe,jdayxe,ihourxe,isecxe,nsec)
              call GRDAY(ilog,iyrxe,jdayxe,imonxe,idayxe)

c --- V1.9.0, Level 121203
c ---        Swap date and x-time into variables for output
             iyoutx=iyrxe
             imoutx=imonxe
             idoutx=idayxe
             jdoutx=jdayxe
             ihoutx=ihourxe
c ---        Apply Midnight Convention to end-time
             if(imidnite.EQ.1 .AND. ihoutx.EQ.24) then
                ihoutx=0
                call MIDNITE(ilog,'TO 00h',iyrxe,imonxe,idayxe,jdayxe,
     &                                    iyoutx,imoutx,idoutx,jdoutx)
             elseif(imidnite.EQ.2 .AND. ihoutx.EQ.0
     &                            .AND. isecxe.EQ.0) then
                ihoutx=24
                call MIDNITE(ilog,'TO 24h',iyrxe,imonxe,idayxe,jdayxe,
     &                                    iyoutx,imoutx,idoutx,jdoutx)
             endif
c        
            istn=idloc(iloc)
            if(lwind(iloc)) then

c --- V1.9.0, Level 121203
               write(io,1010)iyrx,imonx,idayx,ihourx,isecx,
     &                       iyoutx,imoutx,idoutx,ihoutx,isecxe,
     &                       wd,ws,wc
            else
               write(io,1011)iyrx,imonx,idayx,ihourx,isecx,
     &                       iyoutx,imoutx,idoutx,ihoutx,isecxe,
     &                       wc

            endif 
 1010          format(2(i5,3i3,1x,i4.4),2f12.2,E12.5E2)
 1011          format(2(i5,3i3,1x,i4.4),E12.5E2)
c
            call TIMESTAMP(iyrx,jdayx,ihourx,idatel)

c ---    Update period counter (may not be hours)
            ihr=ihr+1
            nsec=isecstep
            call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
            call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
            call TIMESTAMP(iyrx,jdayx,ihourx,ndatenew)
            if(ihr.lt.nbsecext) then          
               goto 2002
            endif
           endif
c
c ---       Step through meteorological fields - second - parameters
c --------------------------------------------
            if(nmetinp.GT.0) then
c ---          Wind Speed
               call IRANGE(imcolwspd,imcommas,nmcommas,i1,i2)
               call RGET320(char320m,i1,i2,wpspd)
c ---          Wind Direction
               call IRANGE(imcolwdir,imcommas,nmcommas,i1,i2)
               call RGET320(char320m,i1,i2,wpdir)

c ---          read validity parameter 
c ---          Validity Parameter
               if(imcolvld.ne.0) then
                  call IRANGE(imcolvld,imcommas,nmcommas,i1,i2)
                  if(imcolwspd.ne.0) then
                     i3=imcolwspd-3
                     ic=i1+i3-1
                     read(char320m(ic:ic),'(a1)')vld
                     call VALD_PAR(vld,wpspd,ws)
                  endif
                  if(imcolwdir.ne.0) then
                     i3=imcolwdir-3
                     ic=i1+i3-1
                     read(char320m(ic:ic),'(a1)')vld
                     call VALD_PAR(vld,wpdir,wd)
                  else
                     wd=wpdir
                  endif
               else
                  wd=wpdir
                  ws=wpspd
               endif
            endif
c
c ---       Step through concentration fields - second - parameters
c -------------------------------------------
c ---       Concentration
            call IRANGE(ipcolconc,ipcommas,npcommas,i1,i2)
c ---    Trap void
         if(i2.LT.i1) then
            rconc=9999.
         else
            call RGET320(char320p,i1,i2,rconc)
         endif
            if(rconc.LT.9998..and.rconc.ge.0.00) then
               rconc=rscale*rconc
            else
               rconc=9999.
            endif
c
c ---    Validity of concentration
         if(ipcolvld.GT.0) then
            call IRANGE(ipcolvld,ipcommas,npcommas,i1,i2)
c ---       Exclude void or short validity string
            i2exp=i1+ipcolconc-1
c            if(i2.GE.i2exp) then
               call VGET320(char320p,i1,i2,ipcolconc,ioffset,lvalid)
               if(.NOT.LVALID) rconc=9999.
               wc=rconc
c            else
c            wc=9999.
c            endif
         else
           wc=rconc
         endif
c
c ---       Output
            istn=idloc(iloc)
            if(lwind(iloc)) then

c --- V1.9.0, Level 121203
               write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                       iyout,imout,idout,ihout,isec,
     &                       wd,ws,wc
            else
               write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                       iyout,imout,idout,ihout,isec,
     &                       wc
            endif

c --- (CEC - 090304 - get Time stamp for last date/time extracted)
            call TIMESTAMP(iyr,jday,ihour,idatel)

c ---       Update period counter (may not be hours)
            ihr=ihr+1
            nsec=isecstep
            call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
            call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
            call TIMESTAMP(iyrx,jdayx,ihourx,ndatenew)
            if(ihr.lt.nbsecext) goto 2000

         else
            goto 2000
         endif

 3001    if(ihr.eq.0) then
         write(ilog,*)'Error: No data were extracted:'
         write(ilog,*)'checked data file and control input file'
         write(ilog,*)'station requested ',idloc(iloc)
         print *,'Error: No data were extracted:'
         print *,'checked data file and control input file'
         print *,'station requested ',idloc(iloc)
         stop
         elseif(ihr.lt.nbsecext) then
         write(ilog,*)'Error: Not all periods were extracted'
      write(ilog,*)'Header Ending date do not match last record of data'
         write(ilog,*)'Periods Extracted: ',ihr
         write(ilog,*)'Periods Requested: ',nbsecext
         write(ilog,*)'Last time extracted (LST): ',idatel,isec
         write(ilog,*)'Last time needed (LST): ',iedathrc,iesecc
         print *,'Error: Not all periods were extracted'
         print *,'Header Ending date do not match last record of data'
         print *,'Periods Extracted: ',ihr
         print *,'Periods Requested: ',nbsecext
         print *,'Last time extracted (LST): ',idatel,isec
         print *,'Last time needed (LST): ',iedathrc,iesecc
         else
            if(mdata.eq.'AMMNETC') then
            write(ilog,'(a)')'AMMNETC.DAT data extraction completed'
            elseif(mdata.eq.'MONITORC') then
            write(ilog,'(a)')'MONITORC.DAT data extraction completed'
            endif
         endif
 3002    continue

         if(nmetinp.GT.0) close(in)
         close(in2)

 6000    continue

      return
      end

c ---------------------------------------------------------------------
      subroutine postext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- C. Escoffier-Czaja           
c
c --- PURPOSE: Extract pollutant time series from TSERIES.DAT output
c              of CALPOST
c
c --- UPDATES:
c --- Version 1.63, level 090415 to Version 1.66, level 090731 (DGS)
c         - Remove IWMO, IDPK, ANEM declaration (not used)
c --- Version 1.62, level 090411 to Version 1.63, level 090415 (DGS)
c         - Fix typo IYR to IYRX in TIMESTAMP call 
c           (current year did not update at New Years, halting run)
c         - Replace old calls to Y2K() with YR4()
c --- Version 1.6, Level: 090318 to Version 1.62, Level: 090411 (CEC)
c         - All header lines in description will be written instead
c           of the two first lines
c --- v1.5(090203) to v1.6(090318) (DGS)
c        - Control variables from /CONTROL/
c        - Place output TSF header calls into HDTSFOUT
c        - Change to Julian Date-hour integer YYYYJJJHH
c
c ---------------------------------------------------------------------
      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'metinp.ser'
      include 'aqinput.ser'

      parameter (iecho=0)
c      parameter (mxstn=300,iecho=0)
c      dimension iwmo(mxstn),idpk(mxstn)
      character*132 fl,fl1
      character*10 astart
      character*8 pmap8
      character*16 tsernam,tserver
      character*64 tsermod
      character*320 hdr(50)

c      real anem(mxstn)

c --- Local variables
      character*320 char320m,char320p,blnk320

      do i=1,320
         blnk320(i:i)=' '
      enddo
      do i=1,10
         astart(i:i)=' '
      enddo

c --- Current code set up for 1 MET input file and 1 AQ input file
      if(nmetinp.NE.1 .OR. naqinp.NE.1) then
         write(ilog,*)'POSTEXT:  Invalid number of input files'
         write(ilog,*)'Expected 1 MET and 1 AQ input file'
         write(ilog,*)'Found NMETINP, NAQINP = ',nmetinp,naqinp
         stop 'Halted in POSTEXT -- see list file'
      endif

c --- Write header for TSF output file
      do iloc=1,ntsfout
         io=iout+iloc
         call HDTSFOUT(io,iloc)
      enddo

c --- Read header information of processed TIMESERIES.TSF data
      ihr=0
      idate=0
      nfile=2
      do 6000 ifile=1,nfile-1

c --- open meteorological data file
         fl=fmet(ifile)
c         nt=index(fl,' ')-1 
         nt=LEN_TRIM(fl)
         print *,'Processing File:',ifile,' ',fl(1:nt)
         write(ilog,1008)ifile,fl(1:nt)
 1008    format(i3,2x,a)
         open(in,file=fl,status='old',action='read')
c
c --- open pollutant data file
         fl1=faq(ifile)
c         nt=index(fl1,' ')-1
         nt=LEN_TRIM(fl1)
         print *,'Processing File:',ifile,' ',fl1(1:nt)
         write(ilog,1009)ifile,fl1(1:nt)
 1009    format(i3,2x,a)
         open(in2,file=fl1,status='old',action='read')

      do 3002 iloc=1,ntsfout
      rewind(in)
      rewind(in2)
c ---    Test first header record to determine dataset version
         read(in,'(2a16,a64)') tsernam,tserver,tsermod
c ---       Read comment records
            read(in,*) ncomm
            do n=1,ncomm
               read(in,'(a80)') comment
            enddo

c ---       Set a default map projection to NONE
            pmap8='NONE    '

c ---       Read header section before data description
            if(tserver.EQ.'1.0             ') then
               read(in,*) nvars
            elseif(tserver.NE.'1.3             ') then
               read(in,'(a320)') char320m
               read(in,*) nvars
            elseif(tserver.EQ.'1.3             ') then
               read(in,*) ntitles
               if(ntitles.LT.2) then
                  write(ilog,*)'Wrong number of title lines in file'
                  write(ilog,*)'Found    ',ntitles
                  write(ilog,*)'Needed 2'
                  write(*,*)'Wrong number of title lines in file'
                  write(*,*)'Found    ',ntitles
                  write(*,*)'Needed 2'
                  stop
               endif
c ---          Read header lines in and store first 2 
               read(in,'(a320)') char320m
               read(in,'(a320)') char320m
               do k=3,ntitles
                  read(in,'(a320)') char320m
               enddo
               read(in,*) pmap8
               if(pmap8.EQ.'NONE    ') then
                  nskip=0
               elseif(pmap8.EQ.'LL      ') then
                  nskip=2
               elseif(pmap8.EQ.'UTM     ') then
                  nskip=3
               else
                  nskip=4
               endif
               do n=1,nskip
                  read(in,*)
               enddo
               read(in,'(a320)') char320m
               read(in,'(a320)') char320m
               read(in,'(a320)') char320m
               read(in,*) nvars
            endif

        do i=1,nvars
          read(in,'(a320)') char320m
          if(char320m(1:6).eq.'WDIR  ')indwd=i
          if(char320m(1:6).eq.'WSPEED')indws=i
        enddo

c ---   Final section of datasets before v1.3
c ---   Expect 2 fixed header records for title information
         if(tserver.NE.'1.3             ') then
            read(in,*) ntitles
            if(ntitles.LT.2) then
               write(ilog,*)'Wrong number of title lines in file'
               write(ilog,*)'Found    ',ntitles
               write(ilog,*)'Needed 2'
               write(*,*)'Wrong number of title lines in file'
               write(*,*)'Found    ',ntitles
               write(*,*)'Needed 2'
               stop
            endif
c ---          (CEC - 090411 - Store all lines from the description lines
c               read(in,'(a)')hdr1
c               read(in,'(a)')hdr2
c               do k=3,ntitles
                do k=1,ntitles
c                  read(in,'(a)')hdr3
                   read(in,'(a)')hdr(k)
               enddo
         endif
c
c --- read header information for concentration data file
      isbg=1
      do i=1,11
      read(in2,'(a320)') char320p
      enddo
      read(in2,'(a320)') char320p
      read(char320p(17:26),'(10a)')astart
1050  isbg=1
      if(astart.eq.'START time') isbg=2
      read(in2,'(a320)',end=3001) char320p
c
      ihr=0
      idate=0
      io=iout+iloc
c --- ndateext = begining time of first time/date = ndatenew - begining seconds = nsecext=nsecnew
      ndatenew = ndateext
      isecx = nsecext
c      call getdate(ndatenew,iyrx,imonx,idayx,ihourx)
c      call julday(ilog,iyrx,imonx,idayx,jdayx)
      call DEDAT(ndatenew,iyrx,jdayx,ihourx)
      call GRDAY(ilog,iyrx,jdayx,imonx,idayx)

2000     continue 
c
c ---    Step through meteorological fields
c -----------------------------------------
c ---    Read line
20       char320m=blnk320
         read(in,'(a320)',end=3001) char320m
c
         isecb=0
         isec=0
c ---    Date-Time - read begining time
         read(char320m(2:5),'(i4)') iyrb
         read(char320m(7:8),'(i2)') imob
         read(char320m(10:11),'(i2)') idayb
         read(char320m(13:14),'(i2)') ihourb
         read(char320m(16:19),'(i4)') isecb
         read(char320m(21:24),'(i4)') iyr
         read(char320m(26:27),'(i2)') imo
         read(char320m(29:30),'(i2)') iday
         read(char320m(32:33),'(i2)') ihour
         read(char320m(35:38),'(i4)') isec
c
c ---    Skip blank record (based on date)
         if(iyr.EQ.0 .OR. imo.EQ.0 .OR. iday.EQ.0) goto 20
         call JULDAY(ilog,iyr,imo,iday,jday)
         call JULDAY(ilog,iyrb,imob,idayb,jdayb)

c ---    Step through concentration fields - first - time stamp
c ---------------------------------------
c ---    Read line
3000     char320p=blnk320
         read(in2,'(a320)',end=3001) char320p
c
c ---    Date-Time
         read(char320p(2:5),'(i4)')  iyr1
         read(char320p(7:9),'(i3)')  jday1
         read(char320p(11:12),'(i2)') ihour1
         read(char320p(13:14),'(i2)') irmn1
         isec1=irmn1*60
c
c --- if time series date is not begining of period but ending of period
c --- need to put it as begining of current period
           if(isbg.eq.1) then
            nsec=-isecstep
c            nhrinc=-1
            iyrb1=iyr1
            jdayb1=jday1
            ihourb1=ihour1
            isecb1=isec1
c            call INCR(ilog,iyrb1,jdayb1,ihourb1,nhrinc)
            call INCRS(ilog,iyrb1,jdayb1,ihourb1,isecb1,nsec)
            iyr1=iyrb1
            jday1=jdayb1
            ihour1=ihourb1
            isec1=isecb1
           endif
c
c ---    Skip blank record (based on date)
         if(iyr1.EQ.0 .OR. jday1.EQ.0) goto 3000
         call GRDAY(ilog,iyr1,jday1,imo1,iday1)
c
          if(imob.ne.imo1.or.idayb.ne.iday1.or.iyrb.ne.iyr1
     &  .or.ihourb.ne.ihour1.or.isecb.ne.isec1) then
         write(ilog,*)'Error: Not same periods in '
         write(ilog,*)'meteorological file :',imob,idayb,iyrb,ihourb,
     &   isecb
         write(ilog,*)'and in pollutant file: ',imo1,iday1,iyr1,ihour1,
     &   isec1
         print *,'Error: Not same periods in '
         print *,'meteorological file :',imob,idayb,iyrb,ihourb,isecb
         print *,'and in pollutant file: ',imo1,iday1,iyr1,ihour1,
     &   isec1
           stop
           endif
c             if(idmeta2.ne.idmeta) then
c         write(ilog,*)'Error: Not same station in '
c         write(ilog,*)'meteorological file :',idmeta
c         write(ilog,*)'and in pollutant file: ',idmeta2
c         print *,'Error: Not same station in '
c         print *,'meteorological file :',idmeta
c         print *,'and in pollutant file: ',idmeta2
c           stop
c           endif
c            
c ---       Create time at beginning of current hour
c --- (CEC - 081106 - Create time at begining of current time step - 60s time step = isecstep
c            nsec=-isecstep
c            nhrinc=-1
c            iyrb=iyr
c            jdayb=jday
c            ihourb=ihour
c            isecb=isec
c            call INCR(ilog,iyrb,jdayb,ihourb,nhrinc)
c            call INCRS(ilog,iyrb,jdayb,ihourb,isecb,nsec)
c         
             call YR4(ilog,iyrb,ierrb)
             call YR4(ilog,iyr,ierr)
             if(ierr.NE.0 .OR.
     &         ierrb.NE.0) stop 'Halted in POSTEXT - Y2K'

c ---    Increment hour if second = 3600
         nhrinc=1
         if(isec.EQ.3600) then
            isec=0
            call INCR(ilog,iyr,jday,ihour,nhrinc)
         endif
         if(isecb.EQ.3600) then
            isecb=0
            call INCR(ilog,iyrb,jdayb,ihourb,nhrinc)
         endif

c ---    Get month/day
         call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
         call GRDAY(ilog,iyr,jday,imon,iday)

c ---    Create timestamp with time at beginning
         call TIMESTAMP(iyrb,jdayb,ihourb,idate)

c ---    Compute difference in seconds between two dates
             call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)

 2002    if(ndelsec.gt.0) then
          goto 2000
         elseif(ndelsec.lt.0) then
c --- (CEC - 090304 - make the run stops if begining date requested by user is earlier
c                     than data availability)
          write(ilog,*)'ERROR- beginning date/time requested is earlier'
          write(ilog,*)'than data in CALPOST TIME SERIES file'
	  write(ilog,*)'date requested = ',ndatenew,isecx
          write(ilog,*)'beginning date in file = ',idate,isecb
          write(*,*)'ERROR- beginning date/time requested is earlier'
          write(*,*)'than data in CALPOST TIME SERIES file'
	  write(*,*)'date requested = ',ndatenew,isecx
          write(*,*)'beginning date in file = ',idate,isecb
          stop
         endif
c              wd=9999.
c              ws=9999.
c             wc=9999.
c              call DEDAT(ndatenew,iyrx,jdayx,ihourx)
c              call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
c ---       Create time at ending of current hour
c --- (080611 - Create time at ending of current period
c               nsec=isecstep
c              iyrex=iyrx
c              jdayex=jdayx
c              ihourex=ihourx
c              isecex=isecx
c              call INCRS(ilog,iyrex,jdayex,ihourex,isecex,nsec)
c              call GRDAY(ilog,iyrex,jdayex,imonex,idayex)
c              call Outputc(io,iyrx,imonx,idayx,ihourx,isecx,
c     &                  iyrex,imonex,idayex,ihourex,isecex,wd,ws,wc,
c     &                  lwind(iloc),lso2(iloc),lno(iloc),lno2(iloc),
c     &                  lnox(iloc),lco(iloc),lo3(iloc),lh2s(iloc),
c     &                  lpm10(iloc),lpm25(iloc))
c ---    Update period counter (may not be hours)
c              ihr=ihr+1
c --- increase ndatenew by 1 hour - to check if any missing hour in the AMMNET file
c --- increase ndatenew by 1 time step isecstep = 60s = 1mn - to check if any missing hours in the AMMNET file
c              nsec=isecstep
c              call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
c              call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
c              call TIMESTAMP(iyr,jdayx,ihourx,ndatenew)
c              call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)
c             if(ndelsec.lt.0.and.ihr.lt.nbsecext) goto 2002
c             endif
c
c ---    Step through meteorological fields - second - parameters
c ----------------------
c --- Wind Speed
      if(indws.eq.2)then
      read(char320m(50:58),'(f9.3)')ws
      elseif(indws.eq.1)then
      read(char320m(40:48),'(f9.3)')ws
      else
      write(ilog,*)'ERROR wind speed and direction are in column 1 or 2'
      write(*,*)'ERROR- wind speed and direction are in column 1 or 2'
      stop
      endif
c --- Wind Direction
      if(indwd.eq.1)then
      read(char320m(40:48),'(f9.3)')wd
      elseif(indwd.eq.2)then
      read(char320m(50:58),'(f9.3)')wd
      else
      write(ilog,*)'ERROR wind speed and direction are in column 1 or 2'
      write(*,*)'ERROR - wind speed and direction are in column 1 or 2'
      stop
      endif
c
c ---    Step through concentration fields - second - parameters
c ----------------
c ---    Concentration
         read(char320p(19:30),'(E12.6E2)')wc
         wc=rscale*wc
c
c        Output
            istn=idloc(iloc)
c            
            call Outputc(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyr,imon,iday,ihour,isec,wd,ws,wc,
     &                  lwind(iloc),lso2(iloc),lno(iloc),lno2(iloc),
     &                  lnox(iloc),lco(iloc),lo3(iloc),lh2s(iloc),
     &                  lpm10(iloc),lpm25(iloc))
c 181        format(i4,3i2.2,3f7.1)

c --- (CEC - 090304 - get Time stamp for last date/time extracted)
            call TIMESTAMP(iyr,jday,ihour,idatel)

c ---    Update period counter (may not be hours)
         ihr=ihr+1
            nsec=isecstep
            call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
            call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
            call TIMESTAMP(iyrx,jdayx,ihourx,ndatenew)
c            call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)
c            if(ihr.lt.nhrext) then
             if(ihr.lt.nbsecext) then
                 goto 2000
            endif
c
c        else
c          goto 2000
c        endif

 3001  if(ihr.eq.0) then
        write(ilog,*)'Error: No data were extracted:'
        write(ilog,*)'checked data file and control input file'
        write(ilog,*)'station requested ',xloc(iloc),yloc(iloc)
        print *,'Error: No data were extracted:'
        print *,'checked data file and control input file'
        print *,'station requested ',xloc(iloc),yloc(iloc)
        stop
       elseif(ihr.lt.nbsecext) then
        write(ilog,*)'Error: Not all periods were extracted'
      write(ilog,*)'Header Ending date do not match last record of data'
        write(ilog,*)'Periods Extracted: ',ihr
        write(ilog,*)'Periods Requested: ',nbsecext
        write(ilog,*)'Last time extracted (LST): ',idatel,isec
        write(ilog,*)'Last time needed (LST): ',iedathrc,iesecc
        print *,'Error: Not all periods were extracted'
        print *,'Header Ending date do not match last record of data'
        print *,'Periods Extracted: ',ihr
        print *,'Periods Requested: ',nbsecext
        print *,'Last time extracted (LST): ',idatel,isec
        print *,'Last time needed (LST): ',iedathrc,iesecc
       else
        write(ilog,'(a)')'TSERIES.DAT data extraction completed'
       endif
 3002    continue
c
         close(in)
         close(in2)
c
 6000    continue

      return
      end

c ---------------------------------------------------------------------
      subroutine mm4ext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100721        MM4EXT

      include 'params.ser'
      include 'metseries.ser'

      print *,'In mm4ext subroutine'

      return
      end


c ---------------------------------------------------------------------
      subroutine upext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c --- Francoise Robe
c
c --- PURPOSE: Extract wind and temperature time series from UP.DAT
c
c --- UPDATES:
c
c --- Version 1.66, level 090731 to Version 1.9.0, Level 121203
c         - Add call to MIDNITE for selected time convention
c         - Add new variables for end-time output
c         - Restrict 24h to seconds=0000
c
c --- Version 1.6, level 090318 to Version 1.66, level 090731 (DGS)
c        - Remove LSTNTSFOUT declaration (not used)
c --- v1.5(090203) to v1.6(090318) (DGS)
c        - Control information from /CONTROL/
c        - Place output TSF header calls into HDTSFOUT
c        - Change to Julian Date-hour integer YYYYJJJHH
c --- v1.45(080627) to v1.5(090203) (DGS)
c        - Fixed logic for exiting read-loop after last requested
c          time period is processed (extra read had been attemped)
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      parameter(iecho=0)

c --- Header variables
      logical lht,ltemp,lwd,lws

      character*4 cname,ctemp
      character*16 clat,clon

      character*4 xyunit
      character*8 datum, pmap, axtz
      character*12 daten
      character*16 dataset,dataver
      character*64 datamod

c --- UP.DAT variables
      real paa(mxnz),zlaa(mxnz),tzaa(mxnz),wsa(mxnz),wda(mxnz)

c --- Local variables (missing variable counters):
      integer nmist(mxloc), nmisw(mxloc)
      data xmissm/998.9/

c --- Write header for TSF output file(s)
      do iloc=1,ntsfout
         io=iout+iloc
         call HDTSFOUT(io,iloc)
      enddo

c --- Start processing file
      nt=LEN_TRIM(fmet(1))
      open(in,file=fmet(1),status='old',action='read')

      write(ilog,*)'Processing File: ',fmet(1)(1:nt)
      write(ilog,*)
      print *,'Processing File: ',fmet(1)(1:nt)
 
c --- Note: Time in UP.DAT is GMT, while it is LST in output time series
c --- Convert ndateext from LST to GMT
c      call getdate(ndateext,iyr,imon,iday,ihour)
c      call chgtim(iyr,imon,iday,ihour,izonec)
c      call timestamp(iyr,imon,iday,ihour,ndateext)
      call DEDAT(ndateext,iyr,jday,ihour)
      call INCR(ilog,iyr,jday,ihour,izonec)
      call TIMESTAMP(iyr,jday,ihour,ndateext)
      call GRDAY(ilog,iyr,jday,imon,iday)
      idate0=ndateext

c --- Note: irregular record frequency in UP.DAT so do not know
c --- a priori how many records there will be. The validity test
c --- will therefore be on beg/end dates rather than # of records read
c --- nhrext is the length of the period to be analyzed not the 
c --- number of records to be extracted.

c --- Compute end date:
      ieyr=iyr
      jeday=jday
      iehour=ihour
      call INCR(ilog,ieyr,jeday,iehour,nhrext)
      call TIMESTAMP(ieyr,jeday,iehour,nedate)
      call GRDAY(ilog,ieyr,jeday,iemon,ieday)
      idate1=nedate
     
c --- Read header and echo to list file
      write(ilog,*)'UP.DAT header information ' 
      read(in,'(2a16,a64)') dataset,dataver,datamod
      write(ilog,'(2a16,a64)') dataset,dataver,datamod

      if(dataset.EQ.'UP.DAT') then
         read(in,*) ncomment
         write(ilog,*) ncomment
         do i=1,ncomment
            read(in,'(a80)') comment1
         enddo
         read(in,'(a8)') pmap
         write(ilog,'(a8)') pmap
         if(pmap.EQ.'NONE    ') then
c ---       Original 2 header records follow + UTC time header line if version 2.1
            if (dataver.eq.'2.1'.or.dataver.eq.'2.2') then
c ---          additional header line with UTC time zone
               read(in,'(a8)')axtz
               write(ilog,'(a8)')axtz
               read(axtz(5:8),'(i4)')itz
               if(itz.ne.0)
     :         stop 'Time zone of subs. UP.DAT must be UTC+0000 STOP'

c ---          explicit beginning/ending times with seconds
               read(in,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,iejulun,
     &                  iehrun,iesecun,ptop,jdat,ifmt
               write(ilog,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,
     &             iejulun,iehrun,iesecun,ptop,jdat,ifmt
            else
               read(in,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
               write(ilog,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
            endif
            read(in,124)lht,ltemp,lwd,lws
            write(ilog,124)lht,ltemp,lwd,lws

         elseif(pmap.EQ.'LL      ') then
c ---       Header with location data
c            lstnloc=.TRUE.
            read(in,'(a8,a10)') datum,daten
            read(in,'(a4)') xyunit
            write(ilog,'(a8,a10)') datum,daten
            write(ilog,'(a4)') xyunit
  
            if (dataver.eq.'2.1'.or.dataver.eq.'2.2') then

c ---          additional header line with UTC time zone
               read(in,'(a8)')axtz
               write(ilog,'(a8)')axtz
               read(axtz(5:8),'(i4)')itz
               if(itz.ne.0)
     :         stop 'Time zone of subst. UP.DAT must be UTC+0000 STOP'

c ---          explicit beginning/ending times with seconds
               read(in,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,iejulun,
     &                  iehrun,iesecun,ptop,jdat,ifmt
               write(ilog,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,
     &                  iejulun,iehrun,iesecun,ptop,jdat,ifmt
            else
               read(in,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
               write(ilog,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
            endif

            read(in,124)lht,ltemp,lwd,lws
            read(in,*) idstn,cname,clat,clon,ielevm
            write(ilog,124)lht,ltemp,lwd,lws
            write(ilog,*) idstn,cname,clat,clon,ielevm
            write(ilog,*)
c ---       Remove leading blanks from CNAME
            do kk=1,4
               ctemp='    '
               if(cname(1:1).EQ.' ') then
                  ctemp(1:3)=cname(2:4)
                  cname=ctemp
               endif
            enddo
         else
            write(ilog,*)
            write(ilog,*) 'UPEXT:  Invalid projection found in UP.DAT'
            write(ilog,*) 'Projection found    = ',pmap
            write(ilog,*) 'Projection expected = NONE or LL'
            stop 'Halted in UPEXT'
         endif

      else
c ---    Incorrect file type
         write(ilog,12)dataset
12       format(//2x,'ERROR IN SUBR. UPEXT -- invalid file dataset'/
     1   5x,'DATASET = ',a16/
     2   5x,'EXPECTED UP.DAT')
         stop 'Halted in UPEXT'
      endif

122   format(1x,6i5,f5.0,2i5)
123   format(1x,8i5,f5.0,2i5)
124   format(1x,4(4x,l1))

c --- Convert hour-ending times to explicit times  
      if (dataver.eq.'2.1'.or.dataver.eq.'2.2') then
c ---    Check year format
         call YR4(ilog,ibyrun,ierrb)
         call YR4(ilog,ieyrun,ierre)
         if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in UPEXT - Y2K'

c ---    Convert seconds to hours
         if(ibsecun.GE.3600) then
            nhrinc=ibsecun/3600
            ibsecun=ibsecun-nhrinc*3600
            call INCR(ilog,ibyrun,ibjulun,ibhrun,nhrinc)
         endif
         if(iesecun.GE.3600) then
            nhrinc=iesecun/3600
            iesecun=iesecun-nhrinc*3600
            call INCR(ilog,ieyrun,iejulun,iehrun,nhrinc)
         endif
c ---    Convert hours to days
         if (ibhrun.ge.24) then
             nhinc=ibhrun-23
             ibhrun=23
             call INCR(ilog,ibyrun,ibjulun,ibhrun,nhinc)
          endif
          if (iehrun.ge.24) then
             nhinc=iehrun-23
             iehrun=23
             call INCR(ilog,ieyrun,iejulun,iehrun,nhinc)
          endif
 
      else
c ---    hour-ending times - convert to explicit times
c ---    Check year format
         call YR4(ilog,ibyru,ierrb)
         call YR4(ilog,ieyru,ierre)
         if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in UPEXT - Y2K'

c ---    Old format: records on the hour 
         ibsecun=0
         iesecun=0
c ---    Explicit ending time is the same as hour-ending ending time
         ieyrun=ieyru 
         iejulun=iejulu 
         iehrun=iehru 
c ---    Convert to explicit time 
         ibyrun=ibyru 
         ibjulun=ibjulu 
         ibhrun=ibhru 
         call INCR(ilog,ibyrun,ibjulun,ibhrun,-1)
      endif

c --- If data type or format type missing, set to default values
      if(jdat.eq.0)jdat=3
      if(ifmt.eq.0)ifmt=1

c --- Test time period
c --- Note: This is a basic test on dates without seconds.
c ---       Consistent with other subroutines but strict
c ---       test should include seconds with call to deltsec
      call GRDAY(ilog,ibyrun,ibjulun,ibmoun,ibdayun)
      call TIMESTAMP(ibyrun,ibjulun,ibhrun,ibdateun)

      if(ibdateun.gt.idate0) then
         write(ilog,*)' Error: Required date too early:'
         write(ilog,*)'        Required Date (GMT):           ',idate0
         write(ilog,*)'        Beginning Date in UP.DAT (GMT):',ibdateun
         print *,' Error: Required date too early:'
         print *,'        Required Date (GMT):           ',idate0
         print *,'        Beginning Date in UP.DAT (GMT):',ibdateun
         stop
      endif
 
      
c --- Read UP.DAT records

      write(ilog,*)
      write(ilog,*)'Reading UP.DAT records'
      write(ilog,*)


c --- Initialize missing variable counters
      do iloc=1,ntsfout
         nmisw(iloc)=0
         nmist(iloc)=0
      end do

2000  continue

      if(dataver.eq.'2.1'.or.dataver.eq.'2.2') then
c ---    explicit beg/ending times with seconds 

         read(in,3,end=2999)nosta,iyrba,imoba,idyba,ihrba,isecba,
     :                      iyrea,imoea,idyea,ihrea,isecea,nlevaa
3        format(9x,i8,2(4x,i4,i4,i3,i3,i5),8x,i5)

         call YR4(ilog,iyrba,ierr)
         if(ierr.NE.0) stop 'Halted in UPEXT - Y2K'
         call YR4(ilog,iyrea,ierr)
         if(ierr.NE.0) stop 'Halted in UPEXT - Y2K'

c ---    Condition beginning time
         call JULDAY(ilog,iyrba,imoba,idyba,ijulba)
         nsecadd=isecba
         isecba=0
         if(ihrba.GT.23) then
            nsecadd=nsecadd+(ihrba-23)*3600
            ihrba=23
         endif
         call INCRS(ilog,iyrba,ijulba,ihrba,isecba,nsecadd)
         call GRDAY(ilog,iyrba,ijulba,imoba,idyba)

c ---    Condition end time
         call JULDAY(ilog,iyrea,imoea,idyea,ijulea)
         nsecadd=isecea
         isecea=0
         if(ihrea.GT.23) then
            nsecadd=nsecadd+(ihrea-23)*3600
            ihrea=23
         endif
         call INCRS(ilog,iyrea,ijulea,ihrea,isecea,nsecadd)
         call GRDAY(ilog,iyrea,ijulea,imoea,idyea)

      else
c ---    single hour-ending times records
 
         read(in,33,end=2999)nosta,iyrea,imoea,idyea,ihrea,nlevaa
33       format(9x,i8,5x,4i2,35x,i5)
         call YR4(ilog,iyrea,ierr)
         if(ierr.NE.0) stop 'Halted in UPEXT - Y2K'
         call JULDAY(ilog,iyrea,imoea,idyea,ijulea)

c ---    Fill in beginning times and seconds
         iyrba=iyrea
         imoba=imoea
         idyba=idyea
         ijulba=ijulea
         ihrba=ihrea
         isecba=0
         isecea=0

      endif


c --- Timestamp:
      call TIMESTAMP(iyrea,ijulea,ihrea,idate)
      write(ilog,*)'Timestamp (GMT): ',idate

c --- exit if requested end date has been passed
      if(idate.gt.idate1) go to 3000

c --- check station id
      if(nosta.ne.idstnup)then
         write(ilog,79)idstnup,nosta,iyrea,imoea,idyea,ihrea
79       format(//1x,'ERROR IN SUBR. UPEXT -- upper air station IDs ',
     1   'do not match'//1x,'station ID requested: ',i8,2x,
     2   'station ID read from upper air data file: ',i8//1x,'yr: ',
     3   i4,2x,'month: ',i2,2x,'day: ',i2,2x,'hr: ',i2,' (GMT)')
         stop
      endif

c --- periods with no data are allowed only when skipping to find
c --- starting date
      if(nlevaa.lt.1 .and.idate.lt.idate0)then
         go to 2000
      else if(nlevaa.lt.1) then 
          write(ilog,81)iyrea,imoea,idyea,ihrea
81       format(//1x,'ERROR IN SUBR. UPEXT -- no upper air data ',
     1   //1x,'on (year,month,day) = (',
     2   i4,',',i2,',',i2,')',2x,'hour = ',i2,' (GMT)')
         stop
      endif
 
c --- check that no. levels does not exceed array dimension
      if(nlevaa.gt.mxnz)then
         write(ilog,86)iyrea,imoea,idyea,ihrea,nlevaa,mxnz
86       format(//1x,'ERROR IN SUBR. UPEXT -- too many levels for ',
     1   'array dimension'//1x,'on (year,month,day) = (',
     2    i4,',',i2,',',i2,')',2x,'hour = ',i2,
     3   ' GMT'//1x,'No. levels = ',i5,3x,'Current array dimension = ',
     4   i5)
         stop
      endif
c
c --- Read data records

      if(ifmt.eq.1)then
c ---    Original slash-delimited format
         read(in,4,end=2999)(paa(ii),zlaa(ii),tzaa(ii),wda(ii),wsa(ii),
     1                       ii=1,nlevaa)
4        format(4(3x,f6.1,1x,f5.0,1x,f5.1,1x,f3.0,1x,f3.0))
      else if(ifmt.eq.2)then
c ---    Comma-delimited data format
         read(in,*,end=2999)(paa(ii),zlaa(ii),tzaa(ii),wda(ii),wsa(ii),
     1                        ii=1,nlevaa)
      else
         write(ilog,*)'ERROR in SUBR. UPEXT - Invalid format type - ',
     1   'IFMT = ',ifmt
         stop
      endif
c

c --- keep reading until first requested record is reached
      if(idate.lt.idate0) go to 2000

c      write(6,*)'Processing (GMT):',idate
     
c --- Output in LST time
      iyrb=iyrba
      ijulb=ijulba
      ihrb=ihrba
      nsecb=isecba
      call INCR(ilog,iyrb,ijulb,ihrb,-izonec)
      call GRDAY(ilog,iyrb,ijulb,imonb,idayb)
      iyre=iyrea
      ijule=ijulea
      ihre=ihrea
      nsece=isecba
      call INCR(ilog,iyre,ijule,ihre,-izonec)
      call GRDAY(ilog,iyre,ijule,imone,idaye)

c --- V1.9.0, Level 121203
c --- Snapshot? (0=no, 1=yes)
      isnap=1
      if(iyrb.NE.iyre) isnap=0
      if(imonb.NE.imone) isnap=0
      if(idayb.NE.idaye) isnap=0
      if(ihrb.NE.ihre) isnap=0
      if(nsecb.NE.nsece) isnap=0
c --- Swap date and end-time into variables for output
      iyout=iyre
      imout=imone
      idout=idaye
      jdout=ijule
      ihout=ihre
c --- Apply Midnight Convention to end-time
      if(imidnite.EQ.1 .AND. ihout.EQ.24) then
        ihout=0
        call MIDNITE(ilog,'TO 00h',iyre,imone,idaye,ijule,
     &                             iyout,imout,idout,jdout)
      elseif(imidnite.EQ.2 .AND. ihout.EQ.0
     &                     .AND. nsece.EQ.0) then
        ihout=24
        call MIDNITE(ilog,'TO 24h',iyre,imone,idaye,ijule,
     &                             iyout,imout,idout,jdout)
      endif

c --- No humidity data in UP.DAT
      qqfin=0.
c

c --- Interpolate data at requested heights
c --- Vertical interpolation

      do iloc=1,ntsfout
         call interpup(zlaa,tzaa,wsa,wda,nlevaa,zwind(iloc),
     :                 ztmpk(iloc),wsfin,wdfin,tkfin)
      
c ---    Output
         io=iout+iloc

c --- V1.9.0, Level 121203
         if(isnap.EQ.0) then
           call Output(io,
     &            iyrb,imonb,idayb,ihrb,nsecb,
     &            iyout,imout,idout,ihout,nsece,
     &            wdfin,wsfin,tkfin,qqfin,
     &            lwind(iloc),ltmpk(iloc),lshum(iloc))
         else
c ---      Snapshot: use same times
           call Output(io,
     &            iyout,imout,idout,ihout,nsecb,
     &            iyout,imout,idout,ihout,nsece,
     &            wdfin,wsfin,tkfin,qqfin,
     &            lwind(iloc),ltmpk(iloc),lshum(iloc))
         endif


c ---    Keep count of missing data
         if (lwind(iloc).and.wdfin.ge.xmissm)nmisw(iloc)=nmisw(iloc)+1
         if (ltmpk(iloc).and.tkfin.ge.xmissm)nmist(iloc)=nmist(iloc)+1
 

      end do

      write(ilog,1010)iyrb,imonb,idayb,ihrb,nsecb,
     &                iyre,imone,idaye,ihre,nsece 
 
 1010 format(2(i5,3i3,1x,i4.4))


c --- Finished if last period requested has been processed
      if(idate.EQ.idate1) goto 3000

c --- Read next UP.DAT records
      goto 2000


2999  continue
      write(ilog,*)
      write(ilog,*)'Error: Not all periods were extracted'
      write(ilog,*)'Last Period Extracted (YYYYJJJHR-GMT): ',idate
      write(ilog,*)'Last Period Requested (YYYYJJJHR-GMT): ',idate1
      write(*,*)
      print *,'Error: Not all periods were extracted'
      print *,'Last Period Extracted (YYYYJJJHR-GMT): ',idate
      print *,'Last Period Requested (YYYYJJJHR-GMT): ',idate1
      goto 3001

3000  continue
      write(*,*)
      print *,'UP.DAT data extraction completed'

      write(ilog,*)
      Do iloc=1,ntsfout
         if (lwind(iloc)) write(ilog,*)nmisw(iloc),
     :    ' missing (ws,wd) values at height: ', zwind(iloc)
         if (ltmpk(iloc)) write(ilog,*)nmist(iloc),
     :    ' missing (Temp) values at height: ', ztmpk(iloc)
      end do 
 
      write(ilog,*)
      write(ilog,'(a)')'UP.DAT data extraction completed'

3001  continue

      return
      end

c ---------------------------------------------------------------------
      subroutine interpup(zlaa,tzaa,wsa,wda,nlev,zw,zt,
     :                    wsfin,wdfin,tkfin)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090203
c --- Francoise Robe           
c
c --- PURPOSE: Linearly interpolate UP.DAT winds and temperatures to
c              selected vertical levels
c
c --- UPDATES:
c --- v1.45(080627) to v1.5(090203) (DGS)
c        - Removed debug write for zsw,zw
c
c --- INPUT VARIABLES:
c     ZLAA (mxnz)   -  real    - UP.DAT level altitudes above MSL (m)
c     TZAA (MXNZ)   -  real    - UP.DAT temperatures (K)
c     WSA  (MXNZ)   -  real    - UP.DAT wind speed (m/s)
c     WDA  (MXNZ)   -  real    - UP.DAT wind direction (m/s)
c     NLEV          -  integer - Number of UP.DAT levels
c     ZW            -  real    - Altitude above ground (m) at which to 
c                                interpolate wind speed and wind dir
c     ZT            -  real    - Altitude above ground (m) at which to 
c                                interpolate temperature 
c
c --- OUTPUT VARIABLES
c     WDFIN         - REAL    - Interpolated wind direction at level
c                               ZW above ground 
c     WSFIN         - REAL    - Interpolated wind speed at level
c                               ZW above ground 
c     TKFIN         - REAL    - Interpolated temperature at level
c                               ZT above ground 
c
c --- INTERPUP called by: UPEXT 
c --- INTERPUP calls: UV2WSR,WS2UVR
c----------------------------------------------------------------------

      include 'params.ser'
      include 'metseries.ser'
      data xmissm/998.9/

c --- UP.DAT variables
      real zlaa(mxnz),tzaa(mxnz),wsa(mxnz),wda(mxnz)
c
c --- Ground elevation
      if (zlaa(1).lt.9998.9) then
         zground=zlaa(1)
      else
c        Return all missing values
         wsfin=9999.
         wdfin=9999.
         tkfin=9999.
         return
      endif

c --- Calculate levels zw above msl (since zlaa above MSL)
      if (zw.ge.0) then
         zsw=zw+zground
      else
c        winds not requested at this level, skip
         goto 200
      endif

c --- WIND SPEED AND WIND DIRECTION
c --- Find 2 nearest non-missing levels at which wind data exist
      n1=0
      n2=0

      do 20 k=1,nlev         

         if(zlaa(k).eq.zsw.and.
     :      wsa(k).lt.xmissm.and.wda(k).lt.xmissm)then
c ---       Requested height on UP.DAT level
c ---       No interpolation needed (unless missing data)           
            wsfin=wsa(k)
            wdfin=wda(k)
            goto 200
         endif

         if(zlaa(k).lt.9998.9.and.zlaa(k).lt.zsw)then  
c ---       Find nearest valid level below requested height
            if (wsa(k).lt.xmissm.and.wda(k).lt.xmissm) n1=k
         endif
         if(zlaa(k).lt.9998.9.and.zlaa(k).gt.zsw)then  
c ---       Find nearest valid level above requested height
            if (wsa(k).lt.xmissm.and.wda(k).lt.xmissm) then
               n2=k
               goto 22
            endif
         endif

20    continue

22    continue

c --- Make sure there are valid data to interpolate from
      if(n1.eq.0.or.n2.eq.0) then
         wsfin=9999.
         wdfin=9999.
         goto 200
      else 
         ws1=wsa(n1)
         ws2=wsa(n2)
         wd1=wda(n1)
         wd2=wda(n2)
         z1=zlaa(n1)
         z2=zlaa(n2)
      endif



c --- Transform ws,wd to u,v for interpolation
      call ws2uvr(wd1,ws1,u1,v1)
      call ws2uvr(wd2,ws2,u2,v2)

c --- interpolate U, V to requested height
      rat=(zsw-z1)/(z2-z1)
      u=u1+(u2-u1)*rat
      v=v1+(v2-v1)*rat
c

c --- Transform interpolated u,v to ws,wd
      call uv2wsr(u,v,wdfin,wsfin)
c --- (090818 - CEC - Add a check that if wind speed is 0.00 then wind dir will be 0.00 as well)
      if(wsfin.lt.1E-5) wdfin=0.0
     
200   continue
 
C --- TEMPERATURE

c --- Calculate levels zt above msl (since zlaa above MSL)
      if (zt.ge.0) then
         zst=zt+zground
      else
c        temperature not requested at this level, skip
         goto 300
      endif

c --- Find 2 nearest non-missing levels at which wind data exist
      n1=0
      n2=0

      do 30 k=1,nlev         

         if(zlaa(k).eq.zst.and.tzaa(k).lt.xmissm)then
c ---       Requested height on UP.DAT level 
c ---       no interpolation needed(unless missing data)
            tkfin=tzaa(k)
            goto 300
         endif

         if(zlaa(k).lt.9998.9.and.zlaa(k).lt.zst)then  
c ---       Find nearest valid level below requested height
            if (tzaa(k).lt.xmissm) n1=k
         endif
         if(zlaa(k).lt.9998.9.and.zlaa(k).gt.zst)then  
c ---       Find nearest valid level above requested height
            if (tzaa(k).lt.xmissm) then
               n2=k
               goto 32
            endif
         endif

30    continue

32    continue
c --- Make sure there are valid data to interpolate from
      if(n1.eq.0.or.n2.eq.0) then
         tkfin=9999.
         goto 300
      else 
         t1=tzaa(n1)
         t2=tzaa(n2)
         z1=zlaa(n1)
         z2=zlaa(n2)
      endif

c --- interpolate T to requested height
      rat=(zst-z1)/(z2-z1)
      tkfin=t1+(t2-t1)*rat
c
300   continue

      return
      end

c ---------------------------------------------------------------------
      subroutine AERMPFLEXT
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c --- C. Escoffier-Czaja          
c
c --- PURPOSE: Extract wind and temperature time series from AERMET.PFL
c
c --- UPDATES:
c
c --- Version 1.66, Level 090731 to Version 1.9.0, Level 121203
c         - Add call to MIDNITE for selected time convention
c         - Change data record input from fixed to free format to
c           adapt to changes in the file format
c         - Add new variables for end-time output
c         - Restrict 24h to seconds=0000
c
c --- Version 1.6, level 090318 to Version 1.66, level 090731 (DGS)
c         - Remove LHT, LTEMP, LWD, LWS, LSTNTSFOUT, CNAME, CTEMP,
c           DATUM, PMAP, AXTZ, DATEN, DATAMOD declaration (not used)
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      parameter(iecho=0)

c --- Header variables
c      logical lht,ltemp,lwd,lws
c      logical lstntsfout

c      character*4 cname,ctemp
      character*6 ctrans

c      character*8 datum, pmap, axtz
c      character*12 daten
c      character*64 datamod

c --- AERMET.PFL variables
      real zlaa(mxnz),tzaa(mxnz),wsa(mxnz),wda(mxnz)

c --- Local variables (missing variable counters):
      integer nmist(mxloc), nmisw(mxloc)
      data xmissm/999./

c --- Write header for TSF output file(s)
      do iloc=1,ntsfout
         io=iout+iloc
         call HDTSFOUT(io,iloc)
      enddo

c --- Start processing file
      nt=LEN_TRIM(fmet(1))
      open(in,file=fmet(1),status='old',action='read')

      write(ilog,*)'Processing File: ',fmet(1)(1:nt)
      write(ilog,*)
      print *,'Processing File: ',fmet(1)(1:nt)
 
c --- Note: Time in AERMET.PFL is LST
      call DEDAT(ndateext,iyr,jday,ihour)
      call GRDAY(ilog,iyr,jday,imon,iday)
      idate0=ndateext

c --- The validity test is done on beg/end dates rather than # of records read
c --- nhrext is the length of the period to be analyzed not the 
c --- number of records to be extracted.

c --- Compute end date:
      ieyr=iyr
      iejul=jday
      iehour=ihour
      call INCR(ilog,ieyr,iejul,iehour,nhrext)
      call TIMESTAMP(ieyr,iejul,iehour,nedate)
      call GRDAY(ilog,ieyr,iejul,iemon,ieday)
      idate1=nedate

c --- NO Header information in the PROFIL format of AERMOD: AERMET.PFL
c --- Read profile records

      write(ilog,*)
      write(ilog,*)'Reading AERMET.PFL records'
      write(ilog,*)
c
c --- Initialize missing variable counters
      do iloc=1,ntsfout
         nmisw(iloc)=0
         nmist(iloc)=0
      end do
c
c --- Initialize the number or period processed
       iper=0	 
2000  continue
	 nlevaa=1

c --- V1.9.0, Level 121203
2001     read(in,*,end=2999)iyrea,imoea,idyea,ihrea,zlaa1,idzz,
     1                       wda1,wsa1,tzaa1

         zlaa(nlevaa)=zlaa1
         if (wda1.gt.-998.9.and.wsa1.gt.-998.9.and.
     1           wda1.lt.998.9.and.wsa1.lt.998.9) then
           wda(nlevaa)=wda1
           wsa(nlevaa)=wsa1
         else
           wda(nlevaa)=xmissm
           wsa(nlevaa)=xmissm
         endif
         if (tzaa1.gt.-98.9.and.tzaa1.lt.98.9) then
           tzaa(nlevaa)=tzaa1+273.15
         else
           tzaa(nlevaa)=xmissm
         endif
         if(idzz.eq.0) then
           nlevaa=nlevaa+1
           goto 2001
         elseif(idzz.eq.1) then
           iper=iper+1
         else
           write(ilog,*)'ERROR - flag for height should be 0 or 1'
           write(ilog,*)'Here, flag = ',idzz
           write(ilog,*)'for date = ',iyrea,imoea,idyea,ihrea
 	   write(*,*)'ERROR - flag for height should be 0 or 1'
           write(*,*)'Here, flag = ',idzz
           write(*,*)'for date = ',iyrea,imoea,idyea,ihrea
           stop
         endif

33       format(i2,3i3,f7.1,i2,f6.0,f8.2,f8.1)

         call YR4(ilog,iyrea,ierr)
         if(ierr.NE.0) stop 'Halted in AERMPFLEXT - Y2K'

c --- Change day N hour = 24 to day N+1 hour =0
         if(ihrea.eq.24) then
           ihrea=0
           ctrans='TO 00h'
           ijulea=-1
           call MIDNITE(ilog,ctrans,iyrea,imoea,idyea,ijulea,
     &                              iyrea,imoea,idyea,ijulea)
         endif
c
c ---    Fill in beginning times and seconds
         call JULDAY(ilog,iyrea,imoea,idyea,ijulea)
         iyrba=iyrea
         ijulba=ijulea
         ihrba=ihrea
         isecba=0
         isecea=0
         nsecadd=-3600
         call INCRS(ilog,iyrba,ijulba,ihrba,isecba,nsecadd)
         call GRDAY(ilog,iyrba,ijulba,imoba,idyba)
         if(iecho.eq.1) then
            write(*,*)'beg period ',iyrba,imoba,ihrba,isecba
            write(*,*)'end period ',iyrea,imoea,ihrea,isecea
            write(*,*)' '
         endif

c --- Test time period for the begining of the file
c --- Note: This is a basic test on dates without seconds.
c ---       Consistent with other subroutines but strict
c ---       test should include seconds with call to deltsec
      call TIMESTAMP(iyrba,ijulba,ihrba,ibdatea)

      if(ibdatea.gt.idate0.and.iper.eq.1) then
         write(ilog,*)' Error: Required date too early:'
         write(ilog,*)'        Required Date:           ',idate0
         write(ilog,*)'        Beginning Date in AERMET.PFL:',ibdatea
         print *,' Error: Required date too early:'
         print *,'        Required Date:           ',idate0
         print *,'        Beginning Date in UP.DAT:',ibdatea
         stop
      endif
 
c --- Timestamp:
      call TIMESTAMP(iyrea,ijulea,ihrea,idate)
      write(ilog,*)'Timestamp (LST): ',idate

c --- exit if requested end date has been passed
      if(idate.gt.idate1) go to 3000

c --- check that no. levels does not exceed array dimension
      if(nlevaa.gt.mxnz)then
         write(ilog,86)iyrea,imoea,idyea,ihrea,nlevaa,mxnz
86       format(//1x,'ERROR IN SUBR. AERMPFLEXT -- too many levels for',
     1   'array dimension'//1x,'on (year,month,day) = (',
     2    i4,',',i2,',',i2,')',2x,'hour = ',i2,
     3   ' GMT'//1x,'No. levels = ',i5,3x,'Current array dimension = ',
     4   i5)
         stop
      endif

c --- keep reading until first requested record is reached
      if(idate.lt.idate0) go to 2000

c      write(6,*)'Processing (LST):',idate
     
c --- No humidity data in AERMET.PFL
      qqfin=9999.

c --- Version: 1.9.0   , Level 121203
c ---    Swap date and end-time into variables for output
         iyout=iyrea
         imout=imoea
         idout=idyea
         jdout=ijulea
         ihout=ihrea
c ---    Apply Midnight Convention
         if(imidnite.EQ.1 .AND. ihout.EQ.24) then
           ihout=0
           ctrans='TO 00h'
           call MIDNITE(ilog,ctrans,iyrea,imoea,idyea,ijulea,
     &                              iyout,imout,idout,jdout)
         elseif(imidnite.EQ.2 .AND. ihout.EQ.0
     &                        .AND. isecea.EQ.0) then
           ihout=24
           ctrans='TO 24h'
           call MIDNITE(ilog,ctrans,iyrea,imoea,idyea,ijulea,
     &                              iyout,imout,idout,jdout)
         endif

c --- Interpolate data at requested heights
c --- Vertical interpolation

      do iloc=1,ntsfout

c --- Check that the height requested is within the range of height in the file
        if (lwind(iloc)) then
	if(zwind(iloc).lt.zlaa(1).or.zwind(iloc).gt.zlaa(nlevaa)) then
      write(ilog,*)'ERROR wind height requested is outside the' 
      write(ilog,*)'wind measurements - height requested= ',zwind(iloc)
      write(ilog,*)'wind measured between ',zlaa(1),'-',zlaa(nlevaa),'m'
        write(*,*)'ERROR wind height requested is outside the' 
        write(*,*)'wind measurements - height requested= ',zwind(iloc)
        write(*,*)'wind measured between ',zlaa(1),'-',zlaa(nlevaa),'m'
        stop
        endif
        endif
        if(ltmpk(iloc)) then
        if(ztmpk(iloc).lt.zlaa(1).or.ztmpk(iloc).gt.zlaa(nlevaa)) then
      write(ilog,*)'ERROR temp. height requested is outside the' 
      write(ilog,*)'temp. measurements - height requested= ',ztmpk(iloc)
      write(ilog,*)'temp. measured between',zlaa(1),'-',zlaa(nlevaa),'m'
        write(*,*)'ERROR temp. height requested is outside the' 
        write(*,*)'temp. measurements - height requested= ',ztmpk(iloc)
        write(*,*)'temp. measured between ',zlaa(1),'-',zlaa(nlevaa),'m'
        stop
        endif
        endif

         call interppfl(zlaa,tzaa,wsa,wda,nlevaa,zwind(iloc),
     :                 ztmpk(iloc),wsfin,wdfin,tkfin)
      
c ---    Output
         io=iout+iloc

c --- V1.9.0, Level 121203
         call Output(io,iyrba,imoba,idyba,ihrba,isecba,
     &            iyout,imout,idout,ihout,isecea,
     &            wdfin,wsfin,tkfin,qqfin,
     &            lwind(iloc),ltmpk(iloc),lshum(iloc))

c ---    Keep count of missing data
         if (lwind(iloc).and.wdfin.ge.xmissm)nmisw(iloc)=nmisw(iloc)+1
         if (ltmpk(iloc).and.tkfin.ge.xmissm)nmist(iloc)=nmist(iloc)+1
 

      end do

      write(ilog,1010)iyrba,imoba,idyba,ihrba,isecba,
     &                iyrea,imoea,idyea,ihrea,isecea 
 
 1010 format(2(i5,3i3,1x,i4.4))


c --- Finished if last period requested has been processed
      if(idate.EQ.idate1) goto 3000

c --- Read next AERMET.PFL records
      goto 2000


2999  continue
      write(ilog,*)
      write(ilog,*)'Error: Not all periods were extracted'
      write(ilog,*)'Last Period Extracted (YYYYJJJHR-LST): ',idate
      write(ilog,*)'Last Period Requested (YYYYJJJHR-LST): ',idate1
      write(*,*)
      print *,'Error: Not all periods were extracted'
      print *,'Last Period Extracted (YYYYJJJHR-LST): ',idate
      print *,'Last Period Requested (YYYYJJJHR-LST): ',idate1
      goto 3001

3000  continue
      write(*,*)
      print *,'AERMET.PFL data extraction completed'

      write(ilog,*)
      Do iloc=1,ntsfout
         if (lwind(iloc)) write(ilog,*)nmisw(iloc),
     :    ' missing (ws,wd) values at height: ', zwind(iloc)
         if (ltmpk(iloc)) write(ilog,*)nmist(iloc),
     :    ' missing (Temp) values at height: ', ztmpk(iloc)
      end do 
 
      write(ilog,*)
      write(ilog,'(a)')'AERMET.PFL data extraction completed'

3001  continue

      return
      end

c ---------------------------------------------------------------------
      subroutine interppfl(zlaa,tzaa,wsa,wda,nlev,zw,zt,
     :                    wsfin,wdfin,tkfin)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100624
c --- C Escoffier-Czaja, modified from interpup           
c
c --- PURPOSE: Linearly interpolate AERMET.PFL winds and temperatures to
c              selected vertical levels
c
c --- UPDATES:
c
c --- Version 1.77, level 090318 to version 1.78, level 100624
c        - If wind or temp were not requested, both were not processed
c          and no data were output - this has been fixed.
c
c --- INPUT VARIABLES:
c     ZLAA (mxnz)   -  real    - UP.DAT level altitudes above MSL (m)
c     TZAA (MXNZ)   -  real    - UP.DAT temperatures (K)
c     WSA  (MXNZ)   -  real    - UP.DAT wind speed (m/s)
c     WDA  (MXNZ)   -  real    - UP.DAT wind direction (m/s)
c     NLEV          -  integer - Number of AERMET.PFL levels
c     ZW            -  real    - Altitude above ground (m) at which to 
c                                interpolate wind speed and wind dir
c     ZT            -  real    - Altitude above ground (m) at which to 
c                                interpolate temperature 
c
c --- OUTPUT VARIABLES
c     WDFIN         - REAL    - Interpolated wind direction at level
c                               ZW above ground 
c     WSFIN         - REAL    - Interpolated wind speed at level
c                               ZW above ground 
c     TKFIN         - REAL    - Interpolated temperature at level
c                               ZT above ground 
c
c --- INTERPUP called by: AERMPFLEXT 
c --- INTERPUP calls: UV2WSR,WS2UVR
c----------------------------------------------------------------------

      include 'params.ser'
      include 'metseries.ser'
      data xmissm/998.9/

c --- UP.DAT variables
      real zlaa(mxnz),tzaa(mxnz),wsa(mxnz),wda(mxnz)
c
c - Initialization
c 
         wsfin=9999.
         wdfin=9999.
         tkfin=9999.
c --- Ground elevation
      if (nlev.le.1.and.zlaa(1).ne.zw.and.zw.ne.-1) then
c        Return all missing values
         wsfin=9999.
         wdfin=9999.
         return
      endif
      if (nlev.le.1.and.zlaa(1).ne.zt.and.zt.ne.-1) then
c        Return all missing values
         tkfin=9999.
         return
      endif

c --- Make sure level required is between the levels measured
      if (zw.ge.zlaa(1).and.zw.le.zlaa(nlev)) then
         zsw=zw
      else
c        winds not requested at this level, skip
         goto 200
      endif

c --- WIND SPEED AND WIND DIRECTION
c --- Find 2 nearest non-missing levels at which wind data exist
      n1=0
      n2=0

      do 20 k=1,nlev         

         if(zlaa(k).eq.zsw.and.
     :      wsa(k).lt.xmissm.and.wda(k).lt.xmissm)then
c ---       Requested height on UP.DAT level
c ---       No interpolation needed (unless missing data)           
            wsfin=wsa(k)
            wdfin=wda(k)
            goto 200
         endif

         if(zlaa(k).lt.9998.9.and.zlaa(k).lt.zsw)then  
c ---       Find nearest valid level below requested height
            if (wsa(k).lt.xmissm.and.wda(k).lt.xmissm) n1=k
         endif
         if(zlaa(k).lt.9998.9.and.zlaa(k).gt.zsw)then  
c ---       Find nearest valid level above requested height
            if (wsa(k).lt.xmissm.and.wda(k).lt.xmissm) then
               n2=k
               goto 22
            endif
         endif

20    continue

22    continue

c --- Make sure there are valid data to interpolate from
      if(n1.eq.0.or.n2.eq.0) then
         wsfin=9999.
         wdfin=9999.
         goto 200
      else 
         ws1=wsa(n1)
         ws2=wsa(n2)
         wd1=wda(n1)
         wd2=wda(n2)
         z1=zlaa(n1)
         z2=zlaa(n2)
      endif



c --- Transform ws,wd to u,v for interpolation
      call ws2uvr(wd1,ws1,u1,v1)
      call ws2uvr(wd2,ws2,u2,v2)

c --- interpolate U, V to requested height
      rat=(zsw-z1)/(z2-z1)
      u=u1+(u2-u1)*rat
      v=v1+(v2-v1)*rat
c

c --- Transform interpolated u,v to ws,wd
      call uv2wsr(u,v,wdfin,wsfin)
c --- (090818 - CEC - Add a check that if wind speed is 0.00 then wind dir will be 0.00 as well)
      if(wsfin.lt.1E-5) wdfin=0.0
     
200   continue
 
C --- TEMPERATURE

c --- Make sure level required is between the levels measured
      if (zt.ge.zlaa(1).and.zt.le.zlaa(nlev)) then
         zst=zt
      else
c        temperature not requested at this level, skip
         goto 300
      endif

c --- Find 2 nearest non-missing levels at which wind data exist
      n1=0
      n2=0

      do 30 k=1,nlev         

         if(zlaa(k).eq.zst.and.tzaa(k).lt.xmissm)then
c ---       Requested height on UP.DAT level 
c ---       no interpolation needed(unless missing data)
            tkfin=tzaa(k)
            goto 300
         endif

         if(zlaa(k).lt.9998.9.and.zlaa(k).lt.zst)then  
c ---       Find nearest valid level below requested height
            if (tzaa(k).lt.xmissm) n1=k
         endif
         if(zlaa(k).lt.9998.9.and.zlaa(k).gt.zst)then  
c ---       Find nearest valid level above requested height
            if (tzaa(k).lt.xmissm) then
               n2=k
               goto 32
            endif
         endif

30    continue

32    continue
c --- Make sure there are valid data to interpolate from
      if(n1.eq.0.or.n2.eq.0) then
         tkfin=9999.
         goto 300
      else 
         t1=tzaa(n1)
         t2=tzaa(n2)
         z1=zlaa(n1)
         z2=zlaa(n2)
      endif

c --- interpolate T to requested height
      rat=(zst-z1)/(z2-z1)
      tkfin=t1+(t2-t1)*rat
c
300   continue

      return
      end

c ---------------------------------------------------------------------
      subroutine clmext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203        CLMEXT
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Extract wind time series from CALMET.DAT
c
c --- Version 1.79, Level 100721 to Version 1.9.0, Level 121203
c         - Add call to MIDNITE for selected time convention
c         - Add new variables for end-time output
c         - Move time conditioning outside loop over locations
c         - Restrict 24h to seconds=0000
c         - Ouput surface pressure when OTHER=1.
c
c --- Version 1.79, Level 100721 from Level 091022 (JSS)
c     1.  Standardize convention and correct reads of LCC origin 
c         lat/long
c     2.  Stop run if reading old CALMET.DAT version prior to
c         04-March-1998
c     3.  Note:  new /MAPINFO/ common block required w/ 'relon0m'
c         variable
c --- Version 1.66, Level 090731 to Version 1.73, Level 091022 (IWL)
c      1. Fix error in true wind calculation for CALMET dataset
c         versions 2.0 and greater. Variable CONECM is used in
c         Subroutine ROTATE and while it exists and is read from
c         the header of CALMET dataset versions < 2.0, it needs to
c         be computed for CALMET dataset versions >= 2.0. This was
c         missing and has been added.
c      2. Add comments (COMMON BLOCK, CALLED BY, CALLS)
c --- Version 1.63, Level 090415 to Version 1.66, Level 090731
c      1. Rename INTERPHCLM to INTERPHUV
c      2. Update calls to INTERPH* subs with METSIMC flag
c      3. Revise location reported with nearest grid cell option
c      4. Replace GETCLOSE with INEAREST for stability class
c      5. Do not rotate wind direction if wind is calm (retains zero
c         wind direction)
c      6. Add the extraction of surface relative humidity data
c         when 'lother' is selected
c --- Version 1.62, Level 090411 to Version 1.63, Level 090415
c      1. Replace old calls to Y2K() with YR4()
c --- Version 1.6, level 090318 to Version 1.62, level 090411 (CEC)
c      1. Fixed extraction of point on the edge of the domain
c      2. Horizontal interpolation of Monin-Obukhov length is done
c         by weighting 1/X rather than X.
c --- Version 1.5, level 090203 to Version 1.6, level 090318 (DGS)
c      1. Control information from /CONTROL/
c      2. Place output TSF header calls into HDTSFOUT
c CEC  3. An error was found when no temperature was required from
c           CALMET.DAT files. It is now fixed.
c           Add an error check so no temperature can be extracted below 
c           the first level of CALMET.
c      4. Remove xext,yext from /LOCINFO/ and use the xloc,yloc arrays
c         instead.  Move ROTATE call to loop over requested locations
c         and change the direction rotation wdrot to an array.
c         This corrects processing in which an LCC wind direction shift
c         from ROTATE used the last requested location for all
c         requested locations.
c      5. Change to Julian Date-hour integer YYYYJJJHH
c CEC  6. Processing sub-hourly time steps for CALMET.DAT format has been 
c         updated.
c CEC  7. Update so no missing are allowed at the beginning
c         or the end of the file is period requested do not match the
c         data availability
c      8. Add full coordinate transformation to cast requested location
c         into model map projection and datum (clean up lat/lon names)
c      9. Add a check on vertical interpolation of wind when wind is 
c           not requested
c
c --- Version 1.5, Level: 060823 to Version 1.5, level 090203 (CEC)
c      1. Add vertical interpolation of temperature when possible
c      2. Add capability to process sub-hourly time steps
c
c
c --- COMMON BLOCK /MAPINFO/:
c       xlat0m,xlon0m,conecm,xlat1m,xlat2m,rlat0m,rlon0m
c       ...
c
c --- CALLED BY:
c       MAIN
c  
c --- CALLS:
c       ROTATE
c       ...
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      parameter(iecho=0)

      real xbuf(mxnx,mxny)
      real elev(mxnx,mxny),z0(mxnx,mxny),zface(mxnzp1)
      real xssta(mxss),yssta(mxss), xusta(mxus),yusta(mxus)
      real xpsta(mxps),ypsta(mxps)
      real u(mxnx,mxny,mxnz),v(mxnx,mxny,mxnz)
      real w(mxnx,mxny,mxnz),ztemp(mxnx,mxny,mxnz)
      real ustar(mxnx,mxny),zi(mxnx,mxny),el(mxnx,mxny)
      real wstar(mxnx,mxny),rmm(mxnx,mxny),xlai(mxnx,mxny)
      real tempk2d(mxnx,mxny),rho2d(mxnx,mxny)
     &     ,qsw2d(mxnx,mxny)
      integer irh2d(mxnx,mxny),ipcode2d(mxnx,mxny)
      real tempk(mxss),rho(mxss),qsw(mxss)

      real prf(mxnz),uprf(4),vprf(4),zht(mxnz),tprf(4)
      real wdrot(mxloc)
      real tk(4),qq(4)
      real sfcpres(4)
      real xqzi(4),xqrmm(4),xqust(4),xqmob(4),xqcvv(4),xqsw(4)
      real xqrh(4)
      integer iqstcl(4)
             

      integer ilandu(mxnx,mxny),ipgt(mxnx,mxny),irh(mxss),ipcode(mxss)
      integer nears(mxnx,mxny)
      integer ibuf(mxnx,mxny)

      dimension ngrdexts(4,mxloc),wgts(4,mxloc)
      dimension wgt(4)
      dimension icell(4),jcell(4)

      character*80 titclm(3),fl
      character*8 vermet,levmet
      character*8 clabel,clabxs,clabys,clabxu,clabyu,clabxp,clabyp
      character*8 clabz0,clablu,clabte,clablai,clabnss

      logical*4 lcalgrd
      logical LLCONFM

c --- For coordinate transformations
      character*8 cmapi,cmapo
      character*12 caction, cactionb
      character*4 c4hem
      real*8 vecti(9),vecto(9), vectib(9),vectob(9)

c --- Local Variables (New for new calmet header - V5.5 L030402) 
      character*16 dataset,dataver
      character*64 datamod
      character*80 doc1
      character*132 comment1,blank
      character*4 utmhem
      character*8 datum,pmap
      character*12 daten
c --- Dataset 2.1
      character*8 axbtz

      data pmap/'        '/
      data datum/'        '/
      data daten/'            '/
      data iutmzn/0/
      data utmhem/'    '/
      data feast/0.0/, fnorth/0.0/

c --- Set the local i,j steps that define the 4 corners of a cell
c --- associated the the weighting arrays
      data icell/0,1,0,1/
      data jcell/0,0,1,1/

c ---------------------------------------------------------------------
      if(ifrmt.ne.1) then
         write(ilog,*)'Location format must be X/Y (km) for calmet.dat'
         write(ilog,*)'IFRMT=',ifrmt
         print *,'Location format must be X/Y (km) for calmet.dat'
         print *,'IFRMT=',ifrmt
         stop
      endif

      ihrclm=0
      idate0=ndateext
      isec0=nsecext
      write(ilog,*)'First date needed from CALMET is: ',idate0,isec0
      write(*,*)'First date needed from CALMET is: ',idate0,isec0

      do i=1,132
         blank(i:i)=' '
      enddo

      do 6000 ifile=1,nmetinp

c ---    Skip remaining files if period has already been extracted
         if(ihrclm.GE.nbsecext) goto 6000

         fl=fmet(ifile)
c         nt=index(fl,' ')-1
         nt=LEN_TRIM(fl)
         print *,'Processing File:',ifile,' ',fl(1:nt)
         write(ilog,1008)ifile,fl(1:nt)
 1008    format(/,i3,2x,a)

         open(in,file=fl,status='old',form='unformatted',action='read')

c ---    Read and test first record to determine header format
c ---    Record #1 - File Declaration -- 24 words
         read(in) dataset,dataver,datamod
         ifilver=0
         i2dmet=0
         itime=0 
         ibsec=0
         iesec=0
         if(dataset.EQ.'CALMET.DAT') then
            ifilver=1
            i2dmet=1
            if(dataver.EQ.'2.1') itime=1
         endif
         REWIND(in)

c ---    Read records
c
         if(ifilver.EQ.1) then  ! CALMET Dataset 2.0 and later
c
c ---       Record #1 - File Declaration -- 24 words
            read(in) dataset,dataver,datamod
            write(ilog,*)dataset,dataver,datamod
c
c ---       Record #2 - Number of comment lines -- 1 word
            read(in) ncom

c ---       Loop over comment records
            do i=1,ncom
               comment1=blank
               read(in) comment1
               if(i.EQ.1) then
c ---             Save model version line
                  doc1=comment1(1:80)
               elseif(i.LE.4) then
c ---             Save 3 title lines
                  titclm(i-1)=comment1(1:80)
               endif

               nt=LEN_TRIM(comment1)
c               write(ilog,*) comment1(1:nt)

            enddo
c
            if(itime.EQ.0) then
c ---          CALMET.DAT - v2.0 dataset version
c ---          record #NCOM+3 - run control parameters -- 33 words
               read(in)ibyr,ibmo,ibdy,ibhr,ibtz,irlg,irtype,
     &         nx, ny, nz, dgrid, xorigr, yorigr, iwfcod, nssta,
     &         nusta, npsta, nowsta, nlu, iwat1, iwat2, lcalgrd,
     &         pmap,datum,daten,feast,fnorth,utmhem,iutmzn,
     &         rnlat0m,relon0m,xlat1m,xlat2m
c
c ---          Convert original latitude/longitude to common block variable names
               rlat0m=rnlat0m
c ---          rlon0m is longitude w/ W long. positive; relon0m is long. w/ E long. positive
               rlon0m=-relon0m
            else
c ---          CALMET.DAT - v2.1 dataset version
c ---          record #NCOM+3 - run control parameters -- 39 words
               read(in) ibyr,ibmo,ibdy,ibhr,ibsec,
     1                  ieyr,iemo,iedy,iehr,iesec,
     2                  axbtz,irlg,irtype,
     3         nx, ny, nz, dgrid, xorigr, yorigr, iwfcod, nssta,
     4         nusta, npsta, nowsta, nlu, iwat1, iwat2, lcalgrd,
     5         pmap,datum,daten,feast,fnorth,utmhem,iutmzn,
     6         rnlat0m,relon0m,xlat1m,xlat2m
c
c ---          Convert original latitude/longitude to common block variable names
               rlat0m=rnlat0m
c ---          rlon0m is longitude w/ W long. positive; relon0m is long. w/ E long. positive
               rlon0m=-relon0m
            endif
c
c ---       Calculate cone constant for LCC (used to adjust winds)
            conecm=0.0
            if(pmap.EQ.'LCC     ') then
              d2r = 0.0174533
c ---         Use absolute value of latitudes, then adjust y coordinate
c ---         later if in Southern Hemisphere
              conecm=log(cos(abs(xlat1m)*d2r)/cos(abs(xlat2m)*d2r))
              conecm=conecm/(log(tan(d2r*(45.-abs(xlat1m)/2.))/
     &                     tan(d2r*(45.-abs(xlat2m)/2.))))
            endif
         endif

         if(ifilver.EQ.0) then  ! Old CALMET

c           record #1 - run title -- 60 words
            read(in,end=6500)titclm

c           record #2 - run control parameters -- 25 words
c           (vermet, levmet are both 8 bytes)
            read(in)vermet,levmet,ibyr,ibmo,ibdy,ibhr,ibtz,irlg,
     &      irtype,nx,ny,nz,dgrid,xorigr,yorigr,iutmzn,iwfcod,nssta,
     &      nusta,npsta,nowsta,nlu,iwat1,iwat2,lcalgrd

c           New record -- #3 - additional run control data -- 8 words
            read(levmet(1:6),'(i6)') ilevmet
            if(ilevmet.GE.980304 .or. ilevmet.lt.500101) then
c ---       This record was introduced in CALMET Version 5.0 (980304)
c ---       (CALMET.DAT dataset v1.5
c              New header record format
               read(in)xlat0m,xlon0m,llconfm,conecm,xlat1m,xlat2m,
     &           rlat0m,rlon0m
c
c ---          relon0m is long. w/ E long. positive; rlon0m is longitude w/ W long. positive 
               relon0m=-rlon0m
            else
               llconfm=.FALSE.
c ---          Stop with CALMET.DAT versions prior to 3/4/1998
               write(ilog,*)'Error in Subr. CLMEXT - ',
     1          'Invalid old CALMET.DAT version'
               write(ilog,*)'CALMET.DAT dataset version is prior to ',
     2          '04-Mar-1998'
               write(*,*)'Error in Subr. CLMEXT - ',
     1          'Invalid old CALMET.DAT version'
               write(*,*)'CALMET.DAT dataset version is prior to ',
     1          '04-Mar-1998'
               stop
            endif

c ---       Recast map projection information
            if(LLCONFM) then
               pmap='LCC     '
            else
               pmap='UTM     '
            endif

         endif

         if(itime.EQ.0) then
c ---       Reset time at end of first hour to start of first hour
            nhrinc=-1
            call JULDAY(ilog,ibyr,ibmo,ibdy,ibjd)
            call INCR(ilog,ibyr,ibjd,ibhr,nhrinc)
            call GRDAY(ilog,ibyr,ibjd,ibmo,ibdy)
c ---       Find time at end of last period (step=1hour)
            ieyr=ibyr
            iejd=ibjd
            iehr=ibhr
            call INCR(ilog,ieyr,iejd,iehr,irlg)
            call GRDAY(ilog,ieyr,iejd,iemo,iedy)
            iesec=0
         else
            call JULDAY(ilog,ibyr,ibmo,ibdy,ibjd)
            call JULDAY(ilog,ieyr,iemo,iedy,iejd)
         endif
c
c --- (CEC - 090203) Compute begining date and ending date in CALMET.DAT file 
c          and total number of seconds in CALMET.DAT
         call TIMESTAMP(ibyr,ibjd,ibhr,idateb)
         call TIMESTAMP(ieyr,iejd,iehr,idatee)
         call DELTSEC(idateb,ibsec,idatee,iesec,ndelsec0)
c
c ---    Listfile output
         do kt=1,3
            write(ilog,*)titclm(kt)
         enddo
         write(ilog,*)'Starting time YYYY MM DD HH SSSS: ',
     &                  ibyr,ibmo,ibdy,ibhr,ibsec
         write(ilog,*)

c ---    Set up extraction information from first file in list
c ---    (Requested location may need to be transformed to CALMET map)
         if(ifile.eq.1) then
c ---       Set translation vectors going to CALMET projection (x,y)km
c ---       Scale factor for Tangential TM projection
            tmsone=1.00000
c ---       Set output projection from CALMET header
            iutmo=iutmzn
            if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
            cmapo=pmap
            if(cmapo.EQ.'TTM     ') cmapo='TM      '
c ---       Reset control file map and datum to model map and datum if
c ---       the map requested is NONE
            if(LNOMAP) then
c ---          Reset input map/datum to model system (from header)
c ---          Datum
               datumc=datum
c ---          Map Projection
               pmapc=pmap
               iutmznc=iutmzn
               utmhemc=utmhem
               rnlat1c=xlat1m
               rnlat2c=xlat2m
               rnlat0c=rnlat0m
               relon0c=relon0m
               feastc=feast
               fnorthc=fnorth
               call LLMAKE(ilog,'LON ',relon0c,clon0c)
               call LLMAKE(ilog,'LAT ',rnlat0c,clat0c)
               call LLMAKE(ilog,'LAT ',rnlat1c,clat1c)
               call LLMAKE(ilog,'LAT ',rnlat2c,clat2c)
c ---          Projection logicals
               lnomap=.FALSE.
               lgeo=.FALSE.
               lutm=.FALSE.
               llcc=.FALSE.
               lps=.FALSE.
               lem=.FALSE.
               llaza=.FALSE.
               lttm=.FALSE.
               if(pmapc.EQ.'NONE') then
                  lnomap=.TRUE.
               elseif(pmapc.EQ.'LL') then
                  lgeo=.TRUE.
               elseif(pmapc.EQ.'UTM') then
                  lutm=.TRUE.
               elseif(pmapc.EQ.'LCC') then
                  llcc=.TRUE.
               elseif(pmapc.EQ.'PS') then
                  lps=.TRUE.
               elseif(pmapc.EQ.'EM') then
                  lem=.TRUE.
               elseif(pmapc.EQ.'LAZA') then
                  llaza=.TRUE.
               elseif(pmapc.EQ.'TTM') then
                  lttm=.TRUE.
               endif
            endif
c ---       Condition input projection
            cmapi=pmapc
            if(cmapi.EQ.'TTM     ') cmapi='TM      '
            iutmi=iutmznc
            if(utmhemc.EQ.'S   ' .AND. iutmznc.LT.900) iutmi=-iutmi

c ---       Set forward-transformation to CALMET projection
            call GLOBE1(cmapi,iutmi,tmsone,rnlat1c,rnlat2c,
     &               rnlat0c,relon0c,feastc,fnorthc,
     &               cmapo,iutmo,tmsone,xlat1m,xlat2m,
     &               rnlat0m,relon0m,feast,fnorth,
     &               caction,vecti,vecto)

c ---       Set back-transformation from CALMET projection
            call GLOBE1(cmapo,iutmo,tmsone,xlat1m,xlat2m,
     &               rnlat0m,relon0m,feast,fnorth,
     &               cmapi,iutmi,tmsone,rnlat1c,rnlat2c,
     &               rnlat0c,relon0c,feastc,fnorthc,
     &               cactionb,vectib,vectob)

            xsw=(xorigr+dgrid/2.)/1000.
            ysw=(yorigr+dgrid/2.)/1000.
            dgridk=dgrid/1000.
            write(ilog,*)' SW/dxy:',xsw,ysw,dgridk
            print *,' SW/dxy:',xsw,ysw,dgridk

c ---       Pass to COMMON BLOCK /LOCINFO/
            dxm=dgridk
            dym=dgridk

c ---       Set logical for LCC map projection
            if(pmap.EQ.'LCC     ') then
               llconfm=.TRUE.
            else
               llconfm=.FALSE.
            endif

c ---       Gridded Domain limits 
            x1dom=xsw
            x2dom=x1dom+(nx-1)*dgridk
            y1dom=ysw
            y2dom=y1dom+(ny-1)*dgridk

            Write(ilog,*)'Model Domain:',x1dom,x2dom,y1dom,y2dom
            Write(ilog,*)' '
            Write(*,*)'Model Domain:',x1dom,x2dom,y1dom,y2dom
            Write(*,*)' '

c ---       Loop over extraction locations
            do iloc=1,ntsfout
c ---          Convert locations to model x,y system
               xin=xloc(iloc)
               yin=yloc(iloc)
               call GLOBE(ilog,caction,datumc,vecti,datum,vecto,
     &                    xin,yin,xext,yext,idum,c4hem)
               xloc(iloc)=xext
               yloc(iloc)=yext

c ---          Test location
               if(xext.lt.x1dom .or. xext.gt.x2dom) then
                  write(ilog,10166)xext,x1dom,x2dom
                  write(*,10166)xext,x1dom,x2dom
10166             format('Extraction site out of domain - X:',3f12.3)
                  stop 'HALTED: See list file'
               endif
               if(yext.lt.y1dom .or. yext.gt.y2dom) then
                  write(ilog,10167)yext,y1dom,y2dom
                  write(*,10167)yext,y1dom,y2dom
10167             format('Extraction site out of domain - Y:',3f12.3)
                  stop 'HALTED: See list file'
               endif

c               fnx=(xext-xsw)/dgridk
c               fny=(yext-ysw)/dgridk
c
               fnx=(xext-xsw)/dgridk+1
               fny=(yext-ysw)/dgridk+1

               write(ilog,10101)fnx,fny,xsw,ysw,xext,yext
10101          format('fnx,fny,xsw,ysw,xext,yext:',6f12.3)

c               if(fnx.lt.0 .or. fny.lt.0 .or. fnx.gt.nx 
c     &            .or. fny.gt.ny) then
               if(fnx.lt.1 .or. fny.lt.1 .or. fnx.gt.nx 
     &            .or. fny.gt.ny) then
                  write(ilog,1010)xext,yext,xorigr/1000.
     &               ,yorigr/1000.,dgrid/1000.,nx,ny
                  write(*,1010)xext,yext,xorigr/1000.
     &               ,yorigr/1000.,dgrid/1000.,nx,ny
 1010             format(/,1x,
     &             'Extraction location out of CALMET domain',
     &             /,5f10.3,2i5)
                  stop 20
               endif

               knx=int(fnx)
               kny=int(fny)

c               ngrdexts(1,iloc)=knx+1
c               ngrdexts(2,iloc)=knx+2
c               ngrdexts(3,iloc)=kny+1
c               ngrdexts(4,iloc)=kny+2
c
	       if(knx.ne.nx.and.kny.ne.ny) then
                ngrdexts(1,iloc)=knx
                ngrdexts(2,iloc)=knx+1
                ngrdexts(3,iloc)=kny
                ngrdexts(4,iloc)=kny+1
c
                wgts(1,iloc)=1-(fnx-knx)
                wgts(2,iloc)=fnx-knx
                wgts(3,iloc)=1-(fny-kny)
                wgts(4,iloc)=fny-kny

               elseif(knx.eq.nx.and.kny.ne.ny) then
                ngrdexts(1,iloc)=knx-1
                ngrdexts(2,iloc)=knx
                ngrdexts(3,iloc)=kny
                ngrdexts(4,iloc)=kny+1
c
                wgts(1,iloc)=knx-fnx
                wgts(2,iloc)=1-(fnx-knx)
                wgts(3,iloc)=1-(fny-kny)
                wgts(4,iloc)=fny-kny

               elseif(knx.ne.nx.and.kny.eq.ny) then
                ngrdexts(1,iloc)=knx
                ngrdexts(2,iloc)=knx+1
                ngrdexts(3,iloc)=kny-1
                ngrdexts(4,iloc)=kny
c
                wgts(1,iloc)=1-(fnx-knx)
                wgts(2,iloc)=fnx-knx
                wgts(3,iloc)=kny-fny
                wgts(4,iloc)=1-(fny-kny)
c
               elseif(knx.eq.nx.and.kny.eq.ny) then
                ngrdexts(1,iloc)=knx-1
                ngrdexts(2,iloc)=knx
                ngrdexts(3,iloc)=kny-1
                ngrdexts(4,iloc)=kny
c
                wgts(1,iloc)=knx-fnx
                wgts(2,iloc)=1-(fnx-knx)
                wgts(3,iloc)=kny-fny
                wgts(4,iloc)=1-(fny-kny)
               endif
            
               write(ilog,1011)iloc,fnx,fny,(wgts(j,iloc),j=1,4)
 1011          format(' Site/Wgt: ',i5,6f8.3)
c               print 1011,iloc,fnx,fny,(wgts(j,iloc),j=1,4)

               if(metsimc.EQ.2) then
c ---             Nearest grid cell option
                  call INEAREST(icell,wgts(1,iloc),ii)
                  call INEAREST(jcell,wgts(1,iloc),jj)
                  ii=knx+ii
                  jj=kny+jj
c ---             Save location requested by user
                  xuloc(iloc)=xin
                  yuloc(iloc)=yin
c ---             New location (nearest grid point)
                  xloc(iloc)=xsw+dgridk*(ii-1)
                  yloc(iloc)=ysw+dgridk*(jj-1)
c ---             Transform from CALMET projection
                  call GLOBE(ilog,cactionb,datum,vectib,datumc,vectob,
     &                       xloc(iloc),yloc(iloc),xin2,yin2,idum,c4hem)
                  xmet(iloc)=xin2
                  ymet(iloc)=yin2

                  write(ilog,*)'Modified for Nearest Grid Point:'
                  write(ilog,1023)xloc(iloc),yloc(iloc),xin2,yin2
 1023             format('CALMET:  (X,Y) = (',f9.3,'km,',f9.3,
     &                'km);  (XLON/YLAT) = (',f9.3,',',f9.3,')')
               endif

c ---          Get wind direction adjustment constant for LLCON
               windrot=0.0
               if(llconfm) call rotate(iloc,windrot)
               wdrot(iloc)=windrot

c ---          Write header for TSF output file
               if(ifile.EQ.1) then
c ---             First data file processed -- top of output files
                  io=iout+iloc
                  call HDTSFOUT(io,iloc)
               endif

            enddo
         endif

c        Check that array dimensions have been sized properly
         if(nx.gt.mxnx.or.ny.gt.mxny.or.nz.gt.mxnz .or.
     &      nssta.gt.mxss.or.nusta.gt.mxus.or.npsta.gt.mxps)then
            write(ilog,2354)nx,mxnx,ny,mxny,nz,mxnz,nssta,mxss,
     &          nusta,mxus,npsta,mxps
 2354       format(/1x,'ERROR -- Array dimensions are too small for ',
     1           'the data in the CALMET.DAT file'/
     2           5x,'NX    = ',i5,4x,'MXNX = ',i5/
     3           5x,'NY    = ',i5,4x,'MXNY = ',i5/
     4           5x,'NZ    = ',i5,4x,'MXNZ = ',i5/
     5           5x,'NSSTA = ',i5,4x,'MXSS = ',i5/
     6           5x,'NUSTA = ',i5,4x,'MXUS = ',i5/
     7           5x,'NPSTA = ',i5,4x,'MXPS = ',i5)
            stop
         endif

c        record #4 - cell face heights (NZ + 1 words)
         nzp1=nz+1
         call rdr1d(in,itime,zface,nzp1,clabel,idum,idum,idum,idum)

c ---    Compute cell-center height above the surface
         do i=1,nz
            zht(i)=(zface(i)+zface(i+1))/2.0
c            print *,i,zht(i),zface(i),zface(i+1)
         enddo

c        records #5 & 6 - x, y coordinates of surface stations
c        (NSSTA words each record)
         if(nssta.gt.0)then
            call rdr1d(in,itime,xssta,nssta,clabxs,idum,idum,
     &                 idum,idum)
            call rdr1d(in,itime,yssta,nssta,clabys,idum,idum,
     &                 idum,idum)
         endif

c        records #7 & 8 - x, y coordinates of upper air stations
c        (NUSTA words each record)
         if(nusta.gt.0)then
            call rdr1d(in,itime,xusta,nusta,clabxu,idum,idum,
     &                 idum,idum)
            call rdr1d(in,itime,yusta,nusta,clabyu,idum,idum,
     &                 idum,idum)
         endif

c        records #9 & 10 - x, y coordinates of precipitation stations
c        (NPSTA words each record)
         if(npsta.gt.0)then
            call rdr1d(in,itime,xpsta,npsta,clabxp,idum,idum,
     &                 idum,idum)
            call rdr1d(in,itime,ypsta,npsta,clabyp,idum,idum,
     &                 idum,idum)
         endif

c        record #11 - surface roughness lengths (NX * NY words)
         call rdr2d(in,itime,z0,xbuf,mxnx,mxny,nx,ny,clabz0,
     &              idum,idum,idum,idum,ieof)
         if(ieof.EQ.1) then
            write(*,*)
            stop 'Unexpected EOF in CALMET header'
         endif

c        record #12 - land use categories (NX * NY words)
         call rdi2d(in,itime,ilandu,ibuf,mxnx,mxny,nx,ny,clablu,
     &              idum,idum,idum,idum)

c        record #13 - elevations (NX * NY words)
         call rdr2d(in,itime,elev,xbuf,mxnx,mxny,nx,ny,clabte,
     &              idum,idum,idum,idum,ieof)
         if(ieof.EQ.1) then
            write(*,*)
            stop 'Unexpected EOF in CALMET header'
         endif

c        record #14 - leaf area index (NX * NY words)
         call rdr2d(in,itime,xlai,xbuf,mxnx,mxny,nx,ny,clablai,
     &              idum,idum,idum,idum,ieof)
         if(ieof.EQ.1) then
            write(*,*)
            stop 'Unexpected EOF in CALMET header'
         endif

c        record #15 - nearest surface station to each grid point
c                  (NX * NY words)
         if(nssta.ge.1) then
            call rdi2d(in,itime,nears,ibuf,mxnx,mxny,nx,ny,clabnss,
     &                 idum,idum,idum,idum)
         endif

c        Loop over hourly data records
c --- (CEC - 090203 change time step to be in seconds
c        Loop over period variation data records (can be hourly or sub-hourly)
         write(*,*)'Start loop over periods'
         write(*,*)

         ihrfile=0

c ---    Sequential data records
c ------------------------------
 1000    continue

c        Read 3-D U, V, W wind components
         do 10 iz=1,nz
            call rdr2d(in,itime,u(1,1,iz),xbuf,mxnx,mxny,nx,ny,clabel,
     &           ndathrb,nsecb,ndathre,nsece,ieof)
            call rdr2d(in,itime,v(1,1,iz),xbuf,mxnx,mxny,nx,ny,clabel,
     &           ndathrb,nsecb,ndathre,nsece,ieof)
            if(lcalgrd) call rdr2d(in,itime,w(1,1,iz),xbuf,mxnx,mxny,
     &           nx,ny,clabel,ndathrb,nsecb,ndathre,nsece,ieof)
 10      continue
         if(ieof.EQ.1) then
            stop 'Unexpected EOF in CALMET data records'
         endif

c        Read the 3-D temperature fields
         if(lcalgrd.and.irtype.eq.1)then 
            do 12 iz=1,nz
               call rdr2d(in,itime,ztemp(1,1,iz),xbuf,mxnx,mxny,nx,ny,
     &              clabel,ndathrb,nsecb,ndathre,nsece,ieof)
 12         continue
            if(ieof.EQ.1) then
               write(*,*)
               stop 'Unexpected EOF in CALMET data records'
            endif
         endif

c        Read the 2-D meteorological fields
c        - PGT stability class,
c        - Friction velocity (m/s),
c        - Mixing height (m),
c        - Monin-Obukhov length (m),
c        - Convective velocity scale (m/s),
c        - Precipitation rate (mm/hr)
c         (if run type = 0, i.e., only winds computed & stored on disk)
         if(irtype.eq.1)then
            call rdi2d(in,itime,ipgt,ibuf,mxnx,mxny,nx,ny,clabel,
     &                 ndathrb,nsecb,ndathre,nsece)
            call rdr2d(in,itime,ustar,xbuf,mxnx,mxny,nx,ny,clabel,
     &                 ndathrb,nsecb,ndathre,nsece,ieof)
            call rdr2d(in,itime,zi,xbuf,mxnx,mxny,nx,ny,clabel,
     &                 ndathrb,nsecb,ndathre,nsece,ieof)
            call rdr2d(in,itime,el,xbuf,mxnx,mxny,nx,ny,clabel,
     &                 ndathrb,nsecb,ndathre,nsece,ieof)
            call rdr2d(in,itime,wstar,xbuf,mxnx,mxny,nx,ny,clabel,
     &                 ndathrb,nsecb,ndathre,nsece,ieof)
            if(npsta.ne.0) then
               call rdr2d(in,itime,rmm,xbuf,mxnx,mxny,nx,ny,clabel,
     &                 ndathrb,nsecb,ndathre,nsece,ieof)
            endif

            if(i2dmet.EQ.0)then
c ---         Read the 1-D meteorological fields
c             - Air temperature (deg. K),
c             - Air density (kg/m**3),
c             - Short-wave solar radiation (W/m**2),
c             - Relative humidity (percent),
c             - Precipitation code
              call rdr1d(in,itime,tempk,nssta,clabel,
     &                   ndathrb,nsecb,ndathre,nsece)
              call rdr1d(in,itime,rho,nssta,clabel,
     &                   ndathrb,nsecb,ndathre,nsece)
              call rdr1d(in,itime,qsw,nssta,clabel,
     &                   ndathrb,nsecb,ndathre,nsece)
              call rdi1d(in,itime,irh,nssta,clabel,
     &                   ndathrb,nsecb,ndathre,nsece)
              if(npsta.gt.0)call rdi1d(in,itime,ipcode,nssta,clabel,
     &                      ndathrb,nsecb,ndathre,nsece)
            elseif(i2dmet.EQ.1)then
c ---        NOOBS CALMET output format - 2D arrays -
             call rdr2d(in,itime,tempk2d,xbuf,mxnx,mxny,nx,ny,clabel,
     &                  ndathrb,nsecb,ndathre,nsece,ieof)
             call rdr2d(in,itime,rho2d,xbuf,mxnx,mxny,nx,ny,clabel,
     &                  ndathrb,nsecb,ndathre,nsece,ieof)
             call rdr2d(in,itime,qsw2d,xbuf,mxnx,mxny,nx,ny,clabel,
     &                  ndathrb,nsecb,ndathre,nsece,ieof)
             call rdi2d(in,itime,irh2d,ibuf,mxnx,mxny,nx,ny,clabel,
     &                  ndathrb,nsecb,ndathre,nsece)

 1550        if(npsta.ne.0) call rdi2d(in,itime,ipcode2d,ibuf,
     &                  mxnx,mxny,nx,ny,clabel,
     &                  ndathrb,nsecb,ndathre,nsece)
            endif

         endif   ! end of irtype

c        Finished reading one period of CALMET data
         ihrfile=ihrfile+1

c ---    Break out date-time components
c ---    End of period
         call DEDAT(ndathre,iyre,jdaye,ihre)
         call YR4(ilog,iyre,ierr)
         if(ierr.NE.0) stop 'Halted in CLMEXT - Y2K'
         call GRDAY(ilog,iyre,jdaye,imone,idaye)
c ---    Start of period
         if(itime.EQ.0) then
c ---       Compute the begin-time of the period
c ---       (always hourly data)
            iyrb=iyre
            jdayb=jdaye
            ihrb=ihre
            nhrinc=-1
            call INCR(ilog,iyrb,jdayb,ihrb,nhrinc)
            call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
            call TIMESTAMP(iyrb,jdayb,ihrb,ndathrb)
         else
            call DEDAT(ndathrb,iyrb,jdayb,ihrb)
            call YR4(ilog,iyrb,ierr)
            if(ierr.NE.0) stop 'Halted in CLMEXT - Y2K'
            call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
         endif

c         print 9, ndathrb,nsecb,ndathre,nsece
c 9       format(' Reading: ',i12,2x,i4.4,'   To ',i12,2x,i4.4)
c 9       format('+Reading: ',i12,2x,i4.4,'   To ',i12,2x,i4.4)
c
c --- (CEC - 090203) Check that time step in CALMET is smaller or equal to time step requested
         call DELTSEC(ndathrb,nsecb,ndathre,nsece,ndelsec)
         if(ndelsec.gt.isecstep) then
            write(ilog,*)'ERROR - Time step requested is smaller than'
            write(ilog,*)'CALMET.DAT time step'
            write(*,*)'ERROR - Time step requested is smaller than'
            write(*,*)'CALMET.DAT time step'
            stop
         endif
c --- (CEC - 090203) Compute number of time step in current CALMET file
         if(ihrfile.eq.1) islg=int(ndelsec0/ndelsec)
c
c ---    Screen for start-time
         call TIMESTAMP(iyrb,jdayb,ihrb,idate1)
c --- (CEC -090203 - checking of time stamp is now done in seconds)
c ---    Compute difference in seconds between current date 
c        in the time period step and date of current reading in CALMET
         call DELTSEC(idate1,nsecb,idate0,isec0,ndelsec)
c         if(idate1.LT.idate0 .and. ihrfile.LT.irlg) then
         if(ndelsec.gt.0 .and. ihrfile.lt.islg) then
            goto 1000
c         elseif(idate1.LT.idate0 .and. ihrfile.EQ.irlg) then
         elseif(ndelsec.gt.0 .and. ihrfile.eq.islg) then
c ---       Get next CALMET file
            goto 6500
         elseif(ndelsec.lt.0) then
c ---       Date requested by user is before first date of CALMET.DAT
            write(ilog,*)'ERROR - first CALMET data file starts later' 
            write(ilog,*)'than date selected.'  
            write(ilog,*)'First date in CALMET =',idate1,nsecb
            write(*,*)'ERROR - first CALMET data file starts later' 
            write(*,*)'than date selected.'  
            write(*,*)'First date in CALMET =',idate1,nsecb
            stop
         endif

         ihrclm=ihrclm+1
         print 19,ihrclm,idate1,nsecb
c19       format(' Extracting Period: ',i6, ' Start Time: ',2i9)
19       format('+Extracting Period: ',i6, ' Start Time: ',2i9)

c --- V1.9.0, Level 121203
c ---    Condition time outside of loop over locations since the
c ---    time is the same for all
c ---    Convert seconds = 3600 to zero (increment hour, check date)
         nhrp1=1
         if(nsecb.EQ.3600) then
            nsecb=0
            call INCR(ilog,iyrb,jdayb,ihrb,nhrp1)
            call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
         endif
         if(nsece.EQ.3600) then
            nsece=0
            call INCR(ilog,iyre,jdaye,ihre,nhrp1)
            call GRDAY(ilog,iyre,jdaye,imone,idaye)
         endif

c ---    Swap date and end-time into variables for output
         iyout=iyre
         imout=imone
         idout=idaye
         jdout=jdaye
         ihout=ihre
c ---    Apply Midnight Convention to end-time
         if(imidnite.EQ.1 .AND. ihout.EQ.24) then
           ihout=0
           call MIDNITE(ilog,'TO 00h',iyre,imone,idaye,jdaye,
     &                                iyout,imout,idout,jdout)
         elseif(imidnite.EQ.2 .AND. ihout.EQ.0
     &                        .AND. nsece.EQ.0) then
           ihout=24
           call MIDNITE(ilog,'TO 24h',iyre,imone,idaye,jdaye,
     &                                iyout,imout,idout,jdout)
         endif

         iloc=1
 2050    continue

c        Extract data at needed grids
c -----------------------------------
c        Vertical interpolation first
         do igrd=1,4
            if(igrd.eq.1) then
               ii=ngrdexts(1,iloc)
               jj=ngrdexts(3,iloc)
            elseif(igrd.eq.2) then
               ii=ngrdexts(2,iloc)
               jj=ngrdexts(3,iloc)
            elseif(igrd.eq.3) then
               ii=ngrdexts(1,iloc)
               jj=ngrdexts(4,iloc)
            elseif(igrd.eq.4) then
               ii=ngrdexts(2,iloc)
               jj=ngrdexts(4,iloc)
            endif

            z0ext=z0(ii,jj)
            hext=zwind(iloc)

            do iz=1,nz
               prf(iz)=u(ii,jj,iz)
            enddo

c --- (090318 CEC - vertical interpolation is done only if wind is required)
            if(lwind(iloc).and.hext.gt.0.0) then
            call interpv(zht,prf,z0ext,hext,nz,pext)
            uprf(igrd)=pext
            elseif(lwind(iloc).and.hext.eq.0.0) then
            uprf(igrd)=0.0
            else
            uprf(igrd)=prf(1)
            endif

            do iz=1,nz
               prf(iz)=v(ii,jj,iz)
            enddo

c --- (090318 CEC - vertical interpolation is done only if wind is required)
            if(lwind(iloc).and.hext.gt.0.0) then
            call interpv(zht,prf,z0ext,hext,nz,pext)
            vprf(igrd)=pext
            elseif(lwind(iloc).and.hext.eq.0.0) then
            vprf(igrd)=0.0
            else
            vprf(igrd)=prf(1)
            endif
c ---
c --- (CEC - 090203 - Add vertical interpolation of temperature)
            if(ztmpk(iloc).gt.0) then
	     if(ztmpk(iloc).lt.zht(1).or.ztmpk(iloc).gt.zht(nz)) then
           write(ilog,*)'ERROR - extraction of temperature below' 
           write(ilog,*)'the first level of CALMET or above'
           write(ilog,*)'the upper level of CALMET can not be performed'
           write(ilog,*)'First level of CALMET = ',zht(1),'meters'
           write(ilog,*)'Upper level of CALMET = ',zht(nz),'meters'
	      write(*,*)'ERROR - extraction of temperature below' 
              write(*,*)'the first level of CALMET or above'
              write(*,*)'the upper level of CALMET can not be performed'
              write(*,*)'First level of CALMET = ',zht(1),'meters'
              write(*,*)'Upper level of CALMET = ',zht(nz),'meters'
              stop
             endif
            endif
            if(lcalgrd.and.irtype.eq.1.and.ztmpk(iloc).ne.-1.)then 
              hextt=ztmpk(iloc)
              do iz=1,nz
                 prf(iz)=ztemp(ii,jj,iz)
              enddo
              call interpv(zht,prf,z0ext,hextt,nz,pext)
              tprf(igrd)=pext
            endif

c ---       Pull Temp and Rel Hum from surface 2D
c --        Extract Surface Pressure 
            if(i2dmet.EQ.1)then
               tk(igrd)=tempk2d(ii,jj)
c ---          Water vapor mixing ratio (g h2o/g air)
c ---          Use CALMET eqn for approximate pressure from air density
c ---          P(mb)=T(K)*RHO(kg/m3)*(287 m**2/(deg K * sec**2)) /
c ---                             (100 kg / (m * sec**2) per mb)
               pmb=tk(igrd)*rho2d(ii,jj)*2.87
               sfcpres(igrd)=pmb
               call VSAT(tk(igrd),psat,qsat)
               qr=0.622*(0.01*irh2d(ii,jj)*psat)/(pmb-psat)
c ---          Convert to spec hum (g/kg)
               qq(igrd)=1000.*(qr/(1.0+qr))
            else
               tk(igrd)=0.0
               qq(igrd)=0.0
               sfcpres(igrd)=0.0         
            endif

c ---       Pull other 2D parameters
            if(irtype.eq.1 .and. lother(iloc))then
             xqzi(igrd)=zi(ii,jj)
               if(npsta.ne.0) then
                xqrmm(igrd)=rmm(ii,jj)
               else
                xqrmm(igrd)=9999.
               endif
             xqust(igrd)=ustar(ii,jj)
             xqmob(igrd)=el(ii,jj)
             iqstcl(igrd)=ipgt(ii,jj)
             xqcvv(igrd)=wstar(ii,jj)
              if(i2dmet.EQ.1)then
               xqsw(igrd)=qsw2d(ii,jj)
               xqrh(igrd)=float(irh2d(ii,jj))
              else
               xqsw(igrd)=9999.
               xqrh(igrd)=9999
              endif
            else
             xqzi(igrd)=9999.
             xqrmm(igrd)=9999.
             xqust(igrd)=9999.
             xqmob(igrd)=9999.
             iqstcl(igrd)=9999
             xqcvv(igrd)=9999.
             xqsw(igrd)=9999.
             xqrh(igrd)=9999
            endif
c
         enddo

c        Horizontal interpolation
         do i=1,4
            wgt(i)=wgts(i,iloc)
         enddo

         call interphuv(metsimc,uprf,vprf,wgt,wsfin,wdfin)
c         print *,'Main: ',wsfin,wdfin

c        Rotate map wind to true wind when not calm
         if(llconfm .AND. wsfin.GT.0.0) then
c            print *,wdfin,wdrot(iloc)
            wdfin=wdfin+wdrot(iloc)
            if(wdfin .le. 0.) wdfin=wdfin+360.
            if(wdfin .gt. 360.) wdfin=wdfin-360.
         endif

c --- (CEC - 090203 - 2Dtemperature is replaced by vertically interpolated temperature
          if(lcalgrd.and.irtype.eq.1)then 
           call interph(metsimc,tprf,wgt,tkfin)
          else
           call interph(metsimc,tk,wgt,tkfin)
          endif
          call interph(metsimc,qq,wgt,qqfin)

          if( i2dmet.eq.1 .and. lother(iloc)) then
             call interph(metsimc,sfcpres,wgt,sfcpfin)
          else
             sfcpfin=9999.
          endif
c
            if(irtype.eq.1 .AND. lother(iloc))then
             call interph(metsimc,xqzi,wgt,zifin)
              if(npsta.ne.0) then
                call interph(metsimc,xqrmm,wgt,rmmfin)
              else
                rmmfin=9999.
              endif
             call interph(metsimc,xqust,wgt,ustfin)
c             call interph(metsimc,xqmob,wgt,xmobfin)
             call interphinv(metsimc,xqmob,wgt,xmobfin)
             call INEAREST(iqstcl,wgt,isclfin)
             call interph(metsimc,xqcvv,wgt,cvvfin)
              if(i2dmet.EQ.1)then
               call interph(metsimc,xqsw,wgt,swfin)
               call interph(metsimc,xqrh,wgt,rhfin)
              else
               swfin=9999.
               rhfin=9999.
              endif
            else
             zifin=9999.
             rmmfin=9999.
             ustfin=9999.
             xmobfin=9999.
             isclfin=9999
             cvvfin=9999.
             swfin=9999.
             rhfin=9999.
            endif
c
c        Output
         io=iout+iloc
c --- V1.9.0, Level 121203
         call Outputcal(io,iyrb,imonb,idayb,ihrb,nsecb,
     &       iyout,imout,idout,ihout,nsece,
     &       wdfin,wsfin,tkfin,qqfin,zifin,rmmfin,ustfin,xmobfin,
     &       isclfin,cvvfin,swfin,rhfin,sfcpfin,
     &       lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))

         iloc=iloc+1

         if(iloc.le.ntsfout) goto 2050

c --- (CEC - 090304 - get timestamp for last date/time extracted in LST)
         call TIMESTAMP(iyre,jdaye,ihre,idatel)

c        Set timestamp for next period (equals end of this period)
c --- (CEC -090203 - next period is now - begining of period of current hour 
c                       + time step in seconds (isecstep))
         nsec=isecstep
         call JULDAY(ilog,iyrb,imonb,idayb,jdayb)             
         call INCRS(ilog,iyrb,jdayb,ihrb,nsecb,nsec)
         call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
         call TIMESTAMP(iyrb,jdayb,ihrb,idate0)
         isec0=nsecb

c         if(ihrclm.lt.nhrext .and. ihrfile.lt.irlg) goto 1000
         if(ihrclm.lt.nbsecext .and. ihrfile.lt.islg) goto 1000

c        close one CALMET file, start another one
 6500    close(in)

 6000 enddo

       if(ihrclm.lt.nbsecext) then
         write(ilog,*)
         write(ilog,*)'Error: Not all periods were extracted'
      write(ilog,*)'Header Ending date do not match last record of data'
         write(ilog,*)'Periods Extracted: ',ihrclm
         write(ilog,*)'Periods Requested: ',nbsecext
         write(ilog,*)'Last time extracted (LST): ',idatel,nsece
         write(ilog,*)'Last time needed (LST): ',iedathrc,iesecc
         write(*,*)
         print *,'Error: Not all periods were extracted'
         print *,'Header Ending date do not match last record of data'
         print *,'Periods Extracted: ',ihrclm
         print *,'Periods Requested: ',nbsecext
         print *,'Last time extracted (LST): ',idatel,nsece
         print *,'Last time needed (LST): ',iedathrc,iesecc
      else
         write(*,*)
         write(ilog,'(a)')'CALMET.DAT data extraction completed'
      endif

      return
      end

c ---------------------------------------------------------------------
      Subroutine ws2uv(iwd,ws,u,v,nz)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Convert profiles of WS/WD to U/V 
c
c --- UPDATES
c --- Version 1.0, Level 060615 to Version 1.66, Level 090731 (DGS)
c     1. Set FACTOR locally instead of in PARAMS.SER
c ---------------------------------------------------------------------

      include 'params.ser'
      dimension iwd(mxnz),ws(mxnz)
      dimension u(mxnz),v(mxnz)
      data factor/57.2957795/

      do k=1,nz
         fwd=iwd(k)/factor
         fws=ws(k)
         u(k)=-fws*sin(fwd)
         v(k)=-fws*cos(fwd)
      enddo

      return
      end

c ---------------------------------------------------------------------
      Subroutine ws2uvr(wd,ws,u,v)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Francoise  Robe         
c
c --- PURPOSE: Convert WS/WD to U/V (WD real)
c
c --- UPDATES
c --- Version 1.45, Level 080627 to Version 1.66, Level 090731 (DGS)
c     1. Set FACTOR locally instead of in PARAMS.SER
c ---------------------------------------------------------------------
      include 'params.ser'
      data factor/57.2957795/

      fwd=wd/factor
      u=-ws*sin(fwd)
      v=-ws*cos(fwd)

      return
      end

c ---------------------------------------------------------------------
      Subroutine uv2ws(uu,vv,iwd,ws)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Convert profiles of U/V to WS/WD 
c
c --- UPDATES
c --- Version 1.0, Level 060615 to Version 1.66, Level 090731 (DGS)
c     1. Set FACTOR locally instead of in PARAMS.SER
c ---------------------------------------------------------------------
      include 'params.ser'
      data factor/57.2957795/

      ss=sqrt(uu*uu+vv*vv)
         
      if(ss.lt.1.0E-5) then
         angle=0
      else
         angle = 270.-atan2(vv,uu)*factor
      endif

      angle = amod(angle,360.)
      
      iangle=nint(angle)
      if (iangle .eq. 0) iangle = 360
      
      iwd=iangle
      ws=ss

      return
      end
c ---------------------------------------------------------------------
      Subroutine uv2wsr(uu,vv,wd,ws)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Francoise Robe          
c
c --- PURPOSE: Convert  U/V to WS/WD (real)
c
c --- UPDATES
c --- Version 1.45, Level 080627 to Version 1.66, Level 090731 (DGS)
c     1. Set FACTOR locally instead of in PARAMS.SER
c ---------------------------------------------------------------------
      include 'params.ser'
      data factor/57.2957795/

      ws=sqrt(uu*uu+vv*vv)
         
      if(ws.lt.1.0E-5) then
         wd=0.
      else
         angle = 270.-atan2(vv,uu)*factor
      endif

      wd = amod(angle,360.)
 
      return
      end

c ---------------------------------------------------------------------
      subroutine getfmt(ioutw,ioutq,ioutc,iouti,ioutg,idvar,frmt,nvar)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 080822
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Determine read format for 3D.DAT
c
c --- Version 1.44, Level 080102 to Version 1.46, Level 080822
c     1. remove the possibility to read the mixing ratios
c        recorded after vapor mixing ratio (CEC)
c ---------------------------------------------------------------------
      include 'params.ser'

c      parameter (nvar_out=8)    ! new output variables in MM5 format
       parameter (nvar_out=3)    ! CEC - 080520 - other mixing ratios not read
      dimension idvar(nvar_out)
      character*80 frmt

c     Initialize idvar
      do k=1,nvar_out
         idvar(k)=0
      enddo

c     Vertical velocity (w, m/s)
      if(ioutw.eq.1) idvar(1)=1

c      RH(%) and q(g/kg) 
      if(ioutq.eq.1) then    
         idvar(2)=1
         idvar(3)=1
      endif

c --- CEC - 080520 - removed the possibility to read the following mixing ratios
c ---  not needed in METSERIES
c     cloud/rain mixing ratio (g/kg)
c      if(ioutc.eq.1) then
c         idvar(4)=1
c         idvar(5)=1
c      endif

c     ice/snow mixing ratio (g/kg)
c      if(iouti.eq.1) then    
c         idvar(6)=1
c         idvar(7)=1
c      endif

c     graupel mixing ratio (g/kg)
c      if(ioutg.eq.1) idvar(8)=1    

      nvar=0
      frmt(1:20)='(i4,i6,f6.1,i4,f5.1,'
      ic1=21
      do i=1,nvar_out
         if(idvar(i).eq.1) then
            nvar=nvar+1
            if(i.eq.1) then
               nc=5
               ni=6
            elseif(i.eq.2) then
               nc=3
               ni=3
            else
               nc=5
               ni=5
            endif
               
            ic2=ic1+nc-1
            if(i.eq.2) then
               write(frmt(ic1:ic2),1050)ni
            else
               write(frmt(ic1:ic2),1051)ni
            endif
 1050       format('i',i1,',')
 1051       format('F',i1,'.2,')

            ic1=ic2+1

         endif
      enddo

      frmt(ic2:ic2)=')'

      if(nvar.gt.nvar_out) then
         write(ilog,*)'Error: Max. NVar in MM5 is ',nvar_out
         write(ilog,*)'NVAR here is:',nvar
         stop 03
      endif

      return
      end

c ---------------------------------------------------------------------
      Subroutine getmm5z0(landuse,imon,iday,nland,z00)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060615
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Determin MM5 z00 used in vertical wind interpolation
c
c ---------------------------------------------------------------------
      include 'params.ser'

      parameter(ntype=3)
      dimension z01(13,2),z02(16,2),z03(24,2)

c     Z01 values used by MM5 13 Land use categories (units: cm)
      data z01/50,15,12,50,50,40,0.01,20,10,10,5,50,15,
     &        50, 5,10,50,50,40,0.01,20,10,10,5,50,15/

c     Z02 values used by MM5 17 Land use categories (units: cm)
c     (only 16 categories)
      data z02/50,50,40,50,50,15,0.12,12,12,10,10,15,20,12,0.01,5,
     &         50,50,40,50,50,15,0.10,10,10,10,10, 5,20,12,0.01,5/

c     Z03 values used by MM5 13 Land use categories (units: cm)
c     (only 24 categories)
      data z03/50,15,15,15,14,20,0.12,10,11,15,50,50,50,50,50,0.01,
     &         20,40,10,10,30,15,0.10,5,
     &         50, 5, 5, 5, 5,20,0.10,10,10,15,50,50,50,50,50,0.01,
     &         20,40,10,10,30,15,   5,5/

c Revised on 9/21/2000. Summer is from 4/15 - 10/15.
      isum=2
      if(imon.gt.4 .and. imon.lt.10) isum=1
      if(imon.eq.4 .and. iday.ge.15) isum=1
      if(imon.eq.10 .and. iday.le.15) isum=1

      if(nland.eq.13) then
         z00=z01(landuse,isum)/100.
      elseif(nland.eq.17) then
         z00=z02(landuse,isum)/100.
      elseif(nland.eq.25) then
         z00=z03(landuse,isum)/100.
      else
         write(ilog,*)'Ilegal LandUse Number'
         write(ilog,*)'NLand = ',nland
         write(ilog,*)'Allowed LandUse Numbers: 13, 17, 25'
         print *,'Ilegal LandUse Number'
         print *,'NLand = ',nland
         print *,'Allowed LandUse Numbers: 13, 17, 25'
         stop
      endif

      return
      end

c ---------------------------------------------------------------------
      Subroutine interpv(zht,ss,z00,hext,nz,sext)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060620
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Vertical interpolate wind speed and wind direction
c               Using logarithm method when hext below 100 m,
c               otherwise use linear interpolation
c
c --- UPDATES:
c --- Version 1.0, Level 060615 to Version 1.1, Level 060620 (DGS)
c       1.  Compute height above the surface before calling sub,
c           as zht(), and remove hsrf from call
c
C Changes from V1.5 L030619  to V1.5 L030626 (Minor change)
C   1. Remove the check of extraction height in sub. interpv,
C      which is not needed, and may cause failur of extraction

c --- Changes from V1.0 L030129 to V1.01 L030519
c       1. Relax the checks of hsrf and hext < 0
c       2. Replace the check by hexe > hsrf check
c     Zhong Wu
c     5/19/2003
C
C   Input:
C     zht array: Vertical profile of height (above surface)
C     ss array: Vertical profile of scale wind (u, v, or ws)
C     Z00: Surface friction length
C     nz: Number of levels in vertical profile
C     hext: Extraction height (m) above the ground
C   Output
C     sext: Extracted scale wind at extraction height hext
c
c ---------------------------------------------------------------------
      include 'params.ser'

      dimension zht(mxnz),ss(mxnz)

c     Check z00
      if(z00.eq.0) then
         write(ilog,*)'z00 is zero: ',z00
         write(ilog,*)'interpv stopped'
         stop 'HALTED: Stopped in INTERPV'
      endif

c     Find the first level above hext
      itop=1
      do k=1,nz
         if(zht(k).ge.hext) then
            itop=k
            goto 1000
         endif
      enddo

      write(ilog,*)'Vertical Interpolation Failed:'
      write(ilog,*)'Extraction height out of model top: ',hext
      stop 24

 1000 continue
      
C     Log interpolation below first model level
      if(itop.eq.1) then
         h2=zht(itop)
         s2=ss(itop)

         rr=log((hext+z00)/z00)/log((h2+z00)/z00)
         sext=s2*rr

C     Linear interpolation above
      else
         h1=zht(itop-1)
         s1=ss(itop-1)
         h2=zht(itop)

         if(h1.ge.h2) then
            write(ilog,*)'Error: h2=h1 ',h1,h2
            print *,'Error: h2=h1 ',h1,h2
            stop
         endif

         s2=ss(itop)
         rr=(hext-h1)/(h2-h1)
         ds=s2-s1
         sext=s1+ds*rr
      endif

      return
      end

c ---------------------------------------------------------------------
      subroutine interphmm5(wsintp,wdintp,wgt,wsfin,wdfin)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060615
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Horizontal interpolation of wind speed and wind
c               direction
c ---------------------------------------------------------------------

      dimension wsintp(4),wdintp(4),wgt(4)
      dimension u(4),v(4)
      data factor/57.2957795/

      do i=1,4
         fwd=wdintp(i)/factor
         fws=wsintp(i)
         u(i)=-fws*sin(fwd)
         v(i)=-fws*cos(fwd)
      enddo

      uext=u(1)*wgt(1)*wgt(3)+u(2)*wgt(2)*wgt(3)+
     &     u(3)*wgt(1)*wgt(4)+u(4)*wgt(2)*wgt(4)
      vext=v(1)*wgt(1)*wgt(3)+v(2)*wgt(2)*wgt(3)+
     &     v(3)*wgt(1)*wgt(4)+v(4)*wgt(2)*wgt(4)

c      print *,'Check Hori-interp'
c      print *, u(1)*wgt(1),u(2)*wgt(2),wgt(3)
c      print *, u(3)*wgt(1),u(4)*wgt(2),wgt(4)
c      print *, v(1)*wgt(1),v(2)*wgt(2),wgt(3)
c      print *, v(3)*wgt(1),v(4)*wgt(2),wgt(4)

c      print *, (u(1)*wgt(1)+u(2)*wgt(2))*wgt(3)
c      print *, (u(3)*wgt(1)+u(4)*wgt(2))*wgt(4)
c      print *, (v(1)*wgt(1)+v(2)*wgt(2))*wgt(3)
c      print *, (v(3)*wgt(1)+v(4)*wgt(2))*wgt(4)

      wsfin=sqrt(uext*uext+vext*vext)
      if(wsfin.lt.1.0E-5) then
         angle=0
      else
         angle = 270.-atan2(vext,uext)*factor
      endif
      wdfin = amod(angle,360.)      

c      if (wdfin .eq. 0.) wdfin = 360.

c      print *,'Check in interphmm5'
c      print *,wsintp
c      print *,wdintp
c      print *,wgt(1),wgt(2),wgt(3),wgt(4)
c      print *,u
c      print *,v
c      print *,uext,vext
c      print *,wsfin,wdfin
c      print *,'Check end'

c      print *,'End of interphmm5'

      return
      end

c ---------------------------------------------------------------------
      subroutine interphclm(u,v,wgt,wsfin,wdfin)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060615
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Horizontal interpolation of wind speed and wind
c               direction
c ---------------------------------------------------------------------

      dimension u(4),v(4),wgt(4)
      data factor/57.2957795/

      uext=u(1)*wgt(1)*wgt(3)+u(2)*wgt(2)*wgt(3)+
     &     u(3)*wgt(1)*wgt(4)+u(4)*wgt(2)*wgt(4)
      vext=v(1)*wgt(1)*wgt(3)+v(2)*wgt(2)*wgt(3)+
     &     v(3)*wgt(1)*wgt(4)+v(4)*wgt(2)*wgt(4)

c      print *,'Check Hori-interp'
c      print *, u(1)*wgt(1),u(2)*wgt(2),wgt(3)
c      print *, u(3)*wgt(1),u(4)*wgt(2),wgt(4)
c      print *, v(1)*wgt(1),v(2)*wgt(2),wgt(3)
c      print *, v(3)*wgt(1),v(4)*wgt(2),wgt(4)

c      print *, (u(1)*wgt(1)+u(2)*wgt(2))*wgt(3)
c      print *, (u(3)*wgt(1)+u(4)*wgt(2))*wgt(4)
c      print *, (v(1)*wgt(1)+v(2)*wgt(2))*wgt(3)
c      print *, (v(3)*wgt(1)+v(4)*wgt(2))*wgt(4)

      wsfin=sqrt(uext*uext+vext*vext)

      if(wsfin.lt.1.0E-5) then
c         print *,'Check CALM wind in interphclm'
c         print *,wgt
c         print *,u
c         print *,v
c         print *,uext,vext
c         print *,wsfin   !,wdfin
c         print *,'Check end'
         wsfin=0
         wdfin=0
      else
         angle = 270.-atan2(vext,uext)*factor
         wdfin = amod(angle,360.)      
         if (wdfin .eq. 0.) wdfin = 360.
      endif

c      print *,'End of interphclm'

      return
      end


c ---------------------------------------------------------------------
      subroutine interph(msim,x,wgt,y)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Horizontal interpolation
c
c --- UPDATES:
c
c --- Version 1.0, Level 060615 to Version 1.66, Level 090731 (DGS)
c       1.  Add interpolation method choice MSIM
c            1 = Bilinear Interpolation
c            2 = Nearest grid point
c
c ---------------------------------------------------------------------

      dimension x(4),wgt(4)

      if(msim.EQ.2) then
c ---    Do nearest point
         call RNEAREST(x,wgt,y)
      else
c ---    Do bilinear
         y=x(1)*wgt(1)*wgt(3)+x(2)*wgt(2)*wgt(3)+
     &     x(3)*wgt(1)*wgt(4)+x(4)*wgt(2)*wgt(4)
      endif

      return
      end

c ---------------------------------------------------------------------
      subroutine interphinv(msim,x,wgt,y)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Horizontal interpolation for monin-obukhov length
c
c --- UPDATES:
c
c --- Version 1.0, Level 060615 to Version 1.66, Level 090731 (DGS)
c       1.  Add interpolation method choice MSIM
c            1 = Bilinear Interpolation
c            2 = Nearest grid point
c
c ---------------------------------------------------------------------

      dimension x(4),wgt(4)
      real X1,X2,X3,X4,Y1

      if(msim.EQ.2) then
c ---    Do nearest point
         call RNEAREST(x,wgt,y)
      else
c ---    Do bilinear interpolation of reciprocals
         X1=1./x(1)
         X2=1./x(2)
         X3=1./x(3)
         X4=1./x(4)
         Y1=X1*wgt(1)*wgt(3)+X2*wgt(2)*wgt(3)+
     &      X3*wgt(1)*wgt(4)+X4*wgt(2)*wgt(4)
         y=1./Y1
      endif

      return
      end

c ---------------------------------------------------------------------
      subroutine inearest(ix,wgt,iy)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- D. Strimaitis
c
c --- PURPOSE:  Select the closest of the 4 points and process integers
c
c          3 ---c--- 4    * Position of corners in W and IX arrays (1-4)
c          |    | o  |    * Position given the largest weight (W) is
c          |----b--a-|      nearest the current location (o)
c          |    |    |    * When location is midway between 2 or 4
c          1 ------- 2      corners, corner above and/or to the right
c                           is selected (corner 4 is selected for
c                           all locations a, b and c).
c ---------------------------------------------------------------------

      integer ix(4),iy
      real wgt(4),w(4)

      w(1)=wgt(1)*wgt(3)
      w(2)=wgt(2)*wgt(3)
      w(3)=wgt(1)*wgt(4)
      w(4)=wgt(2)*wgt(4)

      wmax=w(1)
      k=1
      do i=2,4
         if(w(i).GE.wmax) then
            wmax=w(i)
            k=i
         endif
      enddo
      iy=ix(k)

      return
      end

c ---------------------------------------------------------------------
      subroutine rnearest(x,wgt,y)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- D. Strimaitis
c
c --- PURPOSE:  Select the closest of the 4 points and process reals
c
c          3 ---c--- 4    * Position of corners in W and X arrays (1-4)
c          |    | o  |    * Position given the largest weight (W) is
c          |----b--a-|      nearest the current location (o)
c          |    |    |    * When location is midway between 2 or 4
c          1 ------- 2      corners, corner above and/or to the right
c                           is selected (corner 4 is selected for
c                           all locations a, b and c).
c ---------------------------------------------------------------------

      real x(4),y
      real wgt(4),w(4)

      w(1)=wgt(1)*wgt(3)
      w(2)=wgt(2)*wgt(3)
      w(3)=wgt(1)*wgt(4)
      w(4)=wgt(2)*wgt(4)

      wmax=w(1)
      k=1
      do i=2,4
         if(w(i).GE.wmax) then
            wmax=w(i)
            k=i
        endif
      enddo
      y=x(k)

      return
      end

c ---------------------------------------------------------------------
      subroutine chgtim(iyr,imon,iday,ihour,idt)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060615
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Increase or decrease hours. 
c               Used to convert Local Stand Time to GMT or to setup
c               time stamp for loop
c ---------------------------------------------------------------------

      parameter(nmonth=12)

      dimension ndays(nmonth)

      data ndays/31,28,31,30,31,30,31,31,30,31,30,31/

      if(iyr/4 .eq. iyr/4.0) then
         ndays(2)=29 
      else
         ndays(2)=28
      endif

      ihour=ihour+idt

      if(idt.lt.0) goto 2000

 1000 if(ihour.gt.23) then
         ihour=ihour-24
         iday=iday+1
         
         if(iday.gt.ndays(imon)) then
            iday=1
            imon=imon+1
            
            if(imon.gt.12) then
               imon=1
               iyr=iyr+1
               if(iyr/4 .eq. iyr/4.0) then
                  ndays(2)=29 
               else
                  ndays(2)=28
               endif
            endif
         endif
         goto 1000
      else
         return
      endif

 2000 continue

 3000 if(ihour.lt.0) then
         ihour=ihour+24
         iday=iday-1
         
         if(iday.le.0) then
            imon=imon-1
            if(imon.le.0) then
               iyr=iyr-1
               imon=12
               if(iyr/4 .eq. iyr/4.0) then
                  ndays(2)=29 
               else
                  ndays(2)=28
               endif
            endif
   
            iday=ndays(imon)
         endif
         goto 3000
      else
         return
      endif

      end

c ---------------------------------------------------------------------
      subroutine timestamp(iyr,ijulday,ihour,jdate) 
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090318
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Get time stamp
c ---------------------------------------------------------------------
c --- All dates are Julian (not Gregorian) and integer returned is
c --- YYYYJJJHH format

      jdate=ihour+ijulday*100+iyr*100000

      return
      end

c ---------------------------------------------------------------------
      subroutine getdate(ndate,iyr,imon,iday,ihour)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100721

c --- NDATE must be Gregorian YYYYMMDDHH format (not Julian)
      iyr=ndate/1000000
      imon=ndate/10000-iyr*100
      iday=ndate/100-iyr*10000-imon*100
      ihour=ndate-iyr*1000000-imon*10000-iday*100
      
c      print *,ndate
c      print *,iyr,imon,iday,ihour

      return
      end
c ---------------------------------------------------------------------
      Subroutine Output(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyre,imone,idaye,ihoure,isece,
     &                  wd,ws,t,q,
     &                  lwind,ltemp,lshum)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060615
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Output time series
c ---------------------------------------------------------------------

      logical lwind,ltemp,lshum


      if(LWIND .AND. LTEMP .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q
      elseif(LWIND .AND. LTEMP) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t
      elseif(LWIND .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q
      elseif(LWIND) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws
      elseif(LTEMP .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q
      elseif(LTEMP) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t
      elseif(LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q
      endif
 1010 format(2(i5,3i3,1x,i4.4),4f10.3)

      return
      end

c ---------------------------------------------------------------------
      Subroutine Outputcal(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyre,imone,idaye,ihoure,isece,
     &                  wd,ws,t,q,zi,rmm,ust,xmob,iscl,cvv,sw,rh,
     &                  sfcpres,lwind,ltemp,lshum,lother)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Output time series
c
c --- UPDATES:
c
c --- Version 1.661 Level 090817 to Version 1.9.0 Level 121203
c      1. Write out surface pressure if OTHER=1. (units: mb)
c
c --- Version 1.66, level 090731 to Version 1.661, level 090817 (DGS)
c      1. Expand output field for M-O length, using EXP notation
c
c ---------------------------------------------------------------------

      logical lwind,ltemp,lshum,lother
      integer iscl,irh
      real zi,rmm,ust,xmob,cvv,sw,rh
      real sfcpres

	irh=int(rh)

      if(LWIND .AND. LTEMP .AND. LSHUM .AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,zi,rmm,ust,xmob,cvv,sw,iscl,irh
     &                ,sfcpres
      elseif(LWIND .AND. LTEMP . AND. LOTHER) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,zi,rmm,ust,xmob,cvv,sw,iscl,irh
     &                ,sfcpres
      elseif(LWIND .AND. LSHUM. AND. LOTHER) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,zi,rmm,ust,xmob,cvv,sw,iscl,irh
     &                ,sfcpres
      elseif(LWIND . AND. LOTHER) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,zi,rmm,ust,xmob,cvv,sw,iscl,irh
     &                ,sfcpres
      elseif(LTEMP .AND. LSHUM . AND. LOTHER) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,zi,rmm,ust,xmob,cvv,sw,iscl,irh
     &                ,sfcpres
      elseif(LTEMP .AND. LOTHER) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,zi,rmm,ust,xmob,cvv,sw,iscl,irh
     &                ,sfcpres
      elseif(LSHUM .AND. LOTHER) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,zi,rmm,ust,xmob,cvv,sw,iscl,irh
     &                ,sfcpres
      elseif(LOTHER) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 zi,rmm,ust,xmob,cvv,sw,iscl,irh
     &                ,sfcpres
      elseif(LWIND .AND. LTEMP .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q
      elseif(LWIND .AND. LTEMP) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t
      elseif(LWIND .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q
      elseif(LWIND) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws
      elseif(LTEMP .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q
      elseif(LTEMP) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t
      elseif(LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q
      endif

c --- Use EXP notation for M-O length
c 1010 format(2(i5,3i3,1x,i4.4),10f10.3,2i10)
c 1011 format(2(i5,3i3,1x,i4.4),9f10.3,2i10)
c 1012 format(2(i5,3i3,1x,i4.4),8f10.3,2i10)
c 1013 format(2(i5,3i3,1x,i4.4),7f10.3,2i10)
c 1014 format(2(i5,3i3,1x,i4.4),6f10.3,2i10)
 1010 format(2(i5,3i3,1x,i4.4),7f10.3,1pe13.5,0p,2f10.3,2i10,f10.3)
 1011 format(2(i5,3i3,1x,i4.4),6f10.3,1pe13.5,0p,2f10.3,2i10,f10.3)
 1012 format(2(i5,3i3,1x,i4.4),5f10.3,1pe13.5,0p,2f10.3,2i10,f10.3)
 1013 format(2(i5,3i3,1x,i4.4),4f10.3,1pe13.5,0p,2f10.3,2i10,f10.3)
 1014 format(2(i5,3i3,1x,i4.4),3f10.3,1pe13.5,0p,2f10.3,2i10,f10.3)

      return
      end

c ---------------------------------------------------------------------
      Subroutine Outputmm5(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyre,imone,idaye,ihoure,isece,
     &                  wd,ws,t,q,slvp,rmm,sw,sst,xrh,
     &                  lwind,ltemp,lshum,lother)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Output time series
c ---------------------------------------------------------------------

      logical lwind,ltemp,lshum,lother
      real slvp,rmm,sw,sst,xrh


      if(LWIND .AND. LTEMP .AND. LSHUM .AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,slvp,rmm,sw,sst,xrh
      elseif(LWIND .AND. LTEMP . AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,slvp,rmm,sw,sst,xrh
      elseif(LWIND .AND. LSHUM. AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,slvp,rmm,sw,sst,xrh
      elseif(LWIND . AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,slvp,rmm,sw,sst,xrh
      elseif(LTEMP .AND. LSHUM . AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,slvp,rmm,sw,sst,xrh
      elseif(LTEMP .AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,slvp,rmm,sw,sst,xrh
      elseif(LSHUM .AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,slvp,rmm,sw,sst,xrh
      elseif(LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 slvp,rmm,sw,sst,xrh
      elseif(LWIND .AND. LTEMP .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q
      elseif(LWIND .AND. LTEMP) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t
      elseif(LWIND .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q
      elseif(LWIND) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws
      elseif(LTEMP .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q
      elseif(LTEMP) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t
      elseif(LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q
      endif
 1010 format(2(i5,3i3,1x,i4.4),8f10.3,f8.0)

      return
      end

c ---------------------------------------------------------------------
      Subroutine Outputsrf(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyre,imone,idaye,ihoure,isece,
     &                  wd,ws,t,q,iccv,ich,pmb,ipcode,irh,
     &                  lwind,ltemp,lshum,lother)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Output time series
c ---------------------------------------------------------------------

      logical lwind,ltemp,lshum,lother
      real pmb
      integer iccv,ich,irh,ipcode


      if(LWIND .AND. LTEMP .AND. LSHUM .AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,pmb,iccv,ich,ipcode,irh
      elseif(LWIND .AND. LTEMP . AND. LOTHER) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,pmb,iccv,ich,ipcode,irh
      elseif(LWIND .AND. LSHUM. AND. LOTHER) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,pmb,iccv,ich,ipcode,irh
      elseif(LWIND . AND. LOTHER) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,pmb,iccv,ich,ipcode,irh
      elseif(LTEMP .AND. LSHUM . AND. LOTHER) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,pmb,iccv,ich,ipcode,irh
      elseif(LTEMP .AND. LOTHER) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,pmb,iccv,ich,ipcode,irh
      elseif(LSHUM .AND. LOTHER) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,pmb,iccv,ich,ipcode,irh
      elseif(LOTHER) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 pmb,iccv,ich,ipcode,irh
      elseif(LWIND .AND. LTEMP .AND. LSHUM) then
         write(io,1009)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q
      elseif(LWIND .AND. LTEMP) then
         write(io,1009)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t
      elseif(LWIND .AND. LSHUM) then
         write(io,1009)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q
      elseif(LWIND) then
         write(io,1009)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws
      elseif(LTEMP .AND. LSHUM) then
         write(io,1009)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q
      elseif(LTEMP) then
         write(io,1009)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t
      elseif(LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q
      endif
 1009 format(2(i5,3i3,1x,i4.4),4f10.3)
 1010 format(2(i5,3i3,1x,i4.4),5f10.3,4i10)
 1011 format(2(i5,3i3,1x,i4.4),4f10.3,4i10)
 1012 format(2(i5,3i3,1x,i4.4),3f10.3,4i10)
 1013 format(2(i5,3i3,1x,i4.4),2f10.3,4i10)
 1014 format(2(i5,3i3,1x,i4.4),1f10.3,4i10)

      return
      end

c ---------------------------------------------------------------------
      Subroutine Outputsfc(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyre,imone,idaye,ihoure,isece,
     &                  wd,ws,t,q,zi1,zi2,rmm,ust,xmob,cvv,xsen,icc,
     &                  lwind,ltemp,lshum,lother)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090203
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Output time series
c ---------------------------------------------------------------------

      logical lwind,ltemp,lshum,lother
      integer icc
      real zi1,zi2,rmm,ust,xmob,cvv,xsen


      if(LWIND .AND. LTEMP .AND. LSHUM .AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,zi1,zi2,rmm,ust,xmob,cvv,xsen,icc
      elseif(LWIND .AND. LTEMP . AND. LOTHER) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,zi1,zi2,rmm,ust,xmob,cvv,xsen,icc
      elseif(LWIND .AND. LSHUM. AND. LOTHER) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,zi1,zi2,rmm,ust,xmob,cvv,xsen,icc
      elseif(LWIND . AND. LOTHER) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,zi1,zi2,rmm,ust,xmob,cvv,xsen,icc
      elseif(LTEMP .AND. LSHUM . AND. LOTHER) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,zi1,zi2,rmm,ust,xmob,cvv,xsen,icc
      elseif(LTEMP .AND. LOTHER) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,zi1,zi2,rmm,ust,xmob,cvv,xsen,icc
      elseif(LSHUM .AND. LOTHER) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,zi1,zi2,rmm,ust,xmob,cvv,xsen,icc
      elseif(LOTHER) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 zi1,zi2,rmm,ust,xmob,cvv,xsen,icc
      elseif(LWIND .AND. LTEMP .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q
      elseif(LWIND .AND. LTEMP) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t
      elseif(LWIND .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q
      elseif(LWIND) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws
      elseif(LTEMP .AND. LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q
      elseif(LTEMP) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t
      elseif(LSHUM) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q
      endif
 1010 format(2(i5,3i3,1x,i4.4),11f10.3,i10)
 1011 format(2(i5,3i3,1x,i4.4),10f10.3,i10)
 1012 format(2(i5,3i3,1x,i4.4),9f10.3,i10)
 1013 format(2(i5,3i3,1x,i4.4),8f10.3,i10)
 1014 format(2(i5,3i3,1x,i4.4),7f10.3,i10)

      return
      end

c ---------------------------------------------------------------------
      Subroutine Outputw(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyre,imone,idaye,ihoure,isece,
     &                  wd,ws,t,q,xpmb,swrad,xprc,rh,
     &                  lwind,ltemp,lshum,lother)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Output time series
c ---------------------------------------------------------------------
c
      include 'metinp.ser'
c
      logical lwind,ltemp,lshum,lother
      real xpmb,swrad,xprc,rh

      if(LWIND .AND. LTEMP .AND. LSHUM .AND. LOTHER) then
         if(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xpmb,swrad,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,swrad,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xpmb,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xpmb,swrad,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xpmb,swrad,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,swrad,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,swrad,xprc
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xpmb,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xpmb,xprc
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xpmb,swrad
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xpmb
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,swrad
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q,rh
         endif
      elseif(LWIND .AND. LTEMP . AND. LOTHER) then
         if(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xpmb,swrad,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,swrad,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xpmb,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xpmb,swrad,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xpmb,swrad,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,swrad,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,swrad,xprc
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xpmb,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xpmb,xprc
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xpmb,swrad
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xpmb
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,swrad
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,rh
         endif
      elseif(LWIND .AND. LSHUM. AND. LOTHER) then
         if(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xpmb,swrad,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,swrad,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xpmb,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xpmb,swrad,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xpmb,swrad,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,swrad,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,swrad,xprc
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xpmb,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xpmb,xprc
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xpmb,swrad
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xpmb
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,swrad
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q,rh
         endif
      elseif(LWIND . AND. LOTHER) then
         if(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xpmb,swrad,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,swrad,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xpmb,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xpmb,swrad,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xpmb,swrad,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,swrad,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,swrad,xprc
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xpmb,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xpmb,xprc
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xpmb,swrad
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xpmb
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,swrad
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,rh
         endif
      elseif(LTEMP .AND. LSHUM . AND. LOTHER) then
         if(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xpmb,swrad,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,swrad,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xpmb,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xpmb,swrad,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xpmb,swrad,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,swrad,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,swrad,xprc
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xpmb,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xpmb,xprc
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xpmb,swrad
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xpmb
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,swrad
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q,rh
         endif
      elseif(LTEMP .AND. LOTHER) then
         if(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xpmb,swrad,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,swrad,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xpmb,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xpmb,swrad,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xpmb,swrad,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,swrad,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,swrad,xprc
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xpmb,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xpmb,xprc
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xpmb,swrad
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xpmb
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,swrad
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,rh
         endif
      elseif(LSHUM .AND. LOTHER) then
         if(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1013)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xpmb,swrad,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,swrad,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xpmb,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xpmb,swrad,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xpmb,swrad,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,swrad,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,swrad,xprc
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xpmb,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xpmb,xprc
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xpmb,swrad
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xpmb
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,swrad
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q,rh
         endif
      elseif(LOTHER) then
         if(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xpmb,swrad,xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 swrad,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xpmb,xprc,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xpmb,swrad,rh
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xpmb,swrad,xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.ne.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xprc,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 swrad,rh
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 swrad,xprc
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xpmb,rh
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xpmb,xprc
         elseif(imcolpres.ne.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xpmb,swrad
         elseif(imcolpres.ne.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1017)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xpmb
         elseif(imcolpres.eq.0.and.imcolsw.ne.0.and.imcolprc.eq.0
     &     .and.imcolrh.eq.0) then
         write(io,1017)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 swrad
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.ne.0
     &     .and.imcolrh.eq.0) then
         write(io,1017)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 xprc
         elseif(imcolpres.eq.0.and.imcolsw.eq.0.and.imcolprc.eq.0
     &     .and.imcolrh.ne.0) then
         write(io,1017)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 rh
         endif
      elseif(LWIND .AND. LTEMP .AND. LSHUM) then
         write(io,1014)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,q
      elseif(LWIND .AND. LTEMP) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t
      elseif(LWIND .AND. LSHUM) then
         write(io,1015)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,q
      elseif(LWIND) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws
      elseif(LTEMP .AND. LSHUM) then
         write(io,1016)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,q
      elseif(LTEMP) then
         write(io,1017)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t
      elseif(LSHUM) then
         write(io,1017)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 q
      endif

 1010 format(2(i5,3i3,1x,i4.4),8f10.3)
 1011 format(2(i5,3i3,1x,i4.4),7f10.3)
 1012 format(2(i5,3i3,1x,i4.4),6f10.3)
 1013 format(2(i5,3i3,1x,i4.4),5f10.3)
 1014 format(2(i5,3i3,1x,i4.4),4f10.3)
 1015 format(2(i5,3i3,1x,i4.4),3f10.3)
 1016 format(2(i5,3i3,1x,i4.4),2f10.3)
 1017 format(2(i5,3i3,1x,i4.4),f10.3)

      return
      end

c ---------------------------------------------------------------------
      Subroutine Outputc(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyre,imone,idaye,ihoure,isece,
     &                  wd,ws,wc,lwind,lso2,lno,lno2,lnox,lco,lo3,lh2s,
     &                  lpm10,lpm25)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090203
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Output time series
c ---------------------------------------------------------------------

      logical lwind,lso2,lno,lno2,lnox,lco,lo3,lh2s,lpm10,lpm25

      if(LWIND .AND. LSO2) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,wc
      elseif(LWIND .AND. LNO) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,wc
      elseif(LWIND .AND. LNO2) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,wc
      elseif(LWIND . AND. LNOX) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,wc
      elseif(LWIND . AND. LCO) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,wc
      elseif(LWIND . AND. LO3) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,wc
      elseif(LWIND . AND. LH2S) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,wc
      elseif(LWIND . AND. LPM10) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,wc
      elseif(LWIND . AND. LPM25) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,wc
      endif
 1010 format(2(i5,3i3,1x,i4.4),2f12.2,E12.5E2)

      return
      end

c ---------------------------------------------------------------------
      subroutine rotate(i,wdrot)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100721        ROTATE
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Get wind direction adjust constant rotating from map 
c              wind to true North wind at extraction location
c
c --- Version 1.79, Level 100721 (JSS)
c      1.  Pass correct longitude with E long. positive to coordinate
c            routine (MAPL2G) and standardize notation
c      2.  Note change to /MAPINFO/ common block required (add 
c          'relon0m' variable
c
c --- Version 1.6, level 090318 to Version 1.73, level 091022 (IWL)
c      1. Add comments (COMMON BLOCK, CALLED BY, CALLS)
c
c --- Version 1.0, Level 060615 to Version 1.6, level 090318 (DGS)
c      1. Remove xext,yext from /LOCINFO/ and use the xloc,yloc arrays
c         instead.  Pass location index as argument.
c
c Change on 6/19/2003
c   New CALMET (V5.5 030402) uses East Positive.
c Zhong Wu
c
c
c --- COMMON BLOCK /MAPINFO/:
c       conecm,xlat1m,xlat2m,rlat0m,relon0m
c
c --- CALLED BY:
c       CLMEXT
c  
c --- CALLS:
c       MAPL2G
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'metseries.ser'

c     Get lat/lon coordinates extraction location
      xext=xloc(i)
      yext=yloc(i)
c     Note: Long. west positive in old CALMET, east positive in
c           CALMET starting with (V5.5 L030402)
c *** rlong=-rlon0m
c *** rlong=rlon0m
c --- V1.79 (L100721) use explicit longitude defined with E long as positive
      call mapl2g(rlat0m,relon0m,xlat1m,xlat2m,xext,yext,alat,alon) 
c
c *** write(ilog,*)rlat0m,rlong,xlat1m,xlat2m,xext,yext,alat,alon
c *** print *,rlat0m,rlong,xlat1m,xlat2m,xext,yext,alat,alon
c 
c --- ALON uses E longitude positive convention
      dlon=alon-relon0m

c --- Handle straddle over dateline
      if(dlon.lt.-180.) dlon=dlon+360.
      if(dlon.gt. 180.) dlon=dlon-360.

c --- Southern hemisphere
      if (alat.lt.0.) dlon=-dlon

      wdrot=dlon*conecm
c
      write(ilog,101)rlat0m,relon0m,xlat1m,xlat2m,xext,yext,alat,alon
 101  format(1x,'rlat0m,relon0m,xlat1m,xlat2m,xext,yext,alat,alon: ',/
     &        ,8f12.4)
      write(ilog,102)conecm,wdrot
 102  format('conecm,wdrot:',2f12.4)

      return
      end
c ---------------------------------------------------------------------
      subroutine mapl2g(rlat,rlon,tlat1,tlat2,xdist,ydist,alat,alon)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 970825        MAPL2G
c ---          G. Moore (7/92), E. Chang (8/93)
c ---          Modified by J. Scire (11/96)
c
c --- PURPOSE: Convert Lambert Conformal Conic projection coordinates
c              to geodetic (LAT./LONG.) coordinates.
c
c --- NOTE:    This routine uses the following conventions:
c                 Latitude  - Northern Hemisphere - positive
c                             Southern Hemisphere - negative
c                 Longitude - Eastern Hemisphere  - positive
c                             Western Hemisphere  - negative
c
c --- INPUTS:
c
c        RLAT - real     - Reference latitude (deg.) of the origin of
c                          the LCC projection
c        RLON - real     - Reference longitude (deg.) of the LCC
c                          projection.  LCC origin will be at the point
c                          RLAT, RLON and the Y axis of the LCC grid
c                          will be oriented along the RLON meridian.
c       TLAT1 - real     - Latitude (deg.) of the first standard
c                          parallel for the Lambert conformal proj.
c       TLAT2 - real     - Latitude (deg.) of the second standard
c                          parallel.
c       XDIST - real     - X coordinate (km) in LCC projection.
c       YDIST - real     - Y coordinate (km) in LCC projection.
c
c --- OUTPUTS:
c
c        ALAT - real     - Latitude (deg.) of (XDIST,YDIST).
c        ALON - real     - Longitude (deg.) of (XDIST,YDIST).
c
c --- MAPL2G called by:  READCF
c --- MAPL2G calls:      none
c----------------------------------------------------------------------
c
c --- Set constants: PI4 = pi/4., RADCON=pi/180.
      data pi4/0.78539816/,radcon/0.017453293/
      data rearth/6370.0/
c
c --- Compute constants depending on standard parallels and
c --- reference coordinates
      a1 = cos(tlat1*radcon)/cos(tlat2*radcon)
      a2 = tan(pi4 - 0.5*(radcon*tlat1))
      a3 = tan(pi4 - 0.5*(radcon*tlat2))
      a5 = tan(pi4 - 0.5*(radcon*rlat))
c
c --- Compute the cone constant (cc), (K in other people's notation)
      cc = alog(a1)/alog(a2/a3)
c
c --- Scaling function
      psi = rearth*cos(tlat1*radcon)/(cc*a2**cc)
      rho1 = psi*a5**cc
c
c --- Convert LCC (X,Y) to latitude & longitude
c
c --- Longitude calculation
      dy=rho1-ydist
      rho=sqrt(xdist**2+dy**2)
      if(dy.lt.0.)rho=-rho
c *** theta=asin(xdist/rho)
      theta=atan(xdist/dy)
      alon=rlon+theta/(cc*radcon)
c
c --- Latitude calculation
      c1=1.0/cc
      a4=(rho/psi)**c1
      alat=(2.0/radcon)*(pi4-atan(a4))
c
      return
      end
c ---------------------------------------------------------------------
      Subroutine getxy(buff,x,y)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060615       GETLOC1
C Purpose:
C   Read site location in X/Y (km) format
C Zhong Wu
C 11/11/2004
c ---------------------------------------------------------------------

      character*80 buff

      read(buff,*)x,y

c      print *,'Location X/Y:',x,y

      return
      end

c----------------------------------------------------------------------
	Subroutine getver(buff1,buff2,ivs3)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731        GETVER
C     Zhong-Xiang Wu
C     1/16/2004
C
C --- Purpose: Get 3D.DAT format/version number
c
c --- UPDATES:
c
c --- Version 1.0, level 060615 to Version 1.66, level 090731 (DGS)
c      1. Remove Version 3.x test until it is coded properly
C 
C --- Input: BUFF1, BUFF2 - First two records
C --- Output: ivs3 - 3D.DAT foramt key number
C --- Called by: Main
C --- Calling: None
c----------------------------------------------------------------------

        include 'params.ser'

	character*132 buff1,buff2
	character*12 cset3d

	ivs3=-999
        ncomm=-999

cc --- Step (1): Check for "3D.DAT" or "MM53D.DAT" on second 
c --- record of file (indication of old 3D.DAT file structure
c --- prior to Version 2.0)
      read(buff2,'(a12)')cset3d

      if(cset3d.eq.'3D.DAT'.or.cset3d.eq.'MM53D.DAT')then
         ivs3=1
      else
c
c ---    Step (2) check for new standard 3D.DAT file structure 
c ---    with dataset name, version and comments on first record
         if(buff1(1:6).eq.'3D.DAT')then
            read(buff2,*,err=1000)ncomm
	      if(ncomm.ge.1) then
		 ivs3=2
		 goto 2000
	      endif
 1000	      continue		! no comment lines, assume old MM5 format
	      print *,'3D.DAT with comment line format'
	      print *,'But no comment lines'
	      print *,'Check/correct the 3D.DAT'
              write(ilog,*)'3D.DAT with comment line format'
	      write(ilog,*)'But no comment lines'
	      write(ilog,*)'Check/correct the 3D.DAT'
	      stop
cc ---       Version 3.x (explicit beg/end times with seconds)
c            if(buff1(17:17).eq.'3')ivs3=3
         else
c
c ---       Structure does not fit 3D.DAT conventions -- assume
c ---       file is in MM5.DAT format
            ivs3=0
         endif
      endif

 2000	print *,'File format - ivs3/ncom = ',ivs3, ncomm
        write(ilog,*)'File format - ivs3/ncom = ',ivs3, ncomm

	if(ivs3.lt.0 .or. ivs3.gt.3) then
	   print *,'Illegal 3D.DAT format. Check data files'
           write(ilog,*)'Illegal 3D.DAT format. Check data files'
	   stop
	endif
 
	return
	end

c----------------------------------------------------------------------
	Subroutine getver2(buff1,buff2,ivs2)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060620       GETVER2
C     Zhong-Xiang Wu
C
C --- Purpose: Get 2D.DAT format/version number
c              (Adapted from GETVER for 3D.DAT files --- DGS)
C 
C --- Input: BUFF1, BUFF2 - First two records
C --- Output: ivs2 - 2D.DAT foramt key number
C --- Called by: Main
C --- Calling: None
c----------------------------------------------------------------------

        include 'params.ser'

	character*132 buff1,buff2
	character*12 cset2d

	ivs2=-999
	read(buff2,'(a12)')cset2d
	if(cset2d.eq.'2D.DAT'.or.cset2d.eq.'MM52D.DAT')then
	   ivs2=1
	else
c ---      Step (2) check for new standard 2D.DAT file structure 
c ---      with dataset name, version and comments on first record
	   ncomm=-999
	   if(buff1(1:6).eq.'2D.DAT')then
	      read(buff2,*,err=1000)ncomm
	      if(ncomm.ge.1) then
		 ivs2=2
		 goto 2000
	      endif
 1000	      continue		! no comment lines, assume old MM5 format
              write(ilog,*)'2D.DAT with comment line format'
	      write(ilog,*)'But no comment lines'
	      write(ilog,*)'Check/correct the 2D.DAT'
	      print *,'2D.DAT with comment line format'
	      print *,'But no comment lines'
	      print *,'Check/correct the 2D.DAT'
	      stop
	   else
c ---         Structure does not fit 2D.DAT conventions -- assume
c ---         file is in MM5.DAT format
	      ivs2=0
	   endif
	endif

 2000	print *,'File format - ivs2/ncom = ',ivs2, ncomm
        write(ilog,*)'File format - ivs2/ncom = ',ivs2, ncomm

	if(ivs2.lt.0 .or. ivs2.gt.2) then
           write(ilog,*)'Illegal 2D.DAT format. Check data files'
	   print *,'Illegal 2D.DAT format. Check data files'
	   stop
	endif
 
	return
	end

c----------------------------------------------------------------------
      Subroutine getfrmt(buff,ifrmt)
c----------------------------------------------------------------------
c      
c --- METSERIES  Version: 1.9.0         Level: 060615       GETFRMT
C Purpose:
C   Determine input format
C   Zhong Wu
C 11/11/2004
C
C IFRMT=1: X/Y in km (Default)
C IFRMT=2: Lon/Lat in degree
C IFRMT=3: I/J in real numbers
c----------------------------------------------------------------------

      character*80 buff

      ifrmt=1

      ntd=index(buff,':')-1
      if(ntd.le.0) ntd=80

      do j=1,ntd
         if(buff(j:j).eq.'W' .or. buff(j:j).eq.'w' 
     &    . or. buff(j:j).eq.'E' .or. buff(j:j).eq.'e') then 
            ifrmt=2
            goto 1000
         elseif(buff(j:j).eq.'G' .or. buff(j:j).eq.'g') then
            ifrmt=3
            goto 1000
         endif
      enddo

 1000 continue
      return
      end
c----------------------------------------------------------------------
      subroutine rdi1d(iomet,mtver,idat,nwords,clabel,ndathrb,
     &                 nsecb,ndathre,nsece)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 051012         RDI1D
c
c --- Adapted from:
c --- PRTMET   Version: 4.44      Level: 051012                   RDI1D
c ---          J. Scire, Earth Tech
c
c --- PURPOSE:  Read "NWORDS" of a one-dimensional integer array
c
c --- UPDATE
c --- V4.4-V4.41    051012  (DGS): resolve times to the second, and
c                                  include begin/end times
c                                  (remains compatible with
c                                  older end-time version)
c
c --- INPUTS:
c         IOMET - integer       - Fortran unit number of input file
c         MTVER - integer       - Time-mark flag
c                                 0: end-time (no seconds)
c                                 1: begin-time / end-time
c
c --- OUTPUT:
c  IDAT(nwords) - integer array - Array read from file
c        NWORDS - integer       - Number of words to read
c        CLABEL - character*8   - Variable name
c       NDATHRB - integer       - Beginning date and time (YYYYJJJHH)
c         NSECB - integer       - Beginning seconds (SSSS)
c       NDATHRE - integer       - Ending date and time (YYYYJJJHH)
c         NSECE - integer       - Ending seconds (SSSS)
c
c --- RDI1D called by:  METHDX, RDMET
c --- RDI1D calls:      none
c----------------------------------------------------------------------
c
      integer idat(nwords)
      character*8 clabel
c
      if(mtver.EQ.1) then
         read(iomet)clabel,ndathrb,nsecb,ndathre,nsece,idat
      elseif(mtver.EQ.0) then
         read(iomet)clabel,ndathre,idat
         nsece=0
         ndathrb=0
         nsecb=0
      endif
      return
      end
c----------------------------------------------------------------------
      subroutine rdi2d(iomet,mtver,idat,ibuf,mxnx,mxny,nx,ny,clabel,
     &                 ndathrb,nsecb,ndathre,nsece)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 051012         RDI2D
c
c --- Adapted from:
c --- PRTMET   Version: 4.44      Level: 051012                   RDI2D
c              J. Scire, Earth Tech
c
c --- PURPOSE:  Read NX * NY words of a 2-D integer array
c
c --- UPDATE
c --- V4.4-V4.41    051012  (DGS): resolve times to the second, and
c                                  include begin/end times for CALMET
c                                  Version 6 (remains compatible with
c                                  older version of CALMET)
c
c --- INPUTS:
c               IOMET - integer       - Fortran unit number of input
c                                       file
c               MTVER - integer       - Time-mark flag
c                                       0: end-time (no seconds)
c                                       1: begin-time / end-time
c         IBUF(nx,ny) - integer array - Buffer to hold input data
c           MXNX,MXNY - integers      - Dimensions of data array
c               NX,NY - integers      - Actual size of grid to read
c
c --- OUTPUT:
c     IDAT(mxnx,mxny) - integer array - Input data array (padded if
c                                       necessary)
c              CLABEL - character*8   - Variable name
c             NDATHRB - integer       - Beginning date and time (YYYYJJJHH)
c               NSECB - integer       - Beginning seconds (SSSS)
c             NDATHRE - integer       - Ending date and time (YYYYJJJHH)
c               NSECE - integer       - Ending seconds (SSSS)
c
c --- RDI2D called by:  METHDX, RDMET
c --- RDI2D calls:      none
c----------------------------------------------------------------------
      integer idat(mxnx,mxny),ibuf(nx,ny)
      character*8 clabel
c
      if(nx.eq.mxnx.and.ny.eq.mxny)then
c
c ---    entire array is being used -- read full grid
         if(mtver.EQ.1) then
            read(iomet)clabel,ndathrb,nsecb,ndathre,nsece,idat
         elseif(mtver.EQ.0) then
            read(iomet)clabel,ndathre,idat
            nsece=0
            ndathrb=0
            nsecb=0
         endif
      else
c
c ---    only a portion of grid being used -- read and
c ---    transfer from buffer
c
         if(mtver.EQ.1) then
            read(iomet)clabel,ndathrb,nsecb,ndathre,nsece,ibuf
         elseif(mtver.EQ.0) then
            read(iomet)clabel,ndathre,ibuf
            nsece=0
            ndathrb=0
            nsecb=0
         endif
c
         do 10 i=1,nx
         do 10 j=1,ny
         idat(i,j)=ibuf(i,j)
10       continue
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine rdr1d(iomet,mtver,x,nwords,clabel,
     &                 ndathrb,nsecb,ndathre,nsece)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 051012         RDR1D
c
c --- Adapted from:
c --- PRTMET   Version: 4.44      Level: 051012                   RDR1D
c ---          J. Scire, Earth Tech
c
c --- PURPOSE:  Read "NWORDS" of a one-dimensional real array
c
c --- UPDATE
c --- V4.4-V4.41    051012  (DGS): resolve times to the second, and
c                                  include begin/end times for CALMET
c                                  Version 6 (remains compatible with
c                                  older version of CALMET)
c
c --- INPUTS:
c         IOMET - integer     - Fortran unit number of input file
c         MTVER - integer     - Time-mark flag
c                               0: end-time (no seconds)
c                               1: begin-time / end-time
c
c --- OUTPUT:
c     X(nwords) - real array  - Array read from file
c        NWORDS - integer     - Number of words to read
c        CLABEL - character*8 - Variable name
c       NDATHRB - integer     - Beginning date and time (YYYYJJJHH)
c         NSECB - integer     - Beginning seconds (SSSS)
c       NDATHRE - integer     - Ending date and time (YYYYJJJHH)
c         NSECE - integer     - Ending seconds (SSSS)
c
c --- RDR1D called by:  METHDX, RDMET
c --- RDR1D calls:      none
c----------------------------------------------------------------------
      real x(nwords)
      character*8 clabel
c
      if(mtver.EQ.1) then
         read(iomet)clabel,ndathrb,nsecb,ndathre,nsece,x
      elseif(mtver.EQ.0) then
         read(iomet)clabel,ndathre,x
         nsece=0
         ndathrb=0
         nsecb=0
      endif
      return
      end
c----------------------------------------------------------------------
      subroutine rdr2d(iomet,mtver,x,xbuf,mxnx,mxny,nx,ny,clabel,
     &                 ndathrb,nsecb,ndathre,nsece,ieof)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 051012         RDR2D
c
c --- Adapted from:
c --- PRTMET   Version: 4.44      Level: 051012                   RDR2D
c              J. Scire, Earth Tech
c
c --- PURPOSE:  Read NX * NY words of a 2-D real array
c
c --- UPDATE 
c --- V4.4-V4.41    051012 (DGS): resolve times to the second, and
c                                 include begin/end times for CALMET
c                                 Version 6 (remains compatible with
c                                 older version of CALMET)
c --- 940830  to    040923 (DGS): add IEOF to recover from end-of-file
c
c --- INPUTS:
c            IOMET - integer     - Fortran unit number of input file
c            MTVER - integer     - Time-mark flag
c                                  0: end-time (no seconds)
c                                  1: begin-time / end-time
c      XBUF(nx,ny) - real array  - Buffer to hold input data
c      MXNX,MXNY   - integers    - Dimensions of data array
c            NX,NY - integers    - Actual size of grid to read
c
c --- OUTPUT:
c     X(mxnx,mxny) - real array  - Input data array (padded if nec.)
c           CLABEL - character*8 - Variable name
c          NDATHRB - integer     - Beginning date and time (YYYYJJJHH)
c            NSECB - integer     - Beginning seconds (SSSS)
c          NDATHRE - integer     - Ending date and time (YYYYJJJHH)
c            NSECE - integer     - Ending seconds (SSSS)
c             IEOF - integer     - End-of-File status
c                                  0 = pointer within file
c                                  1 = EOF reached on read
c
c --- RDR2D called by:  METHDX, RDMET
c --- RDR2D calls:      none
c----------------------------------------------------------------------
      real x(mxnx,mxny),xbuf(nx,ny)
      character*8 clabel

c --- Set EOF
      ieof=0
c
      if(nx.eq.mxnx.and.ny.eq.mxny)then
c
c ---    entire array is being used -- read full grid
         if(mtver.EQ.1) then
            read(iomet,end=999)clabel,ndathrb,nsecb,ndathre,nsece,x
         elseif(mtver.EQ.0) then
            read(iomet,end=999)clabel,ndathre,x
            nsece=0
            ndathrb=0
            nsecb=0
         endif
      else
c
c ---    only a portion of grid being used -- read and
c ---    transfer from buffer
         if(mtver.EQ.1) then
            read(iomet,end=999)clabel,ndathrb,nsecb,ndathre,nsece,xbuf
         elseif(mtver.EQ.0) then
            read(iomet,end=999)clabel,ndathre,xbuf
            nsece=0
            ndathrb=0
            nsecb=0
         endif
c
         do 10 i=1,nx
         do 10 j=1,ny
         x(i,j)=xbuf(i,j)
10       continue
      endif
c
      return

999   ieof=1
      return

      end

c----------------------------------------------------------------------
      subroutine vsat(tdegk,psat,csat)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060615          VSAT
c                J. Scire
c
c --- PURPOSE:  Compute saturation vapor pressure and corresponding
c               saturation mass concentration for given temperature
c
c --- INPUTS:
c          tdegk - real       - Temperature (K)
c
c --- OUTPUT:
c           psat - real       - Saturation water vapor pressure (mb)
c           csat - real       - Saturation water vapor mass
c                               concentration (g h2o/m**3 air)
c
c --- VSAT called by:   
c --- VSAT calls:       none
c----------------------------------------------------------------------
c
      data gascon/8.31372e-2/

c --- Compute saturation vapor pressure (Goff-Gratch eqns.)
      trat=273.16/tdegk
      if(tdegk.lt.273.16)then
c ---    temperature below 0. deg. C
         psat=exp(2.303*(-9.09685*(trat-1.0)+
     1   0.87682*(1.0-tdegk/273.16))-3.56654*(5.6100577-alog(tdegk))+
     2   1.81)
      else
c ---    temperature above 0. deg. C
         psat=exp(2.303*(10.79574*(1.0-trat)+
     1   1.50475e-4*(1.0-10.**(-8.2969*(tdegk/273.16-1.0)))+
     2   4.2873e-4*(10.**(4.76955*(1.0-trat))-1.0))-
     3   5.028*(alog(tdegk)-5.6100577)+1.81)
      endif

c --- Compute saturation water vapor mass concentration (g h2o/m**3 air)
c --- (gascon is the gas constant -- 8.31372e-2 m**3*mb/(mole*deg k)
      csat=18.016*psat/(gascon*tdegk)

      return
      end
c----------------------------------------------------------------------
      subroutine RDHD2D(in,ilog,iecho,ieof)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731        RDHD2D
c                D. Strimaitis
c
c --- PURPOSE:  Reads header of 2D.DAT file.  No information is passed
c               back to calling program, because this header info has
c               already been processed from the corresponding 3D.DAT
c               file.  Extensive checks of the 2 headers could be added
c               to trap user errors.
c
c               (Adapted from 3D.DAT reads in subroutine MM5EXT)
c
c --- UPDATES:
c --- Version 1.1, level 060620 to Version 1.66, level 090731 (DGS)
c      1. Remove CKEY, CKEYS declaration (not used)
c
c --- INPUTS:
c            in - integer      - file unit number for current 2D.DAT
c          ilog - integer      - file unit number for list file
c         iecho - integer      - flag to write inputs to list file
c
c --- OUTPUT:
c          ieof - integer      - flag for End Of File
c                                 0 = not at end
c                                 1 = at end of file
c
c --- RDHD2D called by:  MM5EXT
c --- RDHD2D calls:      GETVER2
c----------------------------------------------------------------------

      character*80 title
      character*12 cset2d,cver,clev
      character*64 datamod
      character*132 buff1,buff2

         ieof=0

         read(in,101,end=6500)buff1
         read(in,101,end=6500)buff2
 101     format(a)

         call getver2(buff1,buff2,ivs2)

         if(ivs2.eq.0) then   ! V2 format
c           Record #1     
            read(buff1,1009,end=6500)title,cver,clev 
 1009       format(a80,2a12)
c           Record #2
            read(buff2,1011)ioutw,ioutq,ioutc,iouti,ioutg
 1011       format(6i3)
c           Record #3. Projection parameters
            read(in,1060)rlatc,rlonc,truelat1,truelat2  
 1060       format(9x,f6.2,7x,f8.2,8x,f6.1,8x,f6.1)

c           Record #4. MPHYSICS
            read(in,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &           ifddaan,ifddaob
 1061       format (30i3)

c           Record #5
            read(in,1062)idatebeg,nhours,nxsub,nysub,nz
 1062       format(i8,i5,3i4)

c           Record #6
            read(in,1063)nx1,ny1,nx2,ny2,rxmin,rxmax,rymin,rymax
 1063       format(4i4,4(f8.2))

C           Echo to log file and eliminate compiling message for LF77
            if(iecho.eq.1) then
               write(ilog,*)
               write(ilog,*)  '2D.DAT Header:'
               write(ilog,1009)title,cver,clev 
               write(ilog,1011)ioutw,ioutq,ioutc,iouti,ioutg
               write(ilog,1060)rlatc,rlonc,truelat1,truelat2  
               write(ilog,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &           ifddaan,ifddaob
               write(ilog,1062)idatebeg,nhours,nxsub,nysub,nz
               write(ilog,1063)nx1,ny1,nx2,ny2,rxmin,rxmax,rymin,rymax
            endif
         elseif(ivs2.gt.0) then  ! V3 formats
            if(ivs2.eq.1) then ! V3 format (no comment lines)
c              Record #1,Record #2
               read(buff1,1009,end=6500)title
               read(buff2,1109)cset2d,cver,clev
 1109          format(3a12)
            elseif(ivs2.eq.2) then
               read(buff1,1119,end=6500)cset2d,cver,datamod
 1119          format(2(a12,4x),a64)
               read(buff2,*)ncomm
               do i=1,ncomm
                  read(in,*)
               enddo
            else
               write(ilog,*)'Format not set:',ivs2
               print *,'Format not set:',ivs2
               stop
            endif

c           Record #3
            read(in,1011)ioutw,ioutq,ioutc,iouti,ioutg,iosrf
c           Record #4
            read(in,1113)cmap,rlatc,rlonc,truelat1,truelat2,
     &           xsw,ysw,dxm,nx,ny,nz
 1113       format(a4,f9.4,f10.4,2f7.2,2f10.3,f8.3,2i4,i3)

            dym=dxm

c           Record #5 - physical options
            read(in,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &           ifddaan,ifddaob,igrdt,ipbl,ishf,ilhf,iustr,iswdn,
     &           ilwdn,ist1,ist2,ist3,ist4,ist5,ist6

c           Record #6 - Extracted domain Stamp 1
            read(in,1115)idatebeg,nhours,nxsub,nysub,nzsub
 1115       format(i10,i5,3i4)

c           header record #7: - Extracted domain Stamp 2 (output later
            read(in,1116)nx1,ny1,nx2,ny2,nz1,nz2,
     &           rxmin,rxmax,rymin,rymax
 1116       format(6i4,2f10.4,2f9.4)

            nz=nzsub   ! only nzsub layers in data
            if(nz.ne.(nz2-nz1+1)) then
               write(ilog,*)'Error in vertical layers:'
               write(ilog,*)nzsub,nz1,nz2
               print *,'Error in vertical layers:'
               print *,nzsub,nz1,nz2
               stop
            endif

C           Echo to log file and eliminate compiling message for LF77
            if(iecho.eq.1) then
               write(ilog,1009)title
               write(ilog,1109)cset2d,cver,clev
               write(ilog,1011)ioutw,ioutq,ioutc,iouti,ioutg,iosrf
               write(ilog,1113)cmap,rlatc,rlonc,truelat1,truelat2,
     &           xsw,ysw,dxm,nx,ny,nz
               write(ilog,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &           ifddaan,ifddaob,igrdt,ipbl,ishf,ilhf,iustr,iswdn,
     &           ilwdn,ist1,ist2,ist3,ist4,ist5,ist6
               write(ilog,1115)idatebeg,nhours,nxsub,nysub,nzsub
               write(ilog,1116)nx1,ny1,nx2,ny2,nz1,nz2,
     &           rxmin,rxmax,rymin,rymax
            endif
         endif

c        Sigma levels
         do i=1,nz
            read(in,1064)sigma
            if(iecho.eq.1) write(ilog,1064)sigma
 1064       format(f6.3)	       
         enddo

c        Lat/long locations
         do j=ny1,ny2           
            do i=nx1,nx2
               if(ivs2.eq.0) then
                  read(in,1065)ii,jj,flat,flong,ihh,iland,
     &                 flatcrs,flongcrs
 1065             format(2i3,f7.3,f8.3,i5,i3,1x,f7.3,f8.3)
               else
                  read(in,1165)ii,jj,flat,flong,ihh,iland,
     &                 flatcrs,flongcrs
 1165             format(2i4,f9.4,f10.4,i5,i3,1x,f9.4,f10.4)
               endif
c               if(ifile.eq.1) then
c                  ielev(i,j)=ihh
c                  land(i,j)=iland
c              endif
               if(iecho.eq.1) write(ilog,1165)ii,jj,flat,flong
     &            ,ihh,iland,flatcrs,flongcrs
            Enddo
         enddo

      return

 6500 ieof=1
      return

      end
c----------------------------------------------------------------------
      subroutine pblscale(method,z0m,zr,wr,tr,pr,qr,t0,p0,zw,zt,
     &                    s_zw,t_zt,p_zt)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 060620      PBLSCALE
c                D. Strimaitis
c
c --- PURPOSE:  Calculates friction velocity, potential temperature
c               scale, and the Monin-Obukhov length by a non-iterative
c               parameterization technique from bulk Ri.
c               Estimates wind and temperature at reference heights.
c               Specific humidity is assumed constant in surface layer.
c
c               (Adapted from CALGRID subroutine PBLPAR2)
c
c --- INPUTS:
c        method - integer      - flag controlling profile method
c                                0 = Normal implementation
c                                1 = METSTAT-like implementation
c           Z0M - real         - momentum roughness length (m)
c            ZR - real         - input reference height (m)
c            WR - real         - input wind speed at ZR (m/s)
c            TR - real         - input temperature at ZR (K)
c            PR - real         - input pressure at ZR (mb)
c            QR - real         - input specific humidity at ZR (g/kg)
c            T0 - real         - surface temperature (K)
c            P0 - real         - surface pressure (mb)
c            ZW - real         - output wind speed ref height (m)
c            ZT - real         - output temperature ref height (m)
c
c --- OUTPUT:
c          S_ZW - real         - wind speed at ZW (m/s)
c          T_ZT - real         - temperature at ZT (m/s)
c          P_ZT - real         - pressure at ZT (m/s)
c
c --- PBLSCALE called by:  host subroutines
c --- PBLSCALE calls:      none
c----------------------------------------------------------------------
c --- References:
c
c     1) Jacobson, M. Z., Fundamentals of Atmospheric Modeling,
c        Cambridge University Press, pg 214, (1999).
c     2) Louis, J-F., A parametric model of vertical eddy fluxes
c        in the atmosphere, Boundary Layer Meteorology, 17, 187-202,
c        (1979).
c
c --- Governing Equations:
c
c                 g [thetav(zr) - thetav(z0h)]  (zr-z0m)^2
c      (1) Rib = -------------------------------------------
c                 thetav(z0h)  (zr-z0h)  ws(zr)^2
c
c                   k |ws(zr)| SQRT(Gm)
c      (2) Ustar = ---------------------
c                   ln(zr/z0m)
c
c                    k^2 |ws(zr)| [thetav(zr) - thetav(z0h)] Gh
c      (3) Tstar = ----------------------------------------------
c                    Ustar Prt ln^2(zr/z0m)
c
c                                9.4 Rib
c            Gm =  1 -  ---------------------------------   Rib <= 0
c                           69.56 k^2 (|Rib| zr/z0m)^0.5
c                       1 + -----------------------------
c                                ln^2 (zr/z0m)
c
c                                9.4 Rib
c            Gh =  1 -  ---------------------------------   Rib <= 0
c                           49.82 k^2 (|Rib| zr/z0m)^0.5
c                       1 + -----------------------------
c                                ln^2 (zr/z0m)
c
c                            1
c            Gm,Gh =  -------------------                   Rib > 0
c                       (1 + 4.7 Rib)^2
c
c
c         where,
c
c         Rib    = bulk Richardson number
c         Ustar  = friction velocity (m/s)
c         Tstar  = potential temperature scale (K)
c         k      = von Karman constant (0.4)
c         thetav = potential virtual temperature (K)
c         zr     = reference height (10 m)
c         z0h    = surface roughness length for energy (m)
c         z0m    = surface roughness length for momentum (m)
c         ws     = wind speed (m/s)
c         Prt    = Prandtl Number (=0.95 for k=0.4)
c ---------------------------------------------------------------------

      include 'params.ser'

      data vonk/0.4/

      data rkappa /0.286/
c --- rkappa  = exponent for potential virtual temperature

      data R/0.083145/,Cpd/1004.67/
c --- R   = universal gas constant (0.083145 m3 mb mole-1 K-1)
c ---          multiply by (1000/29) to conver to (m3 mb kg K-1)
c --- Cpd = specific heat of dry air (1004.67 J kg-1 K-1)

      if(method .EQ. 0) then
c ---    NORMAL implementation
         g=9.806
         Prt=0.95
         qq=qr*0.001
      elseif(method .EQ. 1) then
c ---    METSTAT-like implementation
         g=9.8
         Prt=1.0/1.35
         qq=0.0
      else
         write(ilog,*)'Bad call to PBLSCALE:  method = ',method
         write(ilog,*)'            Expected:  method = 0 or 1'
         write(*,*)'Bad call to PBLSCALE:  method = ',method
         write(*,*)'            Expected:  method = 0 or 1'
         stop
      endif

c --- Virtual temperatures
      trv=tr*(1.0+0.608*qq)
      t0v=t0*(1.0+0.608*qq)

c --- Set computational floor for wind speed
      ws=MAX(wr,0.01)
      ws_sq=ws**2

c --- Potential temperatures
      thetav_zr=trv*(1000./pr)**rkappa
      thetav_z0h=t0v*(1000./p0)**rkappa
      thetavdiff=thetav_zr-thetav_z0h
      thetamean=0.5*(thetav_zr+thetav_z0h)

c --- Height factor for bulk Richardson number
      zmdiff=zr-z0m
      alogzrz0m=ALOG(zr/z0m)

c --- Compute variable to be used for z0h (Iteration needed)
c --- rkappad=thermal diffusivity of dry air (J m-1 s-1 K-1)
      rkappad=0.023807+7.1128*1.0e-5*(trv-273.16)
      rhoa=pr/(R*(1000./29.)*trv)
      Dh=rkappad/(rhoa*Cpd)

c --- z0h interation loop
c ------------------------------
c --- Initialize z0h = z0m
      z0h=z0m

c --- Compute bulk Richardson number
101   zhdiff=zr-z0h

      if(method .EQ. 0) then
         Rib0=(g*thetavdiff*zmdiff**2)/(thetav_z0h*ws_sq*zhdiff)
      else
         Rib0=(g*thetavdiff*zmdiff**2)/(thetamean*ws_sq*zhdiff)
      endif

c --- Compute stability functions
      if(Rib0 .LE. 0) then
        denM=69.56*vonk**2*(ABS(Rib0)*zr/z0m)**0.5/(alogzrz0m)**2
        Gm=1.0-9.4*Rib0/(1.0+denM)
        denH=49.82*vonk**2*(ABS(Rib0)*zr/z0m)**0.5/(alogzrz0m)**2
        Gh=1.0-9.4*Rib0/(1+denH)
      else
        Gm=1.0/(1.0+4.7*Rib0)**2
        Gh=Gm
      endif

c --- Compute PBL parameters
      ustar=vonk*ws*SQRT(Gm)/alogzrz0m
      tstar=vonk**2*ws*thetavdiff*Gh/(ustar*Prt*alogzrz0m**2)
c      xmol=ustar**2*thetav_zr/(vonk*g*tstar)
c
c      write(*,*)'PBLScale: Ri,Gm,Gh,u*,t*,L = ',Rib0,Gm,Gh,ustar,
c     &                                          tstar,xmol

      if(method .EQ. 1) goto 103

c --- Estimate new z0h, compare with old one and calculate again
c --- if necessary
      z0hNew=Dh/(ustar*vonk)
      percent=ABS(z0hNew-z0h)*100.0/z0h
      if(percent .GT. 0.01) then
        z0h=z0hNew
        if(z0hNew .LT. z0m) goto 103
        goto 101
      endif

c --- Compute wind and temperature at requested heights
103   alogzwz0m=ALOG(zw/z0m)
      alogztz0m=ALOG(zt/z0m)
      alogztz0h=ALOG(zt/z0h)
c --- Wind
      s_zw=ustar*alogzwz0m/(vonk*SQRT(Gm))
c --- Temperature
      s_zt=ustar*alogztz0m/(vonk*SQRT(Gm))
      theta=thetav_z0h+ustar*tstar*Prt/(s_zt*Gh*(vonk/alogztz0h)**2)
      p_zt=p0+(zt/zr)*(pr-p0)
      tv_zt=theta*(1000./p_zt)**(-rkappa)
      if(tstar.GT.0. .AND. tv_zt.GT.trv) then
         tv_zt=t0v+(zt/zr)*(trv-t0v)
      elseif(tstar.LT.0. .AND. tv_zt.LT.trv) then
         tv_zt=t0v+(zt/zr)*(trv-t0v)
      endif

c --- Convert virtual temperature to air temperature
      t_zt=tv_zt/(1.0+0.608*qq)

      return
      end

c----------------------------------------------------------------------
      subroutine wroseinp
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731      WROSEINP
c                D. Strimaitis
c
c --- PURPOSE:  Process control file inputs for windrose configuration
c
c               (Adapted from WDCOMP Version: 2.1, Level: 070207)
c
c --- UPDATES:
c --- Version 1.6, Level: 090318 to Version 1.66, Level: 090731
c           - Remove ADD_1, ADD_2 (not used)
c
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318
c     (DGS) - Get needed info from /CONTROL/ (new READCF)
c           - Determine if MET and AQ are in different files
c           - Change to Julian Date-hour integer YYYYJJJHH
c
c --- Version 1.4, Level: 070315 to Version 1.5, Level: 090203
c     (CEC) - Add threshold option for low wind or low concentration
c             and range of wind speed or concentrations
c     (DGS) - Add option to define seasons from control file
c     (DGS) - Add controls for pollutant rose species and size
c     (DGS) - Add time period window setup
c
c --- INPUTS:
c          COMMON BLOCK /LOCINFO/ ndateext,nsecext,nbsecext,isecstep
c ---      Common block /CONTROL/ variables:
c           flog,frose,fmet(mxfile),faq(mxfile),ftsf(mxloc),
c           mrosec,mdata,nsecdtc,nstepc,
c           ibyrc,ibmoc,ibdyc,ibjdc,ibhrc,ibsecc,ibdathrc,
c           ieyrc,iemoc,iedyc,iejdc,iehrc,iesecc,iedathrc,
c           idaq(mxloc),xaq(mxloc),yaq(mxloc),
c           idmet(mxloc),xmet(mxloc),ymet(mxloc),zwind(mxloc),
c           ztmpk(mxloc),zshum(mxloc),zother(mxloc),
c           locmet(mxloc),locaq(mxloc),
c           nspec,cspeci(mxspec),cunito(mxspec),rmwt(mxspec),
c           mprof,mcell,nlu3d,xycell1(2),dxycell(2),
c           wsbin(6),ntpdc,nwspc,ntpc(2,mxtpd),wspc(2,mxwsp),
c           nseasn,msnc(12),snamec(12),
c           pspec,punit,rrose,crose,
c
c --- OUTPUT:
c          COMMON BLOCK /WNDROSE/ mrose,nbdathr,nbsec,nedathr,nesec,
c                       ntpd,nwsr,ntp(2,mxtpd),wsp(2,mxwsp),
c                       sname, sname2, nseason,
c                       rose_radius, conc_spec, conc_unit, conc_scale
c
c --- WROSEINP called by:  main
c --- WROSEINP calls:      
c----------------------------------------------------------------------
      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'wndrose.ser'

      character*3 month3(12)

c --- Set abbreviation names for months
      data month3/'Jan','Feb','Mar','Apr','May','Jun',
     &            'Jul','Aug','Sep','Oct','Nov','Dec'/

c --- Wind-rose / Pollutant-rose option
      mrose=mrosec
      if(mrose.EQ.0) return

c --- Use MROSE to set pollutant-rose outputs
      if(mrose.EQ.2) then
         F_max_av=.TRUE.
         F_scat=.TRUE.
      else
         F_max_av=.FALSE.
         F_scat=.FALSE.
      endif

c --- Input to define seasons (default is set in BLOCK DATA)
      if(nseasn.EQ.0) then
c ---    Set array pointer to the default (keep annual & 4 seasons)
         irs=5
         nseason=4
      elseif(nseasn.GT.0) then
c ---    Set array pointer to the annual (will overwrite seasons)
         irs=1
         nseason=nseasn
c ---    Access season names
         do i=1,nseasn
            k=idseas(i)
            sname2(k+irs,1)=snamec(i)
         enddo
c ---    Access month assignments
         do k=1,12
            msn(k)=msnc(k)
         enddo
c ---    Prepare strings
         do i=1,nseasn
            irs=irs+1
            sname2(irs,2)='(                             '
            do j=1,12
               k=LEN_TRIM(sname2(irs,2))
               if(i.EQ.msn(j)) sname2(irs,2)=
     &                         sname2(irs,2)(1:k)//month3(j)//','
            enddo
            sname(irs)='                              '
            k1=LEN_TRIM(sname2(irs,1))
            k2=LEN_TRIM(sname2(irs,2))
            if(sname2(irs,2)(k2:k2).EQ.',')sname2(irs,2)(k2:k2)=')'
            sname(irs)=sname2(irs,1)(1:k1)//sname2(irs,2)(1:k2)
         enddo
      endif
c --- Report season definition
c      if(mrose.EQ.1) then
         write(ilog,*)
         write(ilog,*)'Season Definition:'
         do i=1,irs
            write(ilog,*)sname(i)
         enddo
         write(ilog,*)
c      endif

c --- Access extra time period definition
      ntpd=ntpdc
      if(ntpd.GT.0) then
         do i=1,ntpd
            ntp(1,i)=ntpc(1,i)
            ntp(2,i)=ntpc(2,i)
            irs=irs+1
            write(sname(irs),101)(ntp(ii,i),ii=1,2)
101         format('HR',i2.2,'-',i2.2)
c 101        format('TPD',i2.2,'_',i2.2)
            sname2(irs,1)='TPD'
            write(sname2(irs,2),111)(ntp(ii,i),ii=1,2)
111         format(i2,'_',i2)
         enddo
      endif

c --- Access extra wind speeds definition
      nwsp=nwspc
      if(nwsp.gt.0) then
         do i=1,nwsp
            wsp(1,i)=wspc(1,i)
            wsp(2,i)=wspc(2,i)
            irs=irs+1
            write(sname(irs),102)(nint(wsp(ii,i)),ii=1,2)
 102        format('WSP',i2.2,'_',i2.2)
            sname2(irs,1)='WSP'
            write(sname2(irs,2),112)(nint(wsp(ii,i)),ii=1,2)
 112        format(i2.2,'_',i2.2)
         enddo
      endif

c --- Access Range Data:      iopt=0 (Use Default)
c ---                         iopt=1 (Revise)
      iopt=1
      if(iopt.EQ.1 .AND. mrose.EQ.1) then
c ---    Low wind speed threshold
         wscalm=wsbin(1)
c ---    Ranges for wind speed
         do i=1,5
            j=i+1
            wscls(i)=wsbin(j)
         enddo
c ---    Last value is top (very large)
         wscls(6)=200.

c --- Remove concentration rose (done in SCAT_POLL)
c      elseif(iopt.EQ.1 .AND. mrose.EQ.2) then
cc ---    Read low concentration threshold
c         read(ictr,*)wclow
c         write(ilog,*)
c     &    'Definition of low concentration: lower than:',wclow
c         read(ictr,*)nws_check
c         if (nws_check.ne.nws) then
c            write(ilog,*)'Error - number of ranges must equal ',nws
c            write(*,*)'Error - see list file for error message'
c            stop
c         endif
cc ---    Read ranges for concentrations
c         read(ictr,*)(wccls(i),i=1,nws)
      endif

c --- Access pollutant rose configuration inputs if needed
      if(mrose.EQ.2) then
         rose_radius=rrose
         conc_spec=ADJUSTL(pspec)
         conc_unit=ADJUSTL(punit)
         conc_scale=crose
c ---    Report pollutant rose configuration
         write(ilog,*)
         write(ilog,*)'Pollutant Rose Configuration:'
         write(ilog,*)'   Radius  ',rose_radius
         write(ilog,*)'   Species ',conc_spec
         write(ilog,*)'   Units   ',conc_unit
         if(conc_scale.GT.0.0) then
            write(ilog,*)'   Scale   ',conc_scale
         else
            write(ilog,*)'   Scale   (auto)'
         endif
         write(ilog,*)
      endif

c --- Set extraction begin and end markers
c --- Start time
      nbdathr=ndateext
      nbsec=nsecext
c --- Period
      xhrs=FLOAT(nbsecext)*(FLOAT(isecstep)/3600.)
      ihrinc=INT(xhrs)
      xsecinc=(xhrs-FLOAT(ihrinc))*3600.
      isecinc=NINT(xsecinc)
c --- End time
      nesec=nbsec
      call DEDAT(nbdathr,iyr,jday,ihour)
      call INCR(ilog,iyr,jday,ihour,ihrinc)
      call INCRS(ilog,iyr,jday,ihour,nesec,isecinc)
      call GRDAY(ilog,iyr,jday,imon,iday)
      call TIMESTAMP(iyr,jday,ihour,nedathr)
c --- Report time period configuration
      write(ilog,*)'Time-Window for Rose Output: '
      write(ilog,'(a8,i12.10,i6.4)')'Start = ',nbdathr,nbsec
      write(ilog,'(a8,i12.10,i6.4)')'End   = ',nedathr,nesec

      return
      end

c----------------------------------------------------------------------
      subroutine windrose(iout1,iout2)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100611      WINDROSE
c                D. Strimaitis
c
c --- PURPOSE:  Create windrose frequency tabulations from timeseries
c
c               (Adapted from WDCOMP Version: 2.1, Level: 070207)
c
c --- UPDATES:
c --- Version 1.74, level 091026 to Version 1.77, level 100611 (CEC)
c          - Fix a bug in the number of comment lines when many stations
c            are extracted in a same run
c --- Version 1.66, level 090731 to Version 1.74, level 091026 (CEC)
c          - Put frequency file and tab file in output time zone (ABTZ = izonec)
c            records are read in TSF time zone (atzone8) and change in ABTZ time zone
c            Time Zone information is added in both file beside the beg and end dates
c --- Version 1.62, Level: 090411 to Version 1.66, level 090731 (DGS)
c         - Remove XM, STDM, RR, BUFF, HDR1, HDR2, HDR3,
c           CFNAME (not used)
c --- Version 1.6, Level: 090318 to Version 1.62, Level: 090411 (CEC)
c         - All header lines in description will be written instead
c           of the two first lines
c         - Format of the FRQ header has changed - change also to 
c           version number to 2.2
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c         - Full creation string from /QA/ in place of ver,lev
c         - Update TSF datasets recognized to V1.3
c         - Change to Julian Date-hour integer YYYYJJJHH
c --- Version 1.4, Level: 070315 to Version 1.5, Level: 090203 (DGS)
c         - Add option to define seasons from control file
c         - Change TSF dataset name to TIMESERIES.TSF
c         - Add time period window screen
c
c --- INPUTS:
c         iout1 - integer      - output file unit number (windrose
c                                frequency data)
c         iout2 - integer      - output file unit number (windrose
c                                frequency tables)
c
c --- OUTPUT:
c          none
c
c --- WINDROSE called by:  main
c --- WINDROSE calls:      TIMESTAMP, wdfreqc, freqoutc, acmfreq
c----------------------------------------------------------------------
      include 'params.ser'
      include 'qa.ser'
      include 'wndrose.ser'
      include 'ctrl.ser'

      dimension iyr(mxhrs,mxgrd),imon(mxhrs,mxgrd),iday(mxhrs,mxgrd)
      dimension ihour(mxhrs,mxgrd),isec(mxhrs,mxgrd)
      dimension freq(nws1,ndir1),wsfm(nws1,ndir1)
      dimension wds(mxhrs),wss(mxhrs)
c      dimension xm(5,mxgrd),stdm(5,mxgrd),rr(5,mxgrd)
      dimension xvar(mxvars)

c      character*320 buff,hdr1,hdr2,hdr3,hdr(50)
      character*320 hdr(50)
      character*16 dataset,dataver
      character*64 datamod

      character*16 tsernam,tserver
      character*64 tsermod
      character*80 comment
      character*8 atzone8,pmap8
      character*12 avar(mxvars),aunits(mxvars)
c      character*132 cfname

      integer nodata

c --- Configure output variables
      data dataset/'WIND.FRQ'/, dataver/'2.3'/
      data datamod/'CALWindRose FRQ File Format'/
c      data ncomment/6/
c --- ncomment - number of comment lines - to be added to imported title for .TSF
c      data ncomment/1/
       data ncomment0/1/
c --- nmt - number of text-based header records
      data nmt/5/

c --- Pass file unit numbers into common
      io1=iout1 
      io2=iout2 

c --- NGRD is 1 in this configuration
      ngrd=1

c --- Initialization wind height
      hgt=0.
      z1=0.
      z2=0.

c --- Length of create string
      nc=LEN_TRIM(create80)

c----------------------------------------------------------------------

c     Get time series of wind speed and wind direction
      do igrd=1,ngrd
c ---    Test first header record to determine dataset version
         read(in,'(2a16,a64)') tsernam,tserver,tsermod
         if(tsernam.EQ.'TIMESERIES.TSF  ') then
c ---       Read comment records
            read(in,*) ncomm
            do n=1,ncomm
               read(in,'(a80)') comment
            enddo

c ---       Set a default map projection to NONE
            pmap8='NONE    '

c ---       Read header section before data description
            if(tserver.EQ.'1.0             ') then
               read(in,*) nvars
            elseif(tserver.NE.'1.3             ') then
               read(in,*) atzone8
               read(in,*) nvars
            elseif(tserver.EQ.'1.3             ') then
               read(in,*) ntitles
               if(ntitles.LT.2) then
                  write(ilog,*)'Wrong number of title lines in file'
                  write(ilog,*)'Found    ',ntitles
                  write(ilog,*)'Needed 2'
                  write(*,*)'Wrong number of title lines in file'
                  write(*,*)'Found    ',ntitles
                  write(*,*)'Needed 2'
                  stop
               endif
c ---          (CEC - 090411 - Store all lines from the description lines
c               read(in,'(a)')hdr1
c               read(in,'(a)')hdr2
c               do k=3,ntitles
                do k=1,ntitles
c                  read(in,'(a)')hdr3
                   read(in,'(a)')hdr(k)
               enddo
               read(in,*) pmap8
               if(pmap8.EQ.'NONE    ') then
                  nskip=0
               elseif(pmap8.EQ.'LL      ') then
                  nskip=2
               elseif(pmap8.EQ.'UTM     ') then
                  nskip=3
               else
                  nskip=4
               endif
               do n=1,nskip
                  read(in,*)
               enddo
               read(in,*) atzone8
               read(in,*)
               read(in,*)
               read(in,*) nvars
            endif

c ---       Read data description records
            if(nvars.GT.mxvars) then
               write(ilog,*)'Too many timeseries variables are in file'
               write(ilog,*)'for size of arrays'
               write(ilog,*)'Found NVARS  = ',nvars
               write(ilog,*)'Array MXVARS = ',mxvars
               write(*,*)'Too many timeseries variables are in file'
               write(*,*)'for size of arrays'
               write(*,*)'Found NVARS  = ',nvars
               write(*,*)'Array MXVARS = ',mxvars
               stop
            endif
            do n=1,nvars
               z1=0.0
               x1=0.0
               y1=0.0
               if(tserver.NE.'1.3             ') then
                  read(in,'(2a12,2f12.3)') avar(n),aunits(n),
     &                                     xmissval,z1
               else
                  read(in,'(2a12,5f12.3)') avar(n),aunits(n),xmwt,
     &                                     xmissval,z1,x1,y1
               endif
               if(avar(n)(1:4).eq.'WDIR') z2=z1
               if(avar(n)(1:6).eq.'WSPEED') then
                  if(z2.eq.z1) then
                     hgt=z1
                  else
                     write(ilog,*)'Error- wind speed ht not provided'
                     stop
                  endif
               endif
            enddo

c ---       Final section of datasets before v1.3
c ---       Expect 2 fixed header records for title information
            if(tserver.NE.'1.3             ') then
               read(in,*) ntitles
               if(ntitles.LT.2) then
                  write(ilog,*)'Wrong number of title lines in file'
                  write(ilog,*)'Found    ',ntitles
                  write(ilog,*)'Needed 2'
                  write(*,*)'Wrong number of title lines in file'
                  write(*,*)'Found    ',ntitles
                  write(*,*)'Needed 2'
                  stop
               endif
c ---          (CEC - 090411 - Store all lines from the description lines
c               read(in,'(a)')hdr1
c               read(in,'(a)')hdr2
c               do k=3,ntitles
                do k=1,ntitles
c                  read(in,'(a)')hdr3
                   read(in,'(a)')hdr(k)
               enddo
            endif

c ---       Determine index for wind speed and direction
            kws=0
            kwd=0
            do k=1,nvars
               if(avar(k).EQ.'WSPEED      ') kws=k
               if(avar(k).EQ.'WDIR        ') kwd=k
            enddo
            if(kws.EQ.0 .OR. kwd.EQ.0) then
               write(ilog,*)'Wind data are not found'
               write(ilog,*)'Index for wind speed     = ',kws
               write(ilog,*)'Index for wind direction = ',kwd
               write(*,*)'Wind data are not found'
               write(*,*)'Index for wind speed     = ',kws
               write(*,*)'Index for wind direction = ',kwd
               stop
            endif

c ---       Store end-time of each record
            ip=1
 1001       read(in,*,end=1500) iy0,im0,id0,ih0,is0,
     &                          iy1,im1,id1,ih1,is1,
     &                         (xvar(kvar),kvar=1,nvars)

c ---       Screen time
            call JULDAY(ilog,iy0,im0,id0,jd0)
            call JULDAY(ilog,iy1,im1,id1,jd1)

c ---       (CEC - 091026) - Put data in output time zone (ABTZ = izonec)
c ---            records are read in TSF time zone (atzone8) and change in ABTZ time zone
            call UTCBASR(atzone8,zone)
            izonetsf=NINT(zone)
            if(izonetsf.ne.izonec) then
            idt=izonetsf-izonec
              call INCR(ilog,iy0,jd0,ih0,idt)
              call GRDAY(ilog,iy0,jd0,im0,id0)
              call INCR(ilog,iy1,jd1,ih1,idt)
              call GRDAY(ilog,iy1,jd1,im1,id1)
            endif

            call TIMESTAMP(iy0,jd0,ih0,ndathr0)
            call TIMESTAMP(iy1,jd1,ih1,ndathr1)

c ---       Time is before window?
            if(ndathr1.LT.nbdathr) goto 1001
            if(ndathr1.EQ.nbdathr .AND. is1.LT.nbsec) goto 1001
c ---       Time is after window?
            if(ndathr0.GT.nedathr) goto 1500
            if(ndathr0.EQ.nedathr .AND. is0.GT.nesec) goto 1500
c ---       Accept time
            iyr(ip,igrd)=iy1
            imon(ip,igrd)=im1
            iday(ip,igrd)=id1
            ihour(ip,igrd)=ih1
            isec(ip,igrd)=is1
            wd(ip,igrd)=xvar(kwd)
            ws(ip,igrd)=xvar(kws)
            ip=ip+1
            if(ip.GT.mxhrs)then
               write(ilog,*)
               write(ilog,*)'***   WARNING    ***'
               write(ilog,*)'Reached maximum array setting:',mxhrs
               write(ilog,*)'before all data were read from file'
               write(ilog,*)
               write(*,*)
               write(*,*)'***   WARNING    ***'
               write(*,*)'Reached maximum array setting:',mxhrs
               write(*,*)'before all data were read from file'
               write(*,*)
               goto 1500
            endif
            goto 1001
 1500       nhrs(igrd)=ip-1

         else
            write(ilog,*)'Invalid timeseries format!'
            write(ilog,*)'Found ',tsernam
            write(ilog,*)'Expected TIMESERIES.TSF'
            stop 'Halted in WINDROSE --- See log file'
         endif

      enddo

c     Check time stamp consistency
      n1=nhrs(1)
      do i=2,ngrd
         n2=nhrs(i)
         if(n1.ne.n2) then
            write(ilog,*)'Error - Inconsistent Time Series Length:'
            write(ilog,*)'        at Time Series 1 and ',i
            write(ilog,*)' N1, N2: ',n1,n2
            print *,'Error in Inconsistent Time Series Length:'
            print *,'        at Time Series 1 and ',i
            print *,' N1, N2: ',n1,n2
            stop 01
         endif
      enddo

      ip=0

      do ihr=1,n1 
         iyr1=iyr(ihr,1)
         imon1=imon(ihr,1)
         iday1=iday(ihr,1)
         ihour1=ihour(ihr,1)
         call JULDAY(ilog,iyr1,imon1,iday1,ijul1)
           if(ihour1.eq.24) then
           call midnite(ilog,'TO 00h',iyr1,imon1,iday1,ijul1,
     &          iyr11,imon11,iday11,ijul11)
           iyr1=iyr11
           imon1=imon11
           iday1=iday11
           ijul1=ijul11
           ihour1=0
           endif
         do i=2,ngrd
            iyr2=iyr(ihr,i)
            imon2=imon(ihr,i)
            iday2=iday(ihr,i)
            ihour2=ihour(ihr,i)
         call JULDAY(ilog,iyr2,imon2,iday2,ijul2)
           if(ihour2.eq.24) then
           call midnite(ilog,'TO 00h',iyr2,imon2,iday2,ijul2,
     &          iyr22,imon22,iday22,ijul22)
           iyr2=iyr22
           imon2=imon22
           iday2=iday22
           ijul2=ijul22
           ihour2=0
           endif

            if(iyr1.ne.iyr2 .or. imon1.ne.imon2 .or.
     &         iday1.ne.iday2 .or. ihour1.ne.ihour2) then
               write(ilog,*)'Error - Inconsistent Date:'
               write(ilog,*)iyr1,imon1,iday1,ihour1
               write(ilog,*)iyr2,imon2,iday2,ihour2

               print *,'Error - Inconsistent Date:'
               print *,iyr1,imon1,iday1,ihour1
               print *,iyr2,imon2,iday2,ihour2
            endif

         enddo

         ip=ip+1

      enddo

c Set monthly season ID
      do ihr=1,n1
         mn=imon(ihr,1)
         idsn(ihr)=msn(mn)
      enddo

c --- Windroses 
600   do igrd=1,ngrd

         nwdrs=0
         ngrdloc=igrd
c ---    First 2 station records from TSF are moved to text-based header
         ncomment=ncomment0+ntitles-2

c --- Write header records to FRQ file:
         write(io1,'(2a16,a64)') dataset,dataver,datamod
         write(io1,'(i4,a)') ncomment,' - Comment records'
         write(io1,'(a)') create80(1:nc)
c         write(io1,1015) hdr1
c         write(io1,1015) hdr2
         do i=3,ntitles
            write(io1,1015) hdr(i)
         enddo
        write(io1,'(i4,a)') nmt,' - Number of text-based header records'
         do i=1,2
            write(io1,1015) hdr(i)
         enddo
         write(io1,'(a8,f8.2,a2)')'Height: ',hgt,' m'
c ---    Note: In order to write out calms as eg. 1.0E-05, the 
c              1pe9.1 format descriptor was used which moves all
c              decimal places right by one. This works for the
c              e9.1 format, but causes an equivalent x10 to the
c              values being written using f5.1, which is why 
c              wscls(i) is divided by 10 when written out here
c              This only affects this write statement
c         write(io1,1120) wscalm,(wscls(i)/10,i=1,nws-1)
         write(io1,1120) wscalm,wscalm/10,(wscls(i)/10,i=1,nws-1)
c --- (CEC - 091026 - time zone added - may be different from TSF time zone)
         write(io1,1130) iyr(1,1),imon(1,1),iday(1,1),ihour(1,1),
     &                   isec(1,1),iyr(n1,1),imon(n1,1),iday(n1,1),
     &                   ihour(n1,1),isec(n1,1),azonec

c --- Write header records to TAB file:
         write(io2,'(a)') create80(1:nc)
c         write(io2,1015) hdr1
c         write(io2,1015) hdr2
         do i=1,ntitles
            write(io2,1015) hdr(i)
         enddo
         write(io2,'(a8,f8.2,a2)')'Height: ',hgt,' m'
         write(io2,1120) wscalm,wscalm/10,(wscls(i)/10,i=1,nws-1)
c --- (CEC - 091026 - time zone added - may be different from TSF time zone)
         write(io2,1130) iyr(1,1),imon(1,1),iday(1,1),ihour(1,1),
     &                   isec(1,1),iyr(n1,1),imon(n1,1),iday(n1,1),
     &                   ihour(n1,1),isec(n1,1),azonec
         write(io2,*)
         write(io2,*)

 1015    format(a)
 1120    format('Wind Speed Classes (m/s):',(1pe9.1),
     &          6(',',f5.1))
 1130    format(i4,3i3,1x,i4.4,3x,i4,3i3,1x,i4.4,a10)

         npts=nhrs(igrd)

c        Annual or all hours
         do ihr=1,npts
            wds(ihr)=wd(ihr,igrd)
            wss(ihr)=ws(ihr,igrd)
         enddo

         nodata=0

         call wdfreq(wss,wds,freq,wsfm,npts,nodata)

         nwdrs=nwdrs+1
         idgrd=igrd*ifive+nwdrs

         if(nodata.eq.0) then
c           call freqout(freq,wsfm,npts,'HR:00-23')
           call freqout(freq,wsfm,npts)
         endif

c ---    Not Used?
cc        Accumulative frequency (whole time series only)
c         call acmfreq(wss,wds,npts,igrd)

c        Seasons
         do isn=1,nseason
            do i=1,mxhrs
               wds(i)=0
               wss(i)=0
            enddo

            ip=0
            do ihr=1,npts
               jmon=imon(ihr,igrd)
               ids=msn(jmon)
               if(ids.eq.isn) then
                  ip=ip+1
                  wds(ip)=wd(ihr,igrd)
                  wss(ip)=ws(ihr,igrd)
               endif
            enddo

            ipts=ip

            nodata=0

            call wdfreq(wss,wds,freq,wsfm,ipts,nodata)
            nwdrs=nwdrs+1
            idgrd=igrd*ifive+nwdrs

            if(nodata.eq.0) then
              call freqout(freq,wsfm,ipts)
            endif
         enddo

c        Additional time periods
         if(ntpd.le.0) goto 2000
         do itpd=1,ntpd
            iprd1=ntp(1,itpd)
            iprd2=ntp(2,itpd)

            irev=0
            if(iprd1.gt.iprd2) irev=1

            ip=0
            do ihr=1,npts
               iprd=ihour(ihr,igrd)

               if(irev.eq.0) then
c                  if(iprd.ge.iprd1 .and. iprd.lt.iprd2) then
                  if(iprd.ge.iprd1 .and. iprd.le.iprd2) then
                     ip=ip+1
                     wds(ip)=wd(ihr,igrd)
                     wss(ip)=ws(ihr,igrd)
                  endif
               else
c                  if(iprd.ge.iprd1 .or. iprd.lt.iprd2) then
                  if(iprd.ge.iprd1 .or. iprd.le.iprd2) then
                     ip=ip+1
                     wds(ip)=wd(ihr,igrd)
                     wss(ip)=ws(ihr,igrd)
                  endif
               endif
            enddo

            ipts=ip

            nodata=0

            call wdfreq(wss,wds,freq,wsfm,ipts,nodata)
            nwdrs=nwdrs+1
            idgrd=igrd*ifive+nwdrs

            if(nodata.eq.0) then
              call freqout(freq,wsfm,ipts)
            endif
         enddo

c        Additional wind speed ranges
 2000    continue
         if(nwsp.le.0) goto 3000
         do iwsp=1,nwsp
            ss1=wsp(1,iwsp)
            ss2=wsp(2,iwsp)

            ip=0
            do ihr=1,npts
               ss=ws(ihr,igrd)
c               if(ss.ge.ss1 .and. ss.lt.ss2) then
               if(ss.ge.ss1 .and. ss.le.ss2) then
                  ip=ip+1
                  wds(ip)=wd(ihr,igrd)
                  wss(ip)=ws(ihr,igrd)
               endif
            enddo

            ipts=ip

            nodata=0

            call wdfreq(wss,wds,freq,wsfm,ipts,nodata)
            nwdrs=nwdrs+1
            idgrd=igrd*ifive+nwdrs

            if(nodata.eq.0) then
              call freqout(freq,wsfm,ipts)
            endif
         enddo

c        Finish windrose part
 3000    continue
      enddo

      return
      end

c----------------------------------------------------------------------
      subroutine wdfreq(wss,wds,freq,wsfm,npts,nodata)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203        WDFREQ
c
c Purpose: Calculate windrose frequency at a single position 
c
c wss:     Wind speed
c wds:     Wind direction
c npts:    Number of points of wss and wds series
c ntotal:  Number of Non-missing points of wss and wds time series
c ncalm:   Number of calm wind points
c nws:     Wind speed class
c ndir:    Number of wind scales
c wscalm:  Calm wind speed
c freq:    Frequency array
c nodata:  0=data exists, 1=all missing
c
c --- UPDATES:
c           V1.81 Level 100721 to V1.9.0 Level 121203
c           - Undo previous change regarding NODATA
c
c           V1.81 Level 100721
c           - Remove NODATA=1 and RETURN lines after STOP (before 500)
c           - Remove LDATA
c----------------------------------------------------------------------

      include 'params.ser'
      include 'wndrose.ser'

      dimension wds(mxhrs),wss(mxhrs)
      dimension freq(nws1,ndir1),wsfm(nws1,ndir1),ipp(nws1,ndir1)

c     Initial counter array
      do j=1,ndir1
         do i=1,nws1
            freq(i,j)=0
            wsfm(i,j)=0
            ipp(i,j)=0
         enddo
      enddo

      if(npts.lt.1) then
         write(ilog,*)
         write(ilog,*)'No Data in WDS/WSS timeseries for current subset'
         write(ilog,*)'Incomplete set of Frequency Tables calculated'
c         write(ilog,*)'Exit from wdfreq'

c         print *,'No data in WD/WS time series'
c         print *,'Frequencies have not calculated'
c         print *,'Exit from wdfreq'

         nodata=1

         return

      endif

      nmiss=0
      ncalm=0

      do ih=1,npts
         ss=wss(ih)
         dd=wds(ih)
         if(ss.ne.fmiss .and. dd.ne.fmiss) then
            ihbeg=ih
            goto 500
         endif
         nmiss=nmiss+1
      enddo

      write(ilog,*)'All data in WDS/WSS time series are missing!'
      write(ilog,*)'Frequencies are not calculated'

      nodata = 1
      return

 500  continue

      do 1000 ih=ihbeg,npts     ! wind frequency class
         ss=wss(ih)
         dd=wds(ih)

         if(ss.eq.fmiss .or. dd.eq.fmiss) then
            nmiss=nmiss+1
            goto 1000
         endif

c	     Changed on 4/13/2001
c         if(ss.lt.wscalm .and. dd.eq.0) then
         if(ss.lt.wscalm) then
            ncalm=ncalm+1
            goto 1000
         endif
	      
         idc=nint(dd/22.5)+1
         if(idc.gt.ndir) idc=1  

         do i=1,nws
            ss2=wscls(i)
            if(i.eq.1) then
c              ss1=0
               ss1=wscalm
            else
               ss1=wscls(i-1)
            endif
		
            if(ss.ge.ss1 .and. ss.lt.ss2) then
               isc=i
               goto 1050
            endif
         enddo

         write(ilog,*)'Invalid wind speed: ',ss
         print *,'Invalid wind speed: ',ss
         stop 12

 1050    continue

c        Sum of wind speed class
         ipp(isc,idc)=ipp(isc,idc)+1
         wsfm(isc,idc)=wsfm(isc,idc)+ss

c        Sum of all wind speed class
         ipp(nws1,idc)=ipp(nws1,idc)+1
         wsfm(nws1,idc)=wsfm(nws1,idc)+ss

         ipp(nws1,ndir1)=ipp(nws1,ndir1)+1
         wsfm(nws1,ndir1)=wsfm(nws1,ndir1)+ss

c        Sum of all wind directions
         ipp(isc,ndir1)=ipp(isc,ndir1)+1
         wsfm(isc,ndir1)=wsfm(isc,ndir1)+ss

 1000 enddo

c     QC for sums of points and frequencies
      ntot=0
      do j=1,ndir
         do i=1,nws
            nn=ipp(i,j)
            ntot=ntot+nn
         enddo
      enddo

      ntotal=ntot+ncalm

      nall=ntotal+nmiss
      if(nall.ne.npts) then
         write(ilog,*)'Error: Total Number not Match:',nall,npts
         stop 10
      endif

      atotal=float(ntotal)

      fall=0
      do j=1,ndir1
         do i=1,nws1
            freq(i,j)=ipp(i,j)/atotal
            if(j.ne.ndir1 .and. i.ne.nws1) fall=fall+freq(i,j)
         enddo
      enddo
	      		
      frecalm=float(ncalm)/atotal*100

      fall=fall*100+frecalm

      dfreq=abs(100-fall)
      
      if(dfreq .gt. 1.0) then
         write(ilog,*)'Error in summed frequency:'
         write(ilog,*)fall
         print *,'Error in summed frequency:'
         print *,fall
         stop 11
      endif

c     Get frequency mean wind speed
      do j=1,ndir1
         do i=1,nws1
            ip=ipp(i,j)
            aa=wsfm(i,j)
            if(ip.ge.1) then
               aa=aa/ip
            else
               aa=0
            endif
            wsfm(i,j)=aa
         enddo
      enddo

      return
      end

c----------------------------------------------------------------------
      subroutine acmfreq (wss,wds,npts,igrd)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100721       ACMFREQ
c
c Purpose: Calculate accumulative frequency at a single position 
c
c wss:     Wind speed
c wds:     Wind direction
c npts:    Number of points of wss and wds series
c ns:      Array for number of accumulative frequency based on wind speed
c nd:      Array for number of accumulative frequency based on wind dir.
c ntotal:  Number of Non-missing points of wss and wds time series
c----------------------------------------------------------------------

      include 'params.ser'
      include 'wndrose.ser'

      dimension wds(mxhrs),wss(mxhrs)
      dimension ns(nwsup),nd(nwdup)
      dimension fns(nwsup),fnd(nwdup)
c     Initail range arrays
      do i=1,nwsup
         if(i.eq.1) then
            wsr(1,i)=0
         else
            wsr(1,i)=(i-1)*dsrang
         endif
         wsr(2,i)=i*dsrang
      enddo
      wsr(2,nwsup)=99

      do i=1,nwdup
         if(i.eq.1) then
            wdr(1,i)=360-half
         else
            wdr(1,i)=(i-1)*rwds-half
         endif
         wdr(2,i)=(i-1)*rwds+half
      enddo

      if(npts.lt.1) then
         write(ilog,*)'No Data in WDS/WSS timeseries for current subset'
         write(ilog,*)'Incomplete set of Frequency Tables calculated'
c         write(ilog,*)'Exit from acmfreq'

c         print *,'No data in WD/WS time series'
c         print *,'Frequencies have not calculated'
c         print *,'Exit from acmfreq'

         return
      endif

c     Accumulative frequency based on Wind Speed
      ntotal=0
      do k=1,nwsup
         ss1=wsr(1,k)
         ss2=wsr(2,k)

         nmiss=0

         do ih=1,npts
            ss=wss(ih)
            dd=wds(ih)
            if(ss.ne.fmiss .and. dd.ne.fmiss) then
               ihbeg=ih
               goto 500
            endif
            nmiss=nmiss+1
         enddo

         write(ilog,*)'All data in WDS/WSS time series are missing 2'
         write(ilog,*)'Frequencies have not calculated'
         write(ilog,*)'Exit from acmfreq'

         print *,'All data in WDS/WSS time series are missing 2'
         print *,'Frequencies have not calculated'
         print *,'Exit from acmfreq'
         stop
	   
 500     continue

         isc=0
         do 1000 ih=ihbeg,npts  
            ss=wss(ih)
            dd=wds(ih)

            if(ss.eq.fmiss .or. dd.eq.fmiss) then
               nmiss=nmiss+1
               goto 1000
            endif
            if(ss.ge.ss1 .and. ss.lt.ss2) then
               isc=isc+1
               ntotal=ntotal+1
            endif
 1000    enddo

         ns(k)=isc

      enddo

      if(ntotal+nmiss.ne.npts) then
         write(ilog,*)'Error in subroutine acmfreq:',isc,nmiss,ntotal
         print *,'Error in subroutine acmfreq:',isc,nmiss,ntotal
         stop 41
      endif

      ftotal=float(ntotal)
      dd=0
      do k=1,nwsup
         fns(k)=ns(k)/ftotal
         dd=dd+fns(k)
      enddo

      if(abs(dd-1.0).gt.0.02) then
         write(ilog,*)'Error in subroutine acmfreq:',dd
         print *,'Error in subroutine acmfreq:',dd
         stop 42         
      endif

c     Save in facmws array
      do k=1,nwsup
         aa=fns(k)
         if(aa.ne.fmiss) aa=aa*100
         facmws(k,igrd)=aa
      enddo

c     Accumulative frequency based on Wind Directory
      ntotal=0
      do k=1,nwdup
         dd1=wdr(1,k)
         dd2=wdr(2,k)

         nmiss=0

         do ih=1,npts
            ss=wss(ih)
            dd=wds(ih)
            if(ss.ne.fmiss .and. dd.ne.fmiss) then
               ihbeg=ih
               goto 550
            endif
            nmiss=nmiss+1
         enddo

         write(ilog,*)'All data in WDS/WSS time series are missing 3'
         write(ilog,*)'Frequencies have not calculated'
         write(ilog,*)'Exit from acmfreq'

         print *,'All data in WDS/WSS time series are missing 3'
         print *,'Frequencies have not calculated'
         print *,'Exit from acmfreq'
         stop
	   
 550     continue

         isc=0
         do 1500 ih=ihbeg,npts  
            ss=wss(ih)
            dd=wds(ih)
               
            if(ss.eq.fmiss .or. dd.eq.fmiss) then
               nmiss=nmiss+1
               goto 1500
            endif

            if(k.eq.1) then
               if(dd.ge.dd1 .or. dd.lt.dd2) then
                  isc=isc+1
                  ntotal=ntotal+1
               endif
            else 
               if(dd.ge.dd1 .and. dd.lt.dd2) then
                  isc=isc+1
                  ntotal=ntotal+1
               endif
            endif
 1500    enddo

         nd(k)=isc

      enddo

      if(ntotal+nmiss.ne.npts) then
         write(ilog,*)'Error in subroutine acmfreq:',isc,nmiss,ntotal
         print *,'Error in subroutine acmfreq:',isc,nmiss,ntotal
         stop 43
      endif

      ftotal=float(ntotal)
      dd=0
      do k=1,nwdup
         fnd(k)=nd(k)/ftotal
         dd=dd+fnd(k)
      enddo

      if(abs(dd-1.0).gt.0.02) then
         write(ilog,*)'Error in subroutine acmfreq:',dd
         print *,'Error in subroutine acmfreq:',dd
         stop 44         
      endif

c     Save in facmwd array
      do k=1,nwdup
         aa=fnd(k)
         if(aa.ne.fmiss) aa=aa*100.
         facmwd(k,igrd)=aa
      enddo

      return
      end

c----------------------------------------------------------------------
      Subroutine freqout(freq,wsfm,npts)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090203       FREQOUT
c
c Purpose: Output wind freqency array in the form of EPA windrose format
c Note:     npts,idgrd and htgrd are exta info and not used by EPA windrose
c           program
c
c --- UPDATES:
c
c --- Version 1.4, Level: 070315 to Version 1.5, Level: 090203 (DGS)
c     - Allow for blanks within title strings
c----------------------------------------------------------------------
c
      include 'params.ser'
      include 'wndrose.ser'

      dimension freq(nws1,ndir1)
      dimension wsfm(nws1,ndir1)

      fcalm=float(ncalm)
      atotal=float(ntotal)
      iht=nint(hgt)

c Output frequency classes in the form of CALWindRose Program 
      idm=idgrd-idgrd/1000*1000

c      nt=index(sname(idm),' ')-1
      nt=LEN_TRIM(sname(idm))
      write(io1,*)
      write(io1,'(a)')sname(idm)(1:nt)

c --- (CEC - 081106 - minimum for range is the low wind speed threshold)
c      wscls2(1)=0
       wscls2(1)=wscalm
      do i=1,nws-1
         wscls2(i+1)=wscls(i)
      enddo

      write(io1,1142)(wscls2(i),wscls(i),i=1,nws-1),wscls(nws-1)
 1142 format('WDDIR  ',5(f4.1,'-',f4.1,4x),'   > ',f4.1,'          SUM')

      sdir(17)='SUM'
      do j=1,ndir1
         write(io1,1150)sdir(j),(freq(i,j)*100,i=1,nws1)
      enddo
 1150 format(1x,a3,':',7(3x,f7.3,'%',2x))
      write(io1,1031)frecalm
 1031 format('Calm Winds: ',f7.3,'%')
      write(io1,1040)npts,nint(atotal),nint(fcalm)
 1040 format('Total Periods = ',i5,';  Valid Periods = ',i5,
     &  ';  Calm Wind Periods = ',i5)

c Output frequency classes in tables

      idm=idgrd-idgrd/1000*1000
c      nt=index(sname(idm),' ')-1
      nt=LEN_TRIM(sname(idm))
      write(io2,1039)idgrd,sname(idm)(1:nt)
 1039 format(10x,'Wind Statistics at Station/Grid ID: ',i6,3x,a)

      write(io2,1041)npts,nint(atotal),nint(fcalm),iht
 1041 format('Total Points:    ',i5,10x,
     &  'Valid Points:    ',i5,/,
     &  'Calm Wind Points:',i5,10x,
     &  'Elevation(m):    ',i5,/)

c --- (CEC - 081106 - minimum for range is the low wind speed threshold)
c      wscls2(1)=0
       wscls2(1)=wscalm
      do i=1,nws-1
         wscls2(i+1)=wscls(i)
      enddo

      write(io2,1043)
 1043 format(30x,'Frequency Class (%)')
      write(io2,1042)(wscls2(i),wscls(i),i=1,nws-1),wscls(nws-1)
 1042 format('WDDIR',5(2x,f4.1,'-',f4.1),2x,'  > ',f4.1,'      SUM')

      sdir(17)='SUM'
      do j=1,ndir1
         write(io2,1050)sdir(j),(freq(i,j)*100,i=1,nws1)
      enddo
      write(io2,*)
 1050 format(1x,a3,1x,7(3x,f5.1,3x))

c Output wind speed classes in tables
      write(io2,1051)
 1051 format(30x,'Wind Speed Class (m/s)')

      write(io2,1052)(wscls2(i),wscls(i),i=1,nws-1),wscls(nws-1)
 1052 format('WDDIR',5(2x,f4.1,'-',f4.1),2x,'  > ',f4.1,'      AVE')

      sdir(17)='AVE'
      do j=1,ndir1
         write(io2,1050)sdir(j),(wsfm(i,j),i=1,nws1)
      enddo
      write(io2,*)

c Save frequency array
      do j=1,ndir1
         do i=1,nws1
            freqall(i,j,nwdrs,ngrdloc)=freq(i,j)
         enddo
      enddo

      freqcalm(nwdrs,ngrdloc)=fcalm/100.

c Save frequency mean wind speed array
      do j=1,ndir1
         do i=1,nws1
            wsfmall(i,j,nwdrs,ngrdloc)=wsfm(i,j)
         enddo
      enddo

      return
      end

c----------------------------------------------------------------------
      subroutine pollrose(iout1,iout2,iloc)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100611      POLLROSE
c                D. Strimaitis
c                C. Escoffier-Czaja
c
c --- PURPOSE:  Create pollutant rose from timeseries
c
c               (Adapted from WDCOMP Version: 2.1, Level: 070207)
c               (Adapted from WINDROSE subroutine)
c
c --- UPDATES:
c --- Version 1.72, level 091015 to Version 1.77, level 100611 (CEC)
c          - Fix a bug in the number of comment lines when many stations
c            are extracted in a same run
c --- Version 1.66, level 090731 to Version 1.72, level 091015 (CEC)
c         - transform time as hour 24 to hour 00 next day for comparison
c           of date stamp of the two files (MET and AQ).
c --- Version 1.62, Level: 090411 to Version 1.66, level 090731 (DGS)
c         - Remove XM, STDM, RR, BUFF, HDR1, HDR2, CFNAME (not used)
c --- Version 1.6, Level: 090318 to Version 1.62, Level: 090411 (CEC)
c         - All header lines in description will be written instead
c           of the two first lines
c         - Change the format of frequency files (Header record)
c           and version number of .FRQ POLL ROSE file becomes 2.1
c         - Add screen messages for missing/zero pollutants (DGS)
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c         - Full creation string from /QA/ in place of cversion,clevel
c         - Add option to get MET and AQ from different files
c         - Update TSF datasets recognized to V1.3
c         - Change to Julian Date-hour integer YYYYJJJHH
c
c --- INPUTS:
c         iout1 - integer      - output file unit number (pollutant rose
c                                frequency data)
c         iout2 - integer      - output file unit number (pollutant rose
c                                frequency tables)
c          iloc - integer      - current location index
c
c --- OUTPUT:
c          none
c
c --- POLLROSE called by:  main
c --- POLLROSE calls:      TIMESTAMP, MAXAV_POLL, SCAT_POLL, 
c                          wdfreqc, freqoutc, acmfreq
c----------------------------------------------------------------------
      include 'params.ser'
      include 'qa.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'wndrose.ser'

      dimension iyr(mxhrs,mxgrd),imon(mxhrs,mxgrd),iday(mxhrs,mxgrd)
      dimension ihour(mxhrs,mxgrd),isec(mxhrs,mxgrd)
      dimension freq(nws1,ndir1),wsfm(nws1,ndir1)
      dimension wds(mxhrs),wcs(mxhrs),wss(mxhrs)
c      dimension xm(5,mxgrd),stdm(5,mxgrd),rr(5,mxgrd)
      dimension xvar(mxvars)

c      character*320 buff,hdr1,hdr2,hdr3,hdr(50)
      character*320 hdr3,hdr(50)
      character*64 datamod
      character*16 dataset,dataver

      character*16 tsernam,tserver
      character*64 tsermod
      character*80 comment
      character*8 atzone8,pmap8
      character*12 avar(mxvars),aunits(mxvars),specdb(mxspec)
c      character*132 cfname
      character*80 clab

c --- Molar Mass
      real xMdb(mxspec)

      integer nodata

c --- Control for reading MET/AQ data
      logical LMET, LAQ

c --- Configure output variables
      data dataset/'POLL.FRQ'/, dataver/'2.1'/
      data datamod/'CALPollutantRose FRQ File Format'/
c      data ncomment/6/
c --- ncomment - number of comments before being added to ntitle comment from .TSF
c      data ncomment/1/
       data ncomment0/1/
c --- ncp - number of text-based comment records
      data ncp/5/

c --- Species list
      data specdb/'SO2         ',
     1            'NO          ',
     2            'NO2         ',
     3            'NOX         ',
     4            'CO          ',
     5            'O3          ',
     6            'H2S         ',
     7            'PM10        ',
     8            'PM2.5       '/
c --- Molecular weights for these species
      data xMdb/64.0,30.0,46.0,46.0,28.0,48.0,34.0,-1.0,-1.0/

c --- Pass file unit numbers into common
      io1=iout1 
      io2=iout2 

c --- Pass location index
      inbst=iloc

c --- NGRD is either 1 or 2 in this configuration to control processing
c --- either 1 TSF file (both MET and AQ in same file) or 2 TSF files
c --- (MET and AQ not from same file) --- Controlled by MTSF
      ngrd=MAX(1,mtsf)

c --- Initialization wind height
      hgt=0.
      z1=0.
      z2=0.

c --- Length of create string
      nc=LEN_TRIM(create80)

c----------------------------------------------------------------------

      do igrd=1,ngrd

c ---    Set file unit number
         inx=in
         if(igrd.EQ.2) inx=in2

c ---    Set logic for finding MET and AQ data
         if(igrd.EQ.1 .AND. mtsf.LT.2) then
c ---       Both MET and AQ should be in this file
            lmet=.TRUE.
            laq=.TRUE.
         elseif(igrd.EQ.1 .AND. mtsf.EQ.2) then
c ---       Just MET is used from this file
            lmet=.TRUE.
            laq=.FALSE.
         elseif(igrd.EQ.2) then
c ---       Just AQ is used from this file
            lmet=.FALSE.
            laq=.TRUE.
         else
            stop 'POLLROSE Failed'
         endif

c ---    Acquire all identified data from TSF file
c ---    Test first header record to screen dataset version
         read(inx,'(2a16,a64)') tsernam,tserver,tsermod
         if(tsernam.NE.'TIMESERIES.TSF  ') then
            write(ilog,*)'Invalid timeseries format!'
            write(ilog,*)'Found ',tsernam
            write(ilog,*)'Expected TIMESERIES.TSF'
            stop 'Halted in POLLROSE --- See log file'
         endif
c ---    Skip comment records
         read(inx,*) ncomm
         do n=1,ncomm
            read(inx,'(a80)') comment
         enddo

c ---    Set default map projection to NONE
         pmap8='NONE    '

c ---    Read header section before data description
         if(tserver.EQ.'1.0             ') then
            read(inx,*) nvars
         elseif(tserver.NE.'1.3             ') then
            read(inx,*) atzone8
            read(inx,*) nvars
         elseif(tserver.EQ.'1.3             ') then
            read(inx,*) ntitles
            if(ntitles.LT.2) then
               write(ilog,*)'Wrong number of title lines in file'
               write(ilog,*)'Found    ',ntitles
               write(ilog,*)'Needed 2'
               write(*,*)'Wrong number of title lines in file'
               write(*,*)'Found    ',ntitles
               write(*,*)'Needed 2'
               stop
            endif
c ---       Read header lines in and store first 2 for AQ
c            read(inx,'(a)')hdr3
c            if(LAQ) hdr1=hdr3
c            read(inx,'(a)')hdr3
c            if(LAQ) hdr2=hdr3
c            do k=3,ntitles
             do k=1,ntitles
               read(inx,'(a)')hdr3
               if(LAQ) hdr(k)=hdr3
            enddo
            read(inx,*) pmap8
            if(pmap8.EQ.'NONE    ') then
               nskip=0
            elseif(pmap8.EQ.'LL      ') then
               nskip=2
            elseif(pmap8.EQ.'UTM     ') then
               nskip=3
            else
               nskip=4
            endif
            do n=1,nskip
               read(inx,*)
            enddo
            read(inx,*) atzone8
            read(inx,*)
            read(inx,*)
            read(inx,*) nvars
         endif

c ---    Read data description records
         if(nvars.GT.mxvars) then
            write(ilog,*)'Too many timeseries variables are in file'
            write(ilog,*)'for size of arrays'
            write(ilog,*)'Found NVARS  = ',nvars
            write(ilog,*)'Array MXVARS = ',mxvars
            write(*,*)'Too many timeseries variables are in file'
            write(*,*)'for size of arrays'
            write(*,*)'Found NVARS  = ',nvars
            write(*,*)'Array MXVARS = ',mxvars
            stop
         endif
         do n=1,nvars
            z1=0.0
            x1=0.0
            y1=0.0
            if(tserver.NE.'1.3             ') then
               read(inx,'(2a12,2f12.3)') avar(n),aunits(n),
     &                                   xmissval,z1
            else
               read(inx,'(2a12,5f12.3)') avar(n),aunits(n),xmwt,
     &                                   xmissval,z1,x1,y1
            endif
            if(avar(n)(1:4).eq.'WDIR') z2=z1
            if(avar(n)(1:6).eq.'WSPEED') then
               if(z2.eq.z1) then
                  hgt=z1
               else
                  write(ilog,*)'Error- wind speed ht not provided'
                  stop
               endif
            endif
c ---       Save x,y information for AQ and MET
            if(LMET) then
               if(avar(n)(1:4).eq.'WDIR') then
                  xmet(inbst)=x1
                  ymet(inbst)=y1
               endif
            endif
            if(LAQ) then
               if(avar(n).EQ.conc_spec) then
                  xaq(inbst)=x1
                  yaq(inbst)=y1
               endif
            endif
         enddo

c ---    Final section of datasets before v1.3
c ---    Expect 2 fixed header records for title information
         if(tserver.NE.'1.3             ') then
            read(inx,*) ntitles
            if(ntitles.LT.2) then
               write(ilog,*)'Wrong number of title lines in file'
               write(ilog,*)'Found    ',ntitles
               write(ilog,*)'Needed 2'
               write(*,*)'Wrong number of title lines in file'
               write(*,*)'Found    ',ntitles
               write(*,*)'Needed 2'
               stop
            endif
c ---       Read header lines in and store first 2 for AQ
c            read(inx,'(a)')hdr3
c            if(LAQ) hdr1=hdr3
c            read(inx,'(a)')hdr3
c            if(LAQ) hdr2=hdr3
c            do k=3,ntitles
             do k=1,ntitles
               read(inx,'(a)')hdr3
               if(LAQ) hdr(k)=hdr3
            enddo
         endif

c ---    Determine index for MET and AQ data
         kwc=0
         kws=0
         kwd=0
         do k=1,nvars
            if(avar(k).EQ.conc_spec)      kwc=k
            if(avar(k).EQ.'WDIR        ') kwd=k
            if(avar(k).EQ.'WSPEED      ') kws=k
         enddo
         if(LMET) then
            if(kwd.EQ.0 .OR. kws.EQ.0) then
               write(ilog,*)'Wind data are not found'
               write(ilog,*)'Index for wind direction = ',kwd
               write(ilog,*)'Index for wind speed     = ',kws
               write(*,*)'Wind data are not found'
               write(*,*)'Index for wind direction = ',kwd
               write(*,*)'Index for wind speed     = ',kws
               stop
            endif
         endif
         if(LAQ) then
            if(kwc.EQ.0) then
               write(ilog,*)'Pollutant data are not found'
               write(ilog,*)'Index for pollutant      = ',kwc
               write(*,*)'Pollutant data are not found'
               write(*,*)'Index for pollutant      = ',kwc
               stop
            endif
         endif

         if(tserver.NE.'1.3             ') then
c ---       Get location x,y from header record HDR2 image
c ---       X,Y is located in last pair of () on line
c            i1=INDEX(hdr2,'(',back=.TRUE.)+1
c            i2=INDEX(hdr2,')',back=.TRUE.)-1
c            read(hdr2(i1:i2),*) xloc(inbst),yloc(inbst)
            i1=INDEX(hdr(2),'(',back=.TRUE.)+1
            i2=INDEX(hdr(2),')',back=.TRUE.)-1
            read(hdr(2)(i1:i2),*) xloc(inbst),yloc(inbst)
            if(LMET) then
               xmet(inbst)=xloc(inbst)
               ymet(inbst)=yloc(inbst)
            endif
            if(LAQ) then
               xaq(inbst)=xloc(inbst)
               yaq(inbst)=yloc(inbst)
            endif
         endif

         if(LAQ) then
c ---       Compute units factor to convert from TSF to Rose output
c ---       Identify pollutant in species list
            xMk=0.0
            uscale=1.0
            do k=1,mxspec
               if(specdb(k).EQ.conc_spec) xMk=xMdb(k)
            enddo
            call SCALE(ilog,conc_unit,aunits(kwc),xMk,uscale)
            write(ilog,*)conc_spec,aunits(kwc),conc_unit,uscale
         endif

c ---    Store end-time of each record
         ip=1
 1001    read(inx,*,end=1500) iy0,im0,id0,ih0,is0,
     &                       iy1,im1,id1,ih1,is1,
     &                      (xvar(kvar),kvar=1,nvars)
c ---    Screen time
         call JULDAY(ilog,iy0,im0,id0,jd0)
         call JULDAY(ilog,iy1,im1,id1,jd1)
         call TIMESTAMP(iy0,jd0,ih0,ndathr0)
         call TIMESTAMP(iy1,jd1,ih1,ndathr1)
c ---    Time is before window?
         if(ndathr1.LT.nbdathr) goto 1001
         if(ndathr1.EQ.nbdathr .AND. is1.LT.nbsec) goto 1001
c ---    Time is after window?
         if(ndathr0.GT.nedathr) goto 1500
         if(ndathr0.EQ.nedathr .AND. is0.GT.nesec) goto 1500
c ---    Accept time
         iyr(ip,igrd)=iy1
         imon(ip,igrd)=im1
         iday(ip,igrd)=id1
         ihour(ip,igrd)=ih1
         isec(ip,igrd)=is1
         if(LMET) then
            wd(ip,igrd)=xvar(kwd)
            ws(ip,igrd)=xvar(kws)
         endif
         if(LAQ) then
c ---       Scale only valid concentrations?
            wc(ip,igrd)=xvar(kwc)*uscale
         endif
         ip=ip+1
         if(ip.GT.mxhrs)then
            write(ilog,*)
            write(ilog,*)'***   WARNING    ***'
            write(ilog,*)'Reached maximum array setting:',mxhrs
            write(ilog,*)'before all data were read from file'
            write(ilog,*)
            write(*,*)
            write(*,*)'***   WARNING    ***'
            write(*,*)'Reached maximum array setting:',mxhrs
            write(*,*)'before all data were read from file'
            write(*,*)
            goto 1500
         endif
         goto 1001
 1500    nhrs(igrd)=ip-1

      enddo

c     Check time stamp consistency
      n1=nhrs(1)
      do i=2,ngrd
         n2=nhrs(i)
         if(n1.ne.n2) then
            write(ilog,*)'Error - Inconsistent Time Series Length:'
            write(ilog,*)'        at Time Series 1 and ',i
            write(ilog,*)' N1, N2: ',n1,n2
            print *,'Error in Inconsistent Time Series Length:'
            print *,'        at Time Series 1 and ',i
            print *,' N1, N2: ',n1,n2
            stop
         endif
      enddo

      ip=0

      do ihr=1,n1 
         iyr1=iyr(ihr,1)
         imon1=imon(ihr,1)
         iday1=iday(ihr,1)
         ihour1=ihour(ihr,1)
         call JULDAY(ilog,iyr1,imon1,iday1,ijul1)
           if(ihour1.eq.24) then
           call midnite(ilog,'TO 00h',iyr1,imon1,iday1,ijul1,
     &          iyr11,imon11,iday11,ijul11)
           iyr1=iyr11
           imon1=imon11
           iday1=iday11
           ijul1=ijul11
           ihour1=0
           endif
         do i=2,ngrd
            iyr2=iyr(ihr,i)
            imon2=imon(ihr,i)
            iday2=iday(ihr,i)
            ihour2=ihour(ihr,i)
         call JULDAY(ilog,iyr2,imon2,iday2,ijul2)
           if(ihour2.eq.24) then
           call midnite(ilog,'TO 00h',iyr2,imon2,iday2,ijul2,
     &          iyr22,imon22,iday22,ijul22)
           iyr2=iyr22
           imon2=imon22
           iday2=iday22
           ijul2=ijul22
           ihour2=0
           endif

            if(iyr1.ne.iyr2 .or. imon1.ne.imon2 .or.
     &         iday1.ne.iday2 .or. ihour1.ne.ihour2) then
               write(ilog,*)'Error - Inconsistent Date:'
               write(ilog,*)iyr1,imon1,iday1,ihour1
               write(ilog,*)iyr2,imon2,iday2,ihour2

               print *,'Error - Inconsistent Date:'
               print *,iyr1,imon1,iday1,ihour1
               print *,iyr2,imon2,iday2,ihour2
            endif
         enddo
         ip=ip+1
      enddo

c --- Frequency processing
c --- Set monthly season ID
      do ihr=1,n1
         mn=imon(ihr,1)
         idsn(ihr)=msn(mn)
      enddo

c --- Pollutant roses
c --- Set array index for MET and AQ
      kmet=1
      kaq=1
      if(mtsf.EQ.2) kaq=2
      igrd=1
c --- do igrd=1,ngrd

         nwdrs=0
         ngrdloc=igrd

c ---    Create string with species and units for labels
         ks=LEN_TRIM(conc_spec)
         ku=LEN_TRIM(conc_unit)
         clab=conc_spec(1:ks)//' Classes ('//conc_unit(1:ku)//'):'
         kl=INDEX(clab,':')

         npts=nhrs(igrd)

c        Annual or all hours
         do ihr=1,npts
c ---       wds(ihr)=wd(ihr,igrd)
c ---       wss(ihr)=ws(ihr,igrd)
c ---       wcs(ihr)=wc(ihr,igrd)
            wds(ihr)=wd(ihr,kmet)
            wss(ihr)=ws(ihr,kmet)
            wcs(ihr)=wc(ihr,kaq)
         enddo

c ---    Compute Maximum and Average pollutant rose and scatter plot
c ---    (determines concentration bins for frequency rose)
         nodata=0
         if(F_max_av) call MAXAV_POLL(wds,wcs,npts,nodata,inbst)
         if(nodata.GT.0) then
            print *,' '
            print *,'All pollutant data are missing or ZERO!'
            print *,'Pollutant Rose is not calculated'
            return
         endif
         if(F_scat) call SCAT_POLL(wds,wss,wcs,npts,nodata,inbst)
         if(nodata.GT.0) then
            print *,' '
            print *,'All pollutant data are missing or ZERO!'
            print *,'Pollutant Rose is not calculated'
            return
         endif

c ---    First 2 station records are used as text-based header records
c ---    so only write subsequent records to the comment section
         ncomment=ncomment0+ntitles-2

c ---    Write header records to FRQ file:
         write(io1,'(2a16,a64)') dataset,dataver,datamod
         write(io1,'(i4,a)') ncomment,' - Comment records'
         write(io1,'(a)') create80(1:nc)
c         write(io1,1015) hdr1
c         write(io1,1015) hdr2
         do i=3,ntitles
            write(io1,1015) hdr(i)
         enddo
         write(io1,'(i4,a)')ncp,' - Number of text-based header records'
         do i=1,2
            write(io1,1015) hdr(i)
         enddo
         write(io1,'(a8,f8.2,a2)')'Height: ',hgt,' m'
c ---    Note: In order to write out calms as eg. 1.0E-05, the 
c              1pe9.1 format descriptor was used which moves all
c              decimal places right by one. This works for the
c              e9.1 format, but causes an equivalent x10 to the
c              values being written using f5.1, which is why 
c              wscls(i) is divided by 10 when written out here
c              This only affects this write statement
c         write(io1,1120) wscalm,(wscls(i)/10,i=1,nws-1)
c         write(io1,1120) wclow,wclow/10,(wccls(i)/10,i=1,nws-1)
c         write(io1,1120) clab(1:kl),wclow,wclow/10,
c     &                   (wccls(i)/10,i=1,nws-1)
         write(io1,1120) clab(1:kl),wclow,wclow,(wccls(i),i=1,nws-1)
         write(io1,1130) iyr(1,1),imon(1,1),iday(1,1),ihour(1,1),
     &                   isec(1,1),iyr(n1,1),imon(n1,1),iday(n1,1),
     &                   ihour(n1,1),isec(n1,1)

c ---    Write header records to TAB file:
         write(io2,'(a)') create80(1:nc)
c         write(io2,1015) hdr1
c         write(io2,1015) hdr2
         do i=1,ntitles
            write(io2,1015) hdr(i)
         enddo
         write(io2,'(a8,f8.2,a2)')'Height: ',hgt,' m'
c         write(io2,1120) wclow,wclow/10,(wccls(i)/10,i=1,nws-1)
c         write(io2,1120) clab(1:kl),wclow,wclow/10,
c     &                   (wccls(i)/10,i=1,nws-1)
         write(io2,1120) clab(1:kl),wclow,wclow,(wccls(i),i=1,nws-1)
         write(io2,1130) iyr(1,1),imon(1,1),iday(1,1),ihour(1,1),
     &                   isec(1,1),iyr(n1,1),imon(n1,1),iday(n1,1),
     &                   ihour(n1,1),isec(n1,1)
         write(io2,*)
         write(io2,*)

 1015    format(a)
c 1120    format(a,(1pe9.1),6(',',f6.3))
 1120    format(a,1p,e8.2,6(',',e8.2))
 1130    format(i4,3i3,1x,i4.4,3x,i4,3i3,1x,i4.4)

         write(*,*)'Annual or all hours', npts
         call wdfreqc(wcs,wds,freq,wsfm,npts,nodata)

         nwdrs=nwdrs+1
         idgrd=igrd*ifive+nwdrs

         if(nodata.eq.0) then
c           call freqoutc(freq,wsfm,npts,'HR:00-23')
           call freqoutc(freq,wsfm,npts)
         endif

c ---    Not Used?
cc        Accumulative frequency (whole time series only)
c         call acmfreq(wcs,wds,npts,igrd)

c        Seasons
         do isn=1,nseason
            do i=1,mxhrs
               wds(i)=0
               wcs(i)=0
            enddo

            ip=0
            do ihr=1,npts
               jmon=imon(ihr,igrd)
               ids=msn(jmon)
               if(ids.eq.isn) then
                  ip=ip+1
                  wds(ip)=wd(ihr,kmet)
                  wcs(ip)=wc(ihr,kaq)
               endif
            enddo

            ipts=ip

            nodata=0

            call wdfreqc(wcs,wds,freq,wsfm,ipts,nodata)
            nwdrs=nwdrs+1
            idgrd=igrd*ifive+nwdrs

            if(nodata.eq.0) then
              call freqoutc(freq,wsfm,ipts)
            endif
         enddo

c --- This section is not currently active (not in control file)
cc        Additional time periods
c         if(ntpd.le.0) goto 2000
c         do itpd=1,ntpd
c            iprd1=ntp(1,itpd)
c            iprd2=ntp(2,itpd)
c
c            irev=0
c            if(iprd1.gt.iprd2) irev=1
c
c            ip=0
c            do ihr=1,npts
c               iprd=ihour(ihr,igrd)
c
c               if(irev.eq.0) then
cc                  if(iprd.ge.iprd1 .and. iprd.lt.iprd2) then
c                  if(iprd.ge.iprd1 .and. iprd.le.iprd2) then
c                     ip=ip+1
c                     wds(ip)=wd(ihr,igrd)
c                     wcs(ip)=wc(ihr,igrd)
c                  endif
c               else
cc                  if(iprd.ge.iprd1 .or. iprd.lt.iprd2) then
c                  if(iprd.ge.iprd1 .or. iprd.le.iprd2) then
c                     ip=ip+1
c                     wds(ip)=wd(ihr,igrd)
c                     wcs(ip)=wc(ihr,igrd)
c                  endif
c               endif
c            enddo
c
c            ipts=ip
c
c            nodata=0
c
c            write(*,*)'Additional time periods ',npts
c            call wdfreqc(wcs,wds,freq,wsfm,ipts,nodata)
c            nwdrs=nwdrs+1
c            idgrd=igrd*ifive+nwdrs
c
c            if(nodata.eq.0) then
c              call freqoutc(freq,wsfm,ipts)
c            endif
c         enddo

c --- This section is not currently active (not in control file)
c        Additional concentration ranges
 2000    continue
c         if(nwsp.le.0) goto 3000
c         do iwsp=1,nwsp
c            ss1=wsp(1,iwsp)
c            ss2=wsp(2,iwsp)
c
c            ip=0
c            do ihr=1,npts
c               ss=ws(ihr,igrd)
cc               if(ss.ge.ss1 .and. ss.lt.ss2) then
c               if(ss.ge.ss1 .and. ss.le.ss2) then
c                  ip=ip+1
c                  wds(ip)=wd(ihr,igrd)
c                  wcs(ip)=wc(ihr,igrd)
c               endif
c            enddo
c
c            ipts=ip
c
c            nodata=0
c
c            write(*,*)'Additional conc. range ',npts
c            call wdfreqc(wcs,wds,freq,wsfm,ipts,nodata)
c            nwdrs=nwdrs+1
c            idgrd=igrd*ifive+nwdrs
c
c            if(nodata.eq.0) then
c              call freqoutc(freq,wsfm,ipts)
c            endif
c         enddo

c ---    Finish pollutant rose part
 3000    continue
c --- enddo

      return
      end

c----------------------------------------------------------------------
      subroutine wdfreqc(wss,wds,freq,wsfm,npts,nodata)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731       WDFREQC
c                C. Escoffier-Czaja
c
c Purpose: Calculate pollutantrose frequency at a single position 

c wss:     Pollutant concentration
c wds:     Wind direction
c npts:    Number of points of wss and wds series
c ntotal:  Number of Non-missing points of wss and wds time series
c nlow:    Number of low concentration points
c nws:     Pollutant concentrations class
c ndir:    Number of wind scales
c wclow:   Low concentrations
c freq:    Frequency array
c nodata:  0=data exists, 1=all missing
c
c --- UPDATES:
c --- Version 1.5, Level: 090203 to Version 1.66, Level: 090731 (DGS)
c           - Remove LDATA
c----------------------------------------------------------------------

      include 'params.ser'
      include 'wndrose.ser'

      dimension wds(mxhrs),wss(mxhrs)
      dimension freq(nws1,ndir1),wsfm(nws1,ndir1),ipp(nws1,ndir1)

c     Initial counter array
      do j=1,ndir1
         do i=1,nws1
            freq(i,j)=0
            wsfm(i,j)=0
            ipp(i,j)=0
         enddo
      enddo

      if(npts.lt.1) then
         write(ilog,*)
         write(ilog,*)'No Data in timeseries for current subset'
         write(ilog,*)'Incomplete set of Frequency Tables calculated'
c         write(ilog,*)'Exit from wdfreq'

c         print *,'No data in WD/WS time series'
c         print *,'Frequencies have not calculated'
c         print *,'Exit from wdfreq'

         nodata=1

         return

      endif

      nmiss=0
      nlow=0

      do ih=1,npts
         ss=wss(ih)
         dd=wds(ih)
         if(ss.ne.fmiss .and. dd.ne.fmiss) then
            ihbeg=ih
            goto 500
         endif
         nmiss=nmiss+1
      enddo

      write(ilog,*)'All data in time series are missing!'
      write(ilog,*)'Frequencies are not calculated'
c      write(ilog,*)'HALTED in wdfreq'

c      print *,'All data in WDS/WSS time series are missing!'
c      print *,'Frequencies are not calculated'
c      print *,'HALTED in wdfreq'

      nodata=1

      return
	   
 500  continue

      do 1000 ih=ihbeg,npts     ! pollutant frequency class
         ss=wss(ih)
         dd=wds(ih)

         if(ss.eq.fmiss .or. dd.eq.fmiss) then
            nmiss=nmiss+1
            goto 1000
         endif

c	     Changed on 4/13/2001
c         if(ss.lt.wscalm .and. dd.eq.0) then
         if(ss.lt.wclow) then
            nlow=nlow+1
            goto 1000
         endif
	      
         idc=nint(dd/22.5)+1
         if(idc.gt.ndir) idc=1  

         do i=1,nws
            ss2=wccls(i)
            if(i.eq.1) then
               ss1=wclow
            else
               ss1=wccls(i-1)
            endif
		
            if(ss.ge.ss1 .and. ss.lt.ss2) then
               isc=i
               goto 1050
            endif
         enddo

         write(ilog,*)'Concent. out of range for pollutant roses: ',ss
         print *,'Concentration out of range for pollutant roses: ',ss
         stop 12

 1050    continue

c        Sum of wind speed class
         ipp(isc,idc)=ipp(isc,idc)+1
         wsfm(isc,idc)=wsfm(isc,idc)+ss

c        Sum of all concentrations class
         ipp(nws1,idc)=ipp(nws1,idc)+1
         wsfm(nws1,idc)=wsfm(nws1,idc)+ss

         ipp(nws1,ndir1)=ipp(nws1,ndir1)+1
         wsfm(nws1,ndir1)=wsfm(nws1,ndir1)+ss

c        Sum of all wind directions
         ipp(isc,ndir1)=ipp(isc,ndir1)+1
         wsfm(isc,ndir1)=wsfm(isc,ndir1)+ss

 1000 enddo

c     QC for sums of points and frequencies
      ntot=0
      do j=1,ndir
         do i=1,nws
            nn=ipp(i,j)
            ntot=ntot+nn
         enddo
      enddo

      ntotal=ntot+nlow

      nall=ntotal+nmiss
      if(nall.ne.npts) then
         write(ilog,*)'Error: Total Number not Match:',nall,npts
         stop 10
      endif

      atotal=float(ntotal)

      fall=0
      do j=1,ndir1
         do i=1,nws1
            freq(i,j)=ipp(i,j)/atotal
            if(j.ne.ndir1 .and. i.ne.nws1) fall=fall+freq(i,j)
         enddo
      enddo
	      		
      frelow=float(nlow)/atotal*100

      fall=fall*100+frelow

      dfreq=abs(100-fall)
      
      if(dfreq .gt. 1.0) then
         write(ilog,*)'Error in summed frequency:'
         write(ilog,*)fall
         print *,'Error in summed frequency:'
         print *,fall
         stop 11
      endif

c     Get frequency mean concentration
      do j=1,ndir1
         do i=1,nws1
            ip=ipp(i,j)
            aa=wsfm(i,j)
            if(ip.ge.1) then
               aa=aa/ip
            else
               aa=0
            endif
            wsfm(i,j)=aa
         enddo
      enddo

      return
      end

c----------------------------------------------------------------------
      Subroutine freqoutc(freq,wsfm,npts)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090318      FREQOUTC
c                C. Escoffier-Czaja
c
c Purpose: Output conc freqency array in the form of EPA rose format
c Note:     npts,idgrd and htgrd are exta info and not used by EPA rose
c           program
c
c --- UPDATES:
c
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c     - Use E-notation for wide concentration range
c
c --- Version 1.4, Level: 070315 to Version 1.5, Level: 090203 (DGS)
c     - Allow for blanks within title strings
c----------------------------------------------------------------------

      include 'params.ser'
      include 'wndrose.ser'

      dimension freq(nws1,ndir1)
      dimension wsfm(nws1,ndir1)

      flow=float(nlow)
      atotal=float(ntotal)
      iht=nint(hgt)

c Output frequency classes in the form of CALPollutantRose Program 
c ----------------------------------------------------------------
      idm=idgrd-idgrd/1000*1000

c      nt=index(sname(idm),' ')-1
      nt=LEN_TRIM(sname(idm))
      write(io1,*)
      write(io1,'(a)')sname(idm)(1:nt)

      wccls2(1)=wclow
      do i=1,nws-1
         wccls2(i+1)=wccls(i)
      enddo

c      write(io1,1142)(wccls2(i),wccls(i),i=1,nws-1),wccls(nws-1)
c 1142 format('WDDIR  ',5(f5.3,'-',f5.3,3x),'   > ',f5.3,'         SUM')
      write(io1,1142)(wccls2(i),i=1,nws-1),(wccls(i),i=1,nws-1),
     &                wccls(nws-1)
 1142 format(' FROM',1p,5(2x,e8.2),/
     &       '   TO',5(2x,e8.2),2x,'>',e8.2,'   SUM',/
     &       'WDDIR',5(2x,'--------'),2x,'--------  --------')

      sdir(17)='SUM'
      do j=1,ndir1
         write(io1,1150)sdir(j),(freq(i,j)*100,i=1,nws1)
      enddo
c 1150 format(1x,a3,':',7(3x,f8.3,'%',2x))
 1150 format(1x,a3,': ',7(f8.3,'%',1x))

      write(io1,1031)frelow
 1031 format('Low concentrations: ',f7.3,'%')
      write(io1,1040)npts,nint(atotal),nint(flow)
 1040 format('Total Periods = ',i5,';  Valid Periods = ',i5,
     &  ';  Low Concentration Periods = ',i5)

c Output frequency classes in tables
c ----------------------------------

      idm=idgrd-idgrd/1000*1000
c      nt=index(sname(idm),' ')-1
      nt=LEN_TRIM(sname(idm))
      write(io2,1039)idgrd,sname(idm)(1:nt)
 1039 format(10x,'Conc. Statistics at Station/Grid ID: ',i6,3x,a)

      write(io2,1041)npts,nint(atotal),nint(flow),iht
 1041 format('Total Points:    ',i5,10x,
     &  'Valid Points:    ',i5,/,
     &  'Low Concentration Points:',i5,10x,
     &  'Elevation(m):    ',i5,/)

      wccls2(1)=wclow
      do i=1,nws-1
         wccls2(i+1)=wccls(i)
      enddo

      write(io2,1043)
 1043 format(30x,'Frequency Class (%)')
c      write(io2,1042)(wccls2(i),wccls(i),i=1,nws-1),wccls(nws-1)
c 1042 format('WDDIR',5(2x,f6.3,'-',f6.3),2x,'  > ',f6.3,'      SUM')

      write(io2,1042)(wccls2(i),i=1,nws-1),(wccls(i),i=1,nws-1),
     &                wccls(nws-1)
 1042 format(' FROM',1p,5(2x,e8.2),/
     &       '   TO',5(2x,e8.2),2x,'>',e8.2,'   SUM',/
     &       'WDDIR',5(2x,'--------'),2x,'--------  --------')

      sdir(17)='SUM'
      do j=1,ndir1
         write(io2,1050)sdir(j),(freq(i,j)*100,i=1,nws1)
      enddo
      write(io2,*)
c 1050 format(1x,a3,1x,6(5x,f7.3,3x),f7.3)
 1050 format(1x,a3,2x,7(1x,f7.3,2x))

      write(io2,1051)
 1051 format(30x,'Mean Concentration in Class')

c      write(io2,1052)(wccls2(i),wccls(i),i=1,nws-1),wccls(nws-1)
c 1052 format('WDDIR',5(2x,f6.3,'-',f6.3),2x,'  > ',f6.3,'      AVE')
      write(io2,1052)(wccls2(i),i=1,nws-1),(wccls(i),i=1,nws-1),
     &                wccls(nws-1)
 1052 format(' FROM',1p,5(2x,e8.2),/
     &       '   TO',5(2x,e8.2),2x,'>',e8.2,'   AVE',/
     &       'WDDIR',5(2x,'--------'),2x,'--------  --------')

      sdir(17)='AVE'
      do j=1,ndir1
c         write(io2,1050)sdir(j),(wsfm(i,j),i=1,nws1)
         write(io2,1053)sdir(j),(wsfm(i,j),i=1,nws1)
      enddo
 1053 format(1x,a3,1p,3x,7(e8.2,2x))
      write(io2,*)

c Save frequency array
      do j=1,ndir1
         do i=1,nws1
            freqall(i,j,nwdrs,ngrdloc)=freq(i,j)
         enddo
      enddo

      freqlow(nwdrs,ngrdloc)=flow/100.

c Save frequency mean concentration array
      do j=1,ndir1
         do i=1,nws1
            wsfmall(i,j,nwdrs,ngrdloc)=wsfm(i,j)
         enddo
      enddo

      return
      end

c----------------------------------------------------------------------
      subroutine maxav_poll(wds,wcs,npts,nodata,inbst)
c ---------------------------------------------------------------------
c --- METSERIES  Version: 1.9.0         Level: 100222    MAXAV_POLL
c                C. Escoffier-Czaja
c
c Purpose: Calculate max and average pollutant rose at single position
c          Export in BNA and post files
c
c --- UPDATES:
c
c --- Version 1.66, Level 090731 to Version 1.76, Level 100222 (DGS)
c         - Add option for several direction bin resolutions
c
c --- Version 1.62, Level: 090411 to Version 1.66, Level 090731 (DGS)
c         - Set FACTOR locally instead of in PARAMS.SER
c
c --- Version 1.6, Level: 090318 to Version 1.62, Level: 090411 (DGS)
c         - Trap case where all concentrations are zero
c
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c         - Control information from /CONTROL/
c
c wcs:     Pollutant concentration
c wds:     Wind direction
c npts:    Number of points of wcs and wds series
c nodata:  0=data exist, 1=all missing
c inbst:   File/location index
c ---------------------------------------------------------------------
c --- Set MAX number of directions (this currently for 1-degree)
      parameter (mxdbin=360)

      include 'params.ser'
      include 'ctrl.ser'
      include 'wndrose.ser'
      include 'metseries.ser'

      real wds(mxhrs),wcs(mxhrs)

c --- Local variables
      integer ipp(mxdbin)
      integer ndbin_db(4)
      real c_max(mxdbin),c_ave(mxdbin)
      real Xav(mxdbin),Yav(mxdbin)
      real Xmx(mxdbin),Ymx(mxdbin)
      real Xmxav(mxdbin),Ymxav(mxdbin)
      character*1 dq, cm
      character*8 cmx8,cav8
      character*132 flout

      data dq/'"'/, cm/','/
      data factor/57.2957795/

c --- Set the number of direction bins for each direction type
c        0 = 1 degree        360
c        1 = 5 degrees       72
c        2 = 10 degrees      36
c        3 = 22.5 degrees    16
      data ndbin_db/360,72,36,16/

c --- Number of directions (bins)
      ndbin=ndbin_db(mwdbintyp+1)
c --- Degrees/bin
      bindeg=360./FLOAT(ndbin)
c --- Number of BLN data records
      ndbin1=ndbin+1

c --- QA
      if(npts.lt.1) then
         write(ilog,*)
         write(ilog,*)'No Data in WDS/WCS time series'
         write(ilog,*)'Maximum and Average Roses are not calculated'
         write(ilog,*)'Exit from maxav_poll'
         nodata=1
         return
      endif

c --- Initial arrays
      do j=1,ndbin
         c_max(j)=0.
         c_ave(j)=0.
         ipp(j)=0
      enddo
      nmiss=0

c --- Loop over all records in timeseries file
      do ih=1,npts
         if(wcs(ih).ne.fmiss .and. wds(ih).ne.fmiss) then
            idc=NINT(wds(ih)/bindeg)+1
            if(idc.GT.ndbin) idc=1  
c ---       Sum of concentration for each direction
            ipp(idc)=ipp(idc)+1
            c_ave(idc)=c_ave(idc)+wcs(ih)
c ---       Max for each direction
            if(c_max(idc).LT.wcs(ih)) c_max(idc)=wcs(ih)
         else
            nmiss=nmiss+1
         endif
      enddo

c --- QA
      if(nmiss.EQ.npts) then
         write(ilog,*)
         write(ilog,*)'All data in WDS/WCS time series are missing'
         write(ilog,*)'Maximum and Average Roses are not calculated'
         write(ilog,*)'Exit from maxav_poll'
         nodata=1
         return
      endif

c --- Set center-point coordinates for plotting location (xplot,yplot)
      if(mxypoll.EQ.0) then
         xplot=xaq(inbst)
         yplot=yaq(inbst)
      else
         xplot=xpoll
         yplot=ypoll
      endif

c --- Process each direction bin for averages and peak
      peakave=0.
      peakmax=0.
      do j=1,ndbin
         if(ipp(j).GT.0) then
            c_ave(j)=c_ave(j)/FLOAT(ipp(j))
         else
            c_ave(j)=0.
         endif
         if(peakave.LT.c_ave(j)) peakave=c_ave(j)
         if(peakmax.LT.c_max(j)) peakmax=c_max(j)
      enddo

c --- QA
      if(peakmax.LE.0.0) then
         write(ilog,*)
         write(ilog,*)'All pollutant data are zero'
         write(ilog,*)'Maximum and Average Roses are not calculated'
         write(ilog,*)'Exit from maxav_poll'
         nodata=1
         return
      endif

c --- Set scaling factor to associate maximum conc with a 20km distance
c --- Use 2 significant digits for outer conc ring value
      rkm=rose_radius
      if(conc_scale.GT.0.) then
         write(cmx8,'(e8.2)') conc_scale
         read(cmx8,'(e8.2)') scale
         scfacmx=rkm/scale
         scfacav=scfacmx
         cav8=cmx8
      else
         write(cmx8,'(e8.2)') peakmax
         read(cmx8,'(e8.2)') scale
         scfacmx=rkm/scale
         write(cav8,'(e8.2)') peakave
         read(cav8,'(e8.2)') scale
         scfacav=rkm/scale
      endif

c --- Select base file name
      if(ntsfout.GT.0) then
         flout=ftsf(inbst)
      else
         flout=frose
      endif

c --- Create the BNA files for pollutant rose outputs
      klast=LEN_TRIM(flout)
      open(50,file=flout(1:klast)//'_ave.bna',
     &           status='unknown')
      open(51,file=flout(1:klast)//'_max.bna',
     &           status='unknown')
      open(52,file=flout(1:klast)//'_mxav.bna',
     &           status='unknown')

c --- Outer ring
c --- AVE file
      write(50,*)dq//cav8//dq//cm//dq//'OUTER RING'//dq//cm//'2'
      write(50,*)xplot,',',yplot
      write(50,*)rkm,',',0.0
c --- MAX file
      write(51,*)dq//cmx8//dq//cm//dq//'OUTER RING'//dq//cm//'2'
      write(51,*)xplot,',',yplot
      write(51,*)rkm,',',0.0
c --- MXAV file
      write(52,*)dq//cmx8//dq//cm//dq//'OUTER RING'//dq//cm//'2'
      write(52,*)xplot,',',yplot
      write(52,*)rkm,',',0.0

c --- Scale Lines
      xl=xplot-rkm
      xr=xplot+rkm
      yb=yplot-rkm
      yt=yplot+rkm
      do iu=50,52
         write(iu,*)dq//'E-W'//dq//cm//dq//'SCALE LINE'//dq//cm//'-2'
         write(iu,*)xl,',',yplot
         write(iu,*)xr,',',yplot
         write(iu,*)dq//'N-S'//dq//cm//dq//'SCALE LINE'//dq//cm//'-2'
         write(iu,*)xplot,',',yt
         write(iu,*)xplot,',',yb
      enddo

c --- Concentration output data
      do j=1,ndbin
  	 angle=(float(j-1)*bindeg)/factor
         sinang=SIN(angle)
         cosang=COS(angle)
c ---    Average
         r=c_ave(j)*scfacav
         Xav(j)=xplot+r*sinang
         Yav(j)=yplot+r*cosang
c ---    Maximum
         r=c_max(j)*scfacmx
         Xmx(j)=xplot+r*sinang
         Ymx(j)=yplot+r*cosang
c ---    Average within Maximum plot
         r=c_ave(j)*scfacmx
         Xmxav(j)=xplot+r*sinang
         Ymxav(j)=yplot+r*cosang
      enddo

c --- Write concentration roses
c --- AVE file
      write(50,*)dq//cav8//dq//cm//dq//'ROSE_AVE'//dq//cm,-ndbin1
      do j=1,ndbin
         write(50,*)Xav(j),',',Yav(j)
      enddo
      write(50,*)Xav(1),',',Yav(1)
c --- MAX file
      write(51,*)dq//cmx8//dq//cm//dq//'ROSE_MAX'//dq//cm,-ndbin1
      do j=1,ndbin
         write(51,*)Xmx(j),',',Ymx(j)
      enddo
      write(51,*)Xmx(1),',',Ymx(1)
c --- MAXAV file
      write(52,*)dq//cmx8//dq//cm//dq//'ROSE_MAX'//dq//cm,-ndbin1
      do j=1,ndbin
         write(52,*)Xmx(j),',',Ymx(j)
      enddo
      write(52,*)Xmx(1),',',Ymx(1)
      write(52,*)dq//cmx8//dq//cm//dq//'ROSE_AVE'//dq//cm,-ndbin1
      do j=1,ndbin
         write(52,*)Xmxav(j),',',Ymxav(j)
      enddo
      write(52,*)Xmxav(1),',',Ymxav(1)

      close(50)
      close(51)
      close(52)

c --- Create POST-files to make label for BNA plots
      ip2=LEN_TRIM(conc_spec)
      iu2=LEN_TRIM(conc_unit)
c --- AVE file
      open(50,file=flout(1:klast)//'_ave.bna.dat',
     &           status='unknown')
      write(50,*) xplot,cm,yt,cm,dq//conc_spec(1:ip2)//
     &           '('//conc_unit(1:iu2)//') = '//cav8//dq
      close(50)
c --- MAX and MXAV files
      open(51,file=flout(1:klast)//'_max.bna.dat',
     &           status='unknown')
      open(52,file=flout(1:klast)//'_mxav.bna.dat',
     &           status='unknown')
      do iu=51,52
         write(iu,*) xplot,cm,yt,cm,dq//conc_spec(1:ip2)//
     &           '('//conc_unit(1:iu2)//') = '//cmx8//dq
      enddo
      close(51)
      close(52)


      return
      end

c----------------------------------------------------------------------
      subroutine scat_poll(wds,wss,wcs,npts,nodata,inbst)
c----------------------------------------------------------------------
c --- METSERIES  Version: 1.9.0         Level: 100222     SCAT_POLL
c                C. Escoffier-Czaja
c
c Purpose: Calculate location of pollutant the previous time step
c
c --- UPDATES:
c
c --- Version 1.66, Level 090731 to Version 1.76, Level 100222 (DGS)
c         - Use new control file inputs CBINTYP and CBIN
c --- Version 1.6, Level: 090318 to Version 1.66, Level 090731 (DGS)
c         - Set FACTOR locally instead of in PARAMS.SER
c         - remove IPP (not used)
c
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c         1. Control information from /CONTROL/
c CEC     2. Data in .SCA files (for Pollutant roses application) are
c            output sorted from smallest to largest
c DGS        using SLATEC subroutine SPSORT
c
c wcs:     Pollutant concentration
c wss:     Wind speed
c wds:     Wind direction
c npts:    Number of points of wcs and wds series
c nodata:  0=data exist, 1=all missing
c inbst:   File index
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'wndrose.ser'
      include 'metseries.ser'

      dimension wds(mxhrs),wss(mxhrs),wcs(mxhrs)
      dimension Xav(mxhrs),Yav(mxhrs),xwcs(mxhrs)

c --- Sorted pointer array (points from sorted to original position)
      integer iperm(mxhrs)

c --- Ranks (percentiles) used for conc bins in frequency rose
      real frqrnk(6)

      character*132 flout
      data factor/57.2957795/

c --- Set ranks (percentiles) used for conc bins in frequency rose
      data frqrnk/0.25,0.5,0.6,0.7,0.8,0.9/

c --- Logical to use a default timestep of 1 hour in place of actual
c --- timestep of met data
      logical LHOUR

      data LHOUR/.TRUE./

      if(npts.lt.1) then
         write(ilog,*)'No Data in WDS/WSS/WCS time series'
         write(ilog,*)'Scatter Plot Roses are not calculated'
         write(ilog,*)'Exit from scat_poll'
         nodata=1
         return
      endif

c --- Set center-point coordinates for plotting location (xplot,yplot)
      if(mxypoll.EQ.0) then
         xplot=xaq(inbst)
         yplot=yaq(inbst)
      else
         xplot=xpoll
         yplot=ypoll
      endif

c --- Select base file name
      if(ntsfout.GT.0) then
         flout=ftsf(inbst)
      else
         flout=frose
      endif

c --- Create the scatter plot file for pollutant rose outputs
      klast=LEN_TRIM(flout)
      open(50,file=flout(1:klast)//'.sca',status='unknown')

      nmiss=0

c --- Set number of transport seconds
      itrsec=isecstep
      if(LHOUR) itrsec=3600

c --- Loop over all records in timeseries file
      ihc=0
      do ih=1,npts
         if(wcs(ih).ne.fmiss .and. wds(ih).ne.fmiss .and. 
     &                     wss(ih).ne.fmiss) then
c ---       Process this record
            angle=wds(ih)/factor
c ---       Wind speed (in m/s) is scaled to km/hr
            scfac=wss(ih)*0.001*itrsec
            ihc=ihc+1
	    Xav(ihc)=xplot+scfac*SIN(angle)
            Yav(ihc)=yplot+scfac*COS(angle)
            xwcs(ihc)=wcs(ih)
         else
c ---       Count missings
            nmiss=nmiss+1
         endif
      enddo

c --- Sort from smallest to largest concentration
      ksort=1
      call SPSORT(xwcs,ihc,iperm,ksort,ier)
      if(ier.NE.0) then
         write(ilog,*)'SCAV_POLL:  Sort failed with ier = ',ier
         stop 'Halted in SCAV_POLL -- see log file'
      endif

c --- Write to file in sorted order
      do i=1,ihc
         k=iperm(i)
         write(50,*)Xav(k),',',Yav(k),',',xwcs(k),',',k
      enddo
          
c --- QA
      if(nmiss.EQ.npts) then
         write(ilog,*)'All data in WDS/WSS/WCS time series are missing'
         write(ilog,*)'Scatter Plot Roses are not calculated'
         write(ilog,*)'Exit from scat_poll'
         nodata=1
      endif

      close(50)

      if(mcbintyp.EQ.0) then
c ---    Set up classes for frequency rose (based on percentile concs)
c ---    The low end uses frqrnk(1)
         i1=frqrnk(1)*ihc
         wclow=xwcs(iperm(i1))
c ---    High end uses max value plus 1%
         wccls(6)=1.01*xwcs(iperm(ihc))
c ---    Classes 1-5 use frqrnk for 2-6
         do k=2,6
            kk=frqrnk(k)*ihc
            wccls(k-1)=xwcs(iperm(kk))
         enddo
      else
c ---    Use the User-Defined concentration bins
         wclow=cbin(1)
         do k=2,6
            wccls(k-1)=cbin(k)
         enddo
      endif

      return
      end

c----------------------------------------------------------------------
      subroutine readhdp(icsv)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100107       READHDP
c                D. Strimaitis
c
c --- PURPOSE:   Read and process header of Type 2 AQ file
c
c --- UPDATES:
c --- Version 1.6, level: 100107 to Version 1.75, Level: 100107 (CEC)
c         - Allow two format for header: SO2, CO, H2S,... 
c           and AVESO2, AVECO, AVEH2S,...
c --- Version 1.5, Level: 081120 to Version 1.6, Level: 090318 (DGS)
c         - Remove ITYPE (not used)
c
c --- INPUTS:
c
c ---    Common block /METINP/ variables:
c           CSPEC1, CSPEC2,col_dtm,col_avg,col_stn
c
c --- Parameters used:
c        ICSV, ILST
c
c --- OUTPUT:
c
c ---    Common block /AQINPUT/ variables:
c           IPCOLDATM, IPCOLSTN, IPCOLAVG, IPCOLCONC, IPCOLVLD, NPVARS
c
c --- READHD called by: SETUP
c --- READHD calls:     OMIT320, COLUMN320
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.ser'

c --- Include common blocks
      include 'aqinput.ser'
      include 'metinp.ser'

c --- Local variables
      integer icommas(0:99)
      logical lerror
      character*1 cm,dq
      character*320 char320,blnk320

      data cm/','/
      data dq/'"'/
      data lerror/.FALSE./

      do i=1,320
         blnk320(i:i)=' '
      enddo

c --- Prepare Species name length
      kspec1=LEN_TRIM(cspec1)
      kspec2=LEN_TRIM(cspec2)

c --- Read line
      char320=blnk320
      read(icsv,'(a320)') char320

c --- Create upper-case version of line
      klast=LEN_TRIM(char320)
      call CASE320('UPPER',char320,klast)

c --- Set column name lengths
      kdtm=LEN_TRIM(col_dtm)
      kavg=LEN_TRIM(col_avg)
      kstn=LEN_TRIM(col_stn)
      kvld=LEN_TRIM(col_vald)

c --- Check for required field names
      idatm=INDEX(char320,col_dtm(1:kdtm))
      if(idatm.EQ.0) lerror=.true.
      iaver=INDEX(char320,col_avg(1:kavg))
      if(iaver.EQ.0) lerror=.true.
      istcd=INDEX(char320,col_stn(1:kstn))
      if(istcd.EQ.0) lerror=.true.
      iconc1=INDEX(char320,cspec1(1:kspec1))
      iconc2=INDEX(char320,cspec2(1:kspec2))
      if(iconc1.EQ.0.and.iconc2.EQ.0.) lerror=.true.
      if(LERROR) then
      write(ilog,*)
      write(ilog,*)'READHDP:  Error found'
      write(ilog,*)'Header record does not contain required fields'
      write(ilog,*)'Header:  '//char320(1:klast)
      write(ilog,*)'Expected: '
      write(ilog,*) col_dtm
      write(ilog,*) col_avg
      write(ilog,*) col_stn
      write(ilog,*) cspec1, 'or ',cspec2
      write(ilog,*)'idatm,iaver,istcd,iconc1= ',idatm,iaver,istcd,iconc1
      write(ilog,*)'idatm,iaver,istcd,iconc2= ',idatm,iaver,istcd,iconc2
         write(*,*)
         write(*,*)'READHDP:  Error found'
         write(*,*)'Header record does not contain required fields'
         write(*,*)'Header:  '//char320(1:klast)
         write(*,*)'Expected: '
         write(*,*) col_dtm
         write(*,*) col_avg
         write(*,*) col_stn
         write(*,*) cspec1, 'or ',cspec2
         write(*,*)'idatm,iaver,istcd,iconc1= ',idatm,iaver,istcd,iconc1
         write(*,*)'idatm,iaver,istcd,iconc2= ',idatm,iaver,istcd,iconc2
         stop
      endif

c --- Drop any double quotes from line
      call OMIT320(dq,char320)

c --- Identify column ranges (NVARS=99 here because it is unknown)
      npvars=99
      klast=LEN_TRIM(char320)
      call COLUMN320(char320,klast,cm,npvars,ncommas,icommas)

c --- Step through fields to identify needed columns
      ipcoldatm=0
      ipcolavg=0
      ipcolstn=0
      ipcolconc=0
      ipcolvld=0
      do k=1,npvars
         call IRANGE(k,icommas,ncommas,i1,i2)
         if(char320(i1:i2).EQ.col_dtm(1:kdtm)) ipcoldatm=k
         if(char320(i1:i2).EQ.col_avg(1:kavg)) ipcolavg=k
         if(char320(i1:i2).EQ.col_stn(1:kstn)) ipcolstn=k
         if(char320(i1:i2).EQ.cspec1(1:kspec1)) ipcolconc=k
         if(char320(i1:i2).EQ.cspec2(1:kspec2)) ipcolconc=k
         if(char320(i1:i2).EQ.col_vald(1:kvld)) ipcolvld=k
      enddo
c --- QA
      if(ipcoldatm.EQ.0) then
         write(ilog,*)
         write(ilog,*)'READHDP:  Error found'
         write(ilog,*)'Column not found for DATE-TIME'
         write(*,*)
         write(*,*)'READHDP:  Error found'
         write(*,*)'Column not found for DATE-TIME'
         stop
      endif
      if(ipcolavg.EQ.0) then
         write(ilog,*)
         write(ilog,*)'READHDP:  Error found'
         write(ilog,*)'Column not found for averaging period'
         write(*,*)
         write(*,*)'READHDP:  Error found'
         write(*,*)'Column not found for averaging period'
         stop
      endif
      if(ipcolstn.EQ.0) then
         write(ilog,*)
         write(ilog,*)'READHDP:  Error found'
         write(ilog,*)'Column not found for Station ID'
         write(*,*)
         write(*,*)'READHDP:  Error found'
         write(*,*)'Column not found for Station ID'
         stop
      endif
      if(ipcolconc.EQ.0) then
         write(ilog,*)
         write(ilog,*)'READHDP:  Error found'
         write(ilog,*)'Column not found for Concentration'
         write(*,*)
         write(*,*)'READHDP:  Error found'
         write(*,*)'Column not found for Concentration'
         stop
      endif
      if(ipcolvld.EQ.0) then
         write(ilog,*)
         write(ilog,*)'READHDP:  Warning found'
         write(ilog,*)'Column not found for Validity - Pollutant fields'
         write(ilog,*)'All values are considered valid'
         write(*,*)
         write(*,*)'READHDP:  Warning found'
         write(*,*)'Column not found for Validity - Pollutant fields'
         write(*,*)'All values are considered valid'
      endif

c --- DEBUG
c      write(*,*)'ipcoldatm = ',ipcoldatm
c      write(*,*)'ipcolavg  = ',ipcolavg
c      write(*,*)'ipcolstn  = ',ipcolstn
c      write(*,*)'ipcolconc = ',ipcolconc
c      write(*,*)'ipcolvld = ',ipcolvld
c      write(*,*)

      return
      end
c----------------------------------------------------------------------
      subroutine readhdm(icsv)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090411       READHDM
c                D. Strimaitis
c
c --- PURPOSE:   Read and process header of Type 2 AQ file
c
c --- UPDATES:
c --- Version 1.6, Level: 090318 to Version 1.62, Level: 090411 (CEC)
c         - Add a check that the wind is requested when FLAG for not 
c           finding wind column is called for AMMNETW format
c --- Version 1.5, Level: 090203 to Version 1.6, Level: 090318 (DGS)
c         - Remove ITYPE (not used)
c --- Version 1.5, Level: 081120 to Version 1.5, Level: 090203 (CEC)
c         - Add option to extract other fields than wind,temp and rel. humd.
c
c --- INPUTS:
c
c ---    Common block /METINP/ variables:
c           CSPEC,col_dtm,col_avg,col_stn
c
c --- Parameters used:
c        ICSV, ILST
c
c --- OUTPUT:
c
c ---    Common block /METINPUT/ variables:
c           IMCOLDATM, IMCOLSTN, IMCOLAVG, IMCOLCONC, IMCOLWSPD, IMCOLWDIR, NMVARS
c           IMCOLVLD,IMCOLT2, IMCOLT10, IMCOLRH, IMCOLPRES, IMCOLSW, IMCOLPRC
c
c --- READHD called by: SETUP
c --- READHD calls:     OMIT320, COLUMN320
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- Include common blocks
      include 'metinp.ser'

c --- Local variables
      integer icommas(0:99)
      logical lerror
      character*1 cm,dq
      character*320 char320,blnk320

      data cm/','/
      data dq/'"'/
      data lerror/.FALSE./

      do i=1,320
         blnk320(i:i)=' '
      enddo

c --- Read line
      char320=blnk320
      read(icsv,'(a320)') char320

c --- Create upper-case version of line
      klast=LEN_TRIM(char320)
      call CASE320('UPPER',char320,klast)

c --- Set column name lengths
      kdtm=LEN_TRIM(col_dtm)
      kavg=LEN_TRIM(col_avg)
      kstn=LEN_TRIM(col_stn)
      kvld=LEN_TRIM(col_vald)
      kspd=LEN_TRIM(col_spd)
      kdir=LEN_TRIM(col_dir)
      kt2=LEN_TRIM(col_t2)
      kt10=LEN_TRIM(col_t10)
      krh=LEN_TRIM(col_rh)
      kpres=LEN_TRIM(col_pres)
      ksol=LEN_TRIM(col_sol)
      kprc=LEN_TRIM(col_prc)

c --- Check for required field names
      idatm=INDEX(char320,col_dtm(1:kdtm))
      if(idatm.EQ.0) lerror=.true.
      iaver=INDEX(char320,col_avg(1:kavg))
      if(iaver.EQ.0) lerror=.true.
      istcd=INDEX(char320,col_stn(1:kstn))
      if(istcd.EQ.0) lerror=.true.
c      ivld=INDEX(char320,col_vald(1:kvld))
c      if(ivld.EQ.0) lerror=.true.
      iwspd=INDEX(char320,col_spd(1:kspd))
      if(iwspd.EQ.0) lerror=.true.
      iwdir=INDEX(char320,col_dir(1:kdir))
      if(iwdir.EQ.0) lerror=.true.
      if(LERROR) then
         write(ilog,*)
         write(ilog,*)'READHDM:  Error found'
         write(ilog,*)'Header record does not contain required fields'
         write(ilog,*)'Header:  '//char320(1:klast)
         write(ilog,*)'Expected: '
         write(ilog,*) col_dtm
         write(ilog,*) col_avg
         write(ilog,*) col_stn
         write(ilog,*) col_spd
         write(ilog,*) col_dir
         write(ilog,*)'idatm,iaver,istcd = ',idatm,iaver,istcd
         write(ilog,*)'iwspd,iwdir       = ',iwspd,iwdir
         write(*,*)
         write(*,*)'READHDM:  Error found'
         write(*,*)'Header record does not contain required fields'
         write(*,*)'Header:  '//char320(1:klast)
         write(*,*)'Expected: '
         write(*,*) col_dtm
         write(*,*) col_avg
         write(*,*) col_stn
         write(*,*) col_spd
         write(*,*) col_dir
         write(*,*)'idatm,iaver,istcd = ',idatm,iaver,istcd
         write(*,*)'iwspd,iwdir       = ',iwspd,iwdir
         stop
      endif

c --- Drop any double quotes from line
      call OMIT320(dq,char320)

c --- Identify column ranges (NMVARS=99 here because it is unknown)
      nmvars=99
      klast=LEN_TRIM(char320)
      call COLUMN320(char320,klast,cm,nmvars,ncommas,icommas)

c --- Step through fields to identify needed columns
      imcoldatm=0
      imcolavg=0
      imcolstn=0
      imcolwspd=0
      imcolwdir=0
      imcolvld=0
      imcolt2=0
      imcolt10=0
      imcolrh=0
      imcolpres=0
      imcolsw=0
      imcolprc=0
      do k=1,nmvars
         call IRANGE(k,icommas,ncommas,i1,i2)
         if(char320(i1:i2).EQ.col_dtm(1:kdtm)) imcoldatm=k
         if(char320(i1:i2).EQ.col_avg(1:kavg)) imcolavg=k
         if(char320(i1:i2).EQ.col_stn(1:kstn)) imcolstn=k
         if(char320(i1:i2).EQ.col_spd(1:kspd)) imcolwspd=k
         if(char320(i1:i2).EQ.col_dir(1:kdir)) imcolwdir=k
         if(char320(i1:i2).EQ.col_vald(1:kdir)) imcolvld=k
         if(char320(i1:i2).EQ.col_t2(1:kt2)) imcolt2=k
         if(char320(i1:i2).EQ.col_t10(1:kt10)) imcolt10=k
         if(char320(i1:i2).EQ.col_rh(1:krh)) imcolrh=k
         if(char320(i1:i2).EQ.col_pres(1:kpres)) imcolpres=k
         if(char320(i1:i2).EQ.col_sol(1:ksol)) imcolsw=k
         if(char320(i1:i2).EQ.col_prc(1:kprc)) imcolprc=k
      enddo
c --- QA
      if(imcoldatm.EQ.0) then
         write(ilog,*)
         write(ilog,*)'READHDM:  Error found'
         write(ilog,*)'Column not found for DATE-TIME'
         write(*,*)
         write(*,*)'READHDM:  Error found'
         write(*,*)'Column not found for DATE-TIME'
         stop
      endif
      if(imcolavg.EQ.0) then
         write(ilog,*)
         write(ilog,*)'READHDM:  Error found'
         write(ilog,*)'Column not found for averaging period'
         write(*,*)
         write(*,*)'READHDM:  Error found'
         write(*,*)'Column not found for averaging period'
         stop
      endif
      if(imcolstn.EQ.0) then
         write(ilog,*)
         write(ilog,*)'READHDM:  Error found'
         write(ilog,*)'Column not found for Station ID'
         write(*,*)
         write(*,*)'READHDM:  Error found'
         write(*,*)'Column not found for Station ID'
         stop
      endif
c      if(imcolwspd.EQ.0) then
       if(imcolwspd.EQ.0 .and. LWIND(i)) then
         write(ilog,*)
         write(ilog,*)'READHDM:  Error found'
         write(ilog,*)'Column not found for Wind Speed'
         write(*,*)
         write(*,*)'READHDM:  Error found'
         write(*,*)'Column not found for Wind Speed'
         stop
      endif
c      if(imcolwdir.EQ.0) then
       if(imcolwdir.EQ.0 .and.LWIND(i)) then
         write(ilog,*)
         write(ilog,*)'READHDM:  Error found'
         write(ilog,*)'Column not found for Wind Direction'
         write(*,*)
         write(*,*)'READHDM:  Error found'
         write(*,*)'Column not found for Wind Direction'
         stop
      endif
      do i=1,ntsfout
       if(ltmpk(i)) then
        if(imcolt2.EQ.0.and.imcolt10.EQ.0) then      
          write(ilog,*)
          write(ilog,*)'READHDM:  Error found'
          write(ilog,*)'Column not found for any temperature'
          write(ilog,*)'Required for station',i   
          write(*,*)
          write(*,*)'READHDM:  Error found'
          write(*,*)'Column not found for any temperature'
          write(*,*)'Required for station',i
          stop
        elseif(imcolt2.NE.0.and.imcolt10.EQ.0.and.ztmpk(i).eq.10.0)then         
          write(ilog,*)
          write(ilog,*)'READHDM:  Error found'
          write(ilog,*)'temperature available at 2m, not at 10m'
          write(ilog,*)'change the height for temperature at station',i
          write(*,*)
          write(*,*)'READHDM:  Error found'
          write(*,*)'temperature available at 2m, not at 10m'
          write(*,*)'change the height for temperature at station',i
          stop
        elseif(imcolt2.EQ.0.and.imcolt10.NE.0.and.ztmpk(i).eq.2.0)then   
          write(ilog,*)
          write(ilog,*)'READHDM:  Error found'
          write(ilog,*)'temperature available at 10m, not at 2m'
          write(ilog,*)'change the height for temperature at station',i      
          write(*,*)
          write(*,*)'READHDM:  Error found'
          write(*,*)'temperature available at 10m, not at 2m'
          write(*,*)'change the height for temperature at station',i
          stop
        endif
       endif
       if(lshum(i)) then
        if(imcolrh.EQ.0) then
          write(ilog,*)
          write(ilog,*)'READHDM:  Error found'
          write(ilog,*)'Column not found for Relative Humidity'
          write(ilog,*)'Required for station',i
          write(*,*)
          write(*,*)'READHDM:  Error found'
          write(*,*)'Column not found for Relative Humidity'
          write(*,*)'Required for station',i
          stop
        elseif(imcolpres.EQ.0) then
          write(ilog,*)
          write(ilog,*)'READHDM:  Error found'
          write(ilog,*)'Column not found for Pressure'
          write(ilog,*)'Required for station',i
          write(ilog,*)'for specific humidity calculation'
          write(*,*)
          write(*,*)'READHDM:  Error found'
          write(*,*)'Column not found for Pressure'
          write(*,*)'Required for station',i
          write(*,*)'for specific humidity calculation'
          stop
        endif
       endif
      enddo
      if(imcolvld.EQ.0) then
      write(ilog,*)
      write(ilog,*)'READHDM:  Warning found'
      write(ilog,*)'Column not found for Validity - Meteorology fields'
      write(ilog,*)'All values are considered valid'
         write(*,*)
         write(*,*)'READHDM:  Warning found'
         write(*,*)'Column not found for Validity - Meteorology fields'
         write(*,*)'All values are considered valid'
      endif

c --- DEBUG
c      write(*,*)
c      write(*,*)'imcoldatm = ',imcoldatm
c      write(*,*)'imcolavg  = ',imcolavg
c      write(*,*)'imcolstn  = ',imcolstn
c      write(*,*)'imcolwspd = ',imcolwspd
c      write(*,*)'imcolwdir = ',imcolwdir
c      write(*,*)'imcolt2  = ',imcolt2
c      write(*,*)'imcolt10  = ',imcolt10
c      write(*,*)'imcolrh = ',imcolrh
c      write(*,*)'imcolpres = ',imcolpres
c      write(*,*)'imcolsw = ',imcolsw
c      write(*,*)'imcolprc = ',imcolprc
c      write(*,*)'imcolvld = ',imcolvld
c      write(*,*)

      return
      end

c----------------------------------------------------------------------
      subroutine case320(mode,c320,nlim)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 081017       CASE320
c ---           D. Strimaitis
c
c --- PURPOSE:  Convert all letters within a character string to 
c               either upper or lower case
c
c --- INPUTS:
c
c             MODE - character*5       - Output directive for either 
c                                        upper or lower case
c             C320 - character*320     - Input character string
c             NLIM - integer           - Length of string (characters)
c
c --- OUTPUT:
c
c             C320 - character*320     - Output character string with
c                                        uniform case
c
c --- CASE320 called by: (utility)
c --- CASE320 calls:      IACHAR, CHAR
c----------------------------------------------------------------------

      include 'params.ser'

      character*320 c320
      character*5 mode

      if(nlim.GT.320) then
         write(ilog,*)'ERROR in Subr. CASE320 - string is too long'
         write(ilog,*)'Maximum length  : 320'
         write(ilog,*)'Requested length: ',nlim
         write(*,*)'ERROR in Subr. CASE320 - string is too long'
         write(*,*)'Maximum length  : 320'
         write(*,*)'Requested length: ',nlim
         stop 'Program HALTED'
      endif

      if(mode.EQ.'UPPER' .OR. mode.EQ.'upper') then
         do k=1,nlim
            ia=IACHAR(c320(k:k))
            if(ia.GE.97 .AND. ia.LE.122) then
               ia=ia-32
               c320(k:k)=CHAR(ia)
            endif
         enddo

      elseif(mode.EQ.'LOWER' .OR. mode.EQ.'lower') then
         do k=1,nlim
            ia=IACHAR(c320(k:k))
            if(ia.GE.65 .AND. ia.LE.90) then
               ia=ia+32
               c320(k:k)=CHAR(ia)
            endif
         enddo
      else
         write(ilog,*)'ERROR in Subr. CASE320 - invalid output mode'
         write(ilog,*)'Expected UPPER or LOWER'
         write(ilog,*)'Found: ',mode
         write(*,*)'ERROR in Subr. CASE320 - invalid output mode'
         write(*,*)'Expected UPPER or LOWER'
         write(*,*)'Found: ',mode
         stop 'Program HALTED'
      endif

      return
      end

c----------------------------------------------------------------------
      subroutine noblnk320(c320)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 081017     NOBLNK320
c ---           D. Strimaitis
c
c --- PURPOSE:  Remove all blanks from string (left-justify)
c
c --- INPUTS:
c
c             C320 - character*320     - Input character string
c
c --- OUTPUT:
c
c             C320 - character*320     - Output character string with
c
c --- NOBLNK320 called by: (utility)
c --- NOBLNK320 calls:      ADJUSTL, LEN_TRIM
c----------------------------------------------------------------------

      character*320 c320,d320

c --- Blank out work string
      do i=1,320
         d320(i:i)=' '
      enddo

c --- Remove leading blanks
      c320=ADJUSTL(c320)
      last=LEN_TRIM(c320)

c --- Transfer non-blanks into work string
      n=0
      do i=1,last
         if(c320(i:i).NE.' ') then
            n=n+1
            d320(n:n)=c320(i:i)
         endif
      enddo

c --- Pass work string
      c320=d320

      return
      end

c----------------------------------------------------------------------
      subroutine COLUMN320(c320,nlim,cd,ncol,nc,ic)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 081017     COLUMN320
c ---           D. Strimaitis
c
c --- PURPOSE:  Identifies location of all column delimiters in a
c               string and checks for expected number
c
c --- INPUTS:
c
c             C320 - character*320     - Input character string
c             NLIM - integer           - Length of string (characters)
c               CD - character*1       - Column delimiter character
c             NCOL - integer           - Number of columns expected
c                                        (Enter 99 if unknown)
c
c --- OUTPUT:
c
c             NCOL - integer           - Number of columns processed
c               NC - integer           - Number of delimiters
c       IC(0:NCOL) - integer           - Location of delimiters
c
c --- COLUMN320 called by: (utility)
c --- COLUMN320 calls:      none
c----------------------------------------------------------------------

      include 'params.ser'

      character*1 cd
      character*320 c320
      integer ic(0:ncol)
      logical lncol

      if(nlim.GT.320) then
         write(ilog,*)'ERROR in Subr. COLUMN320 - string is too long'
         write(ilog,*)'Maximum length  : 320'
         write(ilog,*)'Requested length: ',nlim
         write(*,*)'ERROR in Subr. COLUMN320 - string is too long'
         write(*,*)'Maximum length  : 320'
         write(*,*)'Requested length: ',nlim
         stop 'Program HALTED'
      endif

c --- Set logical for processing a specific number of columns
      if(ncol.GT.99) then
         write(ilog,*)'ERROR in Subr. COLUMN320 - too many columns'
         write(ilog,*)'Maximum number  : 99'
         write(ilog,*)'Number requested: ',ncol
         write(*,*)'ERROR in Subr. COLUMN320 - too many columns'
         write(*,*)'Maximum number  : 99'
         write(*,*)'Number requested: ',ncol
         stop 'Program HALTED'
      endif
      lncol=.FALSE.
      if(ncol.LT.99) lncol=.TRUE.

      nc=0
      ic(0)=0
      do k=1,nlim
         if(c320(k:k).EQ.cd) then
            if(LNCOL) then
c ---          Actual number known
               if(nc.LT.ncol) then
                  nc=nc+1
                  ic(nc)=k
               endif
            else
c ---          Actual number unknown
               nc=nc+1
               ic(nc)=k
               ncol=nc
            endif
         endif
      enddo
c --- Last delimiter in line is usually missing
      if(LNCOL) then
         if(nc.LT.ncol) then
            nc=nc+1
            ic(nc)=nlim+1
         endif
      else
         nc=nc+1
         ic(nc)=nlim+1
         ncol=nc
      endif
c --- Check number of columns
      if(nc.LT.ncol) then
         write(ilog,*)'ERROR in Subr. COLUMN320 - '
         write(ilog,*)'Too few columns in the line'
         write(ilog,*)'Expected number of columns: ',ncol
         write(ilog,*)'                     Found: ',nc
         write(ilog,'(a)')c320(1:nlim)
         write(*,*)'ERROR in Subr. COLUMN320 - '
         write(*,*)'Too few columns in the line'
         write(*,*)'Expected number of columns: ',ncol
         write(*,*)'                     Found: ',nc
         write(*,'(a)')c320(1:nlim)
         stop 'Program HALTED'
      endif

      return
      end

c----------------------------------------------------------------------
      subroutine IRANGE(n,ic,nc,i1,i2)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 081017        IRANGE
c ---           D. Strimaitis
c
c --- PURPOSE:  Extracts starting and ending position of field for a
c               particular column in a CSV line
c
c --- INPUTS:
c
c                N - integer           - Column number for field
c         IC(0:NC) - integer           - Location of commas
c               NC - integer           - Number of commas
c
c --- OUTPUT:
c
c               I1 - integer           - Starting position of field
c               I2 - integer           - Ending position of field
c
c --- IRANGE called by: (utility)
c --- IRANGE calls:      none
c----------------------------------------------------------------------

      integer ic(0:nc)

      i1=ic(n-1)+1
      i2=ic(n)-1

      return
      end

c----------------------------------------------------------------------
      subroutine rget320(c320,i1,i2,x)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 081017       RGET320
c ---           D. Strimaitis
c
c --- PURPOSE:  Convert character string to a real.  This sub is needed
c               when there is no decimal point.  The LF95 compiler
c               does not do the internal read conversion without the '.'
c               Also, determine when exponential notation is present.
c
c --- INPUTS:
c
c             C320 - character*320     - Input character string
c               i1 - integer           - First character of substring
c               i2 - integer           - Last character of substring
c
c --- OUTPUT:
c
c                X - real              - Output real
c
c --- RGET320 called by: (utility)
c --- RGET320 calls:      none
c----------------------------------------------------------------------
      character*320 c320
      character*20 c20, blnk20
      data blnk20/'                    '/

      if(i1.GT.i2) return

      c20=blnk20
      c20=c320(i1:i2)

c --- Left justify field
      c20=ADJUSTL(c20)

c --- Test for exponential notation
      ie=MAX(INDEX(c20,'e'),INDEX(c20,'E'))

      if(ie.EQ.0) then
c ---    Simple real number
         ipt=INDEX(c20,'.')
         if(ipt.EQ.0) then
c ---       Decimal point NOT found
            ipt=LEN_TRIM(c20)+1
            c20(ipt:ipt)='.'
         endif
c ---    Decimal point in place: internal read OK
         read(c20,'(f)') x

      else
c ---    Exponential notation
         ipt=INDEX(c20,'.')
         if(ipt.EQ.0) then
c ---       Decimal point NOT found
            do k=20,ie+1,-1
               km1=k-1
               c20(k:k)=c20(km1:km1)
            enddo
            c20(ie:ie)='.'
         endif
c ---    Decimal point in place: internal read OK
         read(c20,'(e)') x

      endif

      return
      end

c----------------------------------------------------------------------
      subroutine omit320(char1,char320)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 081017       OMIT320
c ---           D. Strimaitis
c
c --- PURPOSE:  Removes all instances of a character from a string
c
c --- INPUTS:
c            CHAR1 - char*1       - Character removed
c          CHAR320 - char*320     - Current content of variable
c                                   assignment string
c
c --- OUTPUT:
c          CHAR320 - char*320     - Updated content of variable
c                                   assignment string
c
c --- OMIT320 called by: (main)
c --- OMIT320 calls:     none
c----------------------------------------------------------------------
      character*1 char1
      character*320 char320,work320

      do i=1,320
         work320(i:i)=' '
      enddo

      kk=0
      klast=LEN_TRIM(char320)
      do k=1,klast
         if(char320(k:k).NE.char1) then
            kk=kk+1
            work320(kk:kk)=char320(k:k)
         endif
      enddo
      char320=work320

      return
      end

c----------------------------------------------------------------------
      subroutine VALD_PAR(vld,xinp,outp)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100107        IRANGE
c ---           C. Escoffier-Czaja
c
c --- PURPOSE:  Check the validity parameters for each variable
c 
c --- UPDATES:
c --- Version 1.74, Level: 091026 to Version 1.75, Level: 100107 (CEC)
c         - A character in non standard ASCII is used for "space".
c           in AMMNET files format. A Fix is to accept as VALID 
c           any FLAGS characters which are not unvalid.
c
c --- INPUTS:
c
c              VLD - character         - validity parameter read
c              XINP - real             - value parameter entered
c
c --- OUTPUT:
c              OUTP - real             - value of the parameter 
c
c --- VALD_PAR called by: (utility)
c --- VALD_PAR calls:      none
c----------------------------------------------------------------------
c
       include 'params.ser'

       character*1 vld
       real outp,xinp

            if(vld.eq.'c'.or.vld.eq.'p'.or.vld.eq.'d'.or.vld.eq.'b'
     & .or.vld.eq.'m'.or.vld.eq.'l'.or.vld.eq.'r') then
            outp=9999.
            elseif(vld.eq.' '.or.vld.eq.'D'.or.vld.eq.'B'.or.vld.eq.'+'
     & .or.vld.eq.'-'.or.vld.eq.'R'.or.vld.eq.'P'.or.vld.eq.'C'
     & .or.vld.eq.'Q'.or.vld.eq.'x') then
            outp=xinp                    
            else
            write(ilog,*)'WARNING - validity parameters not recognized'
	    write(ilog,*)'Validity parameter = ',vld,' for value ',xinp
c            write(*,*)'WARNING - validity parameters not recognized'
c	     write(*,*)'Validity parameter = ',vld,' for value ',xinp
            outp=xinp
            endif

       return
       end

c----------------------------------------------------------------------
      subroutine readcf
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203        READCF
c                D. Strimaitis
c
c --- PURPOSE:  Open and read the file containing the file names of
c               the input and output files of the run, and associated
c               control variables, place into program variables,
c               and QA information.
c
c --- UPDATES:
c
c --- Version 1.77, level 100615 to Version 1.9.0, level 121203
c         - Add IMIDNITE to configure convention for writing midnight
c           to TSF data records
c         - Add PRECIP to file types
c         - List-file output for version char*12
c
c --- Version 1.76, level 100222 to Version 1.77, level 100615 (CEC)
c       - Add the possibility to extract data from a SEA.DAT format
c
c --- Version 1.66, level 090731 to Version 1.76, level 100222 (DGS)
c       1.  Add pollutant rose configuration variables MWDBINTYP,
c           MCBINTYP, CBIN
c       2.  Add check for increasing wind speeds in WSBIN array
c
c --- Version 1.65, level 090526 to Version 1.66, level 090731
c   CEC 1.  Fix typo where LCFILES was declared as integer instead of 
c           logical
c   DGS 2.  Add spatial interpolation method for met data (METSIM)
c   CEC 3.  Add variable MONITORC and MONITORW
c
c --- Version 1.6, level 090318  to Version 1.65, level 090526   (F.Robe)
c       1.  Add option to read 2D.DAT file
c
c --- INPUTS:
c
c ---    Common block /QA/ variables:
c           VER, LEVEL
c
c        Parameters: ICTR, ILOG, IOMESG, MXVAR, MXLOC, MXFILE, MXSPEC
c
c --- OUTPUT:
c
c ---    Common block /CONTROL/ variables:
c           nmetinp,naqinp,ntsfout,lcfiles,titlec,
c           flog,frose,fmet(mxfile),faq(mxfile),ftsf(mxloc),
c           mrosec,mdata,nsecdtc,nstepc,metsimc,
c --- V1.9.0, Level 121203
c           imidnite,
c           ibyrc,ibmoc,ibdyc,ibjdc,ibhrc,ibsecc,ibdathrc,
c           ieyrc,iemoc,iedyc,iejdc,iehrc,iesecc,iedathrc,
c           idaq(mxloc),xaq(mxloc),yaq(mxloc),
c           idmet(mxloc),xmet(mxloc),ymet(mxloc),zwind(mxloc),
c           ztmpk(mxloc),zshum(mxloc),zother(mxloc),
c           locmet(mxloc),locaq(mxloc),
c           nspec,cfspec(mxspec),cunito(mxspec),rmwt(mxspec),
c           mprof,mcell,nlu3d,xycell1(2),dxycell(2),
c           wsbin(6),ntpdc,nwspc,ntpc(2,mxtpd),wspc(2,mxwsp),
c           nseasn,msnc(12),snamec(12),
c           pspec,punit,rrose,crose,mxypoll,xpoll,ypoll,
c           mwdbintyp,mcbintyp,cbin(6),
c           iutmznc,feastc,fnorthc,
c           lnomap,lgeo,lutm,llcc,lps,lem,llaza,lttm,
c           rnlat0c,relon0c,rnlat1c,rnlat2c,
c           clat0c,clon0c,clat1c,clat2c,
c           pmapc,datumc,utmhemc,azonec
c
c --- READCF called by:  (main)
c --- READCF calls:      COMLINE, READIN, FILCASE, JULDAY, GRDAY,
c                        DELTSEC, QAYR4, YR4, XTRACTLL
c----------------------------------------------------------------------
c
c --- Include parameter statements and commons
      include 'params.ser'
      include 'params.cal'

c --- Include common blocks
      include 'ctrl.ser'
      include 'qa.ser'

c --- Local variables
      real xmet7(7),xaq3(3)

      integer ixsn(12)
      integer idtsf(mxloc)
      integer ivleng(mxvar,15),ivtype(mxvar,15)

      character*132 cfname
      character*16 inputset,inputver
      character*64 inputmod
      character*4 ctemp(132,3)
      character*4 clatlon(16,4)
      character*4 ctemp12(12,2)
      character*4 cabtz(8),cpmap(8),cdatum(8)
      character*12 cvdic(mxvar,15)
      character*12 mdataqa(21)
      character*16 awdbin(4),acbin(2)
      character*16 mprofqa(6)

      logical lecho
      logical lerrcf

c --- Set control file error logical
      lerrcf=.FALSE.

c --- Available dataset names
c --- V1.9.0, Level 121203
      data nmdata/16/
      data mdataqa/'M2D         ','M3D         ','CALMET      ',
     &             'UP          ','SURF        ','AMMNETW     ',
     &             'AERMSFC     ','AERMPFL     ','POSTIME     ',
     &             'AMMNETC     ','CALPUFF     ','TSF         ',
     &             'MONITORW    ','MONITORC    ','SEA         ',
     &             'PRECIP      ','            ','            ',
     &             '            ','            ','            '/

c --- Profile methods
      data nmprof/6/
      data mprofqa/'STANDARD        ','METSTAT         ',
     &             'NEUTRAL         ','DIRECT          ',
     &             'LINEAR          ','NONE            '/

c --- Wind direction bin methods (pollutant rose)
      data awdbin/' 1 degree       ',' 5 degrees      ',
     &            ' 10 degrees     ',' 22.5 degrees   '/

c --- Concentration bin methods (pollutant rose)
      data acbin/' Automatic      ',' User-Defined   '/

c --- Set Dictionary
      data lecho/.false./
      data names/2/
      data cvdic/
     a  'TSFLST','ROSEPLT','NMETINP','NAQINP','NTSFOUT',
     a  'LCFILES', 54*' ',
     b  'METINP', 59*' ',
     c  'AQINP', 59*' ',
     d  'TSFID','TSFOUT', 58*' ',
     e  'MROSE','MDATA','IBYR','IBMO','IBDY','IBHR','IBSEC',
     e  'IEYR','IEMO','IEDY','IEHR','IESEC','ABTZ','NSECDT',
c --- V1.9.0, Level 121203
     e  'METSIM','IMIDNITE', 44*' ',
     f  'TSFID','LOCMET','LOCAQ','MET','AQ', 55*' ',
     g  'NSPEC', 59*' ',
     h  'CSPEC','UNITS','MWT', 57*' ',
     i  'PMAP','FEAST','FNORTH','IUTMZN','UTMHEM',
     i  'RLAT0','RLON0','XLAT1','XLAT2','DATUM', 50* ' ',
     j  'MPROF','MCELL','NLU3D','XYCELL1','DXYCELL', 55*' ',
     k  'WSBIN','NSEASN','NTPD','NWSP', 56*' ',
     l  'IDSEAS','SEASNAME','MSN', 57*' ',
     m  'HR', 59*' ',
     n  'WSR', 59*' ',
     o  'PSPEC','PUNIT','RROSE','CROSE','MXYPOLL','XPOLL','YPOLL',
     o  'WDBINTYP','CBINTYP','CBIN', 50*' '/

      data ivleng/
     a  2*132,4*1,       54*0,
     b  132,             59*0,
     c  132,             59*0,
     d  1,132,           58*0,
c --- V1.9.0, Level 121203
     e  1,12,10*1,8,3*1, 44*0,
     f  1,2*132,8,4,     55*0,
     g  1,               59*0,
     h  12,8,1,          57*0,
     i  8,4*1,4*16,8,    50*0,
     j  3*1,2*2,         55*0,
     k  6,3*1,           56*0,
     l  2,60,12,         57*0,
     m  2,               59*0,
     n  2,               59*0,
     o  12,8,7*1,6,      50*0/

c --- Variable types (ivtype) are coded as:
c          0 = null
c          1 = real
c          2 = integer
c          3 = logical
c          4 = character
      data ivtype/
     a  2*4,3*2,1*3,          54*0,
     b  4,                    59*0,
     c  4,                    59*0,
     d  2,4,                  58*0,
c --- V1.9.0, Level 121203
     e  2,4,10*2,4,3*2,       44*0,
     f  2,2*4,2*1,            55*0,
     g  2,                    59*0,
     h  2*4,1,                57*0,
     i  4,2*1,2,6*4,          50*0,
     j  3*2,2*1,              55*0,
     k  1,3*2,                56*0,
     l  2,4,2,                57*0,
     m  2,                    59*0,
     n  1,                    59*0,
     o  2*4,2*1,2,2*1,2*2,1,  50*0/

c --- Initialize LOCMET and LOCAQ strings to blank
      do k=1,mxloc
         locmet(k)=' '
         locaq(k)=' '
      enddo

c --- Get control file
      cfname='metseries.inp'
      call COMLINE(cfname)
      open(ictr,file=cfname,status='old',action='read')

c ------------------
c --- File format 
c ------------------
c --- First line includes dataset types, version number
c --- and description
      read(ictr,'(2a16,a64)') inputset,inputver,inputmod
      inputset=ADJUSTL(inputset)
      if(inputset.NE.'METSERIES.INP   ') then
         write(ilog,*)'READCF:  Invalid control file'
         write(ilog,*)'Expected METSERIES.INP'
         write(ilog,*)'Found    ', inputset
         stop 'Halted in READCF -- see list file'
      endif

c --- Run Title
      read(ictr,'(a)')titlec
      
c ------------------
c --- Input Group 0a
c ------------------

c --- Initialize the temporary arrays for filenames in Group 0a
      do i=1,names
         do j=1,132
            ctemp(j,i)(1:1)=' '
         enddo
      enddo

c --- Read the group data
      call READIN(cvdic(1,1),ivleng(1,1),ivtype(1,1),ictr,iomesg,lecho,
     1 ctemp(1,1),ctemp(1,2),nmetinp,naqinp,ntsfout,lcfiles,
     2 idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c --- Prepare any filenames included in the I/O file by erasing
c --- the default filename set above
      if(ctemp(1,1)(1:1).ne.' ')flog=' '
      if(ctemp(1,2)(1:1).ne.' ')frose=' '
c --- Transfer the char*4 data into the char*132 variables
      do j=1,132
         if(ctemp(j,1)(1:1).ne.' ')flog(j:j)=ctemp(j,1)(1:1)
         if(ctemp(j,2)(1:1).ne.' ')frose(j:j)=ctemp(j,2)(1:1)
      enddo

c --- Convert the file names to the proper case
      call FILCASE(lcfiles,flog)
      call FILCASE(lcfiles,frose)

c --- Open listfile
      open(ilog,file=flog,status='unknown')

c --- Write banner to list file
      write(ilog,5) ver,level

c --- V1.9.0, Level 121203
5     format(///,26x,'METSERIES OUTPUT SUMMARY',/,19x,'VERSION:  ',
     &                A12,' LEVEL:  ',A8///)
c     &                A8,' LEVEL:  ',A8///)

c --- Check for too many files
      if(ntsfout.GT.MXLOC) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: Too many output files'
         write(ilog,*) 'Found    NTSFOUT = ',ntsfout
         write(ilog,*) 'Cap is   MXLOC   = ',mxloc
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif
      if(nmetinp.GT.MXFILE .OR. naqinp.GT.MXFILE) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: Too many input files'
         write(ilog,*) 'Found    NMETINP = ',nmetinp
         write(ilog,*) 'Found    NAQINP  = ',naqinp
         write(ilog,*) 'Cap is   MXFILE  = ',mxfile
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif

c ------------------
c --- Input Group 0b
c ------------------
c --- Loop over MET input data filenames (if any)
      do k=1,nmetinp
         kk=MIN(k,mxfile)
c ---    Initialize the temporary arrays for filenames in Group 0b
         do j=1,132
            ctemp(j,3)(1:1)=' '
         enddo

c --- Read the group data
      call READIN(cvdic(1,2),ivleng(1,2),ivtype(1,2),ictr,ilog,lecho,
     1 ctemp(1,3),
     2 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c ---    Prepare any filenames included in the I/O file by erasing
c ---    the default filename set above
         if(ctemp(1,3)(1:1).ne.' ')fmet(kk)=' '
c ---    Transfer the char*4 data into the char*132 variables
         do j=1,132
            if(ctemp(j,3)(1:1).ne.' ')fmet(kk)(j:j)=ctemp(j,3)(1:1)
         enddo
c ---    Convert the file names to the proper case
         call FILCASE(lcfiles,fmet(kk))
      enddo
      
c ------------------
c --- Input Group 0c
c ------------------
c --- Loop over AQ input data filenames (if any)
      do k=1,naqinp
         kk=MIN(k,mxfile)
c ---    Initialize the temporary arrays for filenames in Group 0c
         do j=1,132
            ctemp(j,3)(1:1)=' '
         enddo

c --- Read the group data
      call READIN(cvdic(1,3),ivleng(1,3),ivtype(1,3),ictr,ilog,lecho,
     1 ctemp(1,3),
     2 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c ---    Prepare any filenames included in the I/O file by erasing
c ---    the default filename set above
         if(ctemp(1,3)(1:1).ne.' ')faq(kk)=' '
c ---    Transfer the char*4 data into the char*132 variables
         do j=1,132
            if(ctemp(j,3)(1:1).ne.' ')faq(kk)(j:j)=ctemp(j,3)(1:1)
         enddo
c ---    Convert the file names to the proper case
         call FILCASE(lcfiles,faq(kk))
      enddo
      
c ------------------
c --- Input Group 0d
c ------------------
c --- Loop over TSF output data filenames (if any)
      do k=1,ntsfout
         kk=MIN(k,mxloc)
c ---    Initialize the temporary arrays for filenames in Group 0d
         do j=1,132
            ctemp(j,3)(1:1)=' '
         enddo

c --- Read the group data
      call READIN(cvdic(1,4),ivleng(1,4),ivtype(1,4),ictr,ilog,lecho,
     1 idtsf(kk),ctemp(1,3),
     2 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c ---    Prepare any filenames included in the I/O file by erasing
c ---    the default filename set above
         if(ctemp(1,3)(1:1).ne.' ')ftsf(kk)=' '
c ---    Transfer the char*4 data into the char*132 variables
         do j=1,132
            if(ctemp(j,3)(1:1).ne.' ')ftsf(kk)(j:j)=ctemp(j,3)(1:1)
         enddo
c ---    Convert the file names to the proper case
         call FILCASE(lcfiles,ftsf(kk))
      enddo

c --- Halt here if arrays were exceeded
      if(LERRCF) then
         write(*,*)'ERRORS are found in the CONTROL file'
         write(*,*)'Review messages written to the LIST file'
         stop
      endif

c -----------------
c --- Input Group 1
c -----------------

c --- Initialize the temporary array for the time zone
      do j=1,8
         cabtz(j)(1:1)=' '
c         azonec(j:j)=' '
      enddo

c --- Initialize the temporary array for the input data type
      do j=1,12
         ctemp12(j,1)(1:1)=' '
      enddo

      call readin(cvdic(1,5),ivleng(1,5),ivtype(1,5),ictr,ilog,lecho,
     1 MROSEc,ctemp12(1,1),IBYRc,IBMOc,IBDYc,IBHRc,IBSECc,
c --- V1.9.0, Level 121203
     2 IEYRc,IEMOc,IEDYc,IEHRc,IESECc,CABTZ,NSECDTc,METSIMc,imidnite,
     3 idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c --- Transfer the char*4 data into the char*8 variable (time zone)
      azonec=' '
      do j=1,8
         if(cabtz(j)(1:1).ne.' ')azonec(j:j)=cabtz(j)(1:1)
      enddo

c --- Transfer the char*4 data into the char*12 variable (data type)
      mdata=' '
      do j=1,12
         if(ctemp12(j,1)(1:1).ne.' ')mdata(j:j)=ctemp12(j,1)(1:1)
      enddo
      mdata=ADJUSTL(mdata)

c -----------------
c --- Input Group 2
c -----------------

c --- Number of input groups (!END!) expected
      ngroup=0
      if(nmetinp.GT.0) ngroup=ngroup+1
      if(naqinp.GT.0)  ngroup=ngroup+1
      ngroup=ngroup*ntsfout

c --- Loop over groups
      do k=1,ngroup

c ---    Initialize all temporary variables
         do j=1,132
            ctemp(j,1)(1:1)=' '
            ctemp(j,2)(1:1)=' '
         enddo
         do j=1,7
            xmet7(j)=-1.
         enddo
         do j=1,3
            xaq3(j)=-1.
         enddo

      call readin(cvdic(1,6),ivleng(1,6),ivtype(1,6),ictr,ilog,lecho,
     1 id,ctemp(1,1),ctemp(1,2),xmet7,xaq3,
     2 idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)
         
c ---    Match output index
         kid=0
         do kk=1,ntsfout
            if(id.EQ.idtsf(kk)) kid=kk
         enddo
         if(kid.EQ.0) then
            write(ilog,*)'Bad TSFID in Input Group 2: ',id
            write(ilog,*)'IDs from Input Group 1:'
            do kk=1,ntsfout
               write(ilog,*) '     ',idtsf(kk)
            enddo
            stop 
         endif

c ---    Location name is present only if temp var is not blank
c ---    Transfer the char*4 data into the char*40 variable (location name)
         if(ctemp(1,1)(1:1).ne.' ') locmet(kid)=' '
         if(ctemp(1,2)(1:1).ne.' ') locaq(kid)=' '
         do j=1,40
            if(ctemp(j,1)(1:1).ne.' ')locmet(kid)(j:j)=ctemp(j,1)(1:1)
            if(ctemp(j,2)(1:1).ne.' ')locaq(kid)(j:j)=ctemp(j,2)(1:1)
         enddo

c ---    MET info is present only if temp var is not negative
         if(xmet7(1).GE.0.) then
            idmet(kid)=NINT(xmet7(1))
            xmet(kid)=xmet7(2)
            ymet(kid)=xmet7(3)
            zwind(kid)=xmet7(4)
            ztmpk(kid)=xmet7(5)
            zshum(kid)=xmet7(6)
            zother(kid)=xmet7(7)
         endif
c ---    AQ info is present only if temp var is not negative
         if(xaq3(1).GE.0.) then
            idaq(kid)=NINT(xaq3(1))
            xaq(kid)=xaq3(2)
            yaq(kid)=xaq3(3)
         endif
      enddo

c -----------------
c --- Input Group 3a
c -----------------

c --- Species are used only for AQ inputs, but may always be present

      call readin(cvdic(1,7),ivleng(1,7),ivtype(1,7),ictr,ilog,lecho,
     1 nspec,
     2 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c -----------------
c --- Input Group 3b
c -----------------

c --- Loop over species
      do k=1,nspec
c ---    Initialize the temporary char array for species and units
         do j=1,12
            do n=1,2
               ctemp12(j,n)(1:1)=' '
            enddo
         enddo

      call readin(cvdic(1,8),ivleng(1,8),ivtype(1,8),ictr,ilog,lecho,
     1 ctemp12(1,1),ctemp12(1,2),rmwt(k),
     2 idum,idum,idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c ---    Transfer the char*4 data into the char*12 variables
         cfspec(k)=' '
         cunito(k)=' '
         do j=1,12
            if(ctemp12(j,1)(1:1).ne.' ')cfspec(k)(j:j)=
     &                                  ctemp12(j,1)(1:1)
            if(ctemp12(j,2)(1:1).ne.' ')cunito(k)(j:j)=
     &                                  ctemp12(j,2)(1:1)
         enddo
      enddo

c -----------------
c --- Input Group 4
c -----------------

c --- Initialize the temporary arrays for the character lat/lon fields
      do i=1,4
         do j=1,16
            clatlon(j,i)(1:1)=' '
         enddo
      enddo
      do j=1,16
         clat0c(j:j)=' '
         clon0c(j:j)=' '
         clat1c(j:j)=' '
         clat2c(j:j)=' '
      enddo

c --- Initialize the temporary array for the Datum-Region name and 
c --- map projection
      do j=1,8
         cpmap(j)(1:1)=' '
         cdatum(j)(1:1)=' '
      enddo

      call READIN(cvdic(1,9),ivleng(1,9),ivtype(1,9),ictr,ilog,lecho,
     1 CPMAP,FEASTc,FNORTHc,IUTMZNc,UTMHEMc,
     2 CLATLON(1,1),CLATLON(1,2),CLATLON(1,3),CLATLON(1,4),CDATUM,
     3 idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     7 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c --- Transfer the char*4 data into the char*16 variables
      do j=1,16
         if(clatlon(j,1)(1:1).ne.' ')clat0c(j:j)=clatlon(j,1)(1:1)
         if(clatlon(j,2)(1:1).ne.' ')clon0c(j:j)=clatlon(j,2)(1:1)
         if(clatlon(j,3)(1:1).ne.' ')clat1c(j:j)=clatlon(j,3)(1:1)
         if(clatlon(j,4)(1:1).ne.' ')clat2c(j:j)=clatlon(j,4)(1:1)
      enddo

c --- Translate character lat/lon to real NLat/ELon
      if(clat0c(1:1).NE.' ') call XTRACTLL(ilog,'LAT ',clat0c,rnlat0c)
      if(clon0c(1:1).NE.' ') call XTRACTLL(ilog,'LON ',clon0c,relon0c)
      if(clat1c(1:1).NE.' ') call XTRACTLL(ilog,'LAT ',clat1c,rnlat1c)
      if(clat2c(1:1).NE.' ') call XTRACTLL(ilog,'LAT ',clat2c,rnlat2c)

c --- Transfer the char*4 data into the char*8 variables
      if(cpmap(1)(1:1).ne.' ') then
         pmapc=' '
         do j=1,8
            pmapc(j:j)=cpmap(j)(1:1)
         enddo
      endif
      if(cdatum(1)(1:1).ne.' ') then
         datumc=' '
         do j=1,8
            datumc(j:j)=cdatum(j)(1:1)
         enddo
      endif

c --- Pad the char*4 UTM Hemisphere
      utmhemc(2:4)='   '

c -----------------
c --- Input Group 5
c -----------------

      call READIN(cvdic(1,10),ivleng(1,10),ivtype(1,10),ictr,ilog,lecho,
     1 MPROF,MCELL,NLU3D,XYCELL1,DXYCELL,
     2 idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c -----------------
c --- Input Group 6a
c -----------------

      call READIN(cvdic(1,11),ivleng(1,11),ivtype(1,11),ictr,ilog,lecho,
     1 WSBIN,NSEASN,NTPDC,NWSPC,
     2 idum,idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c -----------------
c --- Input Group 6b
c -----------------

c --- Number of input groups (!END!) expected
      ngroup=nseasn+1

c --- Loop over groups
      kseas=0
      do k=1,ngroup
c ---    Initialize all temporary variables
         do j=1,132
            ctemp(j,3)(1:1)=' '
         enddo
         idxseas=-1
         do j=1,12
            ixsn(j)=-1
         enddo

      call READIN(cvdic(1,12),ivleng(1,12),ivtype(1,12),ictr,ilog,lecho,
     1 idxseas,ctemp(1,3),ixsn,
     2 idum,idum,idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c ---    Season ID is present only if temp var is not negative
         if(idxseas.GT.0) then
            kseas=kseas+1
            idseas(kseas)=idxseas
c ---       Transfer the char*4 data into the char*60 variable (season)
            snamec(kseas)=' '
            do j=1,60
               if(ctemp(j,3)(1:1).ne.' ')snamec(kseas)(j:j)=
     &                                   ctemp(j,3)(1:1)
            enddo
         endif
c ---    Monthly season map is present only if temp var is not negative
         if(ixsn(1).GE.0) then
            do j=1,12
               msnc(j)=ixsn(j)
            enddo
         endif
      enddo

c -----------------
c --- Input Group 6c
c -----------------

      do k=1,ntpdc

      call READIN(cvdic(1,13),ivleng(1,13),ivtype(1,13),ictr,ilog,lecho,
     1 ntpc(1,k),
     2 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

      enddo

c -----------------
c --- Input Group 6d
c -----------------

      do k=1,nwspc

      call READIN(cvdic(1,14),ivleng(1,14),ivtype(1,14),ictr,ilog,lecho,
     1 wspc(1,k),
     2 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     3 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

      enddo

c -----------------
c --- Input Group 7
c -----------------

c --- Initialize the temporary char array for species and units
      do j=1,12
         do k=1,2
            ctemp12(j,k)(1:1)=' '
         enddo
      enddo
      call READIN(cvdic(1,15),ivleng(1,15),ivtype(1,15),ictr,ilog,lecho,
     1 ctemp12(1,1),ctemp12(1,2),RROSE,CROSE,MXYPOLL,XPOLL,YPOLL,
     2 mwdbintyp,mcbintyp,cbin,
     3 idum,idum,
     4 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     5 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     7 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)

c --- Transfer the char*4 data into the char*12 variables
      pspec=' '
      punit=' '
      do j=1,12
         if(ctemp12(j,1)(1:1).ne.' ')pspec(j:j)=ctemp12(j,1)(1:1)
         if(ctemp12(j,2)(1:1).ne.' ')punit(j:j)=ctemp12(j,2)(1:1)
      enddo

c --- Close control file
      CLOSE(ictr)

c -------------------------
c --- QA Checks
c -------------------------

c --- Input Data Format
      k_mdata=0
      do k=1,nmdata
         if(mdata.EQ.mdataqa(k)) k_mdata=k
      enddo
      if(k_mdata.EQ.0) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: Unsupported Data Type'
         write(ilog,*) 'Found    MDATA = ',mdata
         write(ilog,*) 'Expected MDATA = '
         do k=1,nmdata
            write(ilog,*)'          ',mdataqa(k)
         enddo
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif

c --- Number of files
      if(k_mdata.GE.1 .AND. k_mdata.NE.10 .AND. k_mdata.NE.11 
     &   .AND. k_mdata.NE.14) then
c ---    Expect at least 1 MET file
         if(nmetinp.LE.0) then
            write(ilog,*)
            write(ilog,*) '*****'
            write(ilog,*) 'ERROR in control file: '
            write(ilog,*) '1 or more MET input files required'
            write(ilog,*) '*****'
            write(ilog,*)
            LERRCF=.TRUE.
         endif
      endif

      if((k_mdata.GE.9 .AND. k_mdata.LE.11) .OR.
     &   (k_mdata.EQ.12 .AND. mrosec.EQ.2) .OR. k_mdata.EQ.14) then
c ---    Expect at least 1 AQ file
         if(naqinp.LE.0) then
            write(ilog,*)
            write(ilog,*) '*****'
            write(ilog,*) 'ERROR in control file: '
            write(ilog,*) '1 or more AQ input files required'
            write(ilog,*) '*****'
            write(ilog,*)
            LERRCF=.TRUE.
         endif
      endif
      if(k_mdata.EQ.12) then
c ---    TSF inputs do not create TSF output file
         if(ntsfout.NE.0) then
            write(ilog,*)
            write(ilog,*) '*****'
            write(ilog,*) 'ERROR in control file: '
            write(ilog,*) 'There should be no TSF output files'
            write(ilog,*) 'when TSF input files are used'
            write(ilog,*) '*****'
            write(ilog,*)
            LERRCF=.TRUE.
         endif
      else
c ---    Other inputs must create TSF output files
         if(ntsfout.LE.0) then
            write(ilog,*)
            write(ilog,*) '*****'
            write(ilog,*) 'ERROR in control file: '
            write(ilog,*) '1 or more TSF output files are required'
            write(ilog,*) '*****'
            write(ilog,*)
            LERRCF=.TRUE.
         endif
      endif

c --- Spatial interpolation method for gridded MET data
      if(metsimc.LT.1 .OR. metsimc.GT.2) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: '
         write(ilog,*) 'Spatial Interpolation Method for MET data'
         write(ilog,*) 'must be 1 or 2'
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif

c --- V1.9.0, Level 121203
c --- Midnight convention for output TSF records
      if(imidnite.LT.1 .OR. imidnite.GT.2) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: '
         write(ilog,*) 'Midnight convention for output TSF records'
         write(ilog,*) 'must be 1 or 2'
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif

c --- Number of species written to AQ TSF file(s)
      if(naqinp.GT.0 .AND. k_mdata.NE.12 .AND. nspec.LE.0) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: '
         write(ilog,*) 'Pollutant species must be specified'
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif

c --- Check for MET and AQ if pollutant rose requested
      if(mrosec.GT.0 .AND. nmetinp.EQ.0) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: '
         write(ilog,*) 'Rose output needs MET data'
         write(ilog,*) 'NMETINP must not be zero'
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif
      if(mrosec.EQ.2 .AND. naqinp.EQ.0) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: '
         write(ilog,*) 'Pollutant Rose output needs AQ data'
         write(ilog,*) 'NAQINP must not be zero'
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif
c --- No wind rose with 2D.DAT files
      if(mrosec.NE.0 .and.(mdata.EQ.'M2D')) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: '
         write(ilog,*) 'No Wind or Pollutant Rose with 2D.DAT'
         write(ilog,*) 'MROSE must not be zero'
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif

c --- Projection
      if(pmapc.EQ.'NONE') then
         lnomap=.TRUE.
      elseif(pmapc.EQ.'LL') then
         lgeo=.TRUE.
      elseif(pmapc.EQ.'UTM') then
         lutm=.TRUE.
      elseif(pmapc.EQ.'LCC') then
         llcc=.TRUE.
      elseif(pmapc.EQ.'PS') then
         lps=.TRUE.
      elseif(pmapc.EQ.'EM') then
         lem=.TRUE.
      elseif(pmapc.EQ.'LAZA') then
         llaza=.TRUE.
      elseif(pmapc.EQ.'TTM') then
         lttm=.TRUE.
      else
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: bad PMAP = ',pmapc
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif

c --- Inputs for 3D.DAT processing
      if(mdata.EQ.'M3D         ') then
         if(mprof.LT.1 .OR. mprof.GT.4) then
            write(ilog,*)
            write(ilog,*) '*****'
            write(ilog,*) 'ERROR in control file: bad MPROF = ',mprof
            write(ilog,*) 'Expected MPROF = 1, 2, 3, or 4'
            write(ilog,*) '*****'
            write(ilog,*)
            LERRCF=.TRUE.
         endif
         if(mcell.LT.0 .OR. mcell.GT.1) then
            write(ilog,*)
            write(ilog,*) '*****'
            write(ilog,*) 'ERROR in control file: bad MCELL = ',mcell
            write(ilog,*) 'Expected MCELL = 0 or 1'
            write(ilog,*) '*****'
            write(ilog,*)
            LERRCF=.TRUE.
         endif
      endif

c --- Date and time checks
c ------------------------

c --- Y2K QA on starting year
      call QAYR4(ilog,ibyrc,0,ierr)
      if(ierr.NE.0) then
         write(ilog,*) 'READCF:  Y2K Error in Input Group 1'
         lerrcf=.TRUE.
      endif

c --- Make sure ending year is YYYY (Y2K)
      call YR4(ilog,ieyrc,ierr)
      if(ierr.NE.0) then
         write(ilog,*) 'READCF:  Y2K Error in Input Group 1'
         lerrcf=.TRUE.
      endif

c --- Julian day for further checks
      call JULDAY(ilog,ibyrc,ibmoc,ibdyc,ibjdc)
      call JULDAY(ilog,ieyrc,iemoc,iedyc,iejdc)

c --- Check for proper time entries
      if((ibsecc.GT.3600) .OR. (iesecc.GT.3600) .OR. 
     &   (ibsecc.LT.0) .OR. (iesecc.LT.0)) then
         write(ilog,*)'IBSEC and IESEC must be between 0 and 3600'
         write(ilog,*)'(Total Seconds = Minutes*60 + Seconds)'
         lerrcf=.TRUE.
      endif
      if((ibhrc.GT.24) .OR. (iehrc.GT.24) .OR.
     &   (ibhrc.LT.0) .OR. (iehrc.LT.0)) then
         write(ilog,*)'IBHR and IEHR must be between 0 and 24'
         lerrcf=.TRUE.
      endif

c --- Condition hour fields
      if(ibhrc.eq.24) then
         ibhrc=0
         call INCR(ilog,ibyrc,ibjdc,ibhrc,24)
         call GRDAY(ilog,ibyrc,ibjdc,ibmoc,ibdyc)
      endif
      if(iehrc.eq.24) then
         iehrc=0
         call INCR(ilog,ieyrc,iejdc,iehrc,24)
         call GRDAY(ilog,ieyrc,iejdc,iemoc,iedyc)
      endif

c --- Condition seconds fields
      if(ibsecc.EQ.3600) then
         nhrinc=1
         call INCR(ilog,ibyrc,ibjdc,ibhrc,nhrinc)
         call GRDAY(ilog,ibyrc,ibjdc,ibmoc,ibdyc)
         ibsecc=0
      endif
      if(iesecc.EQ.3600) then
         nhrinc=1
         call INCR(ilog,ieyrc,iejdc,iehrc,nhrinc)
         call GRDAY(ilog,ieyrc,iejdc,iemoc,iedyc)
         iesecc=0
      endif

c --- Check that ending date is after starting date
      iedathrc=ieyrc*100000+iejdc*100+iehrc
      ibdathrc=ibyrc*100000+ibjdc*100+ibhrc
      if(ibdathrc.GT.iedathrc)then
         write(ilog,*)
         write(ilog,*) 'READCF:  Error in Input Group 1'
         write(ilog,*) 'Starting date/time is after ending date/time'
         write(ilog,*) 'IBDATHR,IBSEC = ',ibdathrc,ibsecc
         write(ilog,*) 'IEDATHR,IESEC = ',iedathrc,iesecc
         lerrcf=.TRUE.
      elseif(ibdathrc.EQ.iedathrc .AND. ibsecc.GT.iesecc)then
         write(ilog,*)
         write(ilog,*) 'READCF:  Error in Input Group 1'
         write(ilog,*) 'Starting date/time is after ending date/time'
         write(ilog,*) 'IBDATHR,IBSEC = ',ibdathrc,ibsecc
         write(ilog,*) 'IEDATHR,IESEC = ',iedathrc,iesecc
         lerrcf=.TRUE.
      endif

c --- Compute the number of steps
      call DELTSEC(ibdathrc,ibsecc,iedathrc,iesecc,ndelsec)
      stepc=FLOAT(ndelsec)/FLOAT(nsecdtc)
      nstepc=NINT(stepc)

c --- Create time zone as real and integer
      call UTCBASR(azonec,zone)
      izonec=NINT(zone)

c --- Impose ZERO coordinates for locations if no map projection
c --- unless data are from CALMET, CALPUFF, M2D or M3D files
      if(LNOMAP) then
         if(mdata.NE.'CALPUFF' .AND.
     &      mdata.NE.'CALMET'  .AND.
     &      mdata.NE.'M2D'     .AND.
     &      mdata.NE.'M3D') then
            do k=1,ntsfout
               xmet(k)=0.0
               ymet(k)=0.0
               xaq(k)=0.0
               yaq(k)=0.0
            enddo
         endif
      endif

c --- Wind rose configuration
      if(mrosec.GT.0) then
c ---    Check for increasing wind speeds for bins
         nbad=0
         do i=2,6
            if(wsbin(i).LE.wsbin(i-1)) nbad=nbad+1
         enddo
         if(nbad.NE.0) then
            write(ilog,*)
            write(ilog,*) '*****'
            write(ilog,*) 'ERROR in control file: bad WSBIN = ',wsbin
            write(ilog,*) 'Wind speeds must increase'
            write(ilog,*) '*****'
            write(ilog,*)
            LERRCF=.TRUE.
         endif
      endif

c --- Pollutant rose configuration
      if(mdata.NE.'TSF         ') then
         if(mxypoll.NE.0) then
            write(ilog,*)
            write(ilog,*) '*****'
            write(ilog,*) 'WARNING:  generic pollutant rose location'
            write(ilog,*) '          is only used with TSF data files'
            write(ilog,*) '          Resetting MXYPOLL to 0'
            write(ilog,*) '*****'
            write(ilog,*)
            mxypoll=0
         endif
      elseif(mxypoll.LT.0 .OR. mxypoll.GT.1) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: bad MXYPOLL = ',mxypoll
         write(ilog,*) 'Expected MXYPOLL = 0, 1'
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif
      if(mwdbintyp.LT.0 .OR. mwdbintyp.GT.3) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: bad MWDBINTYP = ',
     &                                             mwdbintyp
         write(ilog,*) 'Expected MWDBINTYP = 0, 1, 2, or 3'
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif
      if(mcbintyp.LT.0 .OR. mcbintyp.GT.1) then
         write(ilog,*)
         write(ilog,*) '*****'
         write(ilog,*) 'ERROR in control file: bad MCBINTYP = ',
     &                                             mcbintyp
         write(ilog,*) 'Expected MCBINTYP = 0 or 1'
         write(ilog,*) '*****'
         write(ilog,*)
         LERRCF=.TRUE.
      endif
      if(mcbintyp.EQ.1) then
c ---    Check for increasing concentrations for bins
         nbad=0
         do i=2,6
            if(cbin(i).LE.cbin(i-1)) nbad=nbad+1
         enddo
         if(nbad.NE.0) then
            write(ilog,*)
            write(ilog,*) '*****'
            write(ilog,*) 'ERROR in control file: bad CBIN = ',cbin
            write(ilog,*) 'Concentrations must increase'
            write(ilog,*) '*****'
            write(ilog,*)
            LERRCF=.TRUE.
         endif
      endif

c ----------------------------
c --- Echo inputs to list file
c ----------------------------

c --- Echo filenames

      write(ilog,*)
      n=LEN_TRIM(cfname)
      write(ilog,*) 'Control file name:     ',cfname(1:n)
      n=LEN_TRIM(flog)
      write(ilog,*) 'Output list file name: ',flog(1:n)

      if(nmetinp.EQ.0) then
         write(ilog,*) 'Input MET file names:  (none)'
      else
         write(ilog,*) 'Input MET file names:  '
      endif
      do k=1,nmetinp
         n=LEN_TRIM(fmet(k))
         write(ilog,*) '                       ',fmet(k)(1:n)
      enddo

      if(naqinp.EQ.0) then
         write(ilog,*) 'Input AQ file names:   (none)'
      else
         write(ilog,*) 'Input AQ file names:   '
      endif
      do k=1,naqinp
         n=LEN_TRIM(faq(k))
         write(ilog,*) '                       ',faq(k)(1:n)
      enddo

      if(ntsfout.EQ.0) then
         write(ilog,*) 'Output TSF file names: (none)'
         n=LEN_TRIM(frose)
         write(ilog,*) 'Output Rose file names: ',frose(1:n)//'.*'
      else
         write(ilog,*) 'Output TSF file names: '
      endif
      do k=1,ntsfout
         n=LEN_TRIM(ftsf(k))
         write(ilog,*) '                       ',ftsf(k)(1:n)//'.TSF'
      enddo

      write(ilog,*)
      write(ilog,*) 'Group 1 Inputs'
      write(ilog,*) '--------------'
      write(ilog,*)
      write(ilog,*) '    Process Type : ', mdata
      if(mrosec.EQ.0) then
         write(ilog,*) '     Rose Output : none'
      elseif(mrosec.EQ.1) then
         write(ilog,*) '     Rose Output : Wind Rose'
      elseif(mrosec.EQ.2) then
         write(ilog,*) '     Rose Output : Pollutant Rose'
      endif
      write(ilog,*)
      write(ilog,*) '  Start of period ---'
      write(ilog,*) '    Year   (IBYR) : ', IBYRc
      write(ilog,*) '    Month  (IBMO) : ', IBMOc
      write(ilog,*) '    Day    (IBDY) : ', IBDYc
      write(ilog,*) '    Hour   (IBHR) : ', IBHRc
      write(ilog,*) '    Second (IBSEC): ', IBSECc
      write(ilog,*) '  End of period ---'
      write(ilog,*) '    Year   (IEYR) : ', IEYRc
      write(ilog,*) '    Month  (IEMO) : ', IEMOc
      write(ilog,*) '    Day    (IEDY) : ', IEDYc
      write(ilog,*) '    Hour   (IEHR) : ', IEHRc
      write(ilog,*) '    Second (IESEC): ', IESECc
      write(ilog,*)
      write(ilog,*) '    UTC time zone : ', azonec,' or ',izonec
      write(ilog,*) '    Step (seconds): ', nsecdtc
      write(ilog,*) '   Steps in period: ', nstepc
      write(ilog,*)
      write(ilog,*) ' MET Interpolation: ', metsimc
c --- V1.9.0, Level 121203
      write(ilog,*) '  TSF Midnite flag: ', imidnite

      write(ilog,*)
      write(ilog,*) 'Group 2 Inputs'
      write(ilog,*) '--------------'
      write(ilog,*)
      if(ntsfout.LE.0) then
         write(ilog,*) '  --- Not Applicable (no TSF output files)'
      endif
      do k=1,ntsfout
         n=LEN_TRIM(ftsf(k))
         write(ilog,*)
         write(ilog,*) '  TSF file '//ftsf(k)(1:n)
         if(nmetinp.GT.0) then
            n=LEN_TRIM(locmet(k))
            write(ilog,*) '  MET Data Location: '//locmet(k)(1:n)
            write(ilog,*) '    Station, XE, YN: ',idmet(k),xmet(k),
     &                                            ymet(k)
            write(ilog,*) ' Ht(Wind,Temp,RH,+): ',zwind(k),ztmpk(k),
     &                                            zshum(k),zother(k)
         endif
         if(naqinp.GT.0) then
            n=LEN_TRIM(locaq(k))
            write(ilog,*) '   AQ Data Location: '//locaq(k)(1:n)
            write(ilog,*) '    Station, XE, YN: ',idaq(k),xaq(k),
     &                                            yaq(k)
         endif
      enddo

      write(ilog,*)
      write(ilog,*) 'Group 3 Inputs'
      write(ilog,*) '--------------'
      write(ilog,*)
      if(ntsfout.LE.0 .OR. naqinp.LE.0) then
         write(ilog,*) '  --- Not Applicable (no Pollutant extraction)'
      else
         write(ilog,*) '  --- Pollutant extracted to TSF files'
         do k=1,nspec
            n1=LEN_TRIM(cfspec(k))
            n2=LEN_TRIM(cunito(k))
            write(ilog,*) ' Species, Units, M_Wt.: ',cfspec(k)(1:n1),
     &                    ' ',cunito(k)(1:n2),rmwt(k)
         enddo
      endif

      write(ilog,*)
      write(ilog,*) 'Group 4 Inputs'
      write(ilog,*) '--------------'
      write(ilog,*)
      if(ntsfout.LE.0) then
         write(ilog,*) '  --- Not Applicable (no TSF output files)'
      elseif(LNOMAP) then
         write(ilog,*) '    Map Projection: ', pmapc
      else
         write(ilog,*) '    Map Projection: ', pmapc
         write(ilog,*) '             Datum: ', datumc

         if(LUTM) then
            write(ilog,*)
            write(ilog,*) '          UTM Zone: ', iutmznc
            write(ilog,*) '        Hemisphere: ', utmhemc
         elseif(.NOT.LGEO) then
            write(ilog,*)
            write(ilog,*) '     False Easting: ', feastc
            write(ilog,*) '    False Northing: ', fnorthc
            write(ilog,*) '         Ref. Lat.: ', clat0c
            write(ilog,*) '         Ref. Lon.: ', clon0c
            write(ilog,*) '        Match Lat.: ', clat1c
            write(ilog,*) '        Match Lat.: ', clat2c
         endif
      endif

      write(ilog,*)
      write(ilog,*) 'Group 5 Inputs'
      write(ilog,*) '--------------'
      write(ilog,*)
      if(mdata.NE.'M3D         ') then
         write(ilog,*) '  --- Not Applicable to this data type'
      else
         write(ilog,*) '  --- M3D data type information'
         write(ilog,*) '    Profile Method: ', mprofqa(mprof)
         write(ilog,*) ' Selection by Cell: ', mcell
         write(ilog,*) '    # LandUse Cat.: ', nlu3d
      endif

      write(ilog,*)
      write(ilog,*) 'Group 6 Inputs'
      write(ilog,*) '--------------'
      write(ilog,*)
      if(mrosec.NE.1) then
         write(ilog,*) '  --- Wind Roses Not Requested'
      else
         write(ilog,*) '  --- Wind Roses Requested'
         write(ilog,*) 'Wind Speed Classes: ', wsbin
         write(ilog,*)
         do k=1,ntpdc
            write(ilog,*) ' Extra time ranges: ', (ntpc(j,k),j=1,2)
         enddo
         do k=1,nwspc
            write(ilog,*) 'Extra speed ranges: ', (wspc(j,k),j=1,2)
         enddo
c ---    Seasons
         write(ilog,*)
         do k=1,nseasn
            n=LEN_TRIM(snamec(k))
            write(ilog,*) '  Season: ',idseas(k),snamec(k)(1:n)
         enddo
         write(ilog,*)
         write(ilog,*) '  Monthly Map: ',msnc
      endif

      write(ilog,*)
      write(ilog,*) 'Group 7 Inputs'
      write(ilog,*) '--------------'
      write(ilog,*)
      if(mrosec.NE.2) then
         write(ilog,*) '  --- Pollutant Roses Not Requested'
      else
         write(ilog,*) '  --- Pollutant Roses Requested'
         n1=LEN_TRIM(pspec)
         n2=LEN_TRIM(punit)
         write(ilog,*) ' Species, Units: '//pspec(1:n1)//
     &                 ','//punit(1:n2)
         write(ilog,*) ' Size (radius) of rose (km): ',rrose
         write(ilog,*) ' Concentration of rose ring: ',crose
         write(ilog,*) ' Generic Location Option   : ',mxypoll
         if(mxypoll.EQ.0) then
            write(ilog,*) '  --- Generic Location Not Requested'
         else
            write(ilog,*) '         Generic x: ', xpoll
            write(ilog,*) '         Generic y: ', ypoll
         endif
         write(ilog,*) '    Wind direction bin type: ',mwdbintyp,
     &                                        awdbin(mwdbintyp+1)
         write(ilog,*) '     Concentration bin type: ',mcbintyp,
     &                                          acbin(mcbintyp+1)
         if(mcbintyp.EQ.1) then
            write(ilog,*) ' Concentrations for Bins: ', cbin
         endif
      endif


c --- STOP now if error exists in the control file
      if(LERRCF) then
         write(*,*)'ERRORS are found in the CONTROL file'
         write(*,*)'Review messages written to the LIST file'
         stop
      endif

      return
      end

c----------------------------------------------------------------------
      subroutine now(sdate,stime)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090318           NOW
c                D. Strimaitis
c
c --- PURPOSE:  First call to system date-time functions;  package
c               result for output documentation
c
c --- INPUTS:
c
c --- OUTPUT:
c       sdate - character*12  - System date string (DD-Mmm-YYYY)
c       stime - character*12  - System time string (HH:MM:SS)
c
c ---    Common block /QA/ variables:
c           rcpu,rtime,rdate
c
c --- NOW called by:  (main)
c --- NOW calls:      DATETM
c----------------------------------------------------------------------
c --- Include common blocks
      include 'qa.ser'

      character*12 sdate,stime
      character*3 month3(12)

c --- Set abbreviation names for months
      data month3/'Jan','Feb','Mar','Apr','May','Jun',
     &            'Jul','Aug','Sep','Oct','Nov','Dec'/

      sdate='DD-Mmm-YYYY '
      stime='HH:MM:SS    '

      call DATETM(rdate,rtime,rcpu)

c --- Send time back without change
      stime(1:8)=rtime

c --- Date components
      read(rdate(1:2),'(i2)') imon
      read(rdate(4:5),'(i2)') iday
      read(rdate(7:10),'(i4)') iyear

c --- Create date string
      write(sdate(1:2),'(i2.2)') iday
      sdate(4:6)=month3(imon)
      write(sdate(8:11),'(i4.4)') iyear

      return
      end

c----------------------------------------------------------------------
      subroutine hdtsfout(io,iloc)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203      HDTSFOUT
c                C. Escoffier, D. Strimaitis
c
c --- PURPOSE:  Writes header records to output TSF file
c
c --- UPDATES:
c
c --- V1.77(100615) to V1.9.0(121203)
c        - Add PRECIP.DAT
c        - Modified for WRF/MM5 2D files
c        - Add header line for CALMET surface pressure when OTHER=1. 
c
c
c --- V1.71(090918) to V1.77(100615) CEC
c        - Add the possibility to output SEA.DAT time series
c          extraction
c --- V1.7(090818) to V1.71(090918) IWL
c       1.  Modify TSF header line to write extraction location in
c           both X/Y and I/J for M3D, M2D, and CALMET.
c           Modified: HDTSFOUT
c --- V1.66 (090731) to V1.7 (090818) DGS
c        - Add logic for treating all variables available in M2D files
c        - Use explicit height for surface variables or for fixed
c          heights that are not profiled
c --- V1.62 (090411) to V1.66 (090731) DGS
c        - Add logic for nearest grid point option (METSIM)
c        - Time step format changed from (2x,i5.5) to (2x,i5.4)
c        - Add M2D file option
c (CEC)  - Add output of Relative Humidity in 3D.DAT format, SURF.DAT
c          format, CALMET format and AMMNETW format if 'lother' 
c          option is selected
c        - Add variable name MONITOR which can be used instead of AMMNET
c --- V1.61 (090330) to V1.62 (090411) CEC
c        - Time step format changed from (3x,i4.4) to (2x,i5.5)
c        - Add two additional comment lines for CALPUFF extraction format
c        - For CALPUFF extraction format the location provided for the
c          pollutant is the receptor location in user-requested projection
c --- V1.6 (090318) to V1.61 (090330) DGS
c        -  Change units designation for precip code from NO UNITS
c           to NO_UNITS to maintain the string convention
c
c
c --- INPUTS:
c
c --- OUTPUT:
c
c --- HDTSFOUT called by:  MM5EXT, SRFEXT, AERMSFCEXT, AERMPFLEXT
c                          AMMNETWEXT. AMMNETCEXT, POSTEXT,
c                          UPEXT, CLMEXT, CPFEXT
c --- V1.9.0, Level 121203
c                          PRCEXT
c --- HDTSFOUT calls:      none
c----------------------------------------------------------------------
c --- Include parameters
      include 'params.ser'
c --- Include common blocks
      include 'qa.ser'
      include 'ctrl.ser'
      include 'metinp.ser'
      include 'metseries.ser'

      character*10 dnima
      character*16 xdatanam,xdataver
      character*64 xdatamod
      character*132 ctext(5)

      real rloci,rlocj
      real rlocx,rlocy

      data dnima/'02-21-2003'/
      data xdatanam/'TIMESERIES.TSF  '/
      data xdataver/'1.3             '/
      data xdatamod/'Full location/date/time documentation'/

c --- Missing
      xmiss=9999.0
      xmwt=-1.0

c --- Set heights for variables at the surface or at heights that are
c --- not profiled
      zero=0.0
      z2=2.0
      z10=10.0

c --- Length of creation stamp
      nc=LEN_TRIM(create80)
c --- Length of user title
      nt=LEN_TRIM(titlec)

c --- V1.9.0, Level 121203
c --- Augment title string to indicate WRF of MM5 2D.DAT origin
      if(mdata.EQ.'M2D') then
         if(i2d_type.EQ.1) then
            nt=MIN(132,nt+6)
            titlec(nt-5:nt)=' - MM5'
         elseif(i2d_type.EQ.2) then
            nt=MIN(132,nt+6)
            titlec(nt-5:nt)=' - WRF'
         endif
      endif

c --- Place 1 blank into ctext strings
      do k=1,5
         ctext(k)=' '
      enddo

c --- Set text line 1 for profiling comment
      if(mdata.eq.'SURF'.or.mdata.eq.'AMMNETW'.or.
     & mdata.eq.'AERMSFC'.or.mdata.eq.'M2D'.or.mdata.eq.'MONITORW'

c --- V1.9.0, Level 121203
     & .or.mdata.eq.'SEA'.or.mdata.eq.'PRECIP') then

         ctext(1)='Surface Meteorological data are not profiled'
      elseif(mdata.eq.'AMMNETC'.or.mdata.eq.'POSTIME'.or.
     &  mdata.eq.'MONITORW') then
         ctext(1)='Pollutant data are not profiled'
      elseif(mdata.eq.'CALPUFF') then
         ctext(1)='Pollutant data are not profiled'
      elseif(LLINEAR) then
         ctext(1)='Upper Air data are linearly interpolated'
      elseif(LSTANDARD) then
         ctext(1)='Standard profiling method is used'
      elseif(LMETSTAT) then
         ctext(1)='METSTAT-like profiling method is used'
      elseif(LNEUTRAL) then
         ctext(1)='NEUTRAL wind profiling method is used'
c --- (CEC - 080205) - read DIRECT wind from M3D file
      elseif(LDIRECT) then
         if(mdata.eq.'M3D') then
            ctext(1)='DIRECT wind, T, Q from M3D file'
         else
            write(ilog,'(a)')'ERROR - DIRECT can only be used with M3D'
            stop 'RUN HALTED '
         endif
      elseif(LALLPROF .AND. n.EQ.1) then
         ctext(1)='Standard profiling method is used'
      elseif(LALLPROF .AND. n.EQ.2) then
         ctext(1)='METSTAT-like profiling method is used'
      elseif(LALLPROF .AND. n.EQ.3) then
         ctext(1)='NEUTRAL wind profiling method is used'
      endif
c --- Length of text line 1
      nt1=LEN_TRIM(ctext(1))

c --- Set text line 2 for MET station location
c --- Extraction location coordinates xloc,yloc are now in the
c --- coordinate system of the input data file
      if((mdata.EQ.'M3D').OR.(mdata.EQ.'M2D')) then
         if(ifrmt.EQ.3) then
c ---      Cell ri/rj format for site locations
           rloci=xloc(iloc)
           rlocj=yloc(iloc)
c ---      Compute X/Y
           rlocx=xsw+dxm*(rloci-1)
           rlocy=ysw+dym*(rlocj-1)
         elseif(ifrmt.LE.2) then
c ---      X/Y or Lon/Lat format for site locations
           rlocx=xloc(iloc)
           rlocy=yloc(iloc)
c ---      Compute I/J
           rloci=(rlocx-xsw)/dxm+1
           rlocj=(rlocy-ysw)/dym+1
         endif
         if(metsimc.EQ.2) then
           if(mdata.EQ.'M3D') then
             write(ctext(2),1005)rloci,rlocj,rlocx,rlocy
           elseif(mdata.EQ.'M2D') then
             write(ctext(2),1015)rloci,rlocj,rlocx,rlocy
           endif
         else
           if(mdata.EQ.'M3D') then
             write(ctext(2),1006)rloci,rlocj,rlocx,rlocy
           elseif(mdata.EQ.'M2D') then
             write(ctext(2),1016)rloci,rlocj,rlocx,rlocy
           endif
         endif
      elseif(mdata.EQ.'SURF') then
         write(ctext(2),1010)idmet(iloc)
      elseif(mdata.EQ.'CALMET') then
c ---    X/Y or Lon/Lat format for site locations
         rlocx=xloc(iloc)
         rlocy=yloc(iloc)
c ---    Compute I/J
         rloci=(rlocx-xsw)/dxm+1
         rlocj=(rlocy-ysw)/dym+1
         if(metsimc.EQ.2) then
           write(ctext(2),1022)rloci,rlocj,rlocx,rlocy
         else
           write(ctext(2),1023)rloci,rlocj,rlocx,rlocy
         endif
      elseif(mdata.EQ.'UP') then
         write(ctext(2),1030)idmet(iloc)
      elseif(mdata.EQ.'AMMNETW') then
         write(ctext(2),1041)idmet(iloc)
      elseif(mdata.EQ.'MONITORW') then
         write(ctext(2),1043)idmet(iloc)
      elseif(mdata.EQ.'AMMNETC') then
         write(ctext(2),1041)idmet(iloc)
      elseif(mdata.EQ.'MONITORC') then
         write(ctext(2),1043)idmet(iloc)
      elseif(mdata.EQ.'AERMSFC') then
         write(ctext(2),1050)idmet(iloc)
      elseif(mdata.EQ.'POSTIME')then
         write(ctext(2),1020)xloc(iloc),yloc(iloc)
      elseif(mdata.EQ.'AERMPFL') then
         write(ctext(2),1070)idmet(iloc)
      elseif(mdata.EQ.'SEA') then
         write(ctext(2),1071)idmet(iloc)

c --- V1.9.0, Level 121203
      elseif(mdata.EQ.'PRECIP') then
         write(ctext(2),1072)idmet(iloc)

      endif
c --- Length of text line 2
      nt2=LEN_TRIM(ctext(2))

c --- Set text line 3 for AQ station location
      if(mdata.EQ.'AMMNETC') then
         write(ctext(3),1042)idaq(iloc)
      elseif(mdata.EQ.'MONITORC') then
         write(ctext(3),1044)idaq(iloc)
      elseif(mdata.EQ.'POSTIME')then
         write(ctext(3),1060)xloc(iloc),yloc(iloc)
      elseif(mdata.EQ.'CALPUFF')then
         if(artype(iloc).NE.'G') then
            write(ctext(3),1081)ixloc(iloc),artype(iloc),
     &                          xrloc(iloc),yrloc(iloc)
         else
            write(ctext(3),1082)ixloc(iloc),jyloc(iloc),
     &                          artype(iloc),
     &                          xrloc(iloc),yrloc(iloc)
         endif
      endif
c --- Length of text line 3
      nt3=LEN_TRIM(ctext(3))

c --- Set text line 4 and line 5 for CALPUFF dataset
      if(mdata.EQ.'CALPUFF')then
         if(pmapc.EQ.'LL      ') then
            write(ctext(4),2083)xaq(iloc),yaq(iloc),pmapc
            write(ctext(5),2084)xraq(iloc),yraq(iloc),pmapc
         else
            write(ctext(4),1083)xaq(iloc),yaq(iloc),pmapc
            write(ctext(5),1084)xraq(iloc),yraq(iloc),pmapc
         endif
      endif

c --- Set text line 4 and line 5 for other grid-based datasets
      if(mdata.EQ.'CALMET' .OR. mdata.EQ.'M3D' .OR. mdata.EQ.'M2D')then
c ---    Text Line 4
         if(metsimc.EQ.2) then
            if(ifrmt.EQ.3) then
               write(ctext(4),3183)xuloc(iloc),yuloc(iloc)
            elseif(pmapc.EQ.'LL      ') then
               write(ctext(4),2183)xuloc(iloc),yuloc(iloc),pmapc
            else
               write(ctext(4),1183)xuloc(iloc),yuloc(iloc),pmapc
            endif
         else
            if(ifrmt.EQ.3) then
               write(ctext(4),3083)xloc(iloc),yloc(iloc)
            elseif(pmapc.EQ.'LL      ') then
               write(ctext(4),2083)xmet(iloc),ymet(iloc),pmapc
            else
               write(ctext(4),1083)xmet(iloc),ymet(iloc),pmapc
            endif
         endif
c ---    Text Line 5
         if(metsimc.EQ.2) then
            if(pmapc.EQ.'LL      ') then
               write(ctext(5),2185)xmet(iloc),ymet(iloc),pmapc
            else
               write(ctext(5),1185)xmet(iloc),ymet(iloc),pmapc
            endif
         else
            if(pmapc.EQ.'LL      ') then
               write(ctext(5),2085)xmet(iloc),ymet(iloc),pmapc
            else
               write(ctext(5),1085)xmet(iloc),ymet(iloc),pmapc
            endif
         endif
      endif

c --- Length of text line 4 and line 5
      nt4=LEN_TRIM(ctext(4))
      nt5=LEN_TRIM(ctext(5))

 1001 format('3D.DAT: Interpolated to (I,J)=(',2f9.3,')')
 1002 format('3D.DAT: Interpolated to (X,Y)km=(',2f10.3,
     &       ') in MODEL Projection')
 1003 format('3D.DAT: Nearest Grid Pt (I,J)=(',2f9.3,')')
 1004 format('3D.DAT: Nearest Grid Pt (X,Y)km=(',2f10.3,
     &       ') in MODEL Projection')
 1005 format('3D.DAT: Nearest Grid Pt [(I,J)=(',f9.3,',',f9.3,')]',
     &       ')][(X,Y)km=(',f10.3,',',f10.3,') in MODEL Projection]')
 1006 format('3D.DAT: Interpolated to [(I,J)=(',f9.3,',',f9.3,')]',
     &       ')][(X,Y)km=(',f10.3,',',f10.3,') in MODEL Projection]')
 1011 format('2D.DAT: Interpolated to (I,J)=(',2f9.3,')')
 1012 format('2D.DAT: Interpolated to (X,Y)km=(',2f10.3,
     &       ') in MODEL Projection')
 1013 format('2D.DAT: Nearest Grid Pt (I,J)=(',2f9.3,')')
 1014 format('2D.DAT: Nearest Grid Pt (X,Y)km=(',2f10.3,
     &       ') in MODEL Projection')
 1015 format('2D.DAT: Nearest Grid Pt [(I,J)=(',f9.3,',',f9.3,')]',
     &       ')][(X,Y)km=(',f10.3,',',f10.3,') in MODEL Projection]')
 1016 format('2D.DAT: Interpolated to [(I,J)=(',f9.3,',',f9.3,')]',
     &       ')][(X,Y)km=(',f10.3,',',f10.3,') in MODEL Projection]')
 1010 format('SURF.DAT:  Station ID = ',i7)
 1020 format('CALMET.DAT: Interpolated to (X,Y)km=(',2f10.3,
     &       ') in MODEL Projection')
 1021 format('CALMET.DAT: Nearest Grid Pt (X,Y)km=(',2f10.3,
     &       ') in MODEL Projection')
 1022 format('CALMET.DAT: Nearest Grid Pt [(I,J)=(',f9.3,',',f9.3,')]',
     &       ')][(X,Y)km=(',f10.3,',',f10.3,') in MODEL Projection]')
 1023 format('CALMET.DAT: Interpolated to [(I,J)=(',f9.3,',',f9.3,')]',
     &       ')][(X,Y)km=(',f10.3,',',f10.3,') in MODEL Projection]')
 1030 format('UP.DAT:  Station ID = ',i7)
 1041 format('AMMNETW.CSV:  Station ID = ',i7)
 1042 format('AMMNETC.CSV:  Station ID = ',i7)
 1043 format('MONITORW.CSV:  Station ID = ',i7)
 1044 format('MONITORC.CSV:  Station ID = ',i7)
 1050 format('AERMET.SFC:  Station ID = ',i7)
 1060 format('POSTTIME.DAT:  Model(X,Y)km=(',2f10.3,')')
 1070 format('AERMET.PFL:  Station ID = ',i7)
 1071 format('SEA.DAT:  Station ID = ',i7)

c --- V1.9.0, Level 121203
 1072 format('PRECIP.DAT:  Station ID = ',i7)

 1081 format('CONC.DAT:  Closest Receptor',i7,a1,
     &       ' at (X,Y)km=(',2f10.3,') in MODEL Projection')
 1082 format('CONC.DAT:  Closest Receptor (',i4,',',i4,')',a1,
     &       ' at (X,Y)km=(',2f10.3,') in MODEL Projection')
 1083 format('User requested:   (X,Y)km=(',2f10.3,') in ',a5,
     &       ' Projection below')
 1183 format('Input location:   (X,Y)km=(',2f10.3,') in ',a5,
     &       ' Projection below')
 1084 format('Closest receptor: (X,Y)km=(',2f10.3,') in ',a5,
     &       ' Projection below')
 1085 format('Interpolated to:  (X,Y)km=(',2f10.3,') in ',a5,
     &       ' Projection below')
 1185 format('Nearest Grid Pt:  (X,Y)km=(',2f10.3,') in ',a5,
     &       ' Projection below')
 2083 format('User requested:   (LON,LAT)=(',2f10.3,') in ',a5,
     &       ' Projection below')
 2183 format('Input location:   (LON,LAT)=(',2f10.3,') in ',a5,
     &       ' Projection below')
 2084 format('Closest receptor: (LON,LAT)=(',2f10.3,') in ',a5,
     &       ' Projection below')
 2085 format('Interpolated to:  (LON,LAT)=(',2f10.3,') in ',a5,
     &       ' Projection below')
 2185 format('Nearest Grid Pt:  (LON,LAT)=(',2f10.3,') in ',a5,
     &       ' Projection below')
 3083 format('User requested:   (I,J)=(',2f9.3,')')
 3183 format('Input location:   (I,J)=(',2f9.3,')')


c --- Write header
c ----------------

c --- Dataset record
      write(io,'(2a16,a64)')xdatanam,xdataver,xdatamod

c --- Comment record(s)
      nn=3
      write(io,*) nn,'     --- comment lines'
      write(io,'(a)') create80(1:nc)
      write(io,'(a)') titlec(1:nt)
      write(io,'(a)') ctext(1)(1:nt1)

c --- Station location records
      nn=0
      if(naqinp.GT.0) nn=nn+1
      if(nmetinp.GT.0) nn=nn+1
      nn2=nn*2
      if(mdata.EQ.'CALPUFF')nn2=nn2+2
      if(mdata.EQ.'CALMET')nn2=nn2+2
      if(mdata.EQ.'M3D' .OR. mdata.EQ.'M2D')nn2=nn2+2
      write(io,*) nn2,'     --- station information lines'

      if(naqinp.GT.0) then
         n=LEN_TRIM(locaq(iloc))
         write(io,'(a)') locaq(iloc)(1:n)
         write(io,'(a)') ctext(3)(1:nt3)
         if(mdata.EQ.'CALPUFF') then
            write(io,'(a)') ctext(4)(1:nt4)
            write(io,'(a)') ctext(5)(1:nt5)
         endif
      endif
      if(nmetinp.GT.0) then
         n=LEN_TRIM(locmet(iloc))
         write(io,'(a)') locmet(iloc)(1:n)
         write(io,'(a)') ctext(2)(1:nt2)
         if(mdata.EQ.'CALMET' .OR. mdata.EQ.'M3D'
     &                        .OR. mdata.EQ.'M2D') then
            write(io,'(a)') ctext(4)(1:nt4)
            write(io,'(a)') ctext(5)(1:nt5)
         endif
      endif

c --- Projection
      write(io,'(a8)') pmapc

c --- Projection information (as needed)
      if(LGEO) then
         write(io,'(a8,a10)') datumc,dnima
         write(io,'(a4)') 'DEG '
      elseif(LUTM) then
         write(io,'(i4,a4)') iutmznc,utmhemc
         write(io,'(a8,a10)') datumc,dnima
         write(io,'(a4)') 'KM  '
      elseif(LLCC .OR. LPS) then
         write(io,'(4a16)') clat0c,clon0c,clat1c,clat2c
         write(io,'(2e15.8)') feastc,fnorthc
         write(io,'(a8,a10)') datumc,dnima
         write(io,'(a4)') 'KM  '
      elseif(LTTM .OR. LEM .OR. LLAZA) then
         write(io,'(4a16)') clat0c,clon0c
         write(io,'(2e15.8)') feastc,fnorthc
         write(io,'(a8,a10)') datumc,dnima
         write(io,'(a4)') 'KM  '
      endif

c --- Time zone (of output times)
      write(io,'(a8)') azonec

c --- Date format
      write(io,'(a16)') 'GREGORIAN_YMD   '

c --- Processing period
      write(io,'(2(i4,3i3,i5.4,1x),2x,i5.4)')
     &          ibyrc,ibmoc,ibdyc,ibhrc,ibsecc,
     &          ieyrc,iemoc,iedyc,iehrc,iesecc,nsecdtc

c --- Data order, with units and missing value indicator
      nout=0

c --- Meteorological data formats
      if(mdata.ne.'AMMNETC' .AND. mdata.ne.'POSTIME' .AND.
     &   mdata.ne.'CALPUFF' .AND. mdata.ne.'MONITORC') then
         if(lwind(iloc)) nout=nout+2
         if (ltmpk(iloc)) nout=nout+1 
         if(ltmpk(iloc).and.mdata.eq.'SEA') nout=nout+1
         if(lshum(iloc)) nout=nout+1
         if(mdata.eq.'CALMET'.and.lother(iloc)) nout=nout+9
         if(mdata.eq.'M3D'.and.lother(iloc)) nout=nout+5
         if(mdata.eq.'M2D'.and.lother(iloc)) then
            if(igrdt.EQ.1) nout=nout+1
            if(ipbl.EQ.1) nout=nout+1
            if(iustr.EQ.1) nout=nout+1
            if(iswdn.EQ.1) nout=nout+1
            if(ilwdn.EQ.1) nout=nout+1
            if(it2.EQ.1) nout=nout+1
            if(iq2.EQ.1) nout=nout+1
            if(iu10.EQ.1) nout=nout+1
            if(iv10.EQ.1) nout=nout+1
            if(isst.EQ.1) nout=nout+1

c --- V1.9.0, Level 121203
            if(id_rain.EQ.1) nout=nout+1
            if(id_rainc.EQ.1) nout=nout+1
            if(id_rainnc.EQ.1) nout=nout+1

         endif
         if(mdata.eq.'SURF'.and.lother(iloc)) nout=nout+5

c --- V1.9.0, Level 121203
         if(mdata.eq.'PRECIP'.and.lother(iloc)) nout=nout+1

         if(mdata.eq.'SEA'.and.lother(iloc)) nout=nout+6
         if(mdata.eq.'AERMSFC'.and.lother(iloc)) nout=nout+8
         if(mdata.eq.'AMMNETW'.and.lother(iloc)) then
            if(imcolpres.ne.0) nout=nout+1
            if(imcolsw.ne.0) nout=nout+1
            if(imcolprc.ne.0) nout=nout+1
            if(imcolrh.ne.0) nout=nout+1
         endif
         if(mdata.eq.'MONITORW'.and.lother(iloc)) then
            if(imcolpres.ne.0) nout=nout+1
            if(imcolsw.ne.0) nout=nout+1
            if(imcolprc.ne.0) nout=nout+1
            if(imcolrh.ne.0) nout=nout+1
         endif

        write(io,'(i5,a69)') nout,'     --- measure, units, mol.wt., '//
     &                    'missing,  Z_m,  X or LON,  Y or LAT'

         if(lwind(iloc)) write(io,51) 'WDIR        ','DEGREES     ',
     &             xmwt,xmiss,zwind(iloc),
     &             xmet(iloc),ymet(iloc)
         if(lwind(iloc)) write(io,51) 'WSPEED      ','M/S         ',
     &             xmwt,xmiss,zwind(iloc),
     &             xmet(iloc),ymet(iloc)
         if(ltmpk(iloc)) write(io,51) 'TEMP        ','K           ',
     &             xmwt,xmiss,ztmpk(iloc),
     &             xmet(iloc),ymet(iloc)
         if(ltmpk(iloc).and.mdata.eq.'SEA') 
     &                   write(io,51) 'TAIR-TSEA   ','K           ',
     &             xmwt,xmiss,ztmpk(iloc),
     &             xmet(iloc),ymet(iloc)      
         if(lshum(iloc)) write(io,51) 'SHUMID      ','G/KG        ',
     &             xmwt,xmiss,zshum(iloc),
     &             xmet(iloc),ymet(iloc)
         if(lother(iloc).and.mdata.eq.'CALMET') then
            write(io,51) 'MIXHGT      ','METERS      ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'PRECIP_RATE ','MM/HR       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'USTAR       ','M/S         ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'MONIN_OB    ','METERS      ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'CONV_VEL_S  ','M/S         ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'SHORT_WAVE  ','W/M*2       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'STAB_CLASS  ','CLASS       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'RH_HUMIDITY ','%           ',
     &             xmwt,xmiss,z2,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'SFC_PRESS   ','MB          ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
         elseif(lother(iloc).and.mdata.eq.'M3D') then
            write(io,51) 'SLVPRESS    ','MB          ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'PRECIP_RATE ','MM/HR       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'SHORT_WAVE  ','W/M*2       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'SST/GROUNDT ','K           ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'RH_HUMIDITY ','%           ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)

         elseif(lother(iloc).and.mdata.eq.'M2D') then
            if(igrdt.EQ.1)write(io,51) 'T_GROUND    ','K           ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            if(ipbl.EQ.1)write(io,51) 'PBL_HEIGHT  ','METERS      ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            if(iustr.EQ.1)write(io,51) 'USTAR       ','M/S         ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            if(iswdn.EQ.1)write(io,51) 'SWAVE_DOWN  ','W/M*2       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            if(ilwdn.EQ.1)write(io,51) 'LWAVE_DOWN  ','W/M*2       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            if(it2.EQ.1)write(io,51) 'TEMP        ','K           ',
     &             xmwt,xmiss,z2,
     &             xmet(iloc),ymet(iloc)
            if(iq2.EQ.1)write(io,51) 'SHUMID      ','G/KG        ',
     &             xmwt,xmiss,z2,
     &             xmet(iloc),ymet(iloc)
            if(iu10.EQ.1 .AND. iv10.EQ.1) then
                   write(io,51) 'WSPEED      ','M/S         ',
     &             xmwt,xmiss,z10,
     &             xmet(iloc),ymet(iloc)
                   write(io,51) 'WDIR        ','DEG         ',
     &             xmwt,xmiss,z10,
     &             xmet(iloc),ymet(iloc)
            endif

            if(isst.EQ.1)write(io,51)'T_SEASFC    ','K           ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)

c --- V1.9.0, Level 121203
            if(id_rain.EQ.1)write(io,51)'RAIN_TOT    ','MM          ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            if(id_rainc.EQ.1)write(io,51)'RAIN_CON    ','MM          ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            if(id_rainnc.EQ.1)write(io,51)'RAIN_NCON   ','MM          ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)

         elseif(lother(iloc).and.mdata.eq.'SURF') then
            write(io,51) 'PRESSURE    ','MB          ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'CEILING_HGT ','100_OF_FEET ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'CLD_COVER   ','TENTHS      ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'PRECIP_CODE ','NO_UNIT     ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'RH_HUMIDITY ','%           ',
     &             xmwt,xmiss,zother(iloc),
     &             xmet(iloc),ymet(iloc)

c --- V1.9.0, Level 121203
         elseif(lother(iloc).and.mdata.eq.'PRECIP') then
            write(io,51) 'PRECIP_RATE ','MM/HR       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)

         elseif(lother(iloc).and.mdata.eq.'AERMSFC') then
            write(io,51) 'CONV_LAYER  ','METERS      ',
     &             xmwt,-xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'MECHA_LAYER ','METERS      ',
     &             xmwt,-xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'PRECIP_RATE ','MM/HR       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'USTAR       ','M/S         ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'MONIN_OB    ','METERS      ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'CONV_VEL_S  ','M/S         ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'SENSIBLEFLX ','W/M*2       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'CLD_COVER   ','TENTHS      ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
         elseif(lother(iloc).and.mdata.eq.'AMMNETW') then
            if(imcolpres.ne.0) then
              write(io,51) 'SURF_PRESS  ','MB          ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            endif
            if(imcolsw.ne.0) then
              write(io,51) 'SHORT_WAVE  ','W/M*2       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            endif
            if(imcolprc.ne.0) then
              write(io,51) 'PRECIP_RATE ','MM/HR       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            endif
            if(imcolrh.ne.0) then
              write(io,51) 'RH_HUMIDITY ','%           ',
     &             xmwt,xmiss,zother(iloc),
     &             xmet(iloc),ymet(iloc)
            endif
         elseif(lother(iloc).and.mdata.eq.'MONITORW') then
            if(imcolpres.ne.0) then
              write(io,51) 'SURF_PRESS  ','MB          ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            endif
            if(imcolsw.ne.0) then
              write(io,51) 'SHORT_WAVE  ','W/M*2       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            endif
            if(imcolprc.ne.0) then
              write(io,51) 'PRECIP_RATE ','MM/HR       ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            endif
            if(imcolrh.ne.0) then
              write(io,51) 'RH_HUMIDITY ','%           ',
     &             xmwt,xmiss,zother(iloc),
     &             xmet(iloc),ymet(iloc)
            endif
         elseif(lother(iloc).and.mdata.eq.'SEA') then
            write(io,51) 'MIXHGT      ','METERS      ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'RH_HUMIDITY ','%           ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'DTDZbelowMH ','K/M         ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'DTDZaboveMH ','K/M         ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'WAVE PERIOD ','SEC         ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
            write(io,51) 'WAVE HEIGHT ','METERS      ',
     &             xmwt,xmiss,zero,
     &             xmet(iloc),ymet(iloc)
         endif

c --- Combined meteorological/pollutant data formats
      elseif(mdata.EQ.'AMMNETC' .OR. mdata.EQ.'POSTIME' .OR.
     &       mdata.EQ.'CALPUFF' .OR. mdata.EQ.'MONITORC') then
         nout=nout+nspec
         if(lwind(iloc)) nout=nout+2

         write(io,*) nout,'     --- measure, units, mol.wt., '//
     &                    'missing,  Z_m,  X or LON,  Y or LAT'

         if(lwind(iloc)) write(io,51) 'WDIR        ','DEGREES     ',
     &             xmwt,xmiss,zwind(iloc),
     &             xmet(iloc),ymet(iloc)
         if(lwind(iloc)) write(io,51) 'WSPEED      ','M/S         ',
     &             xmwt,xmiss,zwind(iloc),
     &             xmet(iloc),ymet(iloc)
         do is=1,nspec
            if(mdata.NE.'CALPUFF') then
            write(io,51) cfspec(is),cunito(is),
     &             rmwt(is),xmiss,zaq(iloc),
     &             xaq(iloc),yaq(iloc)
            elseif(mdata.EQ.'CALPUFF') then
            write(io,51) cfspec(is),cunito(is),
     &             rmwt(is),xmiss,zaq(iloc),
     &             xraq(iloc),yraq(iloc)
            endif
         enddo
      endif
51    format(2a12,5f12.3)

      return
      end

c-----------------------------------------------------------------------
      subroutine gethead_cp(io,io1,nf)
c-----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 110301       GETHEAD
c                D. Strimaitis
c
c --- Adapted From:
c --- POSTUTIL  Version: 1.57           Level: 050311           GETHEAD
c ---           D. Strimaitis, SRC
c
c  PURPOSE:     Reads header information from concentration file
c               and passes information to main program through
c               commons /head/ and /head2/.
c
c  UPDATES:
c     V1.42(050311) to V1.8(110301)
c               (DGS) Add dataset version 2.2 format
c     V1.4(040818) to V1.42(050311)
c               (DGS) Allow mix of Dataset 2.* formats
c     V1.3(030402) to V1.4(040818)
c               (DGS) Add dataset version 2.1 format
c     V1.2(030210) to V1.3(030402)
c               (DGS) Dataset version 2.0 format
c               (DGS) add list-file unit to INCR, YR4
c     V1.1(010730)  to V1.2(030210)
c               (JSS) read file type flag (i2drhu)
c                     i2drhu = 0 (original file type)
c                            = 1 (NO-OBS file type)
c     V1.1(990806)  to V1.1(010730)
c               (DGS) output format for year is always YYYY
c
c  ARGUMENTS:
c     PASSED:   io      Unit number for accessing input file         [i]
c              io1      Unit number for list output file             [i]
c               nf      Number of the input file                     [i]
c
c  CALLING ROUTINES:    POSTUTIL
c
c  EXTERNAL ROUTINES:   INCR, YR4, GETDOC_CP, UTCBASR
c-----------------------------------------------------------------------
c --- Parameters and commons /HEAD_CP/ and /CONC_CP/
      INCLUDE 'cpuff.ser'
      include 'params.ser'

c -- Note: all declaration statements for data read in by GETHEAD
c          are contained in these commons

c --- Variables added for DATASET VERSION 2.2 (Stored in /HEAD_CP/)
c     ABTZ                   base time zone as UTC+hhmm
c     ASPUNIT(mxsplv,mxfile) units name for each species-level

c --- Variables added for DATASET VERSION 2.1
c     NSTYPE(mxfile,8) holds the number of each type of source
c                     in each file
c               1 - point sources (Control File)
c               2 - point sources (Var. Emissions File)
c               3 - area sources (Control File)
c               4 - area sources (Var. Emissions File)
c               5 - line sources (Control File)
c               6 - line sources (Var. Emissions File)
c               7 - volume sources (Control File)
c               8 - volume sources (Var. Emissions File)
      integer nstype(mxfile_cp,8)
      character*4 cstype(8)

      character*48 msg(8),msg0
      logical lfatal,ldbg, lvisib
      logical lspunit

      data msg0  /'  **********************************************'/
      data msg(1)/'  *      FATAL Problem Found in GETHEAD!       *'/
      data msg(2)/'  * ------------------------------------------ *'/
      data msg(3)/'  *  Size of Array(s) in CALPUFF.DAT too Large *'/
      data msg(4)/'  *  Re-size Array Parameter(s) in CPUFF.SER   *'/
      data msg(5)/'  *         and Recompile METSERIES            *'/
      data msg(6)/'  * ------------------------------------------ *'/
      data msg(7)/'  * Parameter       CPUFF.SER      CALPUFF.DAT *'/
      data msg(8)/'  * ---------       ----------     ----------- *'/


c --- Set names of each source type for error report section
      data cstype/'pt1 ','pt2 ','ar1 ','ar2 ',
     &            'ln1 ','ln2 ','vl1 ','vl2 '/

      ldbg=.FALSE.
      lfatal=.FALSE.
      lvisib=.FALSE.
      lspunit=.FALSE.

c --- Process first section of CALPUFF output file (including comment
c --- records), and determine dataset version
      call GETDOC_CP(io,nf,idtype,cpverx_cp(nf))
c
c  Read control variables (record NCOM+3)

      if(idtype.EQ.0) then
c ---   Dataset EARLIER than Version 2.0
        i2drhu_cp=0
        read(io,iostat=ierr)
     *     amodel_cp,aver_cp,alev_cp,msyr_cp,mjsday_cp,mshr_cp,
     *     mssec_cp,mnrun_cp,mavgpd_cp,nsecdt_cp,
     *     ielmet_cp,jelmet_cp,delx_cp,dely_cp,nz_cp,
     *     xorigkm_cp,yorigkm_cp,nstas_cp,
     *     iastar_cp,iastop_cp,jastar_cp,jastop_cp,
     *     isastr_cp,jsastr_cp,isastp_cp,jsastp_cp,
     *     meshdn_cp,kpts,kareas,klines,kvols,
     *     ndrec_cp,nctrec_cp,LSGRID_cp,nszout_cp(nf),lcomprs_cp(nf)
        if(ierr.EQ.0) then
           iptimex_cp(nf)=2
           isrcinfox_cp(nf)=0
           isrcindv_cp=0
        else
c ---      May have hit end of header record; try again with old format
           rewind(io)
           read(io)
     *        amodel_cp,aver_cp,alev_cp,msyr_cp,mjsday_cp,mshr_cp,
     *        mnhrs_cp,mavg_cp,
     *        ielmet_cp,jelmet_cp,delx_cp,dely_cp,nz_cp,
     *        xorigkm_cp,yorigkm_cp,nstas_cp,
     *        iastar_cp,iastop_cp,jastar_cp,jastop_cp,
     *        isastr_cp,jsastr_cp,isastp_cp,jsastp_cp,
     *        meshdn_cp,kpts,kareas,klines,kvols,
     *        ndrec_cp,nctrec_cp,LSGRID_cp,nszout_cp(nf),
     *        lcomprs_cp(nf),i2drhu_cp
           iptimex_cp(nf)=1
           isrcinfox_cp(nf)=0
           isrcindv_cp=0
        endif

      else

c ---   Dataset version 2.0 or later format
        if(cpverx_cp(nf).EQ.'2.0             ') then
          read(io)
     *       amodel_cp,aver_cp,alev_cp,msyr_cp,mjsday_cp,mshr_cp,
     *       mnhrs_cp,mavg_cp,
     *       ielmet_cp,jelmet_cp,delx_cp,dely_cp,nz_cp,
     *       xorigkm_cp,yorigkm_cp,nstas_cp,
     *       iastar_cp,iastop_cp,jastar_cp,jastop_cp,
     *       isastr_cp,jsastr_cp,isastp_cp,jsastp_cp,
     *       meshdn_cp,kpts,kareas,klines,kvols,
     *       ndrec_cp,nctrec_cp,LSGRID_cp,nszout_cp(nf),
     *       lcomprs_cp(nf),i2drhu_cp,
     *       iutmzn_cp,feast_cp,fnorth_cp,rnlat0_cp,relon0_cp,
     *       xlat1_cp,xlat2_cp,pmap_cp,utmhem_cp,datum_cp,daten_cp,
     *       clat0_cp,clon0_cp,clat1_cp,clat2_cp
          iptimex_cp(nf)=1
          isrcinfox_cp(nf)=0
          isrcindv_cp=0

        elseif(cpverx_cp(nf).EQ.'2.1             ') then
          read(io)
     *       amodel_cp,aver_cp,alev_cp,msyr_cp,mjsday_cp,mshr_cp,
     *       mssec_cp,xbtz_cp,mnrun_cp,mavgpd_cp,nsecdt_cp,
     *       ielmet_cp,jelmet_cp,delx_cp,dely_cp,nz_cp,
     *       xorigkm_cp,yorigkm_cp,nstas_cp,
     *       iastar_cp,iastop_cp,jastar_cp,jastop_cp,
     *       isastr_cp,jsastr_cp,isastp_cp,jsastp_cp,
     *       meshdn_cp,nstype(nf,1),nstype(nf,2),nstype(nf,3),
     *       nstype(nf,4),nstype(nf,5),nstype(nf,6),
     *       nstype(nf,7),nstype(nf,8),msource_cp,
     *       ndrec_cp,nctrec_cp,LSGRID_cp,nszout_cp(nf),
     *       lcomprs_cp(nf),i2drhu_cp,
     *       iutmzn_cp,feast_cp,fnorth_cp,rnlat0_cp,relon0_cp,
     *       xlat1_cp,xlat2_cp,pmap_cp,utmhem_cp,datum_cp,daten_cp,
     *       clat0_cp,clon0_cp,clat1_cp,clat2_cp
          iptimex_cp(nf)=2
          isrcinfox_cp(nf)=1
          isrcindv_cp=msource_cp
          kpts=nstype(nf,1)+nstype(nf,2)
          kareas=nstype(nf,3)+nstype(nf,4)
          klines=nstype(nf,5)+nstype(nf,6)
          kvols=nstype(nf,7)+nstype(nf,8)

        elseif(cpverx_cp(nf).EQ.'2.2             ') then
          read(io)
     *       amodel_cp,aver_cp,alev_cp,msyr_cp,mjsday_cp,mshr_cp,
     *       mssec_cp,abtz_cp,mnrun_cp,mavgpd_cp,nsecdt_cp,
     *       ielmet_cp,jelmet_cp,delx_cp,dely_cp,nz_cp,
     *       xorigkm_cp,yorigkm_cp,nstas_cp,
     *       iastar_cp,iastop_cp,jastar_cp,jastop_cp,
     *       isastr_cp,jsastr_cp,isastp_cp,jsastp_cp,
     *       meshdn_cp,nstype(nf,1),nstype(nf,2),nstype(nf,3),
     *       nstype(nf,4),nstype(nf,5),nstype(nf,6),
     *       nstype(nf,7),nstype(nf,8),msource_cp,
     *       ndrec_cp,nctrec_cp,LSGRID_cp,nszout_cp(nf),
     *       lcomprs_cp(nf),i2drhu_cp,
     *       iutmzn_cp,feast_cp,fnorth_cp,rnlat0_cp,relon0_cp,
     *       xlat1_cp,xlat2_cp,pmap_cp,utmhem_cp,datum_cp,daten_cp,
     *       clat0_cp,clon0_cp,clat1_cp,clat2_cp
          iptimex_cp(nf)=2
          isrcinfox_cp(nf)=1
          isrcindv_cp=msource_cp
          kpts=nstype(nf,1)+nstype(nf,2)
          kareas=nstype(nf,3)+nstype(nf,4)
          klines=nstype(nf,5)+nstype(nf,6)
          kvols=nstype(nf,7)+nstype(nf,8)
c ---     Convert from UTC string to real base time zone
          call UTCBASR(abtz_cp,xbtz_cp)
c ---     Specie-level units are in header
          lspunit=.TRUE.

        else
          write(io1,*)'ERROR:  Unknown DATASET Version: ',cpverx_cp(nf)
          stop 'Halted in GETHEAD'
        endif

      endif

c --- Update of number of sources for output header
      if(isrcinfox_cp(nf).EQ.0) then
c ---    DO NOT UPDATE SOURCE NUMBERS
cc ---    No individual source information is available, so just keep
cc ---    the maximum number of each type (cannot test for duplicates)
c         npts=MAX(npts,kpts)
c         nareas=MAX(nareas,kareas)
c         nlines=MAX(nlines,klines)
c         nvols=MAX(nvols,kvols)
      elseif(isrcinfox_cp(nf).EQ.1) then
c ---    Retain all source names even though some may be duplicates
c ---    (2 files may hold different species for the same sources)
         npts_cp=npts_cp+kpts
         nareas_cp=nareas_cp+kareas
         nlines_cp=nlines_cp+klines
         nvols_cp=nvols_cp+kvols
      endif

c --- Check year format
      call YR4(io1,msyr_cp,ierry)
      if(ierry.NE.0) stop 'Halted in GETHEAD'

      if(iptimex_cp(nf).EQ.1) then
c ---    Move starting time back 1 hour to identify the start of the
c ---    first hour
         call INCR(io1,msyr_cp,mjsday_cp,mshr_cp,-1)
c ---    Set period step to 1 hour
         nsecdt_cp=3600
         mssec_cp=0
c ---    Rename averaging period variables
         mnrun_cp=mnhrs_cp
         mavgpd_cp=mavg_cp
      endif


c  Check size of array dimensions (compute gridded rec. array dims.)
c  with limits contained in CPUFF.SER file
      ngx_cp=(isastp_cp-isastr_cp)*meshdn_cp+1
      ngy_cp=(jsastp_cp-jsastr_cp)*meshdn_cp+1
      ngrec_cp=ngx_cp*ngy_cp
      if(ngx_cp .GT. mxgx_cp) lfatal=.TRUE.
      if(ngy_cp .GT. mxgy_cp) lfatal=.TRUE.
      if(ndrec_cp .GT. mxdrec_cp) lfatal=.TRUE.
      if(nctrec_cp .GT. mxctrec_cp) lfatal=.TRUE.
      if(nszout_cp(nf) .GT. mxsplv_cp) lfatal=.TRUE.
      nsrc_cp=0
      if(isrcinfox_cp(nf).EQ.1) then
         do k=1,8
            nsrc_cp=MAX(nsrc_cp,nstot_cp(k)+nstype(nf,k))
         enddo
      endif
      if(nsrc_cp .GT. mxsrc_cp) lfatal=.TRUE.

c  Set indicator for full sampling grid
      ifull_cp=0
      if(ngrec_cp .EQ. mxgrec_cp) ifull_cp=1

      if(LFATAL) then
c ---    Report problem information and quit
c ---    Screen (io6) and List File (io1):
c ---    Set for screen first
         iu=io6_cp
         do k=1,2
           write(iu,*)
           write(iu,100) msg0
           do i=1,8
              write(iu,100) msg(i)
           enddo
           write(iu,101)'  *     MXGX',mxgx_cp,ngx_cp
           write(iu,101)'  *     MXGY',mxgy_cp,ngy_cp
           write(iu,101)'  *   MXDREC',mxdrec_cp,ndrec_cp
           write(iu,101)'  *  MXCTREC',mxctrec_cp,nctrec_cp
           write(iu,101)'  *   MXSPLV',mxsplv_cp,nszout_cp(nf)
           write(iu,101)'  *    MXSRC',mxsrc_cp,nsrc_cp
           write(iu,100) msg0
c ---      Set for list file unit
           iu=io1
         enddo

         stop
      endif
c
c  Read title of run (record NCOM+4)
      read(io) atitle_cp
c
c  Read specie/level list (record NCOM+5)
      read(io) (asplst_cp(i,nf),i=1,nszout_cp(nf))

c --- Read units for each specie/level in list (record NCOM+5a)
c --- (introduced in Dataset 2.2)
      if(LSPUNIT) then
         read(io) (aspunit_cp(i,nf),i=1,nszout_cp(nf))
      else
         do i=1,nszout_cp(nf)
            aspunit_cp(i,nf)='NO_UNITS_IN_FILE'
         enddo
      endif
c
c  Read coordinates of non-gridded receptors if any are used
c  (record NCOM+6)
      if(ndrec_cp .NE. 0) read(io) (xrec_cp(i),i=1,ndrec_cp),
     *                          (yrec_cp(i),i=1,ndrec_cp),
     *                          (zrec_cp(i),i=1,ndrec_cp)
c
c  Read coordinates of complex terrain receptors if any are used
c  (record NCOM+7)
      if(nctrec_cp .NE. 0) read(io) (xctr_cp(i),i=1,nctrec_cp),
     *                           (yctr_cp(i),i=1,nctrec_cp),
     *                           (zctr_cp(i),i=1,nctrec_cp),
     *                           (ihill_cp(i),i=1,nctrec_cp)
c

c  Set logicals for receptor types in file
      ldisc_cp=.FALSE.
      lctsg_cp=.FALSE.
      if(ndrec_cp .GT. 0) ldisc_cp=.TRUE.
      if(nctrec_cp .GT. 0) lctsg_cp=.TRUE.

c --- Compute coordinates of gridded receptors when present
      if(LSGRID_cp .AND. ngrec_cp .NE. 0) then
c --- Coord. for lower-left point in sampling grid, and spacing
         gx0=xorigkm_cp+delx_cp*(isastr_cp-0.5)
         gy0=yorigkm_cp+dely_cp*(jsastr_cp-0.5)
         delgx=delx_cp/meshdn_cp
         delgy=dely_cp/meshdn_cp
c ---    Fill out arrays
         do i=1,ngx_cp
            do j=1,ngy_cp
               xgrd_cp(i,j)=gx0+(i-1)*delgx
               ygrd_cp(i,j)=gy0+(j-1)*delgy
            enddo
         enddo
      endif

c --- Dataset version 2.1 introduces source names
c --- HEADER RECORDs #NCOM+8 to 15 -- Source names
      if(isrcinfox_cp(nf).EQ.1) then
         lfatal=.FALSE.
c ---    Loop over source types (points,areas,lines,volumes)
         do k=1,8
            if(nstype(nf,k).GT.0 .AND. .NOT.LFATAL) then
               n1=nstot_cp(k)+1
               nstot_cp(k)=nstot_cp(k)+nstype(nf,k)
               read(io) ktype_cp,(csource_cp(n,k),n=n1,nstot_cp(k))
               if(ktype_cp.NE.k) lfatal=.TRUE.
            endif
         enddo
         if(LFATAL) then
c ---       Report problem information and quit
            write(ilog,*)
            write(ilog,*)
            write(ilog,100)'  *  Unexpected source type found, or     *'
            write(ilog,100)'  *  Unexpected source number found.      *'
            write(ilog,100)'  *  Number of sources expected:          *'
            write(ilog,101)'  *     NPTS',nstot_cp(1),nstot_cp(2)
            write(ilog,101)'  *   NAREAS',nstot_cp(3),nstot_cp(4)
            write(ilog,101)'  *   NLINES',nstot_cp(5),nstot_cp(6)
            write(ilog,101)'  *    NVOLS',nstot_cp(7),nstot_cp(8)
            write(ilog,100)'  *  Source Names Read:                   *'
            write(*,*)
            write(*,*)
            write(*,100)'  *  Unexpected source type found, or     *'
            write(*,100)'  *  Unexpected source number found.      *'
            write(*,100)'  *  Number of sources expected:          *'
            write(*,101)'  *     NPTS',nstot_cp(1),nstot_cp(2)
            write(*,101)'  *   NAREAS',nstot_cp(3),nstot_cp(4)
            write(*,101)'  *   NLINES',nstot_cp(5),nstot_cp(6)
            write(*,101)'  *    NVOLS',nstot_cp(7),nstot_cp(8)
            write(*,100)'  *  Source Names Read:                   *'
            do k=1,8
               do n=1,nstot_cp(k)
                  write(ilog,*)cstype(k),csource_cp(n,k)
                  write(*,*)cstype(k),csource_cp(n,k)
               enddo
            enddo
            stop
         endif
      endif
c
c  Compute number of averaging periods in file
      mnper_cp=mnrun_cp/mavgpd_cp
c
c  Determine length of averaging period found in model file
      if(MOD(nsecdt_cp,3600).EQ.0) then
c ---    Hours
         mavg_cp=mavgpd_cp*(nsecdt_cp/3600)
         avtime_cp='  HOUR'
      elseif(MOD(nsecdt_cp,60).EQ.0) then
c ---    Minutes
         mavg_cp=mavgpd_cp*(nsecdt_cp/60)
         avtime_cp='MINUTE'
      else
c ---    Seconds
         mavg_cp=mavgpd_cp*nsecdt_cp
         avtime_cp='SECOND'
      endif
c
c  Identify model output file used in application
      write(io1,*)
      write(io1,*)
      write(io1,*)
      write(io1,*) 'PROCESSED MODEL FILE ---------- Number ',nf
      write(io1,*)
      write(io1,*) amodel_cp,aver_cp,alev_cp
      write(io1,*)
      write(io1,*) atitle_cp(1)
      write(io1,*) atitle_cp(2)
      write(io1,*) atitle_cp(3)
      write(io1,*)
      write(io1,*) 'Averaging time for values reported from model:'
      write(io1,*) '     ',mavg_cp,' ',avtime_cp
      write(io1,*)
      write(io1,*) 'Number of averaging periods in file from model:'
      write(io1,*) '     ',mnper_cp
      write(io1,*)
      write(io1,*) 'Chemical species for each layer in model:'
      do i=1,nszout_cp(nf)
         write(io1,*) asplst_cp(i,nf), aspunit_cp(i,nf)
      enddo
      write(io1,*)
      write(io1,*) ' msyr,mjsday      =',msyr_cp,mjsday_cp
      write(io1,*) ' mshr,mssec       =',mshr_cp,mssec_cp
      write(io1,*) ' nsecdt (period)  =',nsecdt_cp
      write(io1,*) ' mnper,nszout,mavgpd =',mnper_cp,nszout_cp(nf),
     &                                      mavgpd_cp
      write(io1,*) ' xorigkm,yorigkm,nstas = ',xorigkm_cp,yorigkm_cp,
     &                                         nstas_cp
      write(io1,*) ' ielmet,jelmet =',ielmet_cp,jelmet_cp
      write(io1,*) ' delx,dely,nz =',delx_cp,dely_cp,nz_cp
      write(io1,*) ' iastar,iastop,jastar,jastop =',iastar_cp,iastop_cp,
     *                                             jastar_cp,jastop_cp
      write(io1,*) ' isastr,isastp,jsastr,jsastp =',isastr_cp,isastp_cp,
     *                                             jsastr_cp,jsastp_cp
      write(io1,*) ' (computed) ngx,ngy  =',ngx_cp,ngy_cp
      write(io1,*) ' meshdn,npts,nareas  =',meshdn_cp,npts_cp,nareas_cp
      write(io1,*) ' nlines,nvols        =',nlines_cp,nvols_cp
      write(io1,*) ' ndrec,nctrec,LSGRID =',ndrec_cp,nctrec_cp,LSGRID_cp
      if(ndrec_cp.GT.0 .AND. LDBG) then
         write(io1,*) ' '
         write(io1,*) 'Discrete Receptors (n,x,y,z):'
         do i=1,ndrec_cp
            write(io1,*) i,xrec_cp(i),yrec_cp(i),zrec_cp(i)
         enddo
      endif
      if(nctrec_cp.GT.0 .AND. LDBG) then
         write(io1,*) ' '
         write(io1,*) 'Complex Terrain Receptors (n,x,y,z,hill):'
         do i=1,nctrec_cp
            write(io1,*) i,xctr_cp(i),yctr_cp(i),zctr_cp(i),ihill_cp(i)
         enddo
      endif
      if(LVISIB .AND. LDBG) then
         write(io1,*) ' '
         write(io1,*) 'Surface Met Station UTMs (n,x,y):'
         do i=1,nstas_cp
            write(io1,*) i,xkmsta_cp(i),ykmsta_cp(i)
         enddo
      endif
      if(isrcinfo_cp.EQ.1) then
         write(io1,*) ' '
         write(io1,*) 'Source names stored (all files):'
         do k=1,8
            do n=1,nstot_cp(k)
               write(io1,*)'type: ',cstype(k),'-  ',csource_cp(n,k)
            enddo
         enddo
      endif
c
c  Set off data section from rest of output
      write(io1,*)
      write(io1,*)
      write(io1,*)


100   format(1x,a48)
101   format(1x,a12,2(8x,i8),'   *')

      return
      end

c----------------------------------------------------------------------
      subroutine getdoc_cp(io,ifil,ifilver,dataver)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090318        GETDOC
c                D. Strimaitis
c
c --- Adapted From:
c --- POSTUTIL Version: 1.57      Level: 040818                  GETDOC
c ---          D. Strimaitis,    Earth Tech, Inc.
c
c --- PURPOSE:  Read header comment records of the CALPUFF output
c               data file, and set file type.
c
c --- UPDATES:
c     V1.3(030402) to V1.4(040818)
c               (DGS) Add dataver to output arg list
c
c --- INPUTS:
c            io - integer    - Unit number for CALPUFF file
c          ifil - integer    - File number
c
c
c --- OUTPUT:
c       ifilver - integer    - Dataset version flag
c                              0: Before 2.0
c                              1: 2.0 or later
c       dataver - C*16       - Dataset version string
c
c     Common /CTRL/:
c           ncommout
c
c --- GETDOC called by:  
c --- GETDOC calls:      none
c----------------------------------------------------------------------
c --- Include parameters and commons
      include 'cpuff.ser'

c --- Local Variables
      character*16 dataset,dataset0,dataver,temp16
      character*33 blank33,break33
      character*64 datamod
      character*132 comment1,blank,break

      data blank33/'                                 '/
      data break33/'.................................'/

c --- Set blank (132 characters)
      blank(1:33)=blank33
      blank(34:66)=blank33
      blank(67:99)=blank33
      blank(100:132)=blank33

c --- Set break (132 characters)
      break(1:33)=break33
      break(34:66)=break33
      break(67:99)=break33
      break(100:132)=break33

c --- Read and test first record to check header format
c --- Record #1 - File Declaration -- 24 words
      read(io) dataset,dataver,datamod
      ifilver=0
      if(dataset.EQ.'CONC.DAT') then
         ifilver=1
      elseif(dataset.EQ.'DFLX.DAT') then
         ifilver=1
      elseif(dataset.EQ.'WFLX.DAT') then
         ifilver=1
      elseif(dataset.EQ.'VISB.DAT') then
         ifilver=1
      ELSEIF(dataset.EQ.'TK2D.DAT') then
         ifilver=1
      ELSEIF(dataset.EQ.'RHO2D.DAT') then
         ifilver=1
      endif

      if(ifilver.EQ.0) then
c ---    Old file format with no comment records
         dataver='0.0             '
         REWIND(io)
      elseif(ifilver.EQ.1) then
c ---    Number of comment records
         read(io) ncom
         do k=1,ncom
            comment1=blank
            read(io) comment1
         enddo
      endif

c --- Prepare dataver string for testing in calling program
      temp16='                '
      k=0
      do i=1,16
         if(dataver(i:i).NE.' ') then
            k=k+1
            temp16(k:k)=dataver(i:i)
         endif
      enddo
      dataver=temp16

      return
      end

c-----------------------------------------------------------------------
      subroutine getrcrd_cp(io,io1,tcg,tcd,tct,ix,iy,idrec,itrec,ieof)
c-----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090318    GETRCRD_CP
c                D. Strimaitis
c
c --- Adapted From:
c --- POSTUTIL  Version: 1.57            Level: 050311           GETRCRD
c ---           D. Strimaitis, SRC
c
c  PURPOSE:     Reads hourly data records from CALPUFF data file
c               and passes information to main program through
c               common /conc/ 
c
c  UPDATES:
c
c --- V1.41(050302)-V1.42(050311)
c               (DGS) Allow mix of Dataset 2.* formats
c
c --- V1.4(040818)-V1.41(050302)
c               (CEC) Change in the reading of VISB.DAT if LVISIB=TRUE
c                     to accomodate the changes in GETHDRH.
c                     rtrhd.utl has been added
c
c --- V1.3(030402)-V1.4(040818)
c               (DGS) Replace IPVER6(0,1) with IPTIME(1,2)
c                                 1: end-time (no seconds)
c                                 2: begin-time / end-time
c               (DGS) Implement CALPUFF dataset version 2.1 format with
c                     source information and individual source
c                     contributions
c               (DGS) Add time consistency checks
c     V1.1(000315) to V1.3(030402)
c               (DGS) add list-file unit to INCR, YR4
c     V1.1(990806) to V1.1(000315)
c               (DGS) add scaling option
c
c  ARGUMENTS:
c     PASSED:   io        Unit number for input data file            [i]
c               io1       Unit number for list output file           [i]
c               tcg(i,j)  Temporary gridded receptor array          [ra]
c               tcd(i)    Temporary discrete receptor array         [ra]
c               tct(i)    Temporary complex terrain receptor array  [ra]
c               ix,iy     Dimensions for tcg array                   [i]
c               idrec     Dimension for tcd array                    [i]
c               itrec     Dimension for tct array                    [i]
c               ieof      End of file flag (1=EOF encountered)       [i]
c
c  CALLING ROUTINES:    
c
c  EXTERNAL ROUTINES:   INCR, YR4 
c-----------------------------------------------------------------------
c --- Include parameters and commons
      INCLUDE 'cpuff.ser'
      include 'params.ser'

c --- Declare temporary variables using actual array dimensions
      character*15 tsplv
      real tcg(ix,iy),tcd(idrec),tct(itrec)

      integer inunit(mxfile_cp)
      real xwork1(mxgx_cp,mxgy_cp),xwork2(mxdrec_cp),xwork3(mxctrec_cp)

      logical ltotal,lfatal

      ieof=0
      nwords=ix*iy

c --- Set file number (nf) to 1 since this application does not
c --- combine species from multiple files
      nf=1
      inunit(nf)=io

c --- Initialize output arrays to zero,
      if(lsgrid_cp) then
         do k=1,nszout_cp(nf)
         do j=1,iy
         do i=1,ix
            concg_cp(i,j,k)=0.0
         enddo
         enddo
         enddo
      endif
      if(ldisc_cp) then
         do k=1,nszout_cp(nf)
         do i=1,idrec
            concd_cp(i,k)=0.0
         enddo
         enddo
      endif
      if(lctsg_cp) then
         do k=1,nszout_cp(nf)
         do i=1,itrec
            conct_cp(i,k)=0.0
         enddo
         enddo
      endif

c --- Top of loop over sources within file (when present)
5        continue

c ---    Read time record from CALPUFF data file
c ---    Note that time uses the 00-23 hour convention so that the 24th 
c ---    hour of day 12 has a start time of 23 on day 12 and an end
c ---    time of 00 on day 13
         if(iptimex_cp(nf).EQ.2) then
            read(inunit(nf),end=999) myrb_cp,mjdayb_cp,mhrb_cp,msecb_cp,
     &                               myre_cp,mjdaye_cp,mhre_cp,msece_cp
c ---       Enforce YYYY format for year
            call YR4(io1,myrb_cp,ierrb)
            call YR4(io1,myre_cp,ierre)
            if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in GETRCRD'
c ---       Set target date-time
            mdathrb=myrb_cp*100000+mjdayb_cp*100+mhrb_cp
            mdathre=myre_cp*100000+mjdaye_cp*100+mhre_cp
            if(nf.EQ.1) then
               mdathrb1=mdathrb
               mdathre1=mdathre
            else
c ---          QA time periods across files
               if(mdathrb.NE.mdathrb1 .OR. mdathre.NE.mdathre1) then
                  write(io1,*)'ERROR in GETRCRD for file ',nf
                  write(io1,*)'Period in file 1: ',mdathrb1,mdathre1
                  write(io1,*)'Period in file  : ',mdathrb,mdathre
                  stop
               endif
            endif
         else
            read(inunit(nf),end=999) myre_cp,mjdaye_cp,mhre_cp
            msece_cp=0
            msecb_cp=0
            myrb_cp=myre_cp
            mjdayb_cp=mjdaye_cp
            mhrb_cp=mhre_cp
            call INCR(io1,myrb_cp,mjdayb_cp,mhrb_cp,-1)
c ---       Enforce YYYY format for year
            call YR4(io1,myrb_cp,ierrb)
            call YR4(io1,myre_cp,ierre)
            if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in GETRCRD'
c ---       Set target date-time
            mdathrb=myrb_cp*100000+mjdayb_cp*100+mhrb_cp
            mdathre=myre_cp*100000+mjdaye_cp*100+mhre_cp
            if(nf.EQ.1) then
               mdathrb1=mdathrb
               mdathre1=mdathre
            else
c ---          QA time periods across files
               if(mdathrb.NE.mdathrb1 .OR. mdathre.NE.mdathre1) then
                  write(io1,*)'ERROR in GETRCRD for file ',nf
                  write(io1,*)'Period in file 1: ',mdathrb1,mdathre1
                  write(io1,*)'Period in file  : ',mdathrb,mdathre
                  stop
               endif
            endif
         endif

c ---    Source information record
         if(isrcinfox_cp(nf).EQ.1) then
            read(inunit(nf),end=999) mstype_cp,msnum_cp,sname_cp,
     &                               sxkm_cp,sykm_cp
            if(isrcindv_cp.EQ.0) then
c ---          Total of all sources should be in file
               ltotal=.TRUE.
               lfatal=.FALSE.
               if(sname_cp.NE.'TOTAL           ') lfatal=.TRUE.
               if(mstype_cp.NE.0) lfatal=.TRUE.
               if(msnum_cp.NE.1) lfatal=.TRUE.
               if(LFATAL) then
                  write(ilog,*)
                  write(ilog,*)
                  write(ilog,*)'ERROR in GETRCRD for file ',nf
                  write(ilog,*)'Unexpected source information'
                  write(ilog,*)'Expected: 0 1 TOTAL'
                  write(ilog,*)'Found   : ',mstype_cp,msnum_cp,sname_cp
                  write(*,*)
                  write(*,*)
                  write(*,*)'ERROR in GETRCRD for file ',nf
                  write(*,*)'Unexpected source information'
                  write(*,*)'Expected: 0 1 TOTAL'
                  write(*,*)'Found   : ',mstype_cp,msnum_cp,sname_cp
                  stop
               endif
            elseif(isrcindv_cp.EQ.1) then
c ---          Check for Total of all sources
               if(sname_cp.EQ.'TOTAL           ') then
                  ltotal=.TRUE.
               else
                  ltotal=.FALSE.
               endif
            endif
         else
c ---       No source information in file
            ltotal=.TRUE.
         endif

c ---    Read data and store species/level for output
c ---    Loop over chemical species/levels
         do isl=1,nszout_cp(nf)

            if(lsgrid_cp) then
               if(lcomprs_cp(nf))then
                  read(inunit(nf))ii
                  call uncomprs(xwork1,ii,inunit(nf),nwords,tsplv,tcg)
               else
                  read(inunit(nf)) tsplv,tcg
               endif
               if(LTOTAL) then
c ---             Pass to output array
                  do j=1,iy
                  do i=1,ix
                     concg_cp(i,j,isl)=tcg(i,j)+concg_cp(i,j,isl)
                  enddo
                  enddo
               endif
            endif

            if(ldisc_cp) then
               if(lcomprs_cp(nf))then
                  read(inunit(nf))ii
                  call uncomprs(xwork2,ii,inunit(nf),idrec,tsplv,tcd)
               else
                  read(inunit(nf)) tsplv,tcd
               endif
               if(LTOTAL) then
c ---             Pass to output array
                  do i=1,idrec
                     concd_cp(i,isl)=tcd(i)+concd_cp(i,isl)
                  enddo
               endif
            endif

            if(lctsg_cp) then
               if(lcomprs_cp(nf))then
                  read(inunit(nf))ii
                  call uncomprs(xwork3,ii,inunit(nf),itrec,tsplv,tct)
               else
                  read(inunit(nf)) tsplv,tct
               endif
               if(LTOTAL) then
c ---             Pass to output array
                  do i=1,itrec
                     conct_cp(i,isl)=tct(i)+conct_cp(i,isl)
                  enddo
               endif
            endif
         enddo

c --- Read the next set if results for all sources were not found
      if(.not.LTOTAL) goto 5


      return

c --- EOF encountered
999   ieof=1
      return

      end

c----------------------------------------------------------------------
      subroutine uncomprs(xwork,ii,io,nwords,clabel,xdat)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090318      UNCOMPRS
c                D. Strimaitis
c
c --- Adapted From:
c
c --- POSTUTIL   Version: 1.57     Level:  960422              UNCOMPRS
c                J. Scire, EARTH TECH
c
c --- PURPOSE:  Read a compressed data records and uncompress
c               the data
c
c --- INPUTS:
c        XWORK(nwork) - real array - Work array to temporarily store
c                                    compressed array
c                  II - integer    - Number of words in compressed
c                                    data record
c                  IO - integer    - Unit number of input file
c              NWORDS - integer    - Number of values in data array
c                                    after uncompression
c      PARAMETERS: ILOG
c
c --- OUTPUTS:
c              CLABEL - char*15    - Character record header
c        XDAT(nwords) - real array - Array of uncompressed data to be
c                                    output
c
c --- UNCOMPRS called by: MAIN
c --- UNCOMPRS calls:     none
c----------------------------------------------------------------------
c --- Include parameter statements
      include 'params.ser'
c
      real xwork(ii),xdat(nwords)
      character*15 clabel
c
c --- Read the compressed data record
      read(io)clabel,xwork
c
c --- Uncompress the data
      jj=0
      do 100 i=1,ii
      if(xwork(i).gt.0.0)then
         jj=jj+1
         xdat(jj)=xwork(i)
      else
         nzero=-xwork(i)
         do j=1,nzero
            jj=jj+1
            xdat(jj)=0.0
         enddo
      endif
100   continue
c
c --- QA check that expanded array is correct size
      if(jj.ne.nwords)then
         write(ilog,*)'ERROR in Subr. UNCOMPRS -- Expanded array ',
     1   'is not the correct size -- JJ = ',jj,' NWORDS = ',nwords
         stop
      endif
c
      return
      end

c----------------------------------------------------------------------
      subroutine getrec_cp(x,y,ix,iy,xr,yr,atype)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090318     GETREC_CP
c                D. Strimaitis
c
c --- PURPOSE:  Find the closest receptor to a specified (X,Y)
c               coordinate
c
c --- INPUTS:
c                X - real    - Target X coordinate (km)
c                Y - real    - Target Y coordinate (km)
c
c --- OUTPUT:
c               IX - integer - Easting receptor index (grid) or
c                              absolute receptor index (discrete)
c               IY - integer - Northing receptor index (grid)
c               XR - real    - Nearest X coordinate (km)
c               YR - real    - Nearest Y coordinate (km)
c            ATYPE - char*1  - Receptor type
c                              'G' = grided
c                              'D' = discrete
c                              'C' = CTSG
c
c --- GETREC_CP called by:  
c --- GETREC_CP calls:      none
c----------------------------------------------------------------------
c --- Include parameters and commons
      INCLUDE 'cpuff.ser'

      character*1 atype

      atype=' '
      ix=0
      iy=0
      xr=0.0
      yr=0.0
      dmin2=-10.

c --- Process gridded receptors (if any)
      if(lsgrid_cp) then
         if(dmin2.LT.-9.) then
c ---       Set first distance from (1,1)
            dmin2=(xgrd_cp(1,1)-x)**2+(ygrd_cp(1,1)-y)**2
         endif
         do j=1,ngy_cp
         do i=1,ngx_cp
            dist2=(xgrd_cp(i,j)-x)**2+(ygrd_cp(i,j)-y)**2
            if(dist2.LE.dmin2) then
               dmin2=dist2
               ix=i
               iy=j
               xr=xgrd_cp(i,j)
               yr=ygrd_cp(i,j)
               atype='G'
            endif
         enddo
         enddo
      endif

c --- Process discrete receptors (if any)
      if(ldisc_cp) then
         if(dmin2.LT.-9.) then
c ---       Set first distance from (1)
            dmin2=(xrec_cp(1)-x)**2+(yrec_cp(1)-y)**2
         endif
         do i=1,ndrec_cp
            dist2=(xrec_cp(i)-x)**2+(yrec_cp(i)-y)**2
            if(dist2.LE.dmin2) then
               dmin2=dist2
               ix=i
               iy=0
               xr=xrec_cp(i)
               yr=yrec_cp(i)
               atype='D'
            endif
         enddo
      endif

c --- Process CTSG receptors (if any)
      if(lctsg_cp) then
         if(dmin2.LT.-9.) then
c ---       Set first distance from (1)
            dmin2=(xctr_cp(1)-x)**2+(yctr_cp(1)-y)**2
         endif
         do i=1,nctrec_cp
            dist2=(xctr_cp(i)-x)**2+(yctr_cp(i)-y)**2
            if(dist2.LE.dmin2) then
               dmin2=dist2
               ix=i
               iy=0
               xr=xctr_cp(i)
               yr=yctr_cp(i)
               atype='C'
            endif
         enddo
      endif

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupcpf
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090318
c
c --- PURPOSE: Setup for CONC.DAT (CALPUFF output format)
c
c ---------------------------------------------------------------------
      include 'params.ser'
      include 'aqinput.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

      character*12 aunit2,specdb(3,mxspec)
      integer ipoll(mxspec)

c --- Molar Mass
      real xMdb(mxspec)

c --- Species info (control-file : CALPUFF name : CALPUFF Units)
      data specdb/'SO2         ','SO2         ','G/M3        ',
     1            'NO          ','NO          ','G/M3        ',
     2            'NO2         ','NO2         ','G/M3        ',
     3            'NOX         ','NOX         ','G/M3        ',
     4            'CO          ','CO          ','G/M3        ',
     5            'O3          ','O3          ','G/M3        ',
     6            'H2S         ','H2S         ','G/M3        ',
     7            'PM10        ','PM10        ','G/M3        ',
     8            'PM2.5       ','PM2_5       ','G/M3        '/

c --- Molecular weights for these species
      data xMdb/64.0,30.0,46.0,46.0,28.0,48.0,34.0,-1.0,-1.0/

c --- No profiling is done for AQ
      lnone=.TRUE.
      cprofile='NONE            '

c --- Initialization
      do i=1,mxspec
         rscalex(i)=1.0
         ipoll(i)=0
      enddo
      lso2(1)=.FALSE.
      lno(1)=.FALSE.
      lno2(1)=.FALSE.
      lnox(1)=.FALSE.
      lco(1)=.FALSE.
      lo3(1)=.FALSE.
      lh2s(1)=.FALSE.
      lpm10(1)=.FALSE.
      lpm25(1)=.FALSE.

c --- Each output file for 1 location
      nloc=ntsfout

c --- Assign AQ station location info, and turn off met output
      do i=1,nloc
         idloc(i)=idaq(i)
         xloc(i)=xaq(i)
         yloc(i)=yaq(i)
         lwind(i)=.FALSE.
      enddo

c --- Pollutant Concentration
      npoll=nspec
      write(ilog,*)
      write(ilog,*)'Number of pollutant species: ',npoll
      write(ilog,*)'Input Spec/Units, Output Spec/Units, Scale'
      do i=1,npoll
         do k=1,mxspec
            if(cfspec(i).EQ.specdb(1,k)) ipoll(i)=k
         enddo
         if(ipoll(i).EQ.0) then
            write(ilog,*) 'Invalid pollutant species name: ',cfspec(i)
            stop 'Halted in SETUPCPF:  see log file'
         endif
c ---    Assign species name used in input and output files
         cspeci(i)=specdb(2,ipoll(i))
         cspeco(i)=specdb(1,ipoll(i))
c ---    Choice of units for output concentrations
c ---    (g/m3; mg/m3; ug/m3; ng/m3; ppm; ppb )
         unitoutx(i)=ADJUSTL(cunito(i))
c ---    Compute scaling factor
         xM=xMdb(ipoll(i))
         aunit2=specdb(3,ipoll(i))
         call SCALE(ilog,unitoutx(i),aunit2,xM,rscalex(i))
         write(ilog,*)cspeci(i),aunit2,cspeco(i),unitoutx(i),rscalex(i)
      enddo
c --- Set logicals for identifying species (each station is same)
      do i=1,npoll
         if(specdb(1,ipoll(i)).EQ.'SO2         ') lso2(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'NO          ') lno(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'NO2         ') lno2(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'NOX         ') lnox(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'CO          ') lco(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'O3          ') lo3(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'H2S         ') lh2s(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'PM10        ') lpm10(1)=.TRUE.
         if(specdb(1,ipoll(i)).EQ.'PM2.5       ') lpm25(1)=.TRUE.
      enddo
c --- Distribute across stations
      do k=2,nloc
         lso2(k) =lso2(1)
         lno(k)  =lno(1)
         lno2(k) =lno2(1)
         lnox(k) =lnox(1)
         lco(k)  =lco(1)
         lo3(k)  =lo3(1)
         lh2s(k) =lh2s(1)
         lpm10(k)=lpm10(1)
         lpm25(k)=lpm25(1)
      enddo

      write(ilog,'(a)')'CALPUFF file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      subroutine cpfext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203        CPFEXT
c                D. Strimaitis
c
c --- PURPOSE: Extract time series of 1 or more species from CONC.DAT
c              file (CALPUFF output format)
c
c --- UPDATES:
c
c     V1.8 (110301) to V1.9.0 (121203)
c       - Add call to MIDNITE for selected time convention
c       - Add new variables for end-time output
c       - Restrict 24h to seconds=0000
c
c     V1.66 (090731) to V1.8 (110301)
c       - Add Dataset v2.2:  species have units
c         Demand that they be g/m3 (or g/m2/s?) until the rest of
c         the code is generalized
c
c --- Version 1.62, level 090411 to Version 1.66, level 090731
c   DGS - Fix error in GLOBE1 call placement introduced in 090411 to
c         convert nearest receptor location into user coordinate system
c
c --- Version 1.6, level 090318 to Version 1.62, level 090411
c   DGS - RNLON0C should be RELON0C.
c   CEC - Transform the Receptor extracted location to the user-requested
c         INPUT projection (xraq, yraq)
c
c --- INPUTS:
c
c --- OUTPUT:
c
c --- CPFEXT called by:  
c --- CPFEXT calls:      
c----------------------------------------------------------------------
      include 'params.ser'
      include 'aqinput.ser'
      include 'cpuff.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

      character*132 fl
      character*1 cm
      integer mpoll(mxspec)
      real cout(mxspec)

c --- For coordinate transformations
      character*8 cmapi,cmapo
      character*12 caction, cactionb
      character*4 c4hem
      real*8 vecti(9),vecto(9),vectib(9),vectob(9)

c --- Arrays used in GETRCRD
      real tcg(mxgx_cp,mxgy_cp),tcd(mxdrec_cp),tct(mxctrec_cp)

      data cm/','/

      idate0=ndateext
      isec0=nsecext
      write(ilog,*)'First date needed from CONC.DAT is: ',idate0,isec0
      write(*,*)'First date needed from CONC.DAT is: ',idate0,isec0

c --- Loop over files (sequential, so NF=1 for calls)
      nf=1
      ipd=0
      do 6000 ifile=1,naqinp

c ---    Skip remaining files if period has already been extracted
         if(ipd.GE.nbsecext) goto 6000

         fl=faq(ifile)
         nt=LEN_TRIM(fl)
         write(ilog,1008)ifile,fl(1:nt)
         print *,'Processing File:',ifile,' ',fl(1:nt)
 1008    format(i3,2x,(a))

         open(in,file=fl,status='old',form='unformatted',action='read')

c ---    Obtain header information
         call GETHEAD_CP(in,ilog,nf)

c ---    Trap time-zone difference
         izoneaq=NINT(xbtz_cp)
         call BASRUTC(xbtz_cp,azoneaq)
         if(izoneaq.NE.izonec) then
            write(ilog,*)
            write(ilog,*)' Error processing CALPUFF CONC.DAT file'
            write(ilog,*)'          Data are in time zone: ',azoneaq
            write(ilog,*)'     Extraction is in time zone: ',azonec
            write(ilog,*)' Times zones must match'
            stop 'Halted in CPFEXT --- See log file'
         endif
c ---    Set dimension of data arrays for declarations in SKIPREC, GETRCRD
         idimx=MAX(1,ngx_cp)
         idimy=MAX(1,ngy_cp)
         idimd=MAX(1,ndrec_cp)
         idimt=MAX(1,nctrec_cp)

c ---    Recast extraction locations into model projection
c ---    --------------------------------------------------
c ---    Set translation vectors going to model projection (x,y)km
c ---    Scale factor for Tangential TM projection
         tmsone=1.00000
c ---    Set input projection (control file)
            if(LNOMAP) then
c ---          Reset input map/datum to model system (from header)
c ---          Datum
               datumc=datum_cp
c ---          Map Projection
               pmapc=pmap_cp
               iutmznc=iutmzn_cp
               utmhemc=utmhem_cp
               rnlat1c=xlat1_cp
               rnlat2c=xlat2_cp
               rnlat0c=rnlat0_cp
               relon0c=relon0_cp
               feastc=feast_cp
               fnorthc=fnorth_cp
               call LLMAKE(ilog,'LON ',relon0c,clon0c)
               call LLMAKE(ilog,'LAT ',rnlat0c,clat0c)
               call LLMAKE(ilog,'LAT ',rnlat1c,clat1c)
               call LLMAKE(ilog,'LAT ',rnlat2c,clat2c)
c ---          Projection logicals
               lnomap=.FALSE.
               lgeo=.FALSE.
               lutm=.FALSE.
               llcc=.FALSE.
               lps=.FALSE.
               lem=.FALSE.
               llaza=.FALSE.
               lttm=.FALSE.
               if(pmapc.EQ.'NONE') then
                  lnomap=.TRUE.
               elseif(pmapc.EQ.'LL') then
                  lgeo=.TRUE.
               elseif(pmapc.EQ.'UTM') then
                  lutm=.TRUE.
               elseif(pmapc.EQ.'LCC') then
                  llcc=.TRUE.
               elseif(pmapc.EQ.'PS') then
                  lps=.TRUE.
               elseif(pmapc.EQ.'EM') then
                  lem=.TRUE.
               elseif(pmapc.EQ.'LAZA') then
                  llaza=.TRUE.
               elseif(pmapc.EQ.'TTM') then
                  lttm=.TRUE.
               endif
            endif
c ---    Condition input projection
         cmapi=pmapc
         if(cmapi.EQ.'TTM     ') cmapi='TM      '
         iutmi=iutmznc
         if(utmhemc.EQ.'S   ' .AND. iutmznc.LT.900) iutmi=-iutmi
c ---    Set output projection (model)
         iutmo=iutmzn_cp
         if(utmhem_cp.EQ.'S   ' .AND. iutmzn_cp.LT.900) iutmo=-iutmo
         cmapo=pmap_cp
         if(cmapo.EQ.'TTM     ') cmapo='TM      '

c ---    Set mapping TO model system
         call GLOBE1(cmapi,iutmi,tmsone,rnlat1c,rnlat2c,
     &               rnlat0c,relon0c,feastc,fnorthc,
     &               cmapo,iutmo,tmsone,xlat1_cp,xlat2_cp,
     &               rnlat0_cp,relon0_cp,feast_cp,fnorth_cp,
     &               caction,vecti,vecto)
c ---    Set mapping BACK FROM model system
         call GLOBE1(cmapo,iutmo,tmsone,xlat1_cp,xlat2_cp,
     &               rnlat0_cp,relon0_cp,feast_cp,fnorth_cp,
     &               cmapi,iutmi,tmsone,rnlat1c,rnlat2c,
     &               rnlat0c,relon0c,feastc,fnorthc,
     &               cactionb,vectib,vectob)

c ---    Convert extraction point locations
         do iloc=1,ntsfout
            call GLOBE(ilog,caction,datumc,vecti,datum_cp,vecto,
     &                 xaq(iloc),yaq(iloc),xloc(iloc),yloc(iloc),
     &                 idum,c4hem)

c ---       Find the nearest receptor location to extraction site
            call GETREC_CP(xloc(iloc),yloc(iloc),
     &                     ixloc(iloc),jyloc(iloc),
     &                     xrloc(iloc),yrloc(iloc),artype(iloc))

            write(ilog,1023)xrloc(iloc),cm,yrloc(iloc),
     &                      ixloc(iloc),cm,jyloc(iloc),cm,
     &                      artype(iloc),xaq(iloc),cm,yaq(iloc)
            print 1023,xrloc(iloc),cm,yrloc(iloc),
     &                      ixloc(iloc),cm,jyloc(iloc),cm,
     &                      artype(iloc),xaq(iloc),cm,yaq(iloc)
 1023       format(' CONC.DAT: Receptor (X,Y)km = (',f9.3,a1,f9.3,
     &             ') / (I,J) = (',i4,a1,i4,2a1,
     &             '); Requested: (XELON/YNLAT) = (',
     &             f9.3,a1,f9.3,')')

c --- (CEC - 090411 - Add the computation of the nearest receptor location in the INPUT projection)
c ---    Convert the nearest receptor location in CALPUFF projection to INPUT projection
            call GLOBE(ilog,cactionb,datum_cp,vectib,datumc,vectob,
     &                 xrloc(iloc),yrloc(iloc),xraq(iloc),yraq(iloc),
     &                 idum,c4hem)
         enddo

c ---    Write header for TSF output file(s)
         if(ifile.EQ.1) then
c ---       First data file processed -- top of output files
            do iloc=1,ntsfout
               io=iout+iloc
               call HDTSFOUT(io,iloc)
            enddo
         endif

c ---    Create species map for requested pollutants
         do ip=1,nspec
            mpoll(ip)=0
            do is=1,nszout_cp(nf)
               if(cspeci(ip).EQ.asplst_cp(is,nf)(1:12))mpoll(ip)=is
            enddo
         enddo
c ---    Check
         nbad=0
         write(ilog,*)
         write(ilog,*)'Species map for file '//fl(1:nt)
         do ip=1,nspec
            if(mpoll(ip).NE.0) then
               write(ilog,'(a)')cspeci(ip)//' from '//
     &                          asplst_cp(mpoll(ip),nf)(1:12)
            else
               write(ilog,'(a)')cspeci(ip)//' not found'
               nbad=nbad+1
            endif
         enddo
         if(nbad.GT.0) stop 'Halted in CPFEXT --- See log file'

c ---    Demand that the units for the selected species = g/m3
c ---    if units are in file
         nbad=0
         do ip=1,nspec
            iunitc=INDEX(aspunit_cp(mpoll(ip),nf),'g/m3')
            iunitf=INDEX(aspunit_cp(mpoll(ip),nf),'g/m2/s')
            inone=INDEX(aspunit_cp(mpoll(ip),nf),'NO_UNIT')
            itest=inone+iunitc+iunitf
            if(itest.EQ.0) then
               write(ilog,*)
               write(ilog,'(a)')'Invalid units for '//cspeci(ip)
               write(ilog,'(a)')'Expected g/m3 or g/m2/s'
               write(ilog,'(a)')'Found '//aspunit_cp(mpoll(ip),nf)
               nbad=nbad+1
            endif
         enddo
         if(nbad.GT.0) stop 'Halted in CPFEXT --- See log file'


c ---    Data records
c ----------------------------

c ---    Read array for 1 time period
 6200    call GETRCRD_CP(in,ilog,tcg,tcd,tct,idimx,idimy,
     &                   idimd,idimt,ieof)
         if(ieof.EQ.1) goto 6500

c ---    Create timestamps
         call GRDAY(ilog,myrb_cp,mjdayb_cp,imonb,idayb)
         call GRDAY(ilog,myre_cp,mjdaye_cp,imone,idaye)
         call TIMESTAMP(myrb_cp,mjdayb_cp,mhrb_cp,mdateb)
         call TIMESTAMP(myre_cp,mjdaye_cp,mhre_cp,mdatee)
c ---    Check begin-time with target
         call DELTSEC(mdateb,msecb_cp,idate0,isec0,ndelsec)
         if(ndelsec.GT.0) then
c ---       Start of current CONC.DAT period is earlier than target
            goto 6200
         elseif(ndelsec.LT.0) then
c ---       Start of current CONC.DAT period is later than target
            write(ilog,*)'ERROR - CONC.DAT period starts later' 
            write(ilog,*)'than date-time requested.'  
            write(ilog,*)'Period read from file starts:',mdateb,msecb_cp
            write(ilog,*)'        Target period starts:',idate0,isec0
            write(*,*)'ERROR - CONC.DAT period starts later' 
            write(*,*)'than date-time requested.'  
            write(*,*)'Period read from file starts:',mdateb,msecb_cp
            write(*,*)'        Target period starts:',idate0,isec0
            stop
         endif

c --- V1.9.0, Level 121203
c ---    Swap date and end-time into variables for output
         iyout=myre_cp
         imout=imone
         idout=idaye
         jdout=mjdaye_cp
         ihout=mhre_cp
c ---    Apply Midnight Convention to end-time
         if(imidnite.EQ.1 .AND. ihout.EQ.24) then
             ihout=0
             call MIDNITE(ilog,'TO 00h',myre_cp,imone,idaye,mjdaye_cp,
     &                                  iyout,imout,idout,jdout)
         elseif(imidnite.EQ.2 .AND. ihout.EQ.0
     &                        .AND. msece_cp.EQ.0) then
             ihout=24
             call MIDNITE(ilog,'TO 24h',myre_cp,imone,idaye,mjdaye_cp,
     &                                  iyout,imout,idout,jdout)
         endif

         ipd=ipd+1

c ---    Process output for each location
         do iloc=1,ntsfout
            io=iout+iloc

c ---       Select receptor type
            if(artype(iloc).EQ.'G') then
c ---          Select requested species and convert units
               do ip=1,nspec
                  is=mpoll(ip)
                  cout(ip)=concg_cp(ixloc(iloc),jyloc(iloc),is)*
     &                     rscalex(ip)
               enddo
            elseif(artype(iloc).EQ.'D') then
c ---          Select requested species and convert units
               do ip=1,nspec
                  is=mpoll(ip)
                  cout(ip)=concd_cp(ixloc(iloc),is)*rscalex(ip)
               enddo
            elseif(artype(iloc).EQ.'C') then
c ---          Select requested species and convert units
               do ip=1,nspec
                  is=mpoll(ip)
                  cout(ip)=conct_cp(ixloc(iloc),is)*rscalex(ip)
               enddo
            else
               write(ilog,*)'Error in CPFEXT:  bad receptor type'
               write(ilog,*)'Expected type :G,D, or C'
               write(ilog,*)'   Found type :',artype(iloc)
               stop 'Halted in CPFEXT --- See log file'
            endif

c ---       Write output records
c --- V1.9.0, Level 121203
            write(io,1010)myrb_cp,imonb,idayb,mhrb_cp,msecb_cp,
     &                    iyout,imout,idout,ihout,msece_cp,
     &                    (cout(k),k=1,nspec)

 1010 format(2(i5,3i3,1x,i4.4),20E12.5E2)

         enddo

c ---    Next time required
         call DEDAT(idate0,iyr0,jday0,ihr0)
         call INCRS(ilog,iyr0,jday0,ihr0,isec0,isecstep)
         call TIMESTAMP(iyr0,jday0,ihr0,idate0)

         if(ipd.LT.nbsecext) then
            goto 6200
         else
c ---       Done
            close(in)
            goto 7000
         endif

 6500    close(in)

 6000 continue

 7000 if(ipd.LT.nbsecext) then
         write(ilog,*)'Error: Not all periods were extracted'
         write(ilog,*)'Periods Extracted: ',ipd
         write(ilog,*)'Periods Needed: ',nbsecext
         print *,'Error: Not all periods were extracted'
         print *,'Periods Extracted: ',ipd
         print *,'Periods Needed: ',nbsecext
      else
         write(ilog,'(a)')'CONC.DAT data extraction completed'
      endif
     
      return
      end

c----------------------------------------------------------------------
      subroutine llmake(io,type,rlatlon,clatlon)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731        LLMAKE
c                D. Strimaitis
c
c --- PURPOSE:  Extract the real latitude or longitude from a character
c               string that contains the N/S or E/W convention
c               character, and express result as either North Latitude
c               or East Longitude
c
c --- UPDATES:
c
c --- Version 1.6, Level: 090318 to Version 1.66, Level 090731 (DGS)
c         - Hemisphere assignments for N, E, and W need to be 6
c           characters to fill slots 11:16
c
c
c --- INPUTS:
c               IO - integer    - Unit number for list file output
c             TYPE - char*4     - LAT or LON
c          RLATLON - real       - North Latitude or East Longitude
c                                 (degrees)
c
c --- OUTPUT:
c          CLATLON - char*16    - Latitude or longitude (degrees), with
c                                 1 character that denotes convention
c                                 (e.g. 'N  45.222' or  '35.999S')
c
c --- LLMAKE called by: (utility)
c --- LLMAKE calls:     none
c----------------------------------------------------------------------

      character*16 clatlon
      character*4 type

c --- Was valid type provided?
      if(type.NE.'LAT ' .AND. type.NE.'LON ') then
         write(io,*) 'LLMAKE:  FATAL ERROR reported when ',
     &               'making Latitude/Longitude'
         write(io,*) 'Invalid type:  ',type
         write(io,*) 'Expected LAT or LON'
         write(*,*)
         stop 'Halted in LLMAKE -- see list file'
      endif

c --- Determine character
      if(type.EQ.'LAT ') then
         if(rlatlon.LT.0.0) then
            val=-rlatlon
            clatlon(11:16)='S     '
         else
            val=rlatlon
            clatlon(11:16)='N     '
         endif
c ---    Check range
         if(val.GT.90.0) then
            write(io,*) 'LLMAKE:  FATAL ERROR reported when ',
     &                  'making Latitude/Longitude'
            write(io,*) 'Invalid value:  ',val
            write(io,*) 'Expected LAT range 0-90 deg'
            write(*,*)
            stop 'Halted in LLMAKE -- see list file'
         endif
      endif
      if(type.EQ.'LON ') then
         if(rlatlon.LT.0.0) then
            val=-rlatlon
            clatlon(11:16)='W     '
         else
            val=rlatlon
            clatlon(11:16)='E     '
         endif
c ---    Check range
         if(val.GT.360.0) then
            write(io,*) 'LLMAKE:  FATAL ERROR reported when ',
     &                  'making Latitude/Longitude'
            write(io,*) 'Invalid value:  ',val
            write(io,*) 'Expected LON range 0-360 deg'
            write(*,*)
            stop 'Halted in LLMAKE -- see list file'
         endif
      endif

c --- Create string for output
      write(clatlon(1:10),'(f10.6)') val
      clatlon=ADJUSTL(clatlon)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupm2d
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Francoise Robe           
c
c --- PURPOSE: Setup for 2D.DAT
c
c --- UPDATES:
c
c --- Version 1.65, Level: 090526 to Version 1.66, Level: 090731 (DGS)
c        - Remove NLAND, BUFF, IDLAT, and CPROF16 (not used)
c        - Set and QA OTHER selection required for M2D
c        
c ---------------------------------------------------------------------

C     Setup for MM5-2D.DAT format

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- All data in 2D.DAT files are in GMT (UTC+0000)
      izonemet=0
      azonemet='UTC+0000'

c --- No profile method for 2D.DAT (all surface data)

c --- Not used for MM53D files. They are read in from MM53D files
      xsw=xycell1(1)
      ysw=xycell1(2)
      dxm=dxycell(1)
      dym=dxycell(2)

c --- Set location type
c --- Assume x,y
      ifrmt=1
c --- Unless projection is lat/lon
      if(LGEO) ifrmt=2
c --- Or, unless user selects cell i,j
      if(mcell.EQ.1) ifrmt=3

c --- Each output file for 1 location
      nloc=ntsfout

c --- Station location (X/Y, LON/LAT, I/J)
      do i=1,nloc
         xloc(i)=xmet(i)
         yloc(i)=ymet(i)

c ---    Set logicals for output variables
         lother(i)=.TRUE.
         if(zother(i).LT.0.0) then
            lother(i)=.FALSE.
            write(ilog,*)'Require "OTHER" with 2D.DAT - STOP'
            print *,'Require "OTHER" with 2D.DAT - STOP'
            stop 
         endif

c ---    Check logicals for output variables (only lothers ok
         lwind(i)=.FALSE.
         lshum(i)=.FALSE.
         ltmpk(i)=.FALSE.
         if((zwind(i).GE.0.0) .or. 
     :      (ztmpk(i).GE.0.0) .or.
     :      (zshum(i).GE.0.0) )then
             write(ilog,*)'Only "OTHER" with 2D.DAT - STOP'
             write(ilog,*)'zwind, ztmpk, and zshum must be < 0'
             print *,'Only "OTHER" with 2D.DAT - STOP'
             stop 
          endif
      end do
      write(ilog,'(a)')'M2D file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      subroutine m2dext
c ---------------------------------------------------------------------
c 
c --- METSERIES  Version: 1.9.0         Level: 121203        M2DEXT
c --- Francoise Robe (based on MM5EXT, by Zhong Wu)          
c
c --- PURPOSE: Extract time series from 2D.DAT 
c              Data include all 2D variables in 2D.DAT file
c
c --- UPDATES:
c
c --- Version 1.7, Level 090818 to Version 1.9.0, Level 121203
c         - Add call to MIDNITE for selected time convention
c         - Move MX2D to PARAMS.SER
c         - Add check for N2DVAR > MX2D
c         - Add new variables for end-time output
c         - Restrict 24h to seconds=0000
c         - Modified to process WRF/MM5 2D files
c
c --- Version 1.66, Level 090731 to Version 1.7, Level 090818
c       1.  Extract all variables to TSF file
c       2.  Add list of flags to METSERIES.SER (pass in common)
c       3.  Convert output U,V to WS,WD
c
c --- Version 1.65, Level 090526 to Version 1.66, Level 090731
c       1.  Update calls to INTERPH* subs with METSIMC flag
c       2.  Remove print statement for I,J input option that
c           included a bad format reference, and initialize
c           seconds to zero
c       3.  Revise location reported with nearest grid cell option
c       4.  Remove BUFF3, CKEY, CKEYS (not used)
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'
      include 'map.ser'

c --- V1.9.0, Level 121203
      parameter (nvar_out=8, iecho=0)

      dimension idvar(nvar_out)

      dimension x2d(mxnx,mxny,mx2d)
      dimension x2dintp(4,mx2d),x2dfin(mx2d)

      dimension icell(4),jcell(4)
      dimension i1exts(mxloc),i2exts(mxloc),j1exts(mxloc),j2exts(mxloc)
      dimension ngrds(mxloc)
      dimension wgts(4,mxloc)

      character*132 fl
      character*80 frmt
      character*64 datamod
      character*132 buff1,buff2 
c      character*12 ckeys(1),ckey
      character*8 avar8
      character*4 cmap

      character*8 cmapi,cmapo
      character*12 caction, cactionb
      character*4 c4hem
      real*8 vecti(9),vecto(9), vectib(9),vectob(9)

c      data ckeys/'2D.DAT'/

      data iseven/10000000/
      data factor/57.2957795/

c --- Set the local i,j steps that define the 4 corners of a cell
c --- associated the the weighting arrays
      data icell/0,1,0,1/
      data jcell/0,0,1,1/

c
c     Note: Time in MM5 data is GMT, while it is LST (or user input)
c           in output time series
c 
c     Convert ndateext from LST (or User input time) to GMT
      call DEDAT(ndateext,iyr,jday,ihour)
      call INCR(ilog,iyr,jday,ihour,izonec)
      call TIMESTAMP(iyr,jday,ihour,ndateext)
      call GRDAY(ilog,iyr,jday,imon,iday)

c --- V1.9.0, Level 121203
      fl=fmet(1)
      call scan2d(ilog,fl,n2dvar,vnames,mx2d,iwind,id_ws
     &     ,i2d_type,id_rain,id_rainc,id_rainnc,i2dout_pos
     &     ,n2dout,c2dout_mm5,c2dout_wrf,c2dout)

      write(ilog,181)n2dvar
 181  format(' 2D Variables included:',i4)
      do ivar=1,n2dvar
         write(ilog,182)ivar,vnames(ivar)
 182     format('2D-Var: ',i2.2,2x,a8)
      enddo

      if(iwind.gt.0) then
         write(ilog,183)iwind,vnames(iwind),id_ws
      else
         write(ilog,184)iwind
      endif
 183  format('Position ',i4,' is ',a8,2x,i4)
 184  format('Wind not exist in 2D',i4)

      do k=1,n2dout
         write(ilog,*)k,' ',i2dout_pos(k),' ',trim(c2dout(k))
      enddo

c --- Loop over files
      ihr=0

      do 6000 ifile=1,nmetinp

c --- V1.9.0, Level 121203
c ---    Skip remaining files if period has already been extracted
         if(ihr.gt.nbsecext) goto 6000

         fl=fmet(ifile)
         open(in,file=fl,status='old',action='read')

c ---    Read header information from 2D
c --------------------------------------
c --- Read first two records to determine file format 
c --- ivs3 = 2 for 2D.DAT file structure, Version 2.1
         ivs3=-999
         ncomm=-999
         read(in,101,end=6500)buff1
         read(in,101,end=6500)buff2

          if(buff1(1:6).eq.'2D.DAT')then
            read(buff2,*,err=1000)ncomm
	    if(ncomm.ge.1) ivs3=2
          endif

 101     format(a)

1000     continue

         if(ivs3.eq.2) then  ! V2.1 formats
            read(buff1,1119,end=6500)cset3d,cver,datamod
 1119       format(2(a12,4x),a64)
            do i=1,ncomm
               read(in,*)
            enddo
         else
            write(ilog,*)'2D.DAT Format not set-ivs3/ncomm:',ivs3,ncomm
            write(ilog,*)'Expecting 2D.DAT Version 2.1 - STOP'
            print *,'2D.DAT Format not recognized - STOP'
            stop
         endif

c        Record #3
         read(in,1011)ioutw,ioutq,ioutc,iouti,ioutg,iosrf
 1011       format(6i3)
c        Record #4
         read(in,1113)cmap,rlatc,rlonc,truelat1,truelat2,
     &           xsw,ysw,dxm,nx,ny,nz
 1113    format(a4,f9.4,f10.4,2f7.2,2f10.3,f8.3,2i4,i3)

         dym=dxm

c        Record #5 - physical options
         read(in,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &           ifddaan,ifddaob,igrdt,ipbl,ishf,ilhf,iustr,iswdn,
     &           ilwdn,it2,iq2,iu10,iv10,isst,ist6
 1061       format (30i3)

c --- V1.9.0, Level 121203
        if(i2d_type.eq.2) then
            igrdt=1
            ipbl=1
            iustr=1
            iswdn=1
            ilwdn=1
            it2=1
            iq2=1
            iu10=1
            iv10=1
            isst=1
         endif

c        Record #6 - Extracted domain Stamp 1
         read(in,1115)idatebeg,nhours,nxsub,nysub,nzsub
 1115    format(i10,i5,3i4)

c        header record #7: - Extracted domain Stamp 2 (output later
         read(in,1116)nx1,ny1,nx2,ny2,nz1,nz2,
     &           rxmin,rxmax,rymin,rymax
 1116    format(6i4,2f10.4,2f9.4)

         nz=nzsub   ! only nzsub layers in data
         if(nz.ne.(nz2-nz1+1)) then
            write(ilog,*)'Error in vertical layers:'
            write(ilog,*)nzsub,nz1,nz2
            print *,'Error in vertical layers:'
            print *,nzsub,nz1,nz2
            stop
         endif

C        Echo to log file and eliminate compiling message for LF77
         if(iecho.eq.1) then
           write(ilog,1119)cset3d,cver,clev

           write(ilog,1011)ioutw,ioutq,ioutc,iouti,ioutg,iosrf
           write(ilog,1113)cmap,rlatc,rlonc,truelat1,truelat2,
     &             xsw,ysw,dxm,nx,ny,nz
           write(ilog,1061)inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &             ifddaan,ifddaob,igrdt,ipbl,ishf,ilhf,iustr,iswdn,
     &             ilwdn,it2,iq2,iu10,iv10,isst,ist6
           write(ilog,1115)idatebeg,nhours,nxsub,nysub,nzsub
           write(ilog,1116)nx1,ny1,nx2,ny2,nz1,nz2,
     &             rxmin,rxmax,rymin,rymax
         endif

c ---    Recast idatebeg from YYYYMMDDHH to YYYYJJHH
         call GETDATE(idatebeg,kyr,kmon,kday,khour)
         call JULDAY(ilog,kyr,kmon,kday,kjul)
         call TIMESTAMP(kyr,kjul,khour,idatebeg)

c        Convert YYYY date format in ndateext to YY format if idatebeg 
c              in YY format. 
         if(idatebeg.lt.iseven .and. ifile.eq.1) then
            nn=ndateext/iseven
            ndateext=ndateext-nn*iseven
         endif

         if(ihr.eq.0) idate0=ndateext

c        Sigma levels
         do i=1,nz
            read(in,1064)sigma
            if(iecho.eq.1) write(ilog,1064)sigma
 1064       format(f6.3)	       
         enddo

c        Lat/long locations
         do j=ny1,ny2           
            do i=nx1,nx2
               if(ivs3.eq.0) then
                  read(in,1065)ii,jj,flat,flong,ihh,iland,
     &                 flatcrs,flongcrs
 1065             format(2i3,f7.3,f8.3,i5,i3,1x,f7.3,f8.3)
               else
                  read(in,1165)ii,jj,flat,flong,ihh,iland,
     &                 flatcrs,flongcrs
 1165             format(2i4,f9.4,f10.4,i5,i3,1x,f9.4,f10.4)
               endif
               if(ifile.eq.1) then
                  ielev(i,j)=ihh
                  land(i,j)=iland
               endif
               if(iecho.eq.1) write(ilog,1165)ii,jj,flat,flong
     &            ,ihh,iland,flatcrs,flongcrs
            Enddo
         enddo

         if(ifile.ne.1) goto 6100

c        Get input data format

         call getfmt(ioutw,ioutq,ioutc,iouti,ioutg,idvar,frmt,nvar)

c        Check domain info
         if(dxm.le.0) then
            write(ilog,*)'No grid config info in 2D.DAT file'
            print *,'No grid config info in 2D.DAT file'
            if(ifrmt.ne.3) then
               write(ilog,*)'Error in site location format:',ifrmt
               write(ilog,*)'Site location must be set in I/J format'
               print *,'Error in site location format:',ifrmt
               print *,'Site location must be set in I/J format'
               stop
            endif
         endif

         x1dom=xsw+(nx1-1)*dxm
         x2dom=xsw+(nx2-1)*dxm
         y1dom=ysw+(ny1-1)*dym
         y2dom=ysw+(ny2-1)*dym

         Write(ilog,*)'Model Domain:',x1dom,x2dom,y1dom,y2dom

c ---    Set translation vectors going to M2D projection (x,y)km
c ---    Scale factor for Tangential TM projection
         tmsone=1.00000
c ---    Set projection from M2D header
         iutmo=iutmzn
         if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
         cmapo='        '
         cmapo(1:4)=cmap
         if(cmap.eq.'LCC ' .or. cmap.eq.'lcc ' .or.
     &      cmap.eq.'LLC ' .or. cmap.eq.'llc ' .or.
     &      cmap.eq.'LC  ') then
            cmapo='LCC     '
         elseif(cmap.eq.'PST ' .or. cmap.eq.'pst ') then
            cmapo='PS      '
         elseif(cmap.eq.'EM  ' .or. cmap.eq.'em  ') then
            cmapo='EM      '
         endif
         if(cmapo.EQ.'TTM     ') cmapo='TM      '

c ---    Reset output map and datum to model map and datum if the
c ---    map requested is NONE, or if the location is provided as
c ---    a cell index
         if(ifrmt.EQ.3 .OR. LNOMAP) then
c ---       Reset input map/datum to model system (from header)
c ---       Datum
            datumc=datum3d
c ---       Map Projection
            pmapc=cmapo
            iutmznc=iutmzn
            utmhemc=utmhem
            rnlat1c=truelat1
            rnlat2c=truelat2
            rnlat0c=rlatc
            relon0c=rlonc
            feastc=feast
            fnorthc=fnorth
            call LLMAKE(ilog,'LON ',relon0c,clon0c)
            call LLMAKE(ilog,'LAT ',rnlat0c,clat0c)
            call LLMAKE(ilog,'LAT ',rnlat1c,clat1c)
            call LLMAKE(ilog,'LAT ',rnlat2c,clat2c)
c ---       Projection logicals
            lnomap=.FALSE.
            lgeo=.FALSE.
            lutm=.FALSE.
            llcc=.FALSE.
            lps=.FALSE.
            lem=.FALSE.
            llaza=.FALSE.
            lttm=.FALSE.
            if(pmapc.EQ.'NONE') then
               lnomap=.TRUE.
            elseif(pmapc.EQ.'LL') then
               lgeo=.TRUE.
            elseif(pmapc.EQ.'UTM') then
               lutm=.TRUE.
            elseif(pmapc.EQ.'LCC') then
               llcc=.TRUE.
            elseif(pmapc.EQ.'PS') then
               lps=.TRUE.
            elseif(pmapc.EQ.'EM') then
               lem=.TRUE.
            elseif(pmapc.EQ.'LAZA') then
               llaza=.TRUE.
            elseif(pmapc.EQ.'TTM') then
               lttm=.TRUE.
            endif
         endif

c ---    Condition input projection
         cmapi=pmapc
         if(cmapi.EQ.'TTM     ') cmapi='TM      '
         iutmi=iutmznc
         if(utmhemc.EQ.'S   ' .AND. iutmznc.LT.900) iutmi=-iutmi

c ---    Set forward-transformation to M2D projection
         call GLOBE1(cmapi,iutmi,tmsone,rnlat1c,rnlat2c,
     &               rnlat0c,relon0c,feastc,fnorthc,
     &               cmapo,iutmo,tmsone,truelat1,truelat2,
     &               rlatc,rlonc,feast,fnorth,
     &               caction,vecti,vecto)

c ---    Set back-transformation from M2D projection
         call GLOBE1(cmapo,iutmo,tmsone,truelat1,truelat2,
     &               rlatc,rlonc,feast,fnorth,
     &               cmapi,iutmi,tmsone,rnlat1c,rnlat2c,
     &               rnlat0c,relon0c,feastc,fnorthc,
     &               cactionb,vectib,vectob)

         if(ifrmt.EQ.3) then
c ---       Cell ri/rj format for site locations
c ---       ------------------------------------
c ---       Identify surrounding points and compute weights directly
            do iloc=1,ntsfout
               fnx=xloc(iloc)
               fny=yloc(iloc)
               knx=int(fnx)
               kny=int(fny)

               if(fnx.lt.nx1 .or. fnx.gt.nx2 .or.
     &            fny.lt.ny1 .or. fny.gt.ny2) then
                  print *,'Site outside of data domain:',fnx,fny
                  print *,'nx1/nx2,ny1/ny2:',nx1,nx2,ny1,ny2
                  write(ilog,*)'Site outside of data domain:',fnx,fny
                  write(ilog,*)'nx1/nx2,ny1/ny2:',nx1,nx2,ny1,ny2
                  stop
               endif

               if(knx.lt.nx2.and.kny.lt.ny2) then
               i1exts(iloc)=knx
               i2exts(iloc)=knx+1
               j1exts(iloc)=kny
               j2exts(iloc)=kny+1

               wgts(1,iloc)=1-(fnx-knx)
               wgts(2,iloc)=fnx-knx
               wgts(3,iloc)=1-(fny-kny)
               wgts(4,iloc)=fny-kny
              
               elseif(knx.eq.nx2.and.kny.lt.ny2) then
               i1exts(iloc)=knx-1
               i2exts(iloc)=knx
               j1exts(iloc)=kny
               j2exts(iloc)=kny+1

               wgts(1,iloc)=0
               wgts(2,iloc)=1.
               wgts(3,iloc)=1-(fny-kny)
               wgts(4,iloc)=fny-kny
              
               elseif(knx.lt.nx2.and.kny.eq.ny2) then
               i1exts(iloc)=knx
               i2exts(iloc)=knx+1
               j1exts(iloc)=kny-1
               j2exts(iloc)=kny

               wgts(1,iloc)=1-(fnx-knx)
               wgts(2,iloc)=fnx-knx
               wgts(3,iloc)=0
               wgts(4,iloc)=1.

               elseif(knx.eq.nx2.and.kny.eq.ny2) then
               i1exts(iloc)=knx-1
               i2exts(iloc)=knx
               j1exts(iloc)=kny-1
               j2exts(iloc)=kny

               wgts(1,iloc)=0
               wgts(2,iloc)=1.
               wgts(3,iloc)=0
               wgts(4,iloc)=1.
               endif

               write(ilog,301)iloc,fnx,fny,(wgts(j,iloc),j=1,4)
 301           format(' Site/Wgt: ',i5,6f8.3)

               io=iout+iloc

               if(metsimc.EQ.2) then
c ---             I,J used for nearest grid cell option
                  call INEAREST(icell,wgts(1,iloc),ii)
                  call INEAREST(jcell,wgts(1,iloc),jj)
                  ii=knx+ii
                  jj=kny+jj
c ---             Save location requested by user
                  xuloc(iloc)=xloc(iloc)
                  yuloc(iloc)=yloc(iloc)
c ---             New location (nearest grid point)
                  xloc(iloc)=FLOAT(ii)
                  yloc(iloc)=FLOAT(jj)
                  write(ilog,1022) xloc(iloc),yloc(iloc)
               else
c ---             I,J used for interpolation
                  write(ilog,1022)fnx,fny
c                 print 1022,INT(fnx),INT(fny),zwind(iloc),ztmpk(iloc),
c     &                    zshum(iloc)
               endif

c ---          Set model (x,y)km into stored met coordinates
               xmet(iloc)=xsw+dxm*(xloc(iloc)-1.)
               ymet(iloc)=ysw+dym*(yloc(iloc)-1.)

 1022          format('2D.DAT:  (I,J) = (',f7.2,',',f7.2,')')
            enddo

         elseif(ifrmt.LE.2) then
c ---       X/Y or Lon/Lat format for site locations
c ---       ----------------------------------------
c ---       Convert extraction locations to model x,y system
            do iloc=1,ntsfout
               xin=xloc(iloc)
               yin=yloc(iloc)
               call GLOBE(ilog,caction,datumc,vecti,datum3d,vecto,
     &                    xin,yin,xext,yext,idum,c4hem)
               xloc(iloc)=xext
               yloc(iloc)=yext

               write(ilog,1023)xext,yext,xin,yin
 1023          format('2D.DAT:  (X,Y) = (',f9.3,'km,',f9.3,
     &                'km);  (XLON/YLAT) = (',f7.3,',',f9.3,')')
 1053          format(' 2D.DAT - [X/Y: ',2(f9.3,'km'),'] [XLON/YLAT: '
     &                ,f7.3,f9.3,'] [Z: ',3f8.3,' m]')

               io=iout+iloc

c ---          Test location
               if(xext.lt.x1dom .or. xext.gt.x2dom) then
                  write(ilog,1066)xext,x1dom,x2dom
                  write(*,*)xext,x1dom,x2dom
 1066             format('Extraction site out of domain - X:',3f12.3)
                  stop 'HALTED: See error message in list file'
               endif
               if(yext.lt.y1dom .or. yext.gt.y2dom) then
                  write(ilog,1067)yext,y1dom,y2dom
                  write(*,1067)yext,y1dom,y2dom
 1067             format('Extraction site out of domain - Y:',3f12.3)
                  stop 'HALTED: See error message in list file'
               endif
         
c ---          Find the nearest 4 grids for extraction site
               sdx=xext-xsw
               sdy=yext-ysw

               fnx=sdx/dxm+1
               fny=sdy/dym+1
               knx=int(fnx)
               kny=int(fny)

               if(knx.lt.nx2.and.kny.lt.ny2) then
               i1exts(iloc)=knx
               i2exts(iloc)=knx+1
               j1exts(iloc)=kny
               j2exts(iloc)=kny+1

               wgts(1,iloc)=1-(fnx-knx)
               wgts(2,iloc)=fnx-knx
               wgts(3,iloc)=1-(fny-kny)
               wgts(4,iloc)=fny-kny
              
               elseif(knx.eq.nx2.and.kny.lt.ny2) then
               i1exts(iloc)=knx-1
               i2exts(iloc)=knx
               j1exts(iloc)=kny
               j2exts(iloc)=kny+1

               wgts(1,iloc)=0
               wgts(2,iloc)=1.
               wgts(3,iloc)=1-(fny-kny)
               wgts(4,iloc)=fny-kny
              
               elseif(knx.lt.nx2.and.kny.eq.ny2) then
               i1exts(iloc)=knx
               i2exts(iloc)=knx+1
               j1exts(iloc)=kny-1
               j2exts(iloc)=kny

               wgts(1,iloc)=1-(fnx-knx)
               wgts(2,iloc)=fnx-knx
               wgts(3,iloc)=0
               wgts(4,iloc)=1.

               elseif(knx.eq.nx2.and.kny.eq.ny2) then
               i1exts(iloc)=knx-1
               i2exts(iloc)=knx
               j1exts(iloc)=kny-1
               j2exts(iloc)=kny

               wgts(1,iloc)=0
               wgts(2,iloc)=1.
               wgts(3,iloc)=0
               wgts(4,iloc)=1.
               endif

               write(ilog,301)iloc,fnx,fny,(wgts(j,iloc),j=1,4)

               if(metsimc.EQ.2) then
c ---             Nearest grid cell option
                  call INEAREST(icell,wgts(1,iloc),ii)
                  call INEAREST(jcell,wgts(1,iloc),jj)
                  ii=knx+ii
                  jj=kny+jj
c ---             Save location requested by user
                  xuloc(iloc)=xin
                  yuloc(iloc)=yin
c ---             New location (nearest grid point)
                  xloc(iloc)=xsw+dxm*(ii-1)
                  yloc(iloc)=ysw+dym*(jj-1)
c ---             Transform from M2D projection
                  call GLOBE(ilog,cactionb,datum3d,vectib,datumc,vectob,
     &                       xloc(iloc),yloc(iloc),xin2,yin2,idum,c4hem)
                  xmet(iloc)=xin2
                  ymet(iloc)=yin2

                  write(ilog,*)'Modified for Nearest Grid Point:'
                  write(ilog,1023)xloc(iloc),yloc(iloc),xin2,yin2
               endif

            enddo
         endif
 6100    continue

c --- V1.9.0, Level 121203
c ---    Check array size for the number of 2D variables
         if(n2dvar.GT.mx2d) then
            write(ilog,*) 'M2DEXT: Too many 2D variables found in file'
            write(ilog,*) 'File = '//fl
            write(ilog,*) 'Number found = ',n2dvar
            write(ilog,*) 'MX2D limit   = ',mx2d
            write(ilog,*) 'Increase MX2D in PARAMS.SER and recompile'
            stop 'Halted in M2DEXT -- see list file'
         endif

         if(ifile.EQ.1) then
c ---       First data file processed -- top of output files
            do iloc=1,ntsfout
               io=iout+iloc
               call HDTSFOUT(io,iloc)
            enddo
         endif

c ---    Data records
c -------------------
         write(*,*)

 6200    do iloc=1,ntsfout
            ngrds(iloc)=0
         enddo


10      continue

c ---   Read all 2D fields for 1 time period
        do k=1,n2dvar
           isec=0
           read(in,'(i4,3i2,2x,a8)',end=6500)iyr,imon,iday,ihour,
     &                                            avar8
           do j=ny2,ny1,-1
              read(in,'(8f10.3)') (x2d(i,j,k),i=nx1,nx2)

c ---         Test time period
              call JULDAY(ilog,iyr,imon,iday,jday)
              call TIMESTAMP(iyr,jday,ihour,idate) 
              if(idate.gt.idate0) then
                 write(ilog,*)' Error: Required date too early:'
                 write(ilog,*)'        Required Date:           ',idate0
                 write(ilog,*)'        Beginning Date in 2D.DAT:',idate
                 print *,' Error: Required date too early:'
                 print *,'        Required Date:           ',idate0
                 print *,'        Beginning Date in 2D.DAT:',idate
                 stop
              endif
           enddo 
        enddo
            
c ---   Skip record until requested beginning time
        if(idate.ne.idate0) goto 10

        do iloc=1,ntsfout
           igrd=0

c ---      Neighboring i,j
           i1ext=i1exts(iloc)
           i2ext=i2exts(iloc)
           j1ext=j1exts(iloc)
           j2ext=j2exts(iloc)

c ---      Values at neighboring points
           do j=ny1,ny2
           do i=nx1,nx2
              if(i.eq.i1ext .and. j.eq.j1ext) then
                 igrd=1
                 ngrds(iloc)=ngrds(iloc)+1
                 do k=1,n2dvar
                    x2dintp(igrd,k)=x2d(i,j,k)
                 enddo
              elseif(i.eq.i2ext .and. j.eq.j1ext) then
                 igrd=2
                 ngrds(iloc)=ngrds(iloc)+1
                 do k=1,n2dvar
                    x2dintp(igrd,k)=x2d(i,j,k)
                 enddo
              elseif(i.eq.i1ext .and. j.eq.j2ext) then
                 ngrds(iloc)=ngrds(iloc)+1
                 igrd=3
                 do k=1,n2dvar
                    x2dintp(igrd,k)=x2d(i,j,k)
                 enddo
              elseif(i.eq.i2ext .and. j.eq.j2ext) then
                 ngrds(iloc)=ngrds(iloc)+1
                 igrd=4
                 do k=1,n2dvar
                    x2dintp(igrd,k)=x2d(i,j,k)
                 enddo
              endif
           end do
           end do

c ---      Must have 4 gridpoints to interpolate unless exact (i,j)
           if(ngrds(iloc).ne.4) then
             if(wgts(1,iloc).ne.1.or.wgts(3,iloc).ne.1) then
               write(ilog,*)'Error: 4 grids are needed for interp' 
               write(ilog,*)'Grids found: ',iloc,ngrds(iloc)
               stop 08
             endif
           endif

c ---      In Local Stand Time (Y2K form) 
           if(iloc.eq.1) then
              iyrext=iyr
              call YR4(ilog,iyrext,ierr)
              if(ierr.NE.0) stop 'Halted in M2DEXT - Y2K'
              jdayl=jday
              ihourl=ihour
              idt=-izonec
              call INCR(ilog,iyrext,jdayl,ihourl,idt)
              call GRDAY(ilog,iyrext,jdayl,imonl,idayl)

c --- V1.9.0, Level 121203
c ---         Swap output date and time into variables for output
              iyout=iyrext
              imout=imonl
              idout=idayl
              jdout=jdayl
              ihout=ihourl
c ---         Apply Midnight Convention to end-time
              if(imidnite.EQ.1 .AND. ihout.EQ.24) then
                ihout=0
                call MIDNITE(ilog,'TO 00h',iyrext,imonl,idayl,jdayl,
     &                                     iyout,imout,idout,jdout)
              elseif(imidnite.EQ.2 .AND. ihout.EQ.0
     &                             .AND. isec.EQ.0) then
                ihout=24
                call MIDNITE(ilog,'TO 24h',iyrext,imonl,idayl,jdayl,
     &                                     iyout,imout,idout,jdout)
              endif

           endif

c ---      Write gridded point if exact point is provided
           if(wgts(1,iloc).eq.1.and.wgts(3,iloc).eq.1) then
              do k=1,n2dvar
                 x2dfin(k)=x2dintp(1,k)
              enddo
           else             
              do k=1,n2dvar
                 call interph(metsimc,x2dintp(1,k),wgts(1,iloc),
     &                        x2dfin(k))
              enddo
           endif

c ---      Convert U,V to WS,WD if available
           if(iwind.GT.0) then
c --- V1.9.0, Level 121203
            if(id_ws.eq.1) then
              u=x2dfin(iwind)
              v=x2dfin(iwind+1)
              wsfin=sqrt(u*u+v*v)
              if(wsfin.lt.1.0E-5) then
                 wsfin=0
                 wdfin=0
              else
                 angle = 270.-atan2(v,u)*factor
                 wdfin = amod(angle,360.)      
                 if (wdfin .eq. 0.) wdfin = 360.
              endif
              x2dfin(iwind)=wsfin
              x2dfin(iwind+1)=wdfin
            elseif(id_ws.eq.2 .and. metsimc.eq.2 ) then
C             Only applied to nearest grid
              awdd=x2dfin(iwind)
              awss=x2dfin(iwind+1)
              x2dfin(iwind)=awss
              x2dfin(iwind+1)=awdd
            else
              print *,' Error: not coded for this case'
              stop
            endif

           endif

c ---      Write out record in timeseries file
           io=iout+iloc

c --- V1.9.0, Level 121203
           do k=1,n2dvar
              vname=vnames(k)
              if(trim(vname).eq.'RAIN' .or.
     &             trim(vname).eq.'RAIN CON' .or.
     &             trim(vname).eq.'RAIN NON' .or.
     &             trim(vname).eq.'RAINC' .or.
     &             trim(vname).eq.'RAINNC') then
                 x2dfin(k)=x2dfin(k) * 10. 
              endif
           enddo
           call OUTPUTm2d(io,iyout,imout,idout,ihout,isec,
     &            iyout,imout,idout,ihout,isec,
     &            n2dvar,x2dfin,i2dout_pos,n2dout,mx2d)


c ---   End loop on iloc
        end do


         ihr=ihr+1
c         write(ilog,1070)iyr,imon,iday,jday,ihour,isec,idate0,ihr
 1070    format(5i5,i5.4,i12,i5)
         print 1071,ihr,iyr,imon,iday,jday,ihour,isec
 1071    format('+',6i5,i5.4)

c ---    Get timestamp for last date/time extracted in LST 
         call TIMESTAMP(iyrext,jdayl,ihourl,idatel)

c ---    Figure out next time stamp
         call INCRS(ilog,iyr,jday,ihour,isec,isecstep)
         call GRDAY(ilog,iyr,jday,imon,iday)
         call TIMESTAMP(iyr,jday,ihour,idate)
         idate0=idate

c --- V1.9.0, Level 121203
         if(ihr.le.nbsecext) goto 6200

         write(*,*)

 6500    close(in)

 6000 continue

c
      if(ihr.lt.nbsecext) then
         write(ilog,*)'ERROR: Not all hours were extracted'
      write(ilog,*)'Header Ending date do not match last record of data'
         write(ilog,*)'Hours Extracted: ',ihr
         write(ilog,*)'Hours Needed: ',nbsecext
         write(ilog,*)'Last time extracted (LST): ',idatel,isec
         write(ilog,*)'Last time needed (LST): ',iedathrc,iesecc
         print *,'ERROR: Not all hours were extracted'
         print *,'Header Ending date do not match last record of data'
         print *,'Hours Extracted: ',ihr
         print *,'Hours Needed: ',nbsecext
         print *,'Last time extracted (LST): ',idatel,isec
         print *,'Last time needed (LST): ',iedathrc,iesecc
      else
         write(ilog,'(a)')'2D.DAT data extraction completed'
      endif
     
      return
      end

c ---------------------------------------------------------------------
      Subroutine Outputm2d(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyre,imone,idaye,ihoure,isece,
     &                  n2d,x2d,i2dout_pos,n2dout,mx2d)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c --- Francoise Robe          
c
c --- PURPOSE:  Output time series of 2D.DAT variables
c
c --- UPDATES:
c
c --- Version 1.7, Level 090818 to Version 1.9.0, Level 121203
c         - Modified for variable number of WRF/MM5 2D variables
c
c --- Version 1.65, Level 090526 to Version 1.7, Level 090818 (DGS)
c       1.  Write all M2D variables (currently no more than 12)
c
c ---------------------------------------------------------------------

      real x2d(n2d)

c --- V1.9.0, Level 121203
      dimension i2dout_pos(mx2d)
      dimension x2dtmp(n2dout)
      do k=1,n2dout
         id=i2dout_pos(k)
         x2dtmp(k)=x2d(id)
      enddo
      write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &              iyre,imone,idaye,ihoure,isece,
     &              x2dtmp

 1010 format(2(i5,3i3,1x,i4.4),20f10.3)

      return
      end

c ---------------------------------------------------------------------
      subroutine interphsd(msim,wsintp,wdintp,wgt,wsfin,wdfin)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Horizontal interpolation of wind speed and wind
c               direction (inputs are speed and direction)
c
c --- NOTE:     This is a re-named version of interphmm5
c
c --- UPDATES:
c
c --- Version 1.0, Level 060615 to Version 1.66, Level 090731 (DGS)
c       1.  Add interpolation method choice MSIM
c            1 = Bilinear Interpolation
c            2 = Nearest grid point
c       2.  Calm wind treatment changed to be consistent with interphuv
c
c ---------------------------------------------------------------------

      dimension wsintp(4),wdintp(4),wgt(4)
      dimension u(4),v(4)
      data factor/57.2957795/

      do i=1,4
         fwd=wdintp(i)/factor
         fws=wsintp(i)
         u(i)=-fws*sin(fwd)
         v(i)=-fws*cos(fwd)
      enddo

      if(msim.EQ.2) then
         call RNEAREST(u,wgt,uext)
         call RNEAREST(v,wgt,vext)
      else
c ---    Do bilinear
         uext=u(1)*wgt(1)*wgt(3)+u(2)*wgt(2)*wgt(3)+
     &        u(3)*wgt(1)*wgt(4)+u(4)*wgt(2)*wgt(4)
         vext=v(1)*wgt(1)*wgt(3)+v(2)*wgt(2)*wgt(3)+
     &        v(3)*wgt(1)*wgt(4)+v(4)*wgt(2)*wgt(4)
      endif

c      print *,'Check Hori-interp'
c      print *, u(1)*wgt(1),u(2)*wgt(2),wgt(3)
c      print *, u(3)*wgt(1),u(4)*wgt(2),wgt(4)
c      print *, v(1)*wgt(1),v(2)*wgt(2),wgt(3)
c      print *, v(3)*wgt(1),v(4)*wgt(2),wgt(4)

c      print *, (u(1)*wgt(1)+u(2)*wgt(2))*wgt(3)
c      print *, (u(3)*wgt(1)+u(4)*wgt(2))*wgt(4)
c      print *, (v(1)*wgt(1)+v(2)*wgt(2))*wgt(3)
c      print *, (v(3)*wgt(1)+v(4)*wgt(2))*wgt(4)

      wsfin=sqrt(uext*uext+vext*vext)
      if(wsfin.lt.1.0E-5) then
         wsfin=0
         wdfin=0
      else
         angle = 270.-atan2(vext,uext)*factor
         wdfin = amod(angle,360.)      
         if (wdfin .eq. 0.) wdfin = 360.
      endif

c      print *,'Check in interphsd'
c      print *,wsintp
c      print *,wdintp
c      print *,wgt(1),wgt(2),wgt(3),wgt(4)
c      print *,u
c      print *,v
c      print *,uext,vext
c      print *,wsfin,wdfin
c      print *,'Check end'

c      print *,'End of interphsd'

      return
      end

c ---------------------------------------------------------------------
      subroutine interphuv(msim,u,v,wgt,wsfin,wdfin)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 090731
c --- Zhong-Xiang Wu           
c
c --- PURPOSE:  Horizontal interpolation of wind speed and wind
c               direction (inputs are U and V components)
c
c --- NOTE:     This is a re-named version of interphclm
c
c --- UPDATES:
c
c --- Version 1.0, Level 060615 to Version 1.66, Level 090731 (DGS)
c       1.  Add interpolation method choice MSIM
c            1 = Bilinear Interpolation
c            2 = Nearest grid point
c
c ---------------------------------------------------------------------

      dimension u(4),v(4),wgt(4)
      data factor/57.2957795/

      if(msim.EQ.2) then
         call RNEAREST(u,wgt,uext)
         call RNEAREST(v,wgt,vext)
      else
c ---    Do bilinear
         uext=u(1)*wgt(1)*wgt(3)+u(2)*wgt(2)*wgt(3)+
     &        u(3)*wgt(1)*wgt(4)+u(4)*wgt(2)*wgt(4)
         vext=v(1)*wgt(1)*wgt(3)+v(2)*wgt(2)*wgt(3)+
     &        v(3)*wgt(1)*wgt(4)+v(4)*wgt(2)*wgt(4)
      endif

c      print *,'Check Hori-interp'
c      print *, u(1)*wgt(1),u(2)*wgt(2),wgt(3)
c      print *, u(3)*wgt(1),u(4)*wgt(2),wgt(4)
c      print *, v(1)*wgt(1),v(2)*wgt(2),wgt(3)
c      print *, v(3)*wgt(1),v(4)*wgt(2),wgt(4)

c      print *, (u(1)*wgt(1)+u(2)*wgt(2))*wgt(3)
c      print *, (u(3)*wgt(1)+u(4)*wgt(2))*wgt(4)
c      print *, (v(1)*wgt(1)+v(2)*wgt(2))*wgt(3)
c      print *, (v(3)*wgt(1)+v(4)*wgt(2))*wgt(4)

      wsfin=sqrt(uext*uext+vext*vext)
      if(wsfin.lt.1.0E-5) then
         wsfin=0
         wdfin=0
      else
         angle = 270.-atan2(vext,uext)*factor
         wdfin = amod(angle,360.)      
         if (wdfin .eq. 0.) wdfin = 360.
      endif

c      print *,'Check in interphuv'
c      print *,wgt
c      print *,u
c      print *,v
c      print *,uext,vext
c      print *,wsfin,wdfin
c      print *,'Check end'

c      print *,'End of interphuv'

      return
      end

c ---------------------------------------------------------------------
      subroutine readate_mon(i1,i2,datm,imo,iday,iyr,ihour,irmn)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 091015
c --- C. Escoffier           
c
c --- PURPOSE:  Read DATE/TIME of Monitoring data
c
c----------------------------------------------------------------------
c
        dimension idbsl(2)
        character*16 datm
c
         ibsl=0
	 do ich=i1,i2
            if(datm(ich:ich).eq.'/') then
            ibsl=ibsl+1
            idbsl(ibsl)=ich
            endif
            if(datm(ich:ich).eq.':') then
            idclu=ich
            endif
         enddo
         if(ibsl.gt.2) then
         write(*,*)'ERROR - date in wrong format'
         write(*,*)'Format expected: mm/dd/yyyy hh:mm'
         stop
         endif
        
         if(idbsl(1).eq.2) then
         read(datm(1:1),'(i1)')imo
         elseif(idbsl(1).eq.3) then
         read(datm(1:2),'(i2)')imo
         else
	 write(*,*)'error - date not in correct format'
         write(*,*)'format expected: mm/dd/yyyy hh:mm'
         stop
         endif

         if(idbsl(2)-idbsl(1).eq.2) then
         lbsl=idbsl(1)+1
         read(datm(lbsl:lbsl),'(i1)')iday
         elseif(idbsl(2)-idbsl(1).eq.3) then
         lbsl=idbsl(1)+1
         lbsl1=idbsl(1)+2
         read(datm(lbsl:lbsl1),'(i2)')iday
         else
         write(*,*)'error - date not in correct format'
         write(*,*)'format expected: mm/dd/yyyy hh:mm'
         stop
         endif

         lbsl=idbsl(2)+1
         lbsl1=idbsl(2)+4
         read(datm(lbsl:lbsl1),'(i4)')iyr

         if(idclu-idbsl(2).eq.7) then
         lbsl=idclu-1
         read(datm(lbsl:lbsl),'(i1)')ihour
         elseif(idclu-idbsl(2).eq.8) then
         lbsl=idclu-2
         lbsl1=idclu-1
         read(datm(lbsl:lbsl1),'(i2)')ihour
         else
         write(*,*)'error - date not in correct format'
         write(*,*)'format expected: mm/dd/yyyy hh:mm'
         stop
         endif
         
         lbsl=idclu+1
         lbsl1=idclu+2   
         read(datm(lbsl:lbsl1),'(i2)') irmn

	 return
         end
c----------------------------------------------------------------------
      subroutine VGET320(c320,i1,i2,icol,ioffset,lvalid)
c----------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100107       VGET320
c
c --- Adapted from:
c --- PREPAQ    Version: 1.16     Level: 100107                 VGET320
c ---           D. Strimaitis
c
c --- PURPOSE:  Interprets data validity character
c
c --- UPDATES:
c --- Version 1.15, Level: 081117 to Version 1.16, Level: 100107 (CEC)
c         - A character in non standard ASCII is used for "space".
c           in AMMNET files format. A Fix is to accept as VALID 
c           any FLAGS characters which are not unvalid.
c
c --- INPUTS:
c
c             C320 - character*320     - Input character string
c               i1 - integer           - First character of substring
c               i2 - integer           - Last character of substring
c             ICOL - integer           - Column for target data
c          IOFFSET - integer           - Offset to map data column to
c                                        position of character in
c                                        substring
c
c --- OUTPUT:
c           LVALID - logical           - Validity (T/F)
c
c --- VGET320 called by: (utility)
c --- VGET320 calls:      none
c----------------------------------------------------------------------
      parameter (mxvalid=12)

      character*1 vgood(mxvalid),vbad(mxvalid),c1
      character*320 c320
      logical lvalid

c --- Set validity flags
      data ngood/10/
      data vgood/' ','D','B','+','-','R','P','C','Q','x',2*''/
      data nbad/7/
      data vbad/'c','p','d','b','m','l','r',5*''/

      iqa=0

c --- Set character position in substring
      k=icol-ioffset
      k=i1+k-1

c --- Assign flag
      c1=c320(k:k)

c --- If position k exceeds end i2, then code should be a blank
c --- because trailing blanks may have been excluded in LEN_TRIM call
      if(k.GT.i2 .AND. c1.NE.' ') then
         write(*,*)'VGET: Invalid substring ranges'
         write(*,*)'      Starting position = ',i1
         write(*,*)'     Character position = ',k
         write(*,*)'        Ending position = ',i2
         write(*,*)'     Character(k) found = ',c1
         klast=LEN_TRIM(c320)
         write(*,*)c320(1:klast)
         stop
      endif

c --- Check Good Flags
      do i=1,ngood
         if(c1.EQ.vgood(i)) then
            iqa=i
            lvalid=.TRUE.
         endif
      enddo
      if(iqa.GT.0) return

c --- Check Bad Flags
      do i=1,nbad
         if(c1.EQ.vbad(i)) then
            iqa=i
            lvalid=.FALSE.
         endif
      enddo
      if(iqa.GT.0) return

c --- count warning:
	iw=iw+1
        if(iw.eq.100) then
        write(*,*)'Maximum number of warning messages reached'
        write(*,*)'No additional warnings will be written'
        elseif(iw.lt.100) then
c --- Flag assigned is not in the list
        write(*,*)'WARNING VGET: Accept Invalid flag found: ',c1
        endif
      lvalid=.TRUE.
c      stop

      return
      end

c ---------------------------------------------------------------------
      subroutine seaext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203        SEAEXT
c --- Zhong-Xiang Wu           
c
c --- PURPOSE: Extract wind time series from SEA.DAT
c
c --- UPDATES:
c
c --- Version 1.66, Level 090731 to Version 1.9.0, Level 121203
c         - Add call to MIDNITE for selected time convention
c         - Remove MXSTN and related (unused) arrays
c         - Add new variables for end-time output
c         - Restrict 24h to seconds=0000
c
c --- Version 1.63, level 090415 to Version 1.66, level 090731 (CEC
c         - Add the possibility to output relative humidity in % with
c           the other species.
c --- Version 1.62, level 090411 to Version 1.63, level 090415 (DGS)
c         - Fix typo IYR to IYRX in TIMESTAMP call 
c           (current year did not update at New Years, halting run)
c         - Replace old calls to Y2K() with YR4()
c --- Version 1.6, Level: 090318 to Version 1.62, Level: 090411 (CEC)
c         - add check on WD, WS and Pressure for SURF.DAT format if missing 
c           different than 9999.
c --- Version 1.0, Level: 060615 to Version 1.6, Level: 090318 (DGS)
c         - Control information from /CONTROL/
c         - Filename changed from 80 to 132
c         - Place output TSF header calls into HDTSFOUT
c         - Change to Julian Date-hour integer YYYYJJJHH
c         - Processing sub-hourly time steps has been updated.
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- V1.9.0, Level 121203
      parameter (iecho=0)

      character*132 fl

      character*16 dataset,dataver
      character*64 datamod
      character*8 datum,pmap,axtz
      character*10 daten
      character*4 xyunit,utmhem
      character*16 clat0,clon0,clat1,clat2

c --- V1.9.0, Level 121203
      character*4 cnam,ctemp

      data nlim/1/

c --- Extractions are currently done by station ID, so there
c --- are no modifications to header information
c --- Write header for TSF output file(s)

      if(ntsfout.ne.1) then
       write(ilog,*)'ERROR - only 1 station at a time'
       stop 'Halted: ONLY 1 STATION AT A TIME'
      endif
      do iloc=1,ntsfout
         io=iout+iloc
         call HDTSFOUT(io,iloc)
      enddo

c read header information of processed Sea.dat data
      ihr=0
      idate=0

      do 6000 ifile=1,nmetinp

c ---    Skip remaining files if period has already been extracted
         if(ihr.GE.nbsecext) goto 6000

         fl=fmet(ifile)
c         nt=index(fl,' ')-1
         nt=LEN_TRIM(fl)
         print *,'Processing File:',ifile,' ',fl(1:nt)
         write(ilog,1008)ifile,fl(1:nt)
 1008    format(i3,2x,a)

         open(in,file=fl,status='old',action='read')

c        read header information
      read(in,101) dataset,dataver,datamod
c --- Convert Dataset to upper case
      do i=1,16
         call ALLCAP(dataset(i:i),nlim)
      enddo
 101     format(2a16,a64)
      read(dataver(1:4),'(f4.2)')rverow

         ifilver=0
         itime=0
         if(dataset.EQ.'SEA.DAT') then
            ifilver=1
         else
         write(ilog,*) 'Invalid file format found'
               write(ilog,*) 'file format found    = ',dataset
               write(ilog,*) 'file format expected = SEA.DAT'
               stop 'Halted: Invalid file format found'
         endif
         REWIND(in)

         if(ifilver.eq.1) then
            read(in,101) dataset,dataver,datamod
            read(in,*)ncom
            do i=1,ncom
               read(in,*)
            enddo
            read(in,'(a8)')pmap
            if(iecho.eq.1) write(ilog,'(a8)') pmap
            do i=1,8
              call ALLCAP(pmap(i:i),nlim)
            enddo

            if(pmap.EQ.'UTM     ') then
              read(in,'(i4,a4)') iutmzn,utmhem
            elseif(pmap.EQ.'LCC     ') then
              read(in,'(4a16)') clat0,clon0,clat1,clat2
              read(in,*) feast,fnorth
            elseif(pmap.EQ.'PS      ') then
              read(in,'(3a16)') clat0,clon0,clat1
            elseif(pmap.EQ.'EM      ') then
              read(in,'(2a16)') clat0,clon0
            elseif(pmap.EQ.'LAZA    '.or.pmap.EQ.'TTM     ') then
              read(in,'(2a16)') clat0,clon0
              read(in,*) feast,fnorth
            else
               write(ilog,*)
               write(ilog,*) 'Invalid projection found'
               write(ilog,*) 'Projection found    = ',pmap
               write(ilog,*) 'Projection expected = UTM, LCC, PS, EM, 
     &  LAZA or TTM'
               stop 'Halted: Invalid projection found'
            endif
               read(in,'(a8,a10)') datum,daten
               read(in,'(a4)') xyunit
               if(iecho.eq.1) then
                  write(ilog,'(a8,a10)') datum,daten
                  write(ilog,'(a4)') xyunit
               endif
c --- Record 10: Time Zone and start/end dates
c --- (for Versions>=2.11) (051227)
      if(rverow.GE.2.10999) then
c ---    time zone
         read(in,'(a8)')axtz
         if (iecho.eq.1) write(ilog,'(a8)') axtz

c ---    start and end dates
         read(in,'(6i6)')iwbyr,iwbjdy,iwbhr,
     &              iweyr,iwejdy,iwehr
         if (iecho.eq.1) then
           write(ilog,'(6i6)')iwbyr,iwbjdy,iwbhr,
     &              iweyr,iwejdy,iwehr
         endif
       endif
     
c --- Station identification
c --- Note: idowsta is i9 and chowsta is a132 for Versions 2.11+
      read(in,*) iwmo,cnam
      if (iecho.eq.1) write(ilog,*) iwmo,cnam

         endif
c
         do iloc=1,ntsfout
            idstn=idmet(iloc)
         if(iwmo.ne.idstn) then
            write(ilog,*)'Required station not found'
            write(ilog,*)'Required/Found:',idstn,iwmo
            print *,'Error: Required station not found'
            print *,'Required/Found:',idstn,iwmo
            stop
         endif
         enddo

c --- ndateext = begining time of first time/date = ndatenew - begining seconds = nsecext=nsecnew
      ndatenew = ndateext
      isecx = nsecext
      call DEDAT(ndatenew,iyrx,jdayx,ihourx)
      call GRDAY(ilog,iyrx,jdayx,imonx,idayx)

 2000    continue

         isec=0
         isecb=isec
c ---    SEA.DAT version 2.11 and higher:
c        new variables:air temp sensor height (ztair), water temp
c        sensor depth (zsst - positive downward)
         if (rverow.ge.2.10999)then 
             read(in,*,end=3000)xowkm,yowkm,
     &                     zowsta,ztair,zsst,iyrb,jdayb,ihourb,
     1       iyr,jday,ihour,dt,tk,rh,zi,
     2       tgradb,tgrada,ws,wd,twave,hwave

c ---    SEA.DAT version 2.1 and higher: new variables: twave, rwave; removed:xowlon
         else if (rverow.ge.2.099)then
             read(in,*,end=3000)xowkm,yowkm,
     &                     zowsta,iyrb,jdayb,ihourb,
     1       iyr,jday,ihour,dt,tk,rh,zi,
     2       tgradb,tgrada,ws,wd,twave,hwave
c
         else
            read(in,*,end=3000)xowkm,yowkm,xowlon,
     &                     zowsta,iyrb,jdayb,ihourb,
     1      iyr,jday,ihour,dt,tk,rh,zi,
     2      tgradb,tgrada,ws,wd

         endif
c         
         call YR4(ilog,iyrb,ierrb)
         call YR4(ilog,iyr,ierr)
         if(ierr.NE.0 .OR. ierrb.NE.0) stop 'Halted in SEAEXT - Y2K'

c ---    Increment hour if second = 3600
         nhrinc=1
         if(isec.EQ.3600) then
            isec=0
            call INCR(ilog,iyr,jday,ihour,nhrinc)
         endif
         if(isecb.EQ.3600) then
            isecb=0
            call INCR(ilog,iyrb,jdayb,ihourb,nhrinc)
         endif

c ---    Get month/day
         call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
         call GRDAY(ilog,iyr,jday,imon,iday)   
         if(iecho.eq.1) write(*,*)'beg ',iyrb,jdayb,imonb 
         if(iecho.eq.1) write(*,*)'end ',iyr,jday,imon 

c ---    Create timestamp with time at beginning
         call TIMESTAMP(iyrb,jdayb,ihourb,idate1)
         call TIMESTAMP(iyr,jday,ihour,idate2)

c ---    Compute difference in seconds between two dates
             call DELTSEC(idate1,isecb,ndatenew,isecx,ndelsec1)
             call DELTSEC(idate2,isec,ndatenew,isecx,ndelsec2)
c
         if(ndelsec2.gt.0.and.ndelsec1.gt.0) then
              goto 2000
         elseif(ndelsec1.gt.0.and.(idate1.eq.idate2)) then
              goto 2000
         elseif(ndelsec1.lt.0.and.ndelsec2.lt.0) then
c --- date requested is too early
c --- (CEC - 090304 - make the run stops if begining date requested by user is earlier
c                     than data availability)
          write(ilog,*)'ERROR- beginning date/time requested is earlier'
             write(ilog,*)'than data in SEA.DAT file'
	     write(ilog,*)'date requested = ',ndatenew,isecx
             write(ilog,*)'beginning date in file = ',idate1,isecb
             write(*,*)'ERROR- beginning date/time requested is earlier'
             write(*,*)'than data in SEA.DAT file'
	     write(*,*)'date requested = ',ndatenew,isecx
             write(*,*)'beginning date in file = ',idate1,isecb
             stop
         endif

c --- V1.9.0, Level 121203
c ---    Swap date and time into variables for output
         iyout=iyrx
         imout=imonx
         idout=idayx
         jdout=jdayx
         ihout=ihourx
c ---    Apply Midnight Convention to time
         if(imidnite.EQ.1 .AND. ihout.EQ.24) then
           ihout=0
           call MIDNITE(ilog,'TO 00h',iyrx,imonx,idayx,jdayx,
     &                                iyout,imout,idout,jdout)
         elseif(imidnite.EQ.2 .AND. ihout.EQ.0
     &                        .AND. isecx.EQ.0) then
           ihout=24
           call MIDNITE(ilog,'TO 24h',iyrx,imonx,idayx,jdayx,
     &                                iyout,imout,idout,jdout)
         endif

c        Output
2010      do iloc=1,ntsfout
c
            if(wd.GT.9000.0 .AND. ws.GT.9000.0) then
            wd=9999.
            ws=9999.
            endif
            if(rh.GT.9000.0) then
            rh=9999.
            endif
            if(tk.GT.9000.0) then
            tk=9999.
            endif
            if(dt.GT.9000.0) then
            dt=9999
            endif
            if(zi.GT.9000.0) then
            zi=9999
            endif
            if(tgradb.GT.9000.0) then
            tgradb=9999
            endif
            if(tgrada.GT.9000.0) then
            tgrada=9999
            endif
            if(twave.GT.9000.0) then
            twave=9999
            endif
            if(hwave.GT.9000.0) then
            hwave=9999
            endif
            irh=int(rh)

            io=iout+iloc
c --- V1.9.0, Level 121203
            call Outputsea(io,iyout,imout,idout,ihout,isecx,
     &                 iyout,imout,idout,ihout,isecx,
     &                 wd,ws,tk,dt,zi,tgrada,tgradb,twave,hwave,irh,
     &                 lwind(iloc),ltmpk(iloc),lshum(iloc),lother(iloc))

         enddo

c --- (CEC - 090304 - get Time stamp for last date/time extracted)
            call TIMESTAMP(iyr,jday,ihour,idatel)

c ---    Update period counter (may not be hours)
          ihr=ihr+1
          nsec=isecstep
          call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
          call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
          call TIMESTAMP(iyrx,jdayx,ihourx,ndatenew)
          call DELTSEC(idate2,isec,ndatenew,isecx,ndelsec2)
          if(ihr.le.nbsecext.and.ndelsec2.gt.0) then
          goto 2000
          elseif(ihr.le.nbsecext.and.ndelsec2.le.0) then
          goto 2010
          endif

 3000    close(in)

 6000 continue
      if(ihr.eq.0) then
      write(ilog,*)'Error: No data were extracted:'
      write(ilog,*)'checked data file and control input file'
      write(ilog,*)'station requested ',idloc(iloc)
      print *,'Error: No data were extracted:'
      print *,'checked data file and control input file'
      print *,'station requested ',idloc(iloc)
      stop
      elseif(ihr.lt.nbsecext) then
      write(ilog,*)'ERROR: Not all periods were extracted'
      write(ilog,*)'Header Ending date do not match last record of data'
      write(ilog,*)'Periods Extracted: ',ihr
      write(ilog,*)'Periods Requested: ',nbsecext
      write(ilog,*)'Last time extracted (LST): ',idatel,isec
      write(ilog,*)'Last time needed (LST): ',iedathrc,iesecc
      print *,'ERROR: Not all periods were extracted'
      print *,'Periods Extracted: ',ihr
      print *,'Periods Requested: ',nbsecext
      print *,'Last time extracted (LST): ',idatel,isec
      print *,'Last time needed (LST): ',iedathrc,iesecc
      else
      write(ilog,'(a)')'SEA.DAT data extraction completed'
      endif

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupsea
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203      SETUPSEA
c --- C Escoffier           

c --- PURPOSE: Setup for SEA.DAT 
c
c --- UPDATES:
c
c --- Version 1.77, level 100615 to Version 1.9.0, Level 121203
c         - Set NLIM=1 for calls to ALLCAP
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- Local Header Variables
      character*16 dataset,dataver
      character*64 datamod
      character*4 xyunit
      character*8 datum,pmap
      character*12 daten
      character*8 axtz
      character*4 cnam
      character*16 clat0,clon0,clat1,clat2
      character*4  utmhem

c --- V1.9.0, Level 121203
      data nlim/1/

c --- No profiling is done for SEA.DAT
      lnone=.TRUE.
      cprofile='NONE            '

c --- Impose time zone from user unless it is read in some format below
      izonemet=izonec
      azonemet=azonec

c --- Number of locations = number of TSF files
      nloc=ntsfout

      do i=1,nloc 
         idloc(i)=idmet(i)
c ---    Set logicals for output variables
         lwind(i)=.TRUE.
         if(zwind(i).LT.0.0) lwind(i)=.FALSE.
         ltmpk(i)=.TRUE.
         if(ztmpk(i).LT.0.0) ltmpk(i)=.FALSE.
         lshum(i)=.FALSE.
          if(zshum(i).GE.0.0) then
	   write(*,*)' ERROR - no specific humidity in the file'
	   write(*,*)' TO GET RH, select OTHER'
           stop
          endif
         lother(i)=.TRUE.
         if(zother(i).LT.0.0) lother(i)=.FALSE.
      enddo

c --- Open first file to get time zone from header
c ------------------------------------------------
      open(in,file=fmet(1),status='old',action='read')

c --- Read header information
      read(in,'(2a16,a64)') dataset,dataver,datamod
c --- Convert Dataset to upper case
      do i=1,16
         call ALLCAP(dataset(i:i),nlim)
      enddo
 101     format(2a16,a64)
      read(dataver(1:4),'(f4.2)')rverow

         ifilver=0
         itime=0
         if(dataset.EQ.'SEA.DAT') then
            ifilver=1
         else
         write(ilog,*) 'Invalid file format found'
               write(ilog,*) 'file format found    = ',dataset
               write(ilog,*) 'file format expected = SEA.DAT'
               stop 'Halted: Invalid file format found'
         endif
         REWIND(in)

         if(ifilver.eq.1) then
            read(in,101) dataset,dataver,datamod
            read(in,*)ncom
            do i=1,ncom
               read(in,*)
            enddo
            read(in,'(a8)')pmap
            do i=1,8
              call ALLCAP(pmap(i:i),nlim)
            enddo
           
            if(pmapc.ne.pmap.and.pmapc.ne.'NONE    ') then
            write(ilog,*)'ERROR - Projections do not match '
            write(ilog,*)'Expected/Found ',pmap,pmapc
            stop 'Halted in SETUPSEA --- See log file'
            endif
c            
            if(pmap.EQ.'UTM     ') then
              read(in,'(i4,a4)') iutmzn,utmhem
              if(pmapc.ne.'NONE    ') then
              if(iutmzn.ne.iutmznc.or.utmhem.ne.utmhemc) then
              write(ilog,*)'ERROR - UTM projections do not match '
              write(ilog,*)'Expected/Found ',iutmzn,iutmznc
              write(ilog,*)'Expected/Found ',utmhem,utmhemc
              stop 'Halted in SETUPSEA --- See log file'
              endif
              endif
            elseif(pmap.EQ.'LCC     ') then
              read(in,'(4a16)') clat0,clon0,clat1,clat2
              read(in,*) feast,fnorth
              if(pmapc.ne.'NONE    ') then
              if(clat0.ne.clat0c.or.clon0.ne.clon0c.or.Clat1.ne.Clat1c
     &        .or.Clat2.ne.Clat2c.or.feast.ne.feastc
     &        .or.fnorth.ne.fnorthc) then
              write(ilog,*)'ERROR - LCC projections do not match '
              write(ilog,*)'Expected/Found ',clat0, clat0c
              write(ilog,*)'Expected/Found ',clon0,clon0c
              write(ilog,*)'Expected/Found ',clat1, clat1c
              write(ilog,*)'Expected/Found ',clat2,clat2c
              write(ilog,*)'Expected/Found ',feast, feastc
              write(ilog,*)'Expected/Found ',fnorth,fnorthc
              stop 'Halted in SETUPSEA --- See log file'
              endif
              endif
            elseif(pmap.EQ.'PS      ') then
              read(in,'(3a16)') clat0,clon0,clat1
              if(pmapc.ne.'NONE    ') then
              if(clat0.ne.clat0c.or.clon0.ne.clon0c
     &        .or.Clat1.ne.Clat1c) then
              write(ilog,*)'ERROR - PS projections do not match '
              write(ilog,*)'Expected/Found ',clat0, clat0c
              write(ilog,*)'Expected/Found ',clon0,clon0c
              write(ilog,*)'Expected/Found ',clat1, clat1c
              stop 'Halted in SETUPSEA --- See log file'
              endif
              endif
            elseif(pmap.EQ.'EM      ') then
              read(in,'(2a16)') clat0,clon0
              if(pmapc.ne.'NONE    ') then
              if(clat0.ne.clat0c.or.clon0.ne.clon0c) then
              write(ilog,*)'ERROR - EM projections do not match '
              write(ilog,*)'Expected/Found ',clat0, clat0c
              write(ilog,*)'Expected/Found ',clon0,clon0c
              stop 'Halted in SETUPSEA --- See log file'
              endif
              endif
            elseif(pmap.EQ.'LAZA    '.or.pmap.EQ.'TTM     ') then
             read(in,'(2a16)') clat0,clon0
             read(in,*) feast,fnorth
             if(pmapc.ne.'NONE    ') then
             if(clat0.ne.clat0c.or.clon0.ne.clon0c
     &       .or.feast.ne.feastc.or.fnorth.ne.fnorthc) then
             write(ilog,*)'ERROR - LAZA or TTM projections do not match'
             write(ilog,*)'Expected/Found ',clat0, clat0c
             write(ilog,*)'Expected/Found ',clon0,clon0c
             write(ilog,*)'Expected/Found ',feast, feastc
             write(ilog,*)'Expected/Found ',fnorth,fnorthc
             stop 'Halted in SETUPSEA --- See log file'
             endif
             endif
            else
               write(ilog,*)
               write(ilog,*) 'Invalid projection found'
               write(ilog,*) 'Projection found    = ',pmap
               write(ilog,*) 'Projection expected = UTM, LCC, PS, EM, 
     &  LAZA or TTM'
               stop 'Halted: Invalid projection found'
            endif
               read(in,'(a8,a10)') datum,daten
               read(in,'(a4)') xyunit
              if(pmapc.ne.'NONE    ') then
              if(datum.ne.datumc.or.xyunit.ne.'KM') then
              write(ilog,*)'ERROR - datums do not match '
              write(ilog,*)'Expected/Found ',datum,datumc
              write(ilog,*)'Expected/Found ',xyunit,' KM'
              stop 'Halted in SETUPSEA --- See log file'
              endif
              endif

c --- Record 10: Time Zone and start/end dates
c --- (for Versions>=2.11) (051227)
      if(rverow.GE.2.10999) then
c ---    time zone
         read(in,'(a8)')axtz
         azonemet=axtz
         call UTCBASR(azonemet,zone)
         izonemet=NINT(zone)
c ---    start and end dates
         read(in,'(6i6)')iwbyr,iwbjdy,iwbhr,
     &              iweyr,iwejdy,iwehr
       endif
       endif
c
c --- continue reading up to first line of records
      read(in,*) iwmo,cnam
c ---    SEA.DAT version 2.11 and higher:
c        new variables:air temp sensor height (ztair), water temp
c        sensor depth (zsst - positive downward)
         if (rverow.ge.2.10999)then 
             read(in,*)xowkm,yowkm,
     &                     zowsta,ztair,zsst,iyrb,jdayb,ihourb,
     1       iyr,jday,ihour,dt,tk,rh,zi,
     2       tgradb,tgrada,ws,wd,twave,hwave
c
         if(ztair.ne.ztmpk(1)) then
         write(ilog,*)'ERROR - heights of air temp. record do not match'
         write(ilog,*)'EXPECTED/FOUND',ztair,ztmpk(1)
         stop 'Halted in SETUPSEA --- See log file'
         endif 
c ---    SEA.DAT version 2.1 and higher: new variables: twave, rwave; removed:xowlon
         else if (rverow.ge.2.099)then
             read(in,*)xowkm,yowkm,
     &                     zowsta,iyrb,jdayb,ihourb,
     1       iyr,jday,ihour,dt,tk,rh,zi,
     2       tgradb,tgrada,ws,wd,twave,hwave
c
         if(zowsta.ne.ztmpk(1)) then
         write(ilog,*)'ERROR - heights of air temp. record do not match'
         write(ilog,*)'EXPECTED/FOUND',zowsta,ztmpk(1)
         stop 'Halted in SETUPSEA --- See log file'
         endif 
         else
            read(in,*)xowkm,yowkm,xowlon,
     &                     zowsta,iyrb,jdayb,ihourb,
     1      iyr,jday,ihour,dt,tk,rh,zi,
     2      tgradb,tgrada,ws,wd
c
         if(zowsta.ne.ztmpk(1)) then
         write(ilog,*)'ERROR - heights of air temp. record do not match'
         write(ilog,*)'EXPECTED/FOUND',zowsta,ztmpk(1)
         stop 'Halted in SETUPSEA --- See log file'
         endif 
         endif
         if(zowsta.ne.zwind(1)) then
         write(ilog,*)'ERROR - heights of wind. record do not match'
         write(ilog,*)'EXPECTED/FOUND',zowsta,zwind(1)
         stop 'Halted in SETUPSEA --- See log file'
         endif 
         if(pmapc.ne.'NONE    ') then
         if(xowkm.ne.xmet(1).or.yowkm.ne.ymet(1)) then
         write(ilog,*)'ERROR - X, Y must match first record in SEA.DAT'
         write(ilog,*)'EXPECTED/FOUND',xowkm,xmet(1)
         write(ilog,*)'EXPECTED/FOUND',yowkm,ymet(1)
         stop 'Halted in SETUPSEA --- See log file'
         endif 
         endif

      CLOSE(in)

c --- Trap time-zone difference
      if(izonemet.NE.izonec) then
         write(ilog,*)
         write(ilog,*)' Error processing SEA.DAT file'
         write(ilog,*)'          Data are in time zone: ',azonemet
         write(ilog,*)'     Extraction is in time zone: ',azonec
         write(ilog,*)' Times zones must match'
         stop 'Halted in SETUPSEA --- See log file'
      endif

900   write(ilog,'(a)')'SEA.DAT file setup phase completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      Subroutine Outputsea(io,iyrb,imonb,idayb,ihourb,isecb,
     &                  iyre,imone,idaye,ihoure,isece,
     &                  wd,ws,t,dt,zi,tgrada,tgradb,twave,hwave,irh,
     &                  lwind,ltemp,lshum,lother)
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 100615
c --- C Escoffier           
c
c --- PURPOSE:  Output time series
c ---------------------------------------------------------------------

      logical lwind,ltemp,lshum,lother
      real dt,zi,tgrada,tgradb,twave,hwave
      integer irh


      if(LWIND .AND. LTEMP .AND. LOTHER) then
         write(io,1010)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,dt,zi,irh,tgradb,tgrada,twave,hwave
      elseif(LWIND . AND. LOTHER) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,zi,irh,tgradb,tgrada,twave,hwave
      elseif(LTEMP .AND. LOTHER) then
         write(io,1011)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,dt,zi,irh,tgradb,tgrada,twave,hwave
      elseif(LOTHER) then
         write(io,1012)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 zi,irh,tgradb,tgrada,twave,hwave
      elseif(LWIND .AND. LTEMP) then
         write(io,1009)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws,t,dt
      elseif(LWIND) then
         write(io,1009)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 wd,ws
      elseif(LTEMP) then
         write(io,1009)iyrb,imonb,idayb,ihourb,isecb,
     &                 iyre,imone,idaye,ihoure,isece,
     &                 t,dt
      endif
 1009 format(2(i5,3i3,1x,i4.4),4f10.3)
 1010 format(2(i5,3i3,1x,i4.4),5f10.3,i10,4f10.3)
 1011 format(2(i5,3i3,1x,i4.4),3f10.3,i10,4f10.3)
 1012 format(2(i5,3i3,1x,i4.4),1f10.3,i10,4f10.3)

      return
      end

c ---------------------------------------------------------------------
      Subroutine setupprc
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203      SETUPPRC
c
c --- PURPOSE: Setup for PRECIP.DAT
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

c --- Local Header Variables
      character*64 datamod
      character*16 dataset,dataver
      character*10 daten
      character*8 datum,pmap
      character*4 xyunit

c --- Surface data only
      lnone=.TRUE.
      cprofile='NONE            '

      do i=1,ntsfout 
         idloc(i)=idmet(i)
c ---    Precip is in OTHER group, check request ...
         lother(i)=.TRUE.
         if(zother(i).LT.0.0) then
            write(ilog,*)
            write(ilog,*) 'Invalid PRECIP selection'
            write(ilog,*) 'Expected OTHER > 0'
            write(ilog,*) 'Found    OTHER = ',zother(i)
            stop 'Halted in SETUPPRC -- See log file'
         endif
      enddo

c --- Open and test first file for version format
c -----------------------------------------------
      open(in,file=fmet(1),status='old',action='read')

c --- Configure as old format initially
      ivers=0
      itime=0

c --- Read header information to test
      read(in,'(2a16,a64)') dataset,dataver,datamod
      if(dataset.EQ.'PRECIP.DAT') then
         ivers=1
c ---    Determine time format
         if(dataver.EQ.'2.0') then
c ---       No begin and end times
            itime=0
         else
c ---       Contains begin and end times
            itime=1
         endif
      endif

c --- Reposition file pointer
      REWIND(in)

c --- Get dataset documentation from later file type header
c ---------------------------------------------------------
      if(ivers.EQ.1) then
         read(in,'(2a16,a64)') dataset,dataver,datamod
         read(in,*)ncom
c ---    Skip comments
         do i=1,ncom
            read(in,*)
         enddo
c ---    Map projection (should be NONE or Lat/Lon)
         read(in,'(a8)') pmap
         if(pmap.EQ.'LL      ') then
            read(in,'(a8,a10)') datum,daten
            read(in,'(a4)') xyunit
         elseif(pmap.NE.'NONE    ') then
            write(ilog,*)
            write(ilog,*) 'Invalid projection in PRECIP file'
            write(ilog,*) 'Expected projection = NONE or LL'
            write(ilog,*) 'Found    projection = ',pmap
            stop 'Halted in SETUPPRC -- See log file'
         endif
c ---    Read time zone
         if(itime.EQ.1) then
            read(in,'(a8)') azonemet
            call UTCBASR(azonemet,zone)
            izonemet=NINT(zone)
         else
            read(in,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,izonemet,nstn
            zone=FLOAT(izonemet)
            call BASRUTC(zone,azonemet)
         endif
      endif

c --- Done with file
      CLOSE(in)

c --- Time-zone test
      if(izonemet.NE.izonec) then
         write(ilog,*)
         write(ilog,*)'Extraction time zone must match PRECIP.DAT file'
         write(ilog,*)'  Extraction is in time zone: ',azonec
         write(ilog,*)'Precip data are in time zone: ',azonemet
         stop 'Halted in SETUPPRC -- See log file'
      endif

      write(ilog,*)
      write(ilog,'(a)') 'PRECIP.DAT setup completed'
      write(ilog,*)

      return
      end

c ---------------------------------------------------------------------
      subroutine prcext
c ---------------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c
c --- PURPOSE: Extract precipitation rate time series from PRECIP.DAT
c
c ---------------------------------------------------------------------

      include 'params.ser'
      include 'ctrl.ser'
      include 'metseries.ser'

      dimension iwmo(mxstn),idpk(mxstn),pr(mxstn)

c --- Local strings
      character*132 fnam
      character*16 dataset,dataver
      character*64 datamod
      character*8 datum,pmap, atzone
      character*10 daten
      character*4 xyunit
      character*4 cname(mxstn)
      character*16 clat(mxstn),clon(mxstn)

      logical lecho

c --- Additional outputs to log file?
      lecho=.FALSE.

c --- Pass standard header to TSF files
      do n=1,ntsfout
         call HDTSFOUT(iout+n,n)
      enddo

c --- Read header information of PRECIP.DAT data
      ihr=0
      idate=0

c --- Loop over files
c -------------------
      do ifile=1,nmetinp

c ---    Done if extraction period is complete
         if(ihr.GE.nbsecext) EXIT

c ---    Current filename
         fnam=fmet(ifile)
         open(in,file=fnam,status='old',action='read')

         write(*,*)'PRECIP.DAT File: ',ifile,' ',TRIM(fnam)
         write(ilog,*)
         write(ilog,'(i3,2x,a)') ifile,TRIM(fnam)

c ---    Header
c -------------

c ---    Configure as old format initially
         ivers=0
         itime=0

c ---    Get format information
         read(in,'(2a16,a64)') dataset,dataver,datamod
         if(dataset.EQ.'PRECIP.DAT') then
            ivers=1
c ---       Determine time format
            if(dataver.EQ.'2.0') then
c ---          No begin and end times
               itime=0
            else
c ---          Contains begin and end times
               itime=1
            endif
         endif
c ---    Reposition file pointer
         REWIND(in)

         if(ivers.EQ.1) then
            read(in,'(2a16,a64)') dataset,dataver,datamod
            read(in,*) ncom
            do i=1,ncom
               read(in,*)
            enddo
            read(in,'(a8)') pmap
            if(lecho) write(ilog,*) pmap

            if(pmap.EQ.'NONE    ') then
               if(itime.EQ.1) then
                  read(in,'(a8)') atzone
                  read(in,*) ibyr,ibjul,ibhr,ibsec,
     &                       ieyr,iejul,iehr,iesec,nstn
                  if(lecho) then
                     write(ilog,*) atzone
                     write(ilog,*) ibyr,ibjul,ibhr,ibsec,
     &                             ieyr,iejul,iehr,iesec,nstn
                  endif
               else
                  read(in,*) ibyr,ibjul,ibhr,ieyr,iejul,iehr,izone,nstn
                  if(lecho) then
                     write(ilog,*) ibyr,ibjul,ibhr,
     &                             ieyr,iejul,iehr,izone,nstn
                  endif
               endif

c ---          Test number of stations
               if(nstn.GT.mxstn) goto 9001

               read(in,*) (iwmo(n),n=1,nstn)
               if(lecho) then
                  write(ilog,*)'Station WMO numbers = '
                  do n=1,nstn
                     write(ilog,*) iwmo(n)
                  enddo
               endif
            elseif(pmap.EQ.'LL      ') then
               read(in,'(a8,a10)') datum,daten
               read(in,'(a4)') xyunit
               if(lecho) then
                  write(ilog,*) datum,daten
                  write(ilog,*) xyunit
               endif
               if(itime.EQ.1) then
                  read(in,'(a8)') atzone
                  read(in,*) ibyr,ibjul,ibhr,ibsec,
     &                       ieyr,iejul,iehr,iesec,nstn
                  if(lecho) then
                     write(ilog,*) atzone
                     write(ilog,*) ibyr,ibjul,ibhr,ibsec,
     &                             ieyr,iejul,iehr,iesec,nstn
                  endif
               else
                  read(in,*) ibyr,ibjul,ibhr,ieyr,iejul,iehr,izone,nstn
                  if(lecho) then
                     write(ilog,*) ibyr,ibjul,ibhr,
     &                             ieyr,iejul,iehr,izone,nstn
                  endif
               endif

c ---          Test number of stations
               if(nstn.GT.mxstn) goto 9001

               do n=1,nstn
                 read(in,*) iwmo(n),cname(n),clat(n),clon(n)
c ---            Left-justify CNAME
                 cname(n)=ADJUSTL(cname(n))
                 write(ilog,*) iwmo(n),cname(n),'   ',clat(n),clon(n)
               enddo
            else
               write(ilog,*)
               write(ilog,*) 'Invalid projection in PRECIP file'
               write(ilog,*) 'Expected projection = NONE or LL'
               write(ilog,*) 'Found    projection = ',pmap
               stop 'Halted in PRCEXT -- See log file'
            endif

         endif

c ---    Test for requested stations
         ip=0
         do n=1,ntsfout
            do istn=1,nstn
               if(iwmo(istn).EQ.idmet(n)) then
                  idpk(n)=istn
                  ip=ip+1
               endif
            enddo
         enddo

         if(ip.NE.ntsfout) then
            write(ilog,*)
            write(ilog,*) 'Requested station(s) NOT in PRECIP file'
            write(ilog,*) 'Number requested = ',ntsfout
            write(ilog,*) 'Number   matched = ',ip
            stop 'Halted in PRCEXT -- See log file'
         endif

c ---    Establish times
         ndatenew = ndateext
         isecx = nsecext
         call DEDAT(ndatenew,iyrx,jdayx,ihourx)
         call GRDAY(ilog,iyrx,jdayx,imonx,idayx)

c ---    Top of LOOP over times
10       CONTINUE

         isec=0
         if(itime.EQ.0) then
            read(in,*,end=100) iyr,jday,ihour,
     &                        (pr(istn),istn=1,nstn)
c ---       Beginning of current period
            nsec=-isecstep
            iyrb=iyr
            jdayb=jday
            ihourb=ihour
            isecb=isec
            call INCRS(ilog,iyrb,jdayb,ihourb,isecb,nsec)
         else
            read(in,*,end=100) iyrb,jdayb,ihourb,isecb,
     &                         iyr,jday,ihour,isec,
     &                        (pr(istn),istn=1,nstn)
         endif
         
         call YR4(ilog,iyrb,ierrb)
         call YR4(ilog,iyr,ierr)
         if(ierr.NE.0 .OR. ierrb.NE.0) stop 'Halted in PRCEXT - Y2K'

c ---    Trap second = 3600
         ninc1=1
         if(isec.EQ.3600) then
            isec=0
            call INCR(ilog,iyr,jday,ihour,ninc1)
         endif
         if(isecb.EQ.3600) then
            isecb=0
            call INCR(ilog,iyrb,jdayb,ihourb,ninc1)
         endif
         call GRDAY(ilog,iyrb,jdayb,imonb,idayb)
         call GRDAY(ilog,iyr,jday,imon,iday)

c ---    Create timestamp with time at beginning
         call TIMESTAMP(iyrb,jdayb,ihourb,idate)

c ---    Compute difference in seconds between two dates
             call DELTSEC(idate,isecb,ndatenew,isecx,ndelsec)

c ---    Check for target time (keep reading or quit)
         if(ndelsec.GT.0) goto 10
         if(ndelsec.LT.0) then
c ---       No data in file for date requested
            write(ilog,*)
            write(ilog,*)'Requested time is NOT in PRECIP file'
            write(ilog,*)'Date requested  = ',ndatenew,isecx
            write(ilog,*)'File start date = ',idate,isecb
            stop 'Halted in PRCEXT -- See log file'
         endif
c ---    OK, process this time (remember)
         call TIMESTAMP(iyr,jday,ihour,idatel)

c ---    Swap date and end-time into variables for output
         iyout=iyr
         imout=imon
         idout=iday
         jdout=jday
         ihout=ihour
c ---    Apply Midnight Convention to end-time
         if(imidnite.EQ.1 .AND. ihout.EQ.24) then
           ihout=0
           call MIDNITE(ilog,'TO 00h',iyr,imon,iday,jday,
     &                                iyout,imout,idout,jdout)
         elseif(imidnite.EQ.2 .AND. ihout.EQ.0 .AND. isec.EQ.0) then
           ihout=24
           call MIDNITE(ilog,'TO 24h',iyr,imon,iday,jday,
     &                                iyout,imout,idout,jdout)
         endif

c ---    Write data
         do n=1,ntsfout
            prate=pr(idpk(n))
            if(prate.GT.9000.0) prate=9999.
            io=iout+n
            write(io,15) iyrb,imonb,idayb,ihourb,isecb,
     &                   iyout,imout,idout,ihout,isec,
     &                   prate
         enddo
15       format(2(i5,3i3,1x,i4.4),f10.3)

         if(ihr.LT.nbsecext)  then
c ---       Next period
            ihr=ihr+1
            nsec=isecstep
            call INCRS(ilog,iyrx,jdayx,ihourx,isecx,nsec)
            call GRDAY(ilog,iyrx,jdayx,imonx,idayx)
            call TIMESTAMP(iyrx,jdayx,ihourx,ndatenew)
            goto 10
         endif
c ---    End of LOOP over times

100      CLOSE(in)

c ---    QA on expected number of hours from file
         if(ihr.EQ.0) then
            write(ilog,*)
            write(ilog,*)'NO data were extracted from PRECIP file'
            write(ilog,*)'Check your inputs and data file'
            stop 'Halted in PRCEXT -- See log file'
         elseif(ihr.LT.nbsecext) then
            write(ilog,*)
            write(ilog,*)'Fewer data were extracted from PRECIP file'
            write(ilog,*)'Periods Extracted: ',ihr
            write(ilog,*)'Last time   (LST): ',idatel,isec
            write(ilog,*)'Periods Requested: ',nbsecext
            write(ilog,*)'End time    (LST): ',iedathrc,iesecc
            stop 'Halted in PRCEXT -- See log file'
         else
            write(ilog,'(a)') 'PRECIP.DAT data extraction completed'
         endif

      enddo
c --- End of loop over files

      return

c --- Too many stations
9001  write(ilog,*)
      write(ilog,*) 'Too many precipitation stations found'
      write(ilog,*) 'Number found = ',nstn
      write(ilog,*) 'MXSTN limit  = ',mxstn
      write(ilog,*) 'Increase MXSTN in PARAMS.SER and recompile'
      stop 'Halted in PRCEXT -- see list file'

      end


c -----------------------------------------------------------------
	Subroutine scan2d(ilog,fl,n2d,vnames,mx2d,iwind,id_ws
     &                   ,i2d_type,id_rain,id_rainc,id_rainnc
     &                   ,i2dout_pos,n2dout,c2dout_mm5,c2dout_wrf
     &                   ,c2dout)
c -----------------------------------------------------------------
c
c --- METSERIES  Version: 1.9.0         Level: 121203
c
c ---   Purpose: 
c       Scan a 2D file to obtain list of variables
c
c       Zhong-Xiang Wu
c -----------------------------------------------------------------

        dimension i2dout_pos(mx2d)
        character*8 c2dout_mm5(mx2d),c2dout_wrf(mx2d),c2dout(mx2d)

        character*132 fl
        character*8 vnames(mx2d),vname,vnameout
        character*132 buff
        character*4 cmap

        real xsrf(1000)

	character*64 datamodt
        character*16 name2dt,datavert,datalevelt

	character*16 codevert,codelevelt
	character*16 cmodelt,cmodel_vert

        i2dout_pos=-9
        in=99

c ---   Get 2D.DAT file header
c ----------------------------
	open(in,file=fl,status='old',action='read')

c ---   Record #1
	read(in,'(a)')buff

        read(buff,'(2(a16),a64)')name2dt,datavert,datamodt

        read(datamodt,'(2a16)')cmodelt,cmodel_vert

        if(cmodelt(1:3).eq.'WRF') then
           i2d_type=2
           c2dout=c2dout_wrf
        else
           i2d_type=1
           c2dout=c2dout_mm5
        endif

c ---   Record #2
	read(in,'(i4)')ncomm
c ---   Comment records (ncomm)
        do i=1,ncomm
           read(in,*)
        enddo

c ---   Record #3
        read(in,'(6i3)')ioutw,ioutq,ioutc,iouti,ioutg,iosrf
c ---   Record #4
        read(in,104)cmap,rlatc,rlonc,truelat1,truelat2,xsw,ysw,dxm,
     &              nx,ny,nz
104     format(a4,f9.4,f10.4,2f7.2,2f10.3,f8.3,2i4,i3)

c ---   Record #5 - physics flags
        read(in,'(30i3)')inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     &                   ifddaan,ifddaob,igrdt,ipbl,ishf,ilhf,iustr,
     &                   iswdn,ilwdn,it2,iq2,iu10,iv10,isst,ist6
	
c ---   Record #6
        read(in,'(i10,i5,3i4)')idatebeg,nhours,nxsub,nysub,nzsub

c ---   Record #7
        read(in,'(6i4,2f10.4,2f9.4)')nx1,ny1,nx2,ny2,nz1,nz2,
     &                               rxmin,rxmax,rymin,rymax

c ---   Reset NZ to actual number extracted
        nz=nzsub

c ---   Skip sigma levels
        do i=1,nz
           read(in,'(f6.3)') sigma
        enddo

c ---   Lat/Lon records
        do j=ny1,ny2           
        do i=nx1,nx2
           read(in,105)ii,jj,flat,flong,ihh,iland,flatcrs,flongcrs
        enddo
        enddo
105     format(2i4,f9.4,f10.4,i5,i3,1x,f9.4,f10.4)

c ---   Scan 2D variables
c -----------------------
	nsrf=0
	ip=0

 2000	read(in,'(i10.10,2x,a8)')idate,vname
	
	if(ip.eq.0) then
	   idatecur=idate
	   ip=ip+1
	   vnames(ip)=vname
	elseif(idate.ne.idatecur) then
	   nsrf=ip
	   goto 1000 
	else
	   ip=ip+1
	   vnames(ip)=vname
	endif

	do j=ny2,ny1,-1
	   read(in,'(8f10.3)')(xsrf(i),i=nx1,nx2)
	enddo

	goto 2000

 1000	close(in)

        n2d=ip

        do ivar=1,n2d
           vname=vnames(ivar)
           if(trim(vname).eq.'U10') then
              iwind=ivar
              id_ws=1
              goto 3000
           elseif(trim(vname).eq.'WD10') then
              iwind=ivar
              id_ws=2
              goto 3000
           endif

        enddo

        print *,'Wind is not included in 2D.DAT'
        iwind=-999

 3000   continue

C ---   Output 2D Variables:
        do k=1,n2dout
           vnameout=c2dout(k)

           do ivar=1,n2d
              vname=vnames(ivar)
              if(trim(vname).eq.trim(vnameout)) then
                 i2dout_pos(k)=ivar
                 goto 4000
              endif
           enddo

           write(ilog,*)'Warning: Variable not found',trim(vnameout)
           
 4000      continue
        enddo

	return
	end
