c-----------------------------------------------------------------------
      program calmet
c-----------------------------------------------------------------------
c --- CALMET -- Diagnostic meteorological model for the CALPUFF,          
c ---           CALGRID, and MESOPUFF-II models
c-----------------------------------------------------------------------
c
c     Copyright (c) 2014 by TRC Environmental Corporation         
c
c --- CALMET   Version: 6.4.0     Level: 121203                MAIN
c
c --- CALMET MOD6- Developed by:
c                  Joe Scire and Francoise Robe
c                  Earth Tech, Inc.
c                  Concord, MA
c ---              e-mail: jss@src.com or jscire@alum.mit.edu
c
c --- Original CALMET written by:
c                  J. Scire, R. Yamartino
c                  EARTH TECH/Sigma Research
c                  196 Baker Avenue
c                  Concord, MA  01742
c                  tel: (978) 371-4200
c                  fax: (978) 371-2468
c                           and
c                  S. Douglas, R. Kessler
c                  Systems Applications, Inc.
c                  101 Lucas Valley Road
c                  San Rafael, CA  94903
c
c                  Modifications made by
c                  M. Fernau, X. Zhang, J. Scire, F. Robe, and
c                  D. Strimaitis
c                  EARTH TECH/Sigma Research
c
c-----------------------------------------------------------------------
c --- Model Change Bulletin Updates Included:           MCB-A (040716)
c                                                       MCB-B (051216)
c                                                       MCB-C (070501)
c                                                       MCB-D (070623)
c                                                       MCB-E (080512)
c                                                       MCB-F (110212)
c                                                       MCB-G (110421)
c-----------------------------------------------------------------------
c
c
c **********************************************************************
c --- Exponent, Inc. Updates:
c **********************************************************************
c --- v6.334, Level 110421 to v6.4.0, Level: 121203
c      -   Add wind direction rotation for the Polar Stereographic 
c          projection option; initialize LCCIGF logical
c          Modified: PARAMS.MET, IGF.MET
c                    RDMM4, RDMM5, RDOW, RDS, RDUP, READCF
c                    RDSN, RDUPN, RDUPN2, READHD, RDHDMET, RDCALMET
c      -   Bug Fix: time zone read statement for dataset v2.1 SURF.DAT
c          or v2.1 PRECIP.DAT was missing in branch for headers with
c          full location information (CALMET halts ...)
c          Modified: RDHD
c      -   Add logic to pass 3D.DAT liquid water info to AUX file
c          1 Average M3D LWC to CALMET layers (3D output to AUX file)
c          2 Average M3D LWC>threshqc above CALMET top and report as 2D
c            fields of cloud bottom, cloud top, and average cloud LWC
c          3 Allow more than 99 M3D input files
c          New:      AUXDAT.MET, AUXVAR.MET
c                    OUTAUXHD, AUXOUT, COMPRS, XTRACT, WRDAT, WRINT
c                    Z2FACE, PRFVAR
c          Modified: OUTPT.MET
c                    BLOCK DATA, READFN, SETUP, OPENOT, COMP,
c                    RDMM5, OUTHD
c      -   Add checks for recognized 3D.DAT dataset versions
c          2.0, 2.1, 2.11, 2.12, 2.13, 3.0, 3.1
c          and halt with error message if 3D.DAT is generated by a
c          processor version with known errors.
c          Modified: RDHD53
c      -   Revise logic for selecting format of M3D data records
c          starting with 3D.DAT version 2.0
c          Modified: RDMM5
c      -   Set model version string to character*12 for all i/o
c          Modified: QA.MET
c                    RDHDMET, READCF, OUTHD
c **********************************************************************
c
c --- v6.333 Level 110324 to v6.334 Level 110421
c --- Modifications by J.Scire:
c     (1) Bug Fix: ensure that the same sounding is used to calculate the
c         lapse rate at the top of the convective mixing height during its
c         growth and in the BG mixing height calculation and that used to 
c         define the whole temperature profile. 
c         Modified: MIXHT, MIXHTST
c     (2) Bug Fix: For NPSTA=-1 (CALMET preciptation interpolated from 
c         prognostic precipitation field) overwrite user-defined SIGMAP
c         to ensure that the interpolation always includes the 4 nearest 
c         progn. gridpoints to any CALMET gridpoint (and only those 4) 
c         to ensure consistency of CALMET and prgn. precipitation fields)
c         Modified: RDHD4, RDHD5, READHD
c
c --- v6.332 level 110212 to v6.333 Level 110324 
c --- Modifications by F.Robe:
c      (1) When 3D.DAT lowest level is above lowest CALMET level(s)
c          during a nightime warming (e.g. warm front), allow the same
c          warming at lower CALMET levels as warming at the lowest 3D.DAT
c          level 
c          Modified: STULL
c
c --- v6.331 Level 101206 to v6.332 Level 110212 
c --- Modifications by F.Robe:
c     (1) Bug Fix: pass old convective mixing height overwater to 
c         mixhmc rather than old mixing height (as it was intended
c         since v6.229 but was not done owing to a typo) 
c         Modified: WATER
c     (2) Make relaxation of convective mixing height to equilibrium
c         value an option (to insure backward compatibility with MOD5)
c         (default:On-IZICRLX=1; compatibility with v5.8:off-IZICRLX=0)
c         Modified: CALMET.INP, READCF,MIXHMC, MIXHBG, ZIPARM.MET, 
c                   BLOCK DATA
c     (3) Add IZICRLX=0 to the MREG check:
c         IZICRLX  0      Do NOT use convective mixing height relaxation
c                         to equilibrium value
c         Modified: READCF
c     (4) Allow user to set the ZIc relaxation time 
c         (default: TZICRLX=800s) 
c         Modified: CALMET.INP, READCF,MIXHMC, MIXHBG, ZIPARM.MET, 
c                   BLOCK DATA
c     (5) in MIXHBG, make relaxation ZicBG value consistent with the
c         calculation of the threshold flux
c         Modified : MIXHBG
c     (6) 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 --- v6.330 Level 101006 to v6.331 Level 101206
c --- Modifications by F.Robe:
c     (1) Bug fix: correctly convert beginning year read from  
c         MOD5-CALMET.INP for runs starying on Jan1, at 0 LST
c     (2) Harmonize input/output cloud option: sub-hourly input/output 
c         for both formatted and unformatted with beg/ending times
c         Option to read in old hourly cloud.dat with ending times
c         does not exist any longer - CLOUD.DAT must be with same
c         frequency as CALMET
c         Modified: COMP, OUTCLD, new RDCLDN
c
c --- V6.329 Level 100719 to v6.330 Level 101006
c --- Modifications by C. Escoffier:
c     (1) Change in CALMET.INP the variable ICLOUD into two new
c         variables: MCLOUD and ICLDOUT to distinguished between
c         outputing a CLOUD.DAT and the method of clouds computation
c         or input into CALMET
c         Modified: CALMET.INP, met1.met
c         Modified subroutine: BLOCK data,comp,elustr,elustr2,heatflx,
c         missfc,openot,pgtstb,rdhd5,rdmm4,rdmm5,readcf,readhd,stheor,
c         radflx,wrfiles,outcld
c --- V6.328 Level 090615 to v6.329 Level 100719 
c --- Modifications by F. Robe:
c     (1) Relax convective mixing height to equilibrium value based on  
c         THRESHW (or THRESHL) and turbulence timescale of 800s when the  
c         buoyancy flux is positive but lower than the threshold. 
c         This change can affect Zi and w* prior results for cases where 
c         THRESHW>0 and/or THRESHL>0 during weakly convective times
c         Modified: MIXHMC, MIXHBG 
c     (2) Bug fix: Grow overwater convective mixing height from previous 
c         hour convective mixing height, not from previous hour mixing 
c         height
c         Modified: WATER,WATERP
c
c --- V6.327 Level 090511 to V6.328 Level 090615 
c     (1) Read and store header record data from 3D.DAT files for 2nd, 
c         3rd, ... 3D.DAT file read in a single CALMET run.  Previously,
c         header record data were skipped except in first 3D.DAT file.
c         (Note: this change exists in MOD5 since v5.728)
c         Subr. modified:  RDHD5, RDHD51, RDHD52, RDHD53
c
c --- V6.326 Level 080709 to V6.327 Level 090511 
c     (1) Initialize nscmm5 if it is not read from 3D.DAT header 
c         record (does not affect results but could stop execution 
c         if the compiler checks for non-initialized variables)
c         Modified: RDHD53
c     (2) Initialize qc and qr when those variables are not in the
c         MM5 records (does not affect results but could stop execution
c         if the compiler checks for non-initialized variables)
c         Modified: RDMM5
c     (3) Revised  write statements 1089-1090 to add more information 
c         to error warnings and reflect explicit times with seconds 
c         Modified: PREPDI, TEMP3D, TEMP3D_BACK
c     (4) Remove Format statements 1089 and 1090 in CGAMMA subroutine
c         as they are not used
c         Modified: CGAMMA
c     (5) Update documentation in UPMET.MET to reflect time differences
c         in seconds rather than hours 
c         Modified: UPMET.MET
c     (6) Include more information to output error messages
c         Modified: READHD, COMP
c     (7) Store dataset beginning time as specified in UP.DAT header V2.0
c         and do not shift it by 1 hour 
c         Modified: READHDU
c     (8) Update documentation on the following four routines to the 
c         correct model version number:  
c         Modified: AIRDEN_NS, T2D_NSP, PSIUC, SURFVAR_BACK
c     (9) Updated CALUTILS.FOR to version v2.571 (090511)
c           - Increase control file line length to 200 characters
c           - Activate CPU clock using F95 system routine
c           - Add routine to reformat a date string
c           - New     : FMT_DATE
c           - Modified: PARAMS.CAL, READIN, DATETM
c         Reformat date reported to list file
c         Modified: FIN
c         Reset control-file line-length limit to 200
c         Modified: TFERCF
c    (10) Check that CALMET grid is within the prognostic sub-domain 
c         Modified: RDHD5, RDHD4, PARAMS.MET, INOUT (new subroutine)
c    (11) Create  QA plot file qametg.bna (CALMET domain boundary)
c         Modified: READCF
c
c --- V6.325 Level 080512 to V6.326 Level 080709 
c     (1) Modify timecheck in RDMM5 for the case of multiple overlapping
c         MM5 input data files to avoid the simulation to stop one
c         short (in the case of hourly M3Dfiles only).
c         Results are not affected by this fix if the fields
c         at the last overlapping hour are identical in both files 
c         otherwise they may differ for that hour (and only that one).
c         If MM5 files overlap, the earlier file is read to the end
c         and overlapping times are skipped in the subsequent file.
c         Modified: RDMM5
c     (2) Fixed typo in error message
c         Modified: RDMM5
c     (3) Only call cloud4 if new valid data (icloud=4 option)
c         (Improve efficiency- No result change)- 
c         Modified: RDMM5
c     (4) Corrected level on comment line identifying Version V6.325
c
c --- v6.324 Level 080421 to V6.325 Level 080512
c     (1) Bug fix: Update values of gridpoint locations in the call to  
c         cinterp and r2interp2- Affects computation of prognostic 
c         ceiling heights (3D.DAT only - IPROG>5 and ICLOUD=3,4)
c         Modified: RDMM5
c     (2) Apply temperature interpolation overwater at CALMET levels
c         below lowest M3D level to actual temperature array when 
c         ITWPROG=2 
c         Modified: RDMM5
c
c --- V6.323 Level 080411  to v6.324 Level 080421
c     (1) Allow different map projections and datums for the IGF-CALMET
c         and current CALMET simulations
c         Modified: RDHDMET,RDCALMET.
c     (2) Compute current CALMET x,y coordinates in RDHDMET and store  
c         them in GRID.MET for use in RDCALMET only. 
c         Modified: RDHDMET, GRID.MET, RDCALMET
c     !!!!Note that computing CALMET gridpoints (x,y) only once for all
c         instead of recomputing them in 10 subroutines
c         READHD, MICROI,RDMM4,RDMM5,RDHD4,RDHD5,RDHDMET,RDCALMET,
c         INTER2 and INTERP cannot be implemented because the tiny decimal
c         changes with respect to previous versions this implies can induce  
c         tiny differences in results, which for large grids, can induce 
c         not so tiny changes in CALPUFF (tested in internal version v6.322)   
c     (3) Correct typo (clabxp instead of clabxi) - Does not affect 
c         results
c         Modified: RDHDMET
c     (4) Updated CALUTILS from v2.55 Level 070327 to v2.56 Level 080407
c         Control file entries in exponential notation were not correct
c         if decimal point was missing (2e-02 was read as 0.2e-02).
c         Modified: ALTONU
c --- v6.321 Level 080325 to V6.323 Level 080411 (F.Robe)
c     (1) Bug fix: check values of prognostic ceiling heights at both  
c         times t1 and t2 before performing a time interpolation.
c         (suggested by Bruno Santos)
c         Modified: RDMM5
c     (2) Remove un-necessary unity exponent in COARE stability functions 
c         to avoid potential numerical problems (no change in results)
c         Modified: PSIUD, PSIU
c     (3) Only print out IGF-CALMET ending times in LST file if IGF-CALMET  
c         version 2.1 (undefined ending times otherwise which might stop 
c         compilation/execution on some platforms) -no change in results)
c --- v6.322 - internal developer version Level 080326 - (F.Robe)
c --- v6.32 Level 080205  to v6.321 Level 080325 - (F.Robe)
c --- (1) Bug fix: Remove nsecdt from calling list to rdupn2 (only affects
c         runs with UP.DAT files Version 2.2 and code V6.32 Level 080205)
c         Modified: COMP
c     (2) Modify write statements to LST files to 1) reflect the precipitation 
c         dataset name 2) align values with text in LST file           
c         Does not affect results 
c         Modified: READHD
c     (3) Check precip. station IDs based on LFCPRC not LFCSFC.
c         Modified: READHD
c     (4) Save isec1, isec2 to make sure their values are saved from one
c         timestep to the next. Otherwise can assume wrong values and 
c         cause crash with some compilers.
c         Modified: RDMM5
c     (5) Correct typo that stops a run with a SURF.DAT or PRECIP.DAT file 
c         stating in its header that the surf./precip. records end on the last
c         day of the year at hour 24. 
c         Modified: RDHD
c --- V6.31 Level 071207 to v6.32 Level 080205
c     (1) Allow sub-hourly prognostic timesteps (MM5/M3D format only)
c         (instantaneous records only and timesteps >= CALMET timestep)
c         Note: 3D.DAT version 3.0 has explicit beginning and end times
c         with seconds. For instantaneous records: beginning time=end time
c         New input parameter: ISTEPPGS (pgn timestep in seconds)
c         Modified: RDMM5, RDHD5, RDHD53, READCF,READHD,MM4HDO.MET CALMET.INP      
c     (2) Allow new format for upper air soundings (dataveru=2.2) where
c         - Beg.time=end time for instantaneous soundings
c         - Otherwise, sounding is assumed to be a time-averaged
c           profile, valid for the entire period defined by the
c           beginning and end times (no time interpolation
c           and no adiabatic adjustment).
c         - Note that all previous formats of UP.DAT (end time or
c           explicit beg./end times) are assumed to be instantaneous
c           soundings even if the beginning and end times differ
c         Modified: COMP, RDUPN2 (new), UPMET.MET, RDUP, RDUPN, RDHDU
c                   CGAMMA
c     (3) Compare upper air sounding times with ending time of CALMET
c         timestep to streamline checking process (Up/MM5, etc)
c         Does not affect results unless the CALMET timestep is
c         longer than the upper air sounding frequency (but this is 
c         no longer an option)        
c         Modified: COMP, RDUPN, GAMMAC, PREPDI, TEMP3D, TEMP3D_BACK
c     (4) Add QA checks to ensure that 1) there is no gap in the 
c         surface and precipitation data records and 2) that their 
c         frequency is at least hourly
c         Modified: RDSN, RDPN
c     (5) Add QA checks to ensure that the data frequency is not higher
c         than CALMET sampling (CALMET timestep>= time between new data)
c         Modified: RDSN, RDPN, COMP
c     (6) Remove GMT time from RDMM4 and RDMM5 calling lists (never useD)
c         Modified: DIAGNO, RDMM4, RDMM5
c     (7) Check availability of precipitation and SST data if user
c         wants to use them (could be blank if not available or not good
c         in original prognostic datasets e.g. for RUC data)        
c         Modified: RDHD53, RDHD5, READHD
c   
c --- v6.302 Level 070929 to V6.31 Level 071207
c     (1) Bug fix in READCF: Perform coordinate conversion of 
c         precipitation stations locations based on the presence of
c         precipitation data rather than that of upper air data when
c         the precipitation station coordinates are included in the
c         CALMET.INP file (Ken Richmond)
c         Modified: READCF
c     (2) Keep searching for a first valid MM5 record through 
c         successive MM5 files (and do not stop after the first file)
c         Modified: RDMM5
c     (3) Enforce bounds on dtinc value
c         Modified: RDMM5
c     (4) Make sure that the current and future MM5 timesteps are always 
c         in memory and never the previous and current timesteps 
c         (except for the last simulation timestep) for consistency with  
c         MOD5,proper computing of previous hour prognostic temperature 
c         soundings, proper initialization of Stull surface temperature 
c         cooling, and to avoid the potential of not having the proper
c         records to compute the last
c         timesteps correctly.
c         Modified: RDMM5
c     (5) In NOOBS mode using MM4 temperature fields (ITPROG>0), 
c         use the current hour soundings for computing the convective
c         mixing height growth at the first timestep in the unlikely   
c         event that the first hour of a simulation is convective 
c         (subsequent timesteps keep using the previous hour soundings)
c         Modified: RDMM4
c     (6) Set RH to 100% overwater when there are no overwater 
c         stations (i.e. no SEA.DAT file) to be consistent with default
c         RH value overwater in the rest of the code and when there is
c         a SEA.DAT file (with missing RH obs) (in noobs-RH mode). 
c         Modified: SURFVAR
c     (7) In NOOBS mode (ITPROG=2)initialize surface temperatures 
c         with default value instead of not-yet defined prognostic  
c         temperatures (no change in the results but old formulation
c         could stop run on some platforms)
c         Modified: SURFVAR     
c     (8) COORDLIB from v1.98 Level 060911 to v1.99 Level 070921
c        - Conversion of point in S. hemisphere to UTM-N returned coord.
c          as UTM-S instead, for conversions from all map projections
c          except lat/lon.
c        - Initialization of a few work arrays were missing.  These have
c          no effect on results.
c          Modified:  COORDS, PJINIT
c
c --- V6.301 Level 070927 to V6.302 Level 070929 (JSS)
c     (1) Modification to RDR1D, RDI1D, RDR2D, RDI2D
c            - Add CALMET Version to routine header
c            - Add valid range check for MTVER variable
c            - Add error message write for invalid MTVER
c     (2) Modify calls to RDR1D, RDI1D, RDR2D, RDI2D to
c         include IO6 in argument list
c            - Routines modified: RDHDMET, RDMET2, RDCLD
c     (3) Update PARAMS.MET file to include documentation on new
c         parameters (MXNXI, MXNYI, MXNZI, MXIGF)
c     (4) Update documentation on routines being called/called by
c            - READHD, RDCLD, RDHDMET
c     (5) Update documentation on parameters required in routine
c            - READHD
c
c --- V6.3 Level 070717 to V6.301 Level 070927 (F. Robe)
c     (1) Extend IGF-CALMET capability to read in hourly and sub-hourly
c         MOD6 fields
c         Modified: RDHDMET, RDCALMET,RDMET2,RDCL,IGF.MET
c         Updated: RDR1D, RDI1D, RDR2D, RDI2D 
c         (copied from PRTMET 4.48 Level 070720)
c  
c --- V6.223 Level 070702 to V6.3 Level 070717
c --- Changes to create EPA regulatory option to replicate results
c --- from CALMET v5.53c Level 070501, as modified by MCB-D updates,
c --- with hourly timesteps
c     (1) Introduce an option to use nearest-station surface met data
c         for surface-layer temperature and density instead of the
c         fully interpolated 2D fields, set by ICOARE
c         (ICOARE Not 0 sets ISFCMET=0, to use full 2D fields
c          ICOARE  =  0 sets ISFCMET=1, to use surface stn/prognostic)
c         Also, apply TEMP3D fix for noobs temp mode (ITPROG>0) to
c         TEMP3D_back (temperature adjustment to adiabatic up to
c         the convective mixing height was done up to an un-defined
c         height zic i.e. 0 or random height depending on compiler)-  
c         New     : AIRDEN_NS, T2D_NSP, SURFVAR_back, TEMP3D_back
c         Modified: WPARM.MET
c                   READCF, COMP, DIAGNO, STHEOR
c     (2) Introduce an option to use surface-layer stability correction
c         profiles from CALMET version 5.53 in ELUSTR, ELUSTR2, SIMILT,
c         when using the OCD overwater option set by ICOARE
c         (ICOARE Not 0 sets IPSIFCN=0, to use CALMET/COARE profile PSIU
c          ICOARE  =  0 sets IPSIFCN=1, to use CALMET v5.53 profile PSIU
c         New     : PSIUC
c         Modified: WPARM.MET
c                   READCF, SIMILT, ELUSTR, ELUSTR2,
c                   STHEOR, COMP, DIAGNO, WIND1, WATER2, WATER2P
c     (3) Add precision to the product Vk*g in DELTAT by replacing data
c         statement with the explicit product
c         Modified: DELTAT
c     (4) Establish an EPA Regulatory Conformance switch that tests
c         control-file inputs for several model configuration variables:
c            IMIXH    -1     Maul-Carson convective mixing height
c                            over land; OCD mixing height overwater
c            ICOARE   0      OCD deltaT method for overwater fluxes
c            THRESHL  0.0    Threshold buoyancy flux over land needed
c                            to sustain convective mixing height growth
c            ISURFT   > 0    in OBS mode (pick one representative station)
c                     -2     in NOOBS mode (itprog=2) (average all 
c                            surface prognostic temperatures to get 
c                            a single representative sf. temp)                      
c            IUPT     > 0    in OBS mode (pick one representative station)
c                     -2     in NOOBS mode (ITPROG>0) (average all surface 
c                            prognostic temperatures to get a single 
c                            representative sf. temp)                      
c
c         This switch, MREG, becomes a mandatory input
c         Reset default buoyancy flux over land to 0.0 W/m3
c         Modified: BLOCK DATA, READCF, GEN.MET
c     (5) Revert to using the domain characteristic (IUPT) upper air  
c         station to compute convective mixing height growth at all 
c         gridpoints when IUPT>0 (e.g. in regulatory mode) but keep using  
c         nearest upper station otherwise (IUPT=-1) 
c         Modified: MIXHT,MIXHTST,COMP,ELUSTR2,STHEOR
c     (6) Use average surface Temperature to calculate the Froude
c         adjustement for ISURFT=-2 
c         Modified: FRADJ
c     (7) Use the previous hour prognostic lapse rate rather than the current
c         hour lapse rate to compute mixing height growth when prognostic
c         temperatures are used (ITPROG>0)
c         Modified: RDMM5
c     (8) Shift simulation ending hour by 1 hour and compute the runlength 
c         in subhourly timesteps if the input  file is of MOD5 format
c         Modified: READCF
c     (9) Make sure the 2 MM5 records read in are the current time and the
c         following time, in all cases (i.e. whether the first MM5 record is
c         at the beginning of or prior to the beginning of the simulation)
c         Modified: RDMM5
c    (10) Compute and pass on the ending GMT time to COARE (rather than the 
c         beginning GMT time)
c         Modified: COMP
c
c --- V6.222 Level 070404 to V6.223 Level 070702
c --- Modifications by F.Robe
c     (1) Correct array index of tgrada (nwat instead of ns) in WATER2
c     (2) Correct array index of xowsta in WIND1 (only a pb if barriers
c          are used)
c     (3) Replace calls to r2interp by calls to r2interp2 to interpolate
c         rh850,ccp,qctot,and ceil4 in RDMM5 as r2interp2 is designed for  
c         2D arrays while r2interp is for a slice of a 3D array (does not
c         affect the results but cleaner)- Modified: RDMM5 
c     (4) Replace calls to r2interp by calls to r2interp2 to interpolate
c         rhop, rh850, rh, and ccp in RDMM4 (does not
c         affect the results but cleaner)- Modified: RDMM4
c     (5) Interpolate ceiling height from cloud=4 option with cinterp
c         rather than r2interp (using modified cinterp for 2D arrays)
c         Technical enhancement (affect icloud=4 ceiling height results
c         if partly cloudy sky)
c     (6) Modify Cinterp to take into account the 2D nature of the ceiling
c         height arrays (does not affect the results but cleaner)
c         Modified: CINTERP,RDMM4,RDMM5
c     (7) Restrict spatial interpolation of ccp to icloud=4 option (do not
c         affect results but can stop execution with some compilers. Fix 
c         needed for Versions 6.217 and up)
c         Modified: RDMM5
c     (8) Initialize ldwat sooner in the code to avoid non-initialization
c         if no water stations (with results depending on default value
c         assigned to ldwat by compiler)
c         Modified: TEMP3D
c     (9) only readjust extrapolation weights for valid calm wind data 
c         (results were correct before because no weight was given 
c         to unvalid data but ws10 was not defined in that case which  
c         might cause execution to stop with some compilers)
c         Modified: WIND1
c    (10) Use proper year variable name in Y2K test - Modified: RDHDU
c    (11) Update roughness legnth and log profile coefficients for surface
c         stations located on a water gridcell
c         Modified: WIND1
c    (12) assign z0 value sooner in the code so that filled in even when
c         no valid overwater stations - Modified: WATER
c    (13) Define ws10 also when buoy anemometer height is 10m otherwise 
c         undefined for use in DELTAT method (ICOARE=0) and for the 
c         computation of u* in neutral conditions when observations are 
c         missing. Also affects runs with ITWPROG=2 and ICOARE=10 when 
c         lowest M3D level is at 10m
c         Modified: WATER2,WATER2P 
c    (14) Set buoyancy flux to 0 when missing OW data (neutral)
c         Modified: WATER2
c    (15) Only fill in indx array when valid MM5 records (not when skipping)
c         (useless and besides, index not definied when skipping records)
c         Modified RDMM5
c    (16) Pass on proper value of ilapse to MIXHMC and MIXHBG if overwater
c         gradients are computed from 3D.DAT data (gradient was undefined
c         if itwprog=2)
c         Modified: WATER, WATERP, WATER2, WATER2P
c    (17) Read the MM5 land use into ILU4 array in RDHD51 and RDHD52.
c         This is already done in RDHD53.
c    (18) Allow initial HTOLD convective mixing height to be less than
c         ZIMIN in MIXHT2 and MIXHT2ST
c    (19) Convective velocity (wstar) overwater strictly based on convective  
c         mixing height if ziconv is computed 
c         Modified: WATER, WATERP
c    (20) Echo all input parameter values, even those not listed in input file
c         (for which default values are then used)
c         Modified: READCF
c    (21) Initialize temp2d,irh2d and rho to ensure they are also defined when
c         iwfcod=0 (obj. analysis only) (and add iall=2 option to skip
c         upwind averaging of temperature during that initialization)
c         Modified: DIAGNO, SURFVAR
c    (22) Make sure vertical extrapolation is not done for iextrp=1
c         Modifed: DIAGNO
c    (23) Read axtz as formatted variable if surf.dat is formatted (LL proj)
c         Modified: RDHD
c    (24) Default value for THRESHL reset to 0 for consistency with older
c         CALMET versions and regulatory assumptions
c         Modified: READCF
c
c --- V6.221 Level 070327  to V6.222 Level 070404 
c --- Modifications by F.Robe
c     (1) Initialize the following variables (non-initialization of  
c         thse variables do not affect results but may cause execution
c         to stop with some compilers:
c            - nlevag1,TZ,ZL, TZ1,ZL1 in RDMM4, RDMM5 
c            - dt_wrm  in BULK_FLUX to avoid execution stop with some
c              compilers when jwarm=0 (COARE option)
c            - um,vm in PREPDI
c     (2) Supply ceiling height values to RADFLX subroutine in observation
c         mode (otherwise wrong long wave flux passed on to COARE if COARE
c         option selected)- Modified: COMP, DIAGNO, RADFLX
c     (3) Fill in gridded cloud array with observations for icloud=0,1
c         to provide correct cloud data to RADFLX (otherwise wrong long 
c         wave flux passed on to COARE if COARE option selected)
c         Modified: COMP, OUTCLD
c     (4) Pass on values of dptt to WATER, WATERP, WATER2 and WATER2P  
c         via tjump internal common for call to MIXHMC (otherwise 
c         undefined/un-initialized)
c     (5) Include COORDLIB Version: 1.98 Level: 060911 which has the 
c         following Changes that allow a higher level of FORTRAN error
c         checking:
c         - Replace the constant 4 with an I*4 variable (IUNIT4) in
c           calls to GTPZ0 from COORDS (to/from lat-lon).
c         - Set GTPZ0 argument LENGTH=100 (for direct access files
c           that are not used).
c         - Replace constant 0 with I*4 variable (INSPHZERO) 
c           in argument 1 of SPHDZ0 call in GTPZ0
c         - Change FUNCTION ADJLZ0 argument name and reassign to LON 
c           within(sub is called with a computed argument that should 
c           not be changed within subroutine)
c         - SAVE9 is undefined first time in PJINIT; set to zero in DATA
c     (6) Decode  beginning date of precipitation record in 2.1 format
c         for proper debug writing (debug mode only)
c     (7) bug fix: in noobs temp mode (ITPROG>0) , adjust temperatures 
c         to adiabatic profile up to the convective mixing height 
c         (it was done up to an un-defined height i.e. 0 or random 
c         height depending on compiler)-  Modified: TEMP3D
c
c
c --- V6.220 Level 070206 to V6.221 Level 070327 
c --- Modifications by Zhong Wu and F.Robe
c     (1) Initialize cloud fraction arrays and indices in CLOUD4
c     (2) Use proper year variable names for format2.1 in Y2K test
c         (bug fix but will only stop runs with some compilers; does not
c         affect results if run starts) - Modified: RDHDU 
c     (3) Include 'grid.met' in MIXHTST and MIXHT2ST for debug output
c         call to OUT (otherwise debug output can be very large depending
c         on default values for nx,ny)
c     (4) Add ldbhr to OUTPT.MET and include OUTPT.MET in mixhtst and
c         mixht2st (Was not defined in those subroutines earlier on)
c         Modified: COMP, ELUSTR2,MIXHTST, MIXHT2ST, OUTPT.MET
c     (5) Print out requested variables in list file on hourly basis 
c         (i.e. use nsecb for test instead of isecb)
c     (6) CALUTILS from v2.54 Level 061020 to v2.55 Level 070327
c         Fixed format bug in subroutine BASRUTC for the case of
c         time zone zero (output string was 'UTC+0  0' instead of
c         'UTC+0000'
c         Modified:  UTCBASR, BASRUTC
c --- Modifications suggested by B. Brashers (FRR):
c     (7) Modify computation of prognostic density RHOP in RDMM5  
c         such that it is properly (re)initialized at each timestep, 
c         is always computed at the surface, and is not forced to increase
c         The non-initialization of RHOP could produce wrong values 
c         with some compilers (e.g. PGI  in Linux)
c     (8) Initialize beginning/ending times of surface and precipitaion
c         records (2.1 versions datasets with explicit beg/ending times
c         with seconds) Modified: COMP

c --- V6.219 Level 070123 to V6.220 Level 070206 
c --- Modifications by F. Robe
c     (1) Define lcalgrdi as logical and perform tests on False/true
c         rather than 0/1 in RDHDMET (relevant for IGF-CALMET runs)       
c     (2) Compute ceiling height based on predicted high, middle, and
c         low  cloud fractions for the ICLOUD=4 cloud option instead of 
c         using a single default value of 8,000ft when no prognostic 
c         cloud data is available(CLOUD4/RDMM5/RDMM4 subroutines)
c
c --- V6.218 Level 070113 to V6.219 Level 070123
c --- Modifications by F. Robe
c     (1) When ITWPROG=2, compute the nearest M3D water gridpoints to 
c         all CALMET gridpoints (not just CALMET water gridpoints) to
c         avoid failure in WATER2P  when the nearest CALMET gridpoint 
c         to a buoy is inland - Changes to RDHD5 -
c      
c --- V6.217 Level 061230 to V6.218 Level 070113 
c --- Modifications by F. Robe
c     (1) Allow the use of spatially varying surface temperature in
c         the computation of terrain-induced circulations (instead of  
c         using a single domain representative surface temperature Tinf).
c         Option triggered by ISURFT=-1 (default value) 
c         Additionally, ISURFT=-2 triggers the computation of domain-average 
c         sf temperature when prognostic temperatures are used (ITPROG=2). 
c         Not recommended but exists for consistency with previous versions
c         and with MOD5 results)
c         Modified: DIAGNO,TOPOF2, FRADJ, SLOPE, CGAMMA2, PREPDI, 
c                   READCF, CALMET.INP
c     (2) Allow the use of spatially varying surface lapse rate in
c         the computation of terrain-induced circulations (instead of  
c         using a single domain representative lapse rate ).
c         Option triggered by IUPT=-1 (default value) 
c         Additionally, IUPT=-2 triggers the computation of domain-average 
c         lapse rate when prognostic temperatures are used (ITPROG>0). 
c         Not recommended but exists for consistency with previous versions
c         and with MOD5 results)
c         Modified: DIAGNO, TOPOF2, FRADJ, CGAMMA2, DIAGI,CGAMMA
c                   PREPDI, READCF, COMP, MIXHT, MIXHTST, STHEOR, ELUSTR2,
c                   CALMET.INP, MEt1.MET
c     (3) Removed obsolete common /S1/ in subroutine SLOPE and /T1/ in TOPOF2
c     (4) Reformatted header comments in subroutines TOPOF2, FRADJ
c     (5) Reworded description of ISURFT,IUPT, IDIOPT1,IDIOPT2,IDIOPT3.
c         IUPWND and ZUPWND in CALMET.INP and READCF output comments
c     (6) Removed variable BETA2 which was never used
c     (7) Bug fix: correct date comparison in RDMM4 s.t. ok at midnight
c
c --- V6.216 Level 061230 to V6.217 Level 061231  
c --- Modifications by F. Robe
c     (1) Implemented new NOOBS cloud cover computation method, using
c         prognostic RH, based on MM5toGrads algorithm 
c         New CLOUD4 subroutine and ICLOUD=4 value for this option  
c         Changes to CALMET.INP, ELUSTR, ELUSTR2, HEATFX, PGTSTB, RDHD5
c         RDMM4, RDMM5, CLOUD3 (old name: cloud), CLOUD4 (new),READCF      
c     (2) Renamed CLOUD subroutine CLOUD3 subroutine
c     (3) Modified QCKSRT3 to sort 7 arrays
c
c --- V6.215 Level 061020 to V6.216 Level 061230  
c --- Modifications by F. Robe
c     (1) Bug fix in RDMM4: correct record dates comparison so that
c         the MM4 fields used in CALMET are properly updated on an 
c         hourly basis
c     (2) Bug fix in RDMM4 such that prognostic surface temperature  
c         is computed  correctly (affects all runs using MM4 temperatures)
c     (3) Bug fix in PROGRD: Check ending hour (instead of beg. hour)
c         against progn. record hour (to be consistent with MOD5)
c     (4) Bug fix in PROGRD: make sure to skip reading progn. records
c         for subhourly CALMET timesteps
c     (5) pass nsece to PROGRD instead of nsecb to have consistent
c         notations.
c     (6) Fixed typo in RDUPN (introduced in V6.215)
c     (7) Ensure that precipitable water remains within algorithm range
c         of applicability (RADFLX)
c     
c --- V6.214 Level 060528 to V6.215 Level 061020
c --- Modifications by DGS
c     (1) Test of time span for UP.DAT files did not fully account for
c         time shift between base time zone and UTC, causing an
c         unnecessary halt
c         Modified: RDHDU
c     (2) CGAMMA updated for begin time processing of UP.DAT with
c         seconds (interpolation factor assumed difference between
c         soundings was still in hours, not seconds, so interpolation
c         resulted in using second sounding)
c         Modified: CGAMMA, PREPDI
c     (3) Fix diagnostic write statements that use old hour-ending
c         variable names; activate hour-ending times for MESOPAC
c         output option and restrict output to NSECDT=3600
c         Modified: COMP, READCF
c     (4) UP.DAT dataset version 2.1 snapshot soundings (begin time =
c         end time) are given new begin times that precede the snapshot
c         time by 1 CALMET step.  If the CALMET step is 1 hour, then a
c         sounding at 12Z is given a begin time of 11Z, and is
c         therefore used for the CALMET period from 11Z to 12Z.  If the
c         step is 900s (15 minutes), the sounding is given a begin time
c         of 11Z+2700s (11:45Z) and is used for the CALMET period from
c         11:45Z to 12Z.  Treatment of average soundings (begin time <
c         end time) is not altered, and care should be exercised in
c         using such soundings when the averaging period is not equal to
c         the CALMET step.  Older UP.DAT files (no begin time) are also
c         treated as snapshots.
c         Modified: RDUP, RDUPN, COMP
c     (5) CALUTILS from v2.52 Level 060519 to v2.54 Level 061020
c         Move GLOBE1 to COORDLIB
c         Allow negative increments in INCRS
c         Modified:  INCRS
c         Removed:   GLOBE1
c     (6) COORDLIB from v1.95 Level 050126 to v1.97 Level 060626
c         Add Albers Conical Equal Area projection
c         Add GLOBE1 (from CALUTILS)
c
c --- v6.213 Level 060525 to V6.214 Level 060528
c --- Modifications by F. Robe
c --- Changes contributed by Ken Richmond, Geomatrix Consultants)
c     (1) Use SST in celsius rather than kelvins for call to COARE
c         Modified: WATERP
c     (2) Set wave height and period to missing when there are no buoy data 
c         Modified: WATER2P 
c --- Additional changes:
c     (1) Overwater, clear up the confusion between buoyancy flux and sensible heat flux
c         Make sure to use the buoyancy flux to compute the convective velocity scale. 
c         QH used to refer to the buoyancy flux when computed by deltaT method and to 
c         the sensible heat flux when computed by COARE
c         Modified: DeltaT, WATER
c     (2) Overwater, store the buoyancy flux into the sensible heat flux array QH
c         (common block metgrd.met): this was already the case when deltaT method
c         was used (i.e . historically). The Sensible heat flux array QH is truly a
c         buoyancy flux array (= sensible heat flux overland but not overwater where
c         effect of moisture on buoyancy is not negligible)
c         Modified: WATER
c     (3) Compute the buoyancy flux in terms of <W'Tehtav'> after call to DeltaT
c         to pass on to mixing height subroutines
c         Modified: WATER2, WATER2P
c     (4) Skip definition of qe in water/waterp and of thstar,qh,qe WATER2, WATER2P
c         as never used 
c         modified : WATER,WATERP,WATER2,WATER2P
c
c --- v6.212 Level 060519 to v6.213 Level 060525
c --- Modifications by DGS
c     (1) Impose a minimum RH of 1% when computing the precipitable
c         water (wp) in RADFLX.  IRH=0 resulted in wp=0.0, which then
c         makes LOG10(wp) undefined (error stops run).
c         Modified:  RADFLX
c     (2) Add GRID.CMN to MIXHT2ST for debug output call to OUT
c         (Change contributed by Bart Brashers, Geomatrix Consultants)
c         Modified:  MIXHT2ST
c     (3) Change nsec1 (not initialized) to isec1 (initialized to 0) in
c         call to DELTSEC. 
c         (nsec1 problem identified by Bart Brashers, Geomatrix
c         Consultants) 
c         Modified:  RDMM5
c
c --- v6.211 Level 060414 to v6.212 Level 060519
c --- Modifications by DGS
c     (1) Revise placement of QA test on input date of simulation
c         (QA on MOD5 control file failed)
c         Modified:  READCF
c     (2) Reset character*4 CTIME array from (1,4) to (70) to
c         match character*70 ABTZ declaration
c         Modified:  READCF
c     (3) CALUTILS from v2.51 Level 051019 to v2.52 Level 060519
c         Variable names in control file are not processed correctly
c         if there are too many characters (including blanks) to the
c         left of the "=" sign (run stops in setup phase).
c         Modified:  READIN
c
c --- v6.210 Level 060408 to v6.211 Level 060414
c --- Modifications by DGS
c     (1) IGF CALMET file produced a read error when no precip stations
c         are in the file because I2DMET was not set.
c         Modified:  RDHDMET
c
c --- v6.209 Level 060331 to v6.210 Level 060408 
c --- Modifications by F.Robe  
c     (1) Add user-input parameter IRHPROG to allow use of prognostic
c         RH in noobs=0,1 cases (stored in MET1.MET) and change internal
c         array name irhprog(mxnx,mxny) to irhpg(mxnx,mxny)
c         IRHPROG=0 : use RH from SURF.DAT file (default)
c         IRHPROG=1 : use prognostic RH (from M4/MM5/3D.DAT files)    
c         Modified: READCF, SURFVAR,RDMM4,RDMM5,BLOCK DATA, MET1.MET
c
c --- v6.208 Level 060329 to v6.209 Level 060331
c --- Modifications by DGS  
c     (1) Revise error report text for runs that do not start before
c         5AM
c         Modified:  COMP
c
c --- v6.207 Level 060328 to v6.208 Level 060329
c --- Modifications by DGS  
c     (1) Fix date matching test on precip.dat file dates for old
c         file format (MOD5)
c         Modified:  COMP
c     (2) Revise end-of-run text to list file
c         Modified:  FIN
c
c --- v6.206 Level 060322 to v6.207 Level 060328 
c --- Modifications by DGS  
c     (1) Modify test for start of MM4 data records
c         Modified:  READHD
c
c --- v6.205 Level 060309 to v6.206 Level 060322 
c --- Modifications by F.Robe  
c     (1) Replace mod5 nhrz and ihrgmt by mod6 nhrzb (COMP)
c     (2) Store previous hour prognostic temperature profile in TZO (RDMM5)
c         instead of '2-hour-ago' progn. temp.(important for mixing height
c         growth when prognostic lapse rates are used itprog=1,2; itwprog=1)
c     (3) Fixed typo in WATER that used the overwater (OW) Tair from
c         the last OW station in the list with the Tair-Tsea difference
c         from the nearest OW station when computing Tsea for the 
c         nearest OW station.(V5.719 Level 060314  by DGS)
c         Modified: WATER, WATER2
c     (4) Make sure SST is above -3C (WATER/WATER2/WATERP/WATERP2)
c     (5) Allow for round-off error when checking for missing ZOWSTA (WATER)
c     (6) Add a check for missing Tairow before call to COARE and
c         replace by default Tair if missing (WATER)
c     (7) Set default prognostic ocean land use category ILUOC3D=16,
c         corresponding to MM5 ocean LU cat (BLOCK DATA)(also in V5.720)
c     (8) Extrapolate prognostic temperatures from lowest level to
c         the surface over water using either the prognostic SST
c         if available or an adiabatic profile at night (no surface 
c         cooling at night over water) (RDMM5,RDMM4) (also in V5.720)
c     (9) Fill in values of ILU4(mxnxp,mxnyp) no matter ITWPROG value
c         (RDHD53)(also in V5.720)
c    (10) Assign ocean LU to zero elevation MM5 gridpoints for old 
c         format files from which prognostic landuse is not read in
c         (RDHD52)(also in V5.720)
c    (11) Fix date second matching test on calmet/sea.dat (RDOW)
c    (12) Add check for negative log arguments in mixhbg (also in v5.722)
c
c --- v6.204 Level 060304 to v6.205 Level 060309 (internal) 
c --- Modifications by F.Robe (internal 060308) 
c     (1) Modified MIXHBG : Replace Tk by dummy variable tsf 
c         in call to mixdt2 otherwise mixdt2 overwrites Tk with MM5 
c         surface temperature (not ok for all options e.g. overwater)
c         (also in V5.718 Level 060305)
c     (2) Fix date matching test on beginning times MM5/CALMET in READHD
c     (3) Fix date matching test on calmet/surf.dat dates for old surf.dat
c         file format (Subroutine COMP)
c     (4) Fix date matching test on calmet/sea.dat (RDOW)
c     (5) Change argument type from real to integer in call to delsec (RDMM5)
c     (6) Do not compute nowtz (MOD5 variable) as nhr,njul and nyr are no
c         longer updated (COMP)
c     (7) replace nhr by nhrb in day loop (COMP)
c
c --- Modifications by D. Strimaitis (internal 060309) 
c     (8) COORDLIB from v1.95 Level 050126 to v1.96 Level 051010
c     (9) CALUTILS from v2.5 Level 041123 to v2.51 Level 051019
c    (10) Filnames changed from c*70 to c*132 (for CALUTILS V2.3
c         and later)
c         Modified:  FILNAM.MET , READFN, WRFILES
c
c --- v6.203 Level 060301 to v6.204 Level 060304 
c --- Modifications by F.Robe
c     (1) Convert argument of min/sign function from single to double 
c         precision to avoid compiler warnings in Linux 
c         Modified: COARE original subroutines ASL,PSIUT,PSIT,ZETA,PSIUD,PSITD
c
c --- v6.202 Level 060219 to v6.203 Level 060301 
c --- Modifications by F.Robe
c     (1) Replace numerical integration of the BG equations for mixing height
c         growth by an analytical integration method ("false images") to
c         optimize accuracy/CPU time (also in V5.716 Level 060228)
c         ( MIXHBG + new function FBG)
c     (2) Test whether convective growth based on net surface buoyancy flux 
c         (wt-wto) (i.e. consider threshold too) in MIXHMC 
c     (3) Calculate values for Tht and THTP even when negative net flux (ilapse=1)
c         as they are needed in mixht/mixht2 in that case too (MIXHBG,MIXHMC)
c
c --- Version 6.201 Level 060218 to Version 6.202 Level 060219
c --- Modified by F.Robe
c     (1) Correct interpolation of sine solar angle between 1800s 
c         and 3600sec (subroutine COMP)
c     (2) Delete wrong definition of onedte and twodte in MIXHMC
c
c --- Version 6.2 Level 060215 to Version 6.201 Level 060218
c --- Modified by F.Robe
c     (1) Add QA output file of SEA.DAT station locations
c         (also in V5.714 Level 060217  by D. Strimaitis)
c         Modified: PARAMS.MET, OUTPT.MET
c         Modified: BLOCK DATA, SETUP
c         New     : QAPLOT1
c     (2) Add check for different datum code when testing header of
c         SEA.DAT file (also in V5.714 Level 060217 by D. Strimaitis)
c         Modified: RDHDOW
c     (3) Use dgrid instead of dx,dy (not yet defined) in microi to
c         compute grid points latitude, longitude and solar angle
c         Modified: MICROI
c
c --- 5.711 Level 060106 to Version 6.2 Level 060215 (Merged MOD5-MOD6)
c --- Modified by F.Robe
c     (1) Merge with V5.6 Level 041208 changes: 
c         - Implement hour-ending and explicit beginning/ending times with seconds 
c           in SURF.DAT, PRECIP.DAT and UP.DAT, CALMET.DAT, CALMET.INP (stored
c           in GEN.MET);
c         - call new explicit time subroutines (RDSN,RDUN,RDPN) according to          
c           Dataset version numbers (which are stored in MET1.MET)
c         - Time zones in input and output are relative to UTC and formatted
c           as character*8  variables. Internally, the "CALMET" convention
c           (opposite to UTC) is still used. 
c         - First line of CALMET.INP indicates that new 2.1 format i.e.
c           New parameters: IEYR,IEMO,IEHR,IESEC,IBSEC, ABTZ
c           IRLG  and IBTZ are no longer input (computed internally).
C           CALMET can still read pre-2.1 CALMET.INP files
c         - New CALUTILS V2.5 (041123) (with utcbasr and basrutc subroutines)
c         - Changes to RDHD, RDHDU, READCF,READCF, OUTHD,OUTHR,
c           WRTR2D, WRTI2D. WRTR1D, WRTI1D, GEN.MET, MET1.MET
c           UPMET.MET,CALMET.INP
c     (2) Merge with V6.01 Level 051206 changes: 
c         - Implement sub-hourly timestep in all pre-MMS subroutines 
c         - Still hourly solar angle
c
c     (3) Specific post-v5.711/V6.01 changes:
c         - Compare timestep beginning time with SEA.DAT records taking into account
c           that the latter are still in hour-ending time format
c           (also in v6.02 level 060206)
c         - Replace real argument deltas/deltskip by integer ndeltas/ndeltskip 
c           in call to deltsec in subroutines RDMM4/5 (also in V6.03 Level 060207)
c         - solar angle computed on hourly basis (25 values) and linearly 
c           interpolated to half-time steps (COMP,SOLAR and GEN.MET)
c         - Bug fix: Use solar angle at nearest CALMET gridpoint to 
c           determine sunrise/sunset in RDMM4/RDMM5  (rather than 
c           solar angle on CALMET grid which could have caused  
c           array dimension mismatch if NXP> MXNX and/or
c           NYP>MXNY) (also in V5.712 Level 060213 and v6.04 Level 060213)
c         - Bug fix: time-index of sinalp shifted by 1 hour in RDMM4/RDMM5
c           (also in V5.713 Level 060215 and V6.05 Level 060215)
c
c --- version 5.7 Level 051230 to Version 5.711 Level 060106
c     (1) Allow initial guess field to be built up from existing 
c         CALMET.DAT files 
c         Different format/resolution/options IGF-CALMET.DAT files 
c         allowed but with hourly records only. Overlapping periods
c         are resolved. 
c         Same map projection and datum for IGF and current CALMET
c         New subroutines: RDHDMET, RDCALMET,RDMET2,R2INTERPI
c         Imported from PRTMET: RDR1D,RDI1D,RDI2D
c         Modified: READCF,READFN,WRFILES, READHD, SETUP,RDR2D,DIAGNO, SETUP
c         Modified PARAMS.MET: add MXIGF(max number of igf-calmet files)
c           and io18=18 (file unit for IGFCALMEt files) and
c           mxnxi,mxnyi,mxnzi (max dimensions for IGF-CALMET)
c         Modified WPARM.MET: add igfmet (flag to use coarse CALMET
c           files as IGF)
c         Modified FILNAM.MET: add IGFDAT filenames
c         New IGF.MET: parameters and variables related to IGF-CALMET
c    
c --- Version 5.614 Level 051218 to version 5.7 Level 051230
c --- Modifications by J. Scire
c     (1) MIXHMC: Correct check of max mixing ht, add checks of range
c         of WT and debug write statements, update comments
c     (2) Common /OVRWAT/ Update comment on THRESHW default to
c         0.05 W/m2/m
c     (3) BULK_FLUX:  Introduce STI change to COARE warm layer 
c         algorithm (minimum stress of 0.002)
c     (4) ASL: Introduce STI change to COARE evaporative cooling/
c         net absorption eqn (coefficient of 0.137 changed to 0.060)
c     (5) READCF:  Change default values for COARE IWARM and ICOOL
c         options to OFF
c
c --- Version 5.613 Level 051227 to Version 5.614 Level 051228
c --- Modifications by F. Robe 
c     (1) Use actual SST sensor depth in COARE if available. 
c         Modified: WATER,WATERP,WATER2,WATER2P,COARE
c     (2) Change the default SST sensor depth from 0.05m (floating
c         sensor) to 0.6m when SEA.DAT is used(NDBC moored buoy SST 
c         sensor depth). Keep 0.05m if SST come from prognostic model
c         Modified: WATER,WATERP,WATER2,WATER2P,COARE
c     (3) Change missing value indicator from -999. to 9999. for
c         wave height and period initialization in RDHDOW
c 
c --- Version 5.612 Level 051214 to Version 5.613 Level 051227
c --- Modifications by F. Robe 
c     (1) Add option to read in SEA.DAT files versions 2.11. 
c         Added features: time zone, Air Temp Sensor Height, Water Temp 
c         Sensor Depth + format changes . Initialize values in RDHDOW
c         Modified: RDHDOW,RDOW and OVRWAT.MET
c     (2) Use actual Tair sensor height instead of anemometer height
c         in call to COARE if available (SEA.DAT versions 2.11+). 
c         Modified: WATER, WATER2
c
c --- Version 5.611 Level 051113 to Version 5.612 Level 051214
c --- Modifications by F. Robe and D. Strimaitis
c     (1) Replace call to water2p by call to water2 when itwprog<2 in
c         subroutine STHEOR
c     (2) Use double precision argument for PSIUD (elustr)
c     (3) Use only one iteration for the computation of surface fluxes
c         in ASL subroutine (COARE module) to insure numerical stability
c
c --- Version 5.61 Level 051111 to Version 5.611 Level 051113
c --- Modifications by F. Robe
c     (1) Allow use of prognostic overwater deltaT for offshore BL 
c         computations (only possible for 3D.DAT version 2.0 and higher 
c         if SST is part of datasets i.e. for MM5 but not RUC or ETA)
c         - New input parameter ITWPROG
c           ITWPROG = 0 : deltaT from SEA.DAT     
c                   = 2 : prognostic deltaT (from 3D.DAT)
c         - New input parameter: ILUOC3D (Land use category flagging ocean
c           land use in 3D.DAT dataset - only used for ITWPROG=2)
c         - Modified: READCF, WATER, WATER2, READHD, RDHD5,RDHD53,
c                     RDMM5,COMP,DIAGNO, DELTAT
c                     OVRWAT.MET,MM4HDO.MET,CALMET.INP
c         - New subroutines: WATERP and WATER2P
c         - New include file: M3DMET.MET
c     (2) Remove zimin from MIXHMC calling list ( MIXHMC,WATER, WATER2,
c         MIXHT,MIXHTST,MIXHT2, MIXHT2ST)
c     (3) Replace index+1 by index1 in call to STULL (RDMM5,RDMM4)
c         only affects prognostic datasets with redundant lowest levels
c         (this fix was only partially implemented before)
c
c --- Version 5.6g Level 051109 to Version 5.61 Level 051111
c --- Modifications by D. Strimaitis
c     (1) Change missing value indicator from -999. to 9999. for
c         wave height and period in SEA.DAT dataset 2.1 format.
c         Stop processing if wave period is zero.
c         Modified:  RDOW
c     (2) Reset defaults as follows:
c         ICOARE = 10  (not 0)
c         IMXHT = 1    (not -1)
c         Modified:  READCF
c     (3) Use a free-format read for the number of comment records
c         in the 3D.DAT file
c         Modified:  RDHD53
c     (4) Store rverow as an array to check each SEA.DAT file
c         Modified:  OVRWAT.MET
c         Modified:  RDHDOW, RDOW
c     (5) Change in RDMM5 to fix an errant test in IFIRSTPG
c
c --- Version 5.6f Level 050824 to Version 5.6g Level 051109
c     (V5.6g includes all changes made in parallel versions 
c     5.552/5.553/5.554)
c --- Modifications by F. Robe
c     (1) Allow new 3D.DAT format (version 2.1) with new format for
c         liquid and frozen moisture variables (changes to RDMM5)
c     (2) Bug fix for last timestep at end of leap year in RDMM5 
c --- Modifications by D. Strimaitis
c     (3) Correct QA test for IEXTRP=1 that requires BIAS(2+)=1 so that no
c         warning is made if the bias is already set properly.
c         Skip BIAS/IEXTRP checks if surface obs are not used
c         Modified:  READCF
c
c --- Version 5.6e Level 050520  to Version 5.6f Level 050824
c     Modified by D. Strimaitis
c     (1) Check for missing Tair-Tsea before calling COARE
c         Modified:  WATER2
c
c --- Version 5.6d Level 050428  to Version 5.6e Level 050520
c     Modified by D. Strimaitis
c     (1) Fix typo: ZIOBS should be IZIOBS
c         Modified:  WATER
c     (2) Restore IPROG constraints before call to RDHD5
c         Modified:  READHD
c     (3) Replace common /charney/ with /charnock/ -- an old section of
c         code was used in version 5.6c that partially reversed changes
c         made in version 5.6a
c         Modified:  COARE
c
c --- Version 5.6c Level 050419  to Version 5.6d Level 050428
c     Modified by F.Robe
c     (1) - Fix log profile coefficients and OW mixing heights when multiple
c           overwater stations (RDOW-WATER)
c     (2) - Declare tstar,qstar as real*8 in water2 (for COARE)
c     (3) - Remove npsta from calling list to rdhd5 
c
c --- Version 5.6b Level 050412  to Version 5.6c Level 050419
c     Modified by F.Robe
c     (1) - Add user-input to select warm layer COARE options
c           IWARM and ICOOL for warm layer and cool skin computations
c           (new  CALMET.INP and OVRWAT.MET)
c     (2) - Move overwater surface flux input parameters (icoare,dshelf)
c           to Input Group 6 => new CALMET.INP (compatible with
c           pre-MMS codes (pre-050328) but not intermediate MMS codes)
c     (2) - Ensure that the warm layer COARE option is applied
c           independently to each overwater gridpoint (Changes to
c           subroutines COARE, BULK_FLUX, WATER2)
c     (3) - Remove 6AM deadline for start of warm layer integration
c           (subroutine bulk_flux)
c --- Version 5.6a Level 050331 to Version 5.6b Level 050412
c     Modified by F. Robe
c     (1) Add checks in AVEMIX and AVETMP to ensure upwind averaging
c         of mixing heights and temperatures is done over gridpoints
c         within cone of influence and mnmdav-side square only.
c
c --- Version 5.6 Level 050328  to Version 5.6a Level 050331
c     Modified by D. Strimaitis
c     (1) Fix typo that causes DSHELF variable to be zero in all calls to
c         the COARE module, and correct all references to Charnock
c         Modified:  OVRWAT.MET, COARE, ASL
c
c     (2) Correct QA test for IEXTRP<0 that requires BIAS(1)=-1 so that no
c         warning is made if the bias is already set properly.
c         Modified:  READCF
c
c --- Version 5.551 Level 050310  to Version 5.6 Level 050328
c
c *** MMS - COARE  modifications by F.Robe:
c     (1) Add option to use the Coupled Ocean Atmosphere Response Experiment 
c         (COARE) bulk flux model for computing Zo, u*, L and QH overwater
c         User-input ICOARE paramete with values of 0,10,11,12 corresponding 
c         to: 0=deltaT method, 10,11,12=COARE method with COARE wave options
c         0,1,2 respectively. 
c  
c     (2) Add option to use measured wave properties with COARE. Dominant  
c         Wave period and wave height are read in from SEA.DAT files (new
c         SEA.DAT format VErsion 2.1) 
c         Use of equilibrium properties vs. observed properties is flagged
c         by positive/negative ICOARE input parameter (in CALMET.INP) 
c         Computations dones in New Subroutine COARE (original 
c         COARE 2.6 bw flux model and associated subroutines 
c         (self-contained set of subroutines to allow easy updates))
c
c     (3) New subroutine DELTAT which isolates the deltaT computations
c         that used to be in the WATER/WATER2 subroutines. Either DELTAT 
c         or COARE are called depending on values of ICOARE
c
c     (4) Modification of the original COARE code for shallow water:
c         A shallow water corrective factor of the Charnock parameter
c         is introduced to reflect higher values of charn in shallow 
c         waters. A typical ength scale for the coastal region is introduced 
c         (dshelf, reflecting the coastal shelf extent) such that charn varies 
c         between the shallow water value and the deep sea value depending
c         on the distance to the nearest coast (DCOAST(i,j))-
c         dshelf is a new user input in CALMET.INP -DCOAST is computed
c         in new subroutine SETCOAST and stored in GRID.MET
c
c     (5) Debug option to write out the distance to the coast
c         Gridded 2D field in GRD format - Default filename DCST.GRD 
c         New input parameter (LDBCST) and filename (DCSTGD) in CALMET.INP
c
c     (6) New subroutine RADFLX to compute downward long wave radiative flux
c         at the surface (only called when COARE option is selected)
c      
c     (7) Invert T*,Q* assignments in subroutine bulk_flux (COARE) otherwise
c         tstar takes a e+92 value when qstar is assigned so tstar
c         must be assigned AFTER qstar.  It does not make any sense but 
c         I can't find out why (common and declaration apparently match)
c         
c     (8) Change SEA.DAT version number (2.1) to reflect changes in the
c         data (removed: xowlon, added: observed wave properties twave,hwave).
c         Twave=dominant wave period; hwave=significant wave height
c         lat/lon of overwater stations are computed internally.
c         Internally, xowlon is East longitude (no longer west longitude, 
c         except in old SEA.DAT files)
c
c     (9) Subroutine MICROI: compute mapping parameters from (x,Y) CALMET
c         to N.LAt, E.Long, store them in MAP.MET, and  N.LAt, E.Long in
c         GRID.MET- Compute gridded value of  Coriolis parameter
c         as a function of the latitude at each gridpoint. FCORIOL is no longer
c         an input but if an old CALMET.INP is used, the gridded values will all  
c         be overwritten by the single user-input value. Stored in ZIPARM.MET
c         Also made cmech an array and tore in ZIPARM.MET
c
c    (10) Initialize important COARE constants and conversion factors
c         in subroutine bulk_flux rather than in subroutine ASL, otherwise
c         crash when warm layer calculations (bug already in original COARE
c         program)
c
c
c
c *** MMS - Convective Mixing Height modifications by F.Robe
c
c     (1) New convective boundary layer parameterization following
c         Batchvarova and Gryning (1991,1994).
c
c     (2) Convective mixing height parameterizations applied to overwater 
c         cells as well land cells
c
c     (3) New convective boundary layer input parameters:
c          IMIXH = 1: Maul-Carson for land and water cells
c                =-1: Maul-Carson for land cells only - Original
c                     OCD mixing height overwater (i.e. pre-MMS version)
c                = 2: Batchvarova and Gryning for land and water cells
c                =-2: Batchvarova and Gryning for land cells only - Original
c                     OCD mixing height overwater
c                  Stored in HFLUX.MET
c
c         THRESHW: threshold buoyancy energy flux per meter of marine
c                  boundary layer required for Mixing Growth overwater
c                  (default: 0.05 W/m2 /m)- Stored in OVRWAT.MET
c       
c         THRESHL: threshold buoyancy energy flux per meter of land
c                  boundary layer required for Mixing Growth over land
c                  (default: 0.05 W/m2 /m)- Stored in ZIPARM.MET
c
c         ITWPROG: Flag to use either SEA.DAT (or default constant) 
c                  overwater lapse rates or prognostic lapse rates
c                  above the current OW mixing height
c                = 0 : use SEA.DAT air/sea temperatures and lapse rates
c                      for the marine BL growth
c                = 1 : use SEA.DAT air/sea temperatures and MM5 lapse rates
c                Stored in OVRWAT.MET
c
c     (4) Use Tz2,zl2 to initialize tz0,zl0 in rdmm5 instead of tz1,zl1 
c         (important if mixht2/mixdt2 are called at first time step, which
c         could now occur if convective overwater boundary layer 
c
c
c *** MMS - Vertical wind extrapolation modifications by F.Robe
c
c     (1) Scale surface observations (land and water) from anenometer height
c         to first CALMET level using user-defined extrapolation technique
c         (iextrp>1) and or, if non (iextrp=1)e, using a neutral log profile
c         Changes to DIAGNO, WIND1,SIMILT,DIAGI,RDOW,ELUSTR2,WATER2
c
c     (2) Use consistent similarity relations throughout the code
c         (Paulson (1970) and Dyer 91974) for the unstable surface layer,
c         coupled with a free convection relation for large z/L
c         (Gratchev et al, 2000) and new  relations for stable atm.
c         (Beljaars and Holtslag, 1991)
c         => use COARE stabitily functions PSIU and PSIT except with
c         factor 16 instead of 15 for the Kansas unstable function (following
c         Dyer's fit
c         for COARE, add a user-input switch to use original COARE PSIU/PSIT
c         (with factor 15) or, more correct, PSIUD,PSITD with factor 16
c         new PSIUT/D everywhere EXCEPT in subroutine DELTAT (original OCD psiu/psit)
c         Changes to subroutines ELUSTR, ELUSTR2, SIMILT
c
c     (3) Bug fix in WATER2: winds used for OCD (DELTAT) technique were assumed
c         to be at 10m but were in fact at anemometer height. now winds are
c         scaled to 10m using log profile (note:this was not the case
c         for call to DeltaT in subroutine WATER)
c
c     (4) Bug fix in DIAGNO: do not extrapolate missing data (iextrp=2),
c
c
c *** Other modifications (F.Robe):
c
c     (1) Subr RDMM5-RDMM4: use previous hour sounding to compute lapse rate above 
c         previous  hour mixing height (used in MIXDT2 - itprog>0 mode) to avoid
c         unrealistic overgrowth of mixing height.This will change results 
c         obtained with previous versions.
c
c     (2) Bug fix in RDOW: xkm, ykm must be real*4 not real*8 in call to GLOBE
c
c     (3) Explicity common D1/D3/D4/D6 replaced by "include D1-3-4-6.met" in 
c         all relevant subroutines
c
c     (4) Better spatial interpolation of surface temperature,
c         RH and ipcode (may change results: arrays temp2d,irh2d,ipcode2d).
c         and consistent use of the surface variables throughout the code
c         Required changing subroutine calling order in COMP.
c 
c     (5) Add a computation flag in SURFVAR to avoid computing IRH2D and
c         IPCODE2D at every call to the subroutine (2 calls to surface are
c         needed for temperatures temp2d only)
c
c     (6) Use temp2d rather than tprog/tempk in ELUSTR, ELUSTR2, WSTARR
c
c     (7) SURFVAR: use OTEMPK rather than TEMPK in SURFVAR as the former
c         is the original data with missing values and the latter, T data
c         with missing replaced by nearest station value (not ok for spatial
c         interpolation). otempk stored in MET2.MET
c
c     (8) Remove ioutmm5 restriction on NPSTA=-1 as surface precipitation is
c         is always part of the M3D record even if rainfall profiles (qr)
c         are not
c     
c     (9) Correct name CTITLE3 to CTITLE3D in /MM4HDO/.  Dataset title
c         for 3D.DAT was not declared as character field due to typo.
c
c
c --- V5.55 Level 050217 to V5.551 Level 050310
c --- Modifications by D. Strimaitis
c    (1) Modify output format statements to allow surface station IDs
c        to be at least 6 digits long
c        Modified: READCF
c
c --- V5.549 Level 050128 to V5.55 Level 050217
c --- Modified by F.Robe
c     - Properly initialize call to barier in INTER2
c     - Only call barier when nbar> 0 in inter2, interp, wind1
c
c --- V5.548c Level 050125 to V5.549 Level 050128
c    (1) COORDLIB updated to stop UTM conversions with a DATUM that is
c        not mapped to the list in the USGS UTM subroutine.  An example
c        is the sphere datum NWS-84 (Earth radius 6370km), since only
c        the sphere datum ESR-S (Earth radius 6371km) is available.
c        Unmapped datums had defaulted to the Clarke 1866 spheroid.
c        LAZA Projection:  removed assignment of 6370 km earth
c        radius (NWS-84 datum) when a value less than 6000 km is
c        found.  This assignment can override a requested radius
c        of 6371 (ESR-S datum) if the NWS-84 datum is used with
c        any valid projection prior to the request for ESR-S.
c        LAZA(NWS-84) coordinate distances from the projection
c        origin are about 0.016% smaller than LAZA(ESR-S).
c        Error message and version strings added to COORDS calls and new
c        subroutine COORDSVER to report COORDS version documentation.
c        (Version 1.95, Level 050126)
c
c    (2) Added call to COORDSVER to access the COORDS version info and
c        passed string to list file and comment section of output files.
c        Modified: READCF, OUTHD
c
c --- Version V5.548b Level 050113 to V5.548c Level 050125
c --- Modified by F.Robe
c      (1) Save it1,it2 in subroutine RDMM5
c
c --- Version V5.548a Level 050101 to V5.548b Level 050113
c --- Modified by F.Robe
c      (1) Make sure no duplicate prognostic levels are used in subroutines
c          STULL0, STULL (subroutines RDMM4, RDMM5
c
c --- Version V5.548 Level 041101 to V5.548a Level 050101
c --- Modified by F.Robe
c     (1) Apply KBAR (vertical limitation to barriers) to step 2 field 
c         as well. Changes to INTER2,INTERP
c     (2) Rationalize storage of barrier parameters in commons: a) removed 
c         NBAR, XYBAR and KBAR from WPARM, b) added kbar to D3.MET,   
c         c) replaced internal common /d3/ by include external D3.MET 
c         in subroutines bariers and diagno (and changed variable names
c         accordingly), d) include d3.met in block data, readcf,diagi
c         and wind 1 subroutines
c     (3) Cleaned up old comments 
c         
c --- Version V5.547 Level 041016 to V5.548 Level 041101
c --- Modified by F.Robe
c     (1) Implement barriers in initial guess field 
c         Valid for spatially varying initial guess fields based on 
c         observations (changes to WIND1)
c     (2) Introduce user-input KBAR, the level up to which barriers are
c         applied in the initial guess field (no change to step 2 barriers yet)
c         (changes to CALMET.INP,WPARM.MET,READCF,WIND1)
c
c --- Version V5.546a Level 041001 to V5.547 Level 041016
c --- Modified by F.Robe
c     (1) DIAGNO: define water cell by SEA.DAT/landuse and not by 
c         zero terrain elevation (htopo=0) (iextrp=2)
c     (2) Bug fix in MIXHT: RHO is 2D not 1D . (Change in MIXHT,COMP)
c     (3) Allow multiple 3D.DAT (consecutive or overlapping files)
c         Only one 3D.DAT file is open at any time.
c         Changes to RDHD5,RDHD5123,RDHD4,RDMM5,RDMM4,READCF,READFN,
c         SETUP,WRFILE,OPENOT
c         New NM3D and M3DDAT parameters in CALMET.INP, MM4HDO.MET,FILNAM.MET
c         New MXM3D in PARAMS.MET, NFM3D in internal common PROGSTEP
c     (4) Remove NOOBS from WATER's argument list as not needed
c         (change to WATER,COMP)
c     (5) Bug fix in RDOW: xkm, ykm must be real*4 not real*8 in call 
c         to GLOBE
c        
c --- Version V5.546a Level 041001 to V5.547 Level 041010
c --- Modified by F.Robe
c     (1) Bug fix in DIAGNO: define water cell by SEA.DAT/landuse and 
c         not by htopo=0 (iextrp=2)
c     (2) Bug fix in MIXHT: RHO is 2D not 1D . (Change in MIXHT,COMP)
c     (3) Allow multiple 3D.DAT (consecutive or overlapping files)
c         Only one 3D.DAT file is open at any time.
c         Changes to RDHD5,RDHD5123,RDHD4,RDMM5,RDMM4,READCF,READFN,
c         SETUP,WRFILE,OPENOT
c         New NM3D and M3DDAT parameters in CALMET.INP, MM4HDO.MET,FILNAM.MET
c         New MXM3D in PARAMS.MET, NFM3D in internal common PROGSTEP
c     (4) Remove NOOBS from WATER's argument list as not needed
c         (change to WATER,COMP)
c
c --- Version V5.546 Level 040924 to V5.546a Level 041001
c --- Modified by C. Czaja
c     (1) Correction added according to mail from F. Robe
c         dated 4/27/2004, asking to comment the line nowsta=0
c         when noobs=2, sea.dat can be accepted in READCF subroutine.
c --- Version V5.545 Level 040612 to V5.546 Level 040924
c --- Modifications by D. Strimaitis
c     (1) Reset the pressure check in subroutine RDMM4 from 8500
c         to 850 (i.e., millibars)  
c     (2) Add stop in READCF if DATUM in control file is UNKNOWN
c     (3) COORDLIB updated to respond to UTM conversion across the
c         equator from S. hemisphere to N. hemisphere, when the S.
c         hemisphere zone is forced.  Also fixed a problem with the
c         conversion to/from spherical NWS-84 datum when using UTM
c         projection (USGS program input array conflicts).
c         (Version: 1.93, Level: 040713)
c --- Modifications by F. Robe
c     (4) Computation of the relative positions of MM5 gridpoints
c         moved from subroutine interpqr to rdhd4 & rdhd5,and stored in
c         MM4HDO.MET as X04, Y04 (with units correction (bug fix))
c
c --- Version 5.544 Level 040109 to V5.545 Level 040612
c --- Modifications by F.Robe
c     (1) STULL updated to avoid possible exponential overflow

c --- Version 5.543, Level 031215 to Version 5.544, Level 040109
c --- Modifications by D. Strimaitis
c     (1) COORDLIB updated to respond to projection parameter
c         changes when both the projection type and datum do not
c         change
c         (Version: 1.92, Level: 031201)
c
c --- Version 5.542, Level 031126 to Version 5.543, Level 031215
c --- Modifications by D. Strimaitis
c     (1) Place call to SETCOM after call to READHD in SETUP
c         as station locations may be read from headers
c     (2) Left-justify station name in RDHD, RDHDU
c     (3) Add station ID and name to RDHDU arg list
c
c --- Version 5.541, Level 031106 to Version 5.542, Level 031126
c --- Modifications by J. Scire
c     (1) Changes to accomodate new (Version 2.0) data set structure
c         for 3D.DAT file.  Modifications to RDHD5, RDHD51, RDHD52, 
c         common block /MM4HDO/.  New routine RDHD53.
c     (2) Write 3D.DAT/MM5.DAT/MM4.DAT grid point coordinates
c         (X, Y, long, lat) to a QA file (QA3D.DAT).  Modifications
c         to RDHD4, RDHD51, RDHD52, RDHD53. Add a new parameter (IO4)
c         to the PARAMS.MET file.
c     (3) Fix array dimensioning problems in READHD, RDHD and common
c         block /MET1/.  Subr. READHD/RDHD: Change calls to RDHD to 
c         include character arrays for latitude/longitude in the 
c         argument list.  /MET1/ common block: Fix an error in the 
c         dimension of the precipitation lat/long arrays.
c
c --- Version 5.54, Level 031017 to Version 5.541, Level 031106
c --- Modifications by K. Morrison
c     (1) Subr. READCF - correction to the variable type definitions
c         of IAVET and TGDEFA
c
c --- Version 5.531, Level 030905 to Version 5.54, Level 031017
c --- Modifications by D.Strimaitis
c     (1) Allow location data for surface, upper, and precip stations
c         to be missing from control file if they are provided in the
c         corresponding data files.  Accept lat/lon coordinates for met
c         station locations provided in met file (no other type)
c         Modified:  MET1.MET, READCF, READHD, RDHD, RDHDU
c     (2) WGS-72 DATUM bug for UTM calls fixed in COORDLIB
c         (Version: 1.91, Level: 031017) 
c
c --- Version 5.53, Level 030709 to Version 5.531, Level 030905
c     (1) Bug fix in interpqr 
c     (2) DATUMs updated in COORDLIB (Version: 1.9, Level: 030905)
c     (3) Default DATUMs reset
c
c --- Version 5.52, Level 030528 to Version 5.53, Level 030709
c --- Modifications by F.Robe
c     (1) Subr RDMM5 -RDMM4: bug fix - removal of a spurious statement
c
c --- Version 5.51, Level 030515 to Version 5.52, Level 030528
c --- Modifications by J. Scire, D. Strimaitis
c     (1) CALUTILS library updated to Version: 2.2, Level: 030528
c     (2) COORDLIB library updated to Version: 1.15, Level: 030528
c     (3) COORDLIB common block /blockdat.crd/ updated
c --- Modifications by F.Robe (Version 5.511, Level 030526 change)
c     (4) Subr. RDMM5 - correction to ensure a smooth transition from 
c         Dec 31 to January 1 (if period straddles these dates)
c
c --- Version 5.5, Level 030402 to Version 5.51, Level 030515
c --- Modifications by J. Scire
c     (1) Subr. RDMM5 - correction to ensure IGF is defined when
c         conducting a 1-hour run
c     (2) Subr. READCF - correction to the variable type definition
c         of IAVET
c     (3) Subr. WATER - eliminate check to skip mixing height
c         calculations over water when NOOBS = 1 or 2
c     (4) Subrs. RDMM4 and RDMM5 - introduce changes to check 
c         MM4 or MM5/3D.DAT grid point I,J vs. values expected.
c     (5) Insert correct level numbers in Subrs. R2INTERP2, CINTERP,
c         SURFVAR, INTERPQR, CLOUD, SOLAR (comment), and 
c         TEMP3D (comment) corresponding to No-Obs changes made to 
c         Level 030119
c --- Modifications by D. Strimaitis
c     (6) Subr. READGE - fix to read/QA header records for LCC map 
c         projection
c     (7) Subr. RDHD4, RDHD51, RDHD52 and Common block /MM4HDO.MET):
c         Add MM4/MM5 grid points to list file (LPRT) output
c     (8) Subr. RDHD4, RDHD51, RDHD52, BLOCK DATA and Common 
c         block /MM4HDO.MET):  Assign DATUM for MM4/MM5 file
c         datum3d = 'NWS-84  '
c
c --- Version 5.4, Level 030214 to Version 5.5, Level 030402
c --- D. Strimaitis
c     (1) Replace common utility subroutines with the CALUTILS group
c         of subroutines configured for LF95 compilation
c         CALUTILS.FOR (Version 2.1, Level 030402)
c     (2) Change UNDER0 call to generic UNDRFLW, and place compiler-
c         specific implementation routines there
c     (3) Move Y2K processing of system date into subroutine DATETM
c         and change rdate from (MM-DD-YY) to (MM-DD-YYYY)
c     (4) Change UP.DAT format to accept i8 rather than i5 field for
c         station ID
c     (5) Implement full coordinate conversion and documentation
c              - COORDLIB.FOR (Version 1.14, Level 030402)
c              - Control file input for map, datum info
c              - New header for SURF.DAT, GEO.DAT, UP.DAT, SEA.DAT,
c                PRECIP.DAT input files and CALMET.DAT output file
c              - LLCONF replaced with LLCC
c              - Removed input for Lat/Lon of SW corner of cell 1,1
c              - (XMAP0,YMAP0) = (XORIGR,YORIGR) / 1000 
c     (6) Restructure CALMET.DAT headers to include the entire input
c         control file as 'comments' (a132), and recast variables
c         explicitly written to the header to capture related info
c         not contained in the control file.
c
c --- Version 5.3, Level 030119 to Version 5.4, Level 030214
c --- C. Escoffier-Cjaza
c     (1) Correction to RDMM5: precipitation initilalized with the
c         current hour
c
c --- Version 5.2, Level 000602d to Version 5.3, Level 030119
c --- F. Robe
c
c     NO-OBS Mode
c        noobs= 0 : surface and upper air observations are available
c               1 : only surface observations are available
c                   MM5 data is used to supply upper air info
c               2 : no observations - MM5 data is used in lieu of obs.
c
c     2D arrays of solar angle, rho, heat flux, relative humidity,
c     precip code
c     Changes to GEN.MET, HEATFX, ELUSTR, ELUSTR2, R2INTERP2(new),
c                INTERPQR(new), AIRDEN, RDMM5, OUTHR, COMP, DIAGNO,
c                PARAMS.MET (version#), WSTARR
c     2-D arrays of RHO, QSW, IPCODE, RH, SF TEMP require changes in
c     PRTMET and CALPUFF (also must accept npsta=-1, nssta=0)
c
c     Flag NPSTA = -1 if MM5 data are to be used for precipitation
c
c     New flag in input file to compute 3D temperature based on MM5
c     also computes gamma (itprog>=1) and tinf (itprog=2) from MM5 data 
c     ITPROG = 0 - 3D temperature from sfc and upper air obs.
c            = 1 - Upper air temp from MM5 data and surface from obs.
c            = 2 - 3D temperature from MM5 data (2D sf air density also
c                  from MM5)
c     Changes to TEMP3D, MET1.MET, block data, READCF, CALMET.INP,
c                CGAMMA2
c 
c     New MIXHT2 and MIXDT2: mixing height based on progn. T if 
c          ITPROG=1,2;
c          vertical temperature profiles at MM5 gridpoints are used
c          instead of upper air soundings
c
c     Additional option ICLOUD=3 to compute cloud cover from MM5 rel.
c     humidity and ceiling height from MM5 qc
c     New CLOUD  and CINTERP subroutines 
c     Changes to RDHD5, RDMM5, READHD, READCF, COMP, DIAGNO, PGTSTB,
c                HEATFX, ELUSTR, ELUSTR2, STHEOR
c
c     Additional changes to OPENOT, RDWT, CGAMMA2 for NOOBS
c
c     Allow non hourly MM5 input
c     Changes to RDHD5, RDMM5, BLOCK DATA, COMP, READCF,TEMP3D
c                GEN.MET, MM4HDO.MET, CALMET.INP (new ISTEPPG)
c
c     Default values for all new input parameters
c       NOOBS   = 0
c       ITPROG  = 0
c       ISTEPPG = 1
c
c     Binary output is modified => new PRTMET.FOR and new CALPUFF.FOR
c
c     (1) Level 020211
c         - RDMM5: bug fix to account for date change
c
c     (2) Level 020710
c         - Bug fix (xbuf instead of xubf)
c
c     (3) Level 021022
c         - Bug fix in RDMM5: new way to check on istepmm5 (RDMM5)
c         - Allow only for MM5 timestep of 12 hours maximum (READCF)
c
c     (4) Level 021028
c         - Fix bug in bug fix of v021022 (RDMM5) for isteppg
c
c     (5) Level 021105
c         - allow vertical interpolation of surface wind obs. with
c           NOOBS=1
c          (changes in DIAGNO, INTER2, READCF, STHEOR, ELUSTR2)
c         - new subroutines MIXHTST and MIXHTST2 to compute mixing hts 
c           at surface stations (short version (one (i,j) ) of MIXHT
c           and MIXHT2
c         - bug fix in missfc
c         - correct cloud formula: based on RH at 850mb rather than sfc
c         - bug fix in RDMM5 use IRHPROG not RHPROG (typo)
c
c     (6) Level 030106
c         - Vertical extrapolation of prog T from lowest prog level
c           down to lowest CALMET level (in subroutine RDMM5)
c           Daytime: assume dry adiabatic profile
c           Nightime: assume exponential profile (Stull, 1983)
c         - Allow for more than 1 MM5  levels below ground (occurs
c           with ETA-M3D data) (in RDMM5)
c         - Correct vertical profile used in MIXDT2 (MM5 Temp profile)
c           to reflect extrapolation and use of only above sfc
c           MM5 levels
c
c     (7) Level 030119
c         - NOOBS version for MM4 as well (hourly records only)
c
c --- Version 5.2, Level 000602c to Version 5.2, Level 000602d
c
c     (1) Add option to read new prognostic data format (3D.DAT file
c         format).  Code is backward-compatible with MM4.DAT and
c         MM5.DAT formats. (Zhong Wu) 
c         Changes include:
c         (a) Modify RDHD5 and RDMM5 routines
c         (b) Add RDHD51 (read original format) 
c             and RDHD52 (read 3D.DAT format) 
c         (This version contains the V5.2, L0011 modifications, 
c         added to 000602c by J. Scire)
c     (2) Modify default land use categories to be consistent with
c         new (010206) version of MAKEGEO. (J. Scire) 
c         Changes to BLOCK DATA:
c         (a) Default water land use 50, 54, and 55; 
c         (b) z0 for snow changed to 0.05 m
c     (3) Modify READGE to skip UTM zone check if using Lambert
c         Conformal coordinates
c
c --- Version 5.2, Level 000602b to Version 5.2, Level 000602c
c --- J. Scire (1/12/2001)
c
c     (1) Add code in Subr. DIAGI to set FEXTRP array (used in wind 
c         module) to FEXTR2 array (variable used for input of 
c         user-defined wind extrapolation factors). (Piotr Staniaszek)
c
c --- Version 5.2, Level 000602a to Version 5.2, Level 000602b
c --- J. Scire (9/24/2000)
c
c     (1) Add option to read radiation parameters from control file
c         (Modifications to BLOCK DATA, MICRO, READCF)
c     (2) Default value of ICALM set to zero (BLOCK DATA)
c
c --- Version 5.2, Level 000602 to Version 5.2, Level 000602a
c
c    (1) Subr. RDP - old PRECIP.DAT 1-24 is changed to 0-23 hour format
c
c --- Version 5.1, Level 991104a to Version 5.2, Level 000602
c
c    (1) Subr. WIND1 - corrects extropolation of winds when
c        using the power law option (K. Richmond).
c
c --- Version 5.1, Level 991104 to Version 5.1, Level 991104a
c
c    (a1/5.1) Logic added to 3 coordinate routines (MAPG2L, LL2UTM,
c        and UTM2LL) to accommodate -180 to +180 longitude boundary
c
c --- Version 5.0, Level 990228 to Version 5.1, Level 991104 
c
c    (1) Implement Y2K logic (YYYY format for year).  Add new subr.
c        YR4, YR4C, QAYR4.  Modifications to CGAMMA, COMP, DEDAT, FIN, 
c        INCR, MISSFC, OUT, PREPDI, RDHD, RDHD4, RDHD5, RDHDU, RDMM4, 
c        RDMM5, RDOW, RDP, RDS, RDUP, READCF, READHD, RDCLD 
c    (2) Allow either new or old MM5 header format.  Modifications to
c        RDMM5.
c    (3) Allow increments greater than 8760 hours in INCR.
c    (4) Write error messages to list file as well as screen (READFN,
c        YR4, QAYR4)
c
c----------------------------------------------------------------------
c
      logical lflag
c
c --- include QA common block
      include 'qa.met'
c
c --- Lahey F77 compiler -- set underflows ( < 10**-38 ) to zero
      lflag=.true.
      call UNDRFLW(lflag)
c
c --- set version and level number of program
      ver='6.4.0'
      level='121203'
c
c --- (1) setup phase -- initialization & program setup operations
      itest=2
      call setup(itest)
c
c --- Skip COMPUTATIONAL phase and STOP program execution if in TEST
c --- mode
      if(itest.eq.1)go to 999
c
c --- (2) computational phase -- basic time loop with scientific modules
      call comp
c
c --- (3) termination phase -- program termination functions
999   continue
      call fin(itest)
c
      stop
      end
c-----------------------------------------------------------------------
      BLOCK DATA
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203          BLOCK DATA
c ---          J. Scire, Earth Tech, Inc.
c ---          modified by M. Fernau, J. Scire , F.Robe
c
c
c --- v6.4.0, Level 121203
c        - Add THRESHQC in /AUXDAT/ for cloud liquid water processing
c        - Add IAUXLWC in /OUTPT/ for cloud liquid water AUX file
c
c --- include parameters
      include 'params.met'
c
      include 'flags.met'
      include 'gen.met'
      include 'geo.met'
      include 'grid.met'
      include 'hflux.met'
      include 'metgrd.met'
      include 'outpt.met'
      include 'ovrwat.met'
      include 'qa.met'
      include 'wparm.met'
      include 'ziparm.met'
      include 'breez.met'
      include 'lon.met'
      include 'map.met'
      include 'tmp.met'
      include 'met1.met'
      include 'filnam.met'
      include 'mm4hdo.met'
      include 'd3.met'

c --- v6.4.0, Level 121203
      include 'auxdat.met'

      common /tjump/ dptt(mxnx,mxny)
      data dptt/mxxy*0./

c --- v6.4.0, Level 121203
c --- AUXDAT common block
      data threshqc/0.005/
c
c --- GEN common block
      data irtype/1/,lcalgrd/.true./,nendhr/0/
      data mreg/-1/
      data nsecdt/3600/
c
c --- GEO common block
      data nlu/14/,
     1 ilucat/ 10,  20, -20,  30,  40,  50,  54,  55,  60,  61,  62,
     1         70,  80,  90, 38*0/,
     2 z0lu  /1.0, .25, .25, .05, 1.0,.001,.001,.001, 1.0, 1.0, .20,
     2        .05, .20, .05, 38*0./,
     3 alblu /.18, .15, .15, .25, .10, .10, .10, .10, .10, .10, .10,
     3        .30, .30, .70, 38*0./,
     4 bowlu /1.5, 1.0, 0.5, 1.0, 1.0, 0.0, 0.0, 0.0, 0.5, 0.5, 0.1,
     4        1.0, 0.5, 0.5, 38*0./,
     5 hcglu /.25, .15, .15, .15, .15, 1.0, 1.0, 1.0, .25, .25, .25,
     5        .15, .15, .15, 38*0./,
     6 qflu  / 0.,  0.,  0.,  0.,  0.,  0.,  0.,  0.,  0.,  0.,  0.,
     6         0.,  0.,  0., 38*0./,
     7 xlailu/0.2,  3.,  3., 0.5,  7.,  0.,  0.,  0.,  2.,  2.,  1.,
     7        .05,  0.,  0., 38*0./,
     7 iwat1/55/,iwat2/55/
c
c --- GRID common block
      data xlat0/9999./,xlon0/9999./
c
c --- HFLUX common block 
      data ha1/990./,ha2/-30./,hb1/-0.75/, hb2/3.4/
      data hc1/5.31e-13/,hc2/60./,hc3/0.12/

c --- OUTPT common block
      data lsave/.true./,lprint/.false./,iprinf/1/
      data ldb/.false./,nn1/1/,nn2/1/,ldbcst/.false./
      data iuvout/mxnz*0/,iwout/mxnz*0/,itout/mxnz*0/,imtout/8*0/
      data iformo/1/
      data iqaplot/1/

c --- v6.4.0, Level 121203
      data iauxlwc/1/
c
c --- METGRD common block
      data ztemp/mxxyz*283.0/
c
c --- OVRWAT common block
      data iowbeg/mxows*0/,iowend/mxows*0/
      data ziminw/50./,zimaxw/3000./,constw/0.16/
c
c --- ZIPARM common block
      data constb/1.41/,conste/0.15/,constn/2400./,dptmin/0.001/
      data dzzi/200./,zimax/3000./,zimin/50./
      data iavezi/1/,mnmdav/1/,hafang/30./,ilevzi/1/
c --- 110212 
      data izicrlx/1/,tzicrlx/800./

c --- 050328: f is computed as a function of the latitude unless given by
c     the user in CALMET.INP- Initializing f to 999. serves as a flag to
c     trigger the internal computation     
c     data fcoriol/1.e-4/
      data fcoriol/999./
c
c --- QA common block
      data rcpu/0.0/
c
c --- WPARM common block
      data iwfcod/1/,ifradj/1/,ikine/0/,iobr/0/
      data iextrp/-4/,fextr2/mxnz*0.0/,rmin/0.1/,rmin2/4./
      data lvary/.false./,iupwnd/-1/
      data iprog/0/
      data alpha/0.1/,idiopt/5*0/
      data zupt/200./,zupwnd/1.,1000./
      data divlim/5.e-6/,niter/50/,nsmth/2,mxnzm1*4/,critfn/1.0/
      data ioutd/0/,nzprn2/1/,ipr0/0/,ipr1/0/,ipr2/0/,ipr3/0/
      data ipr4/0/,ipr5/0/,ipr6/0/,ipr7/0/,ipr8/0/
      data bias/mxnz*0.0/
      data islope/1/,icalm/0/
c
c --- D3 common block
      data nbar/0/
c
c --- FLAGS common block
      data lmesg /.true./, iomesg /6/
c
c --- BREEZ common block
      data llbreze /.false./
c
c --- LON common block
      data dlongs /mxss*0.0/, dlongu /mxus*0.0/
c
c --- MAP common block
      data pmap/'UTM     '/
      data datum/'WGS-84  '/
      data utmhem/'N   '/
      data iutmzn/-999/
      data xlat1 /-999./, xlat2 /-999./
      data rlon0 /-999./, rlat0 /-999./
      data relon0 /-999./, rnlat0 /-999./
      data feast/0.0/, fnorth/0.0/
c --- Derived variables
      data lutm/.false./, llcc/.false./, lps/.false./
      data lem/.false./, llaza/.false./, lttm/.false./
c
c --- TMP common block
      data irad /1/
      data iavet /1/
      data numwb /0/
      data tgdefb /-.0098/
      data tgdefa /-.0045/
      data jwat1/999/,jwat2/999/
c *** data trad /20./
      data tradkm/500./
      data numts /5/
c
c --- MET1 common block
      data nflagp /2/,sigmap/100.0/,cutp /0.01/
      data iforms/2/,iformp/2/,iformc/2/
      data noobs /0/
      data itprog /0/
ccec101006 --- no default for icloud, mcloud, icldout
      data icloud/999/
      data mcloud/999/
      data icldout/999/
      data irhprog/0/
c
c frr (09/01) non hourly prognostic data
c --- MM4HDO common block
      data isteppg /1/
      data datum3d/'NWS-84  '/
      data iluoc3d/16/
c
c --- FILNAM common block - (UPDAT,SEADAT,m3ddat initialized in READFN)
      data metinp/'calmet.inp'/,geodat/'geo.dat'/,srfdat/'surf.dat'/,
     1 prcdat/'precip.dat'/,diadat/'diag.dat'/,prgdat/'prog.dat'/,
     2 mm4dat/'mm4.dat'/,wtdat/'wt.dat'/,clddat/'cloud.dat'/
      data metlst/'calmet.lst'/,metdat/'calmet.dat'/,
     1 pacdat/'pacout.dat'/,tstprt/'test.dat'/,tstout/'test.out'/,
     2 tstkin/'test.kin'/,tstfrd/'test.frd'/,tstslp/'test.slp'/,
     3 dcstgd/'dcst.grd'/
      end

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

c --- v6.4.0, Level 121203
c --- AUX-FILE SUBROUTINES
      include 'auxutils.for'

c-----------------------------------------------------------------------
      subroutine adjust(u,v,phi,htopo,hbar,ub,vb)
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328              ADJUST
c
c --- include parameters
      include 'params.met'
      include 'd6.met'
c
c--NEW:frr (12/96) - D5 replaced by grid.met
c      COMMON /D5/ NX,NY,NZ,DX,DY,dz(mxnz),NZPRNT
      include 'grid.met'
c frr 040630 : include 'd6.met' replaces explicity common
c      COMMON /D6/ IRD,IWR,IFILE,irdp
      DIMENSION U(mxnx,mxny,*),V(mxnx,mxny,*)
      DIMENSION PHI(mxnx,mxny,*),HTOPO(mxnx,*)
      DIMENSION UB(mxny,2,*),VB(mxnx,2,*)
C
C      THIS ROUTINE ADJUSTS SURFACE WINDS FOR TERRAIN EFFECTS
C
C     INPUTS:  U (R ARRAY)     - GRIDDED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY)     - GRIDDED Y-DIRECTION WIND COMPONENTS
C              HTOPO (R ARRAY) - GRIDDED TERRAIN HEIGHTS
C              HBAR (R ARRAY)  - MODEL LEVELS
C              UB (R ARRAY)    - U-COMPONENT BOUNDARY VALUES
C              VB (R ARRAY)    - V-COMPONENT BOUNDARY VALUES
c       Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C     OUTPUTS:  U (R ARRAY) - X-DIRECTION WIND COMPONENTS WITH
C                             ADJUSTED SURFACE LAYER WINDS
C               V (R ARRAY) - Y-DIRECTION WIND COMPONENTS WITH
C                             ADJUSTED SURFACE LAYER WINDS
C
C     ITERATION CRITERIA
C
      DATA ITMAX,EPSI,OVREL/75,0.02,1.5/
      KK = 1
C
C     COMPUTE TERRAIN GRADIENTS AND INITIAL POTENTIAL
C
      DXI=0.5/DX
      DYI=0.5/DY
      FX=DXI/(HBAR)
      FY=DYI/(HBAR)
      DO 20 J=1,NY
      DO 20 I=1,NX
      HTOIM1=HTOPO(I,J)
      HTOJM1=HTOPO(I,J)
      IF(I.GT.1) HTOIM1=HTOPO(I-1,J)
      IF(J.GT.1) HTOJM1=HTOPO(I,J-1)
      HTOIP1=HTOPO(I,J)
      HTOJP1=HTOPO(I,J)
      IF(I.LT.NX) HTOIP1=HTOPO(I+1,J)
      IF(J.LT.NY) HTOJP1=HTOPO(I,J+1)
      DHDX=(HTOIP1-HTOIM1)*FX
      DHDY=(HTOJP1-HTOJM1)*FY
      PHI(I,J,2)=(U(I,J,KK)*DHDX+V(I,J,KK)*DHDY)
   20 CONTINUE
C
C     SET BOUNDARY VALUES FOR PHI
C
      DO 30 J=1,NY
      UB(J,1,1)=PHI(1,J,KK)
      UB(J,2,1)=PHI(NX,J,KK)
   30 CONTINUE
      DO 35 I=1,NX
      VB(I,1,1)=PHI(I,1,KK)
      VB(I,2,1)=PHI(I,NY,KK)
   35 CONTINUE
C
C     SOLVE POISSON EQUATION BY GAUSS-SEIDEL METHOD FOR
C     VELOCITY POTENTIAL
C
      DXSQ=DX*DX
      DYSQ=DY*DY
      DSQ=DXSQ*DYSQ
      FACT=1.0/(2.0*(DXSQ+DYSQ))
      DO 100 IT=1,ITMAX
      DO 90 IDIR=1,4
      ERROR=-1.0E+09
      DO 50 JJ=1,NY
      DO 50 II=1,NX
      GO TO (71,72,73,74),IDIR
   71 I=II
      J=JJ
      GO TO 75
   72 I=NX-II+1
      J=JJ
      GO TO 75
   73 I=II
      J=NY-JJ+1
      GO TO 75
   74 I=NX-II+1
      J=NY-JJ+1
   75 CONTINUE
      XOLD=PHI(I,J,KK)
      PHIIM1=UB(J,1,1)
      IF(I.GT.1)PHIIM1=PHI(I-1,J,KK)
      PHIJM1=VB(I,1,1)
      IF(J.GT.1)PHIJM1=PHI(I,J-1,KK)
      PHIIP1=UB(J,2,1)
      IF(I.LT.NX)PHIIP1=PHI(I+1,J,KK)
      PHIJP1=VB(I,2,1)
      IF(J.LT.NY)PHIJP1=PHI(I,J+1,KK)
      XX=DYSQ*(PHIIP1+PHIIM1)
      YY=DXSQ*(PHIJP1+PHIJM1)
      PHI(I,J,KK) = (1.-OVREL)*PHI(I,J,KK)
     1            + OVREL*FACT*(XX+YY-DSQ*PHI(I,J,2))
      IF(I.EQ.1) UB(J,1,1)=PHI(1,J,KK)
      IF(I.EQ.NX) UB(J,2,1)=PHI(NX,J,KK)
      IF(J.EQ.1) VB(I,1,1)=PHI(I,1,KK)
      IF(J.EQ.NY) VB(I,2,1)=PHI(I,NY,KK)
      IF(XOLD.EQ.0.) GO TO 50
      IF(ABS(XOLD).LT.1.0E-10) GO TO 50
      ERR=ABS((PHI(I,J,KK)-XOLD)/XOLD)
      ERROR=AMAX1(ERR,ERROR)
   50 CONTINUE
   90 CONTINUE
      IF (ERROR.LE.EPSI) GO TO 150
  100 CONTINUE
  150 CONTINUE
C
C     COMPUTE WIND COMPONENTS FROM VELOCITY POTENTIAL
C
      DO 170 J=1,NY
      DO 170 I=1,NX
      PHIIM1=UB(J,1,1)
      PHIJM1=VB(I,1,1)
      PHIIP1=UB(J,2,1)
      PHIJP1=VB(I,2,1)
      IF(I.GT.1) PHIIM1=PHI(I-1,J,KK)
      IF(J.GT.1) PHIJM1=PHI(I,J-1,KK)
      IF(I.LT.NX) PHIIP1=PHI(I+1,J,KK)
      IF(J.LT.NY) PHIJP1=PHI(I,J+1,KK)
      U(I,J,KK)=(PHIIP1-PHIIM1)*DXI+U(I,J,KK)
      V(I,J,KK)=(PHIJP1-PHIJM1)*DYI+V(I,J,KK)
  170 CONTINUE
  200 CONTINUE
C
C     RESET BOUNDARY ARRAY
C
      DO 300 K=1,2
      DO 250 J=1,NY
  250 UB(J,K,1)=0.
      DO 260 I=1,NX
  260 VB(I,K,1)=0.
  300 CONTINUE
      RETURN
      END
c-----------------------------------------------------------------------
      subroutine airden(pres,temp2d,rho)
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328              AIRDEN
c ---          J. Scire, SRC
c              Modified by F.Robe, Earth Tech, to allow 2D arrays
c
c --- PURPOSE:  Compute the air density (kg/m**3) using the ideal
c               gas law
c --- UPDATES
c     - V5.6 050328 (Frr)
c        - Remove nssta from calling list (not used)
c        - Use 2D temperature field rather than temp at sf. stations
c
c --- Note: 2-D field of surface pressure should be computed and used
c           (first compute sea level pressure at all stations, interpolate
c           spatially, then refine by taking gridpoint eleveation into
c           account)
c
c --- INPUTS:
c           PRES(mxss) - real array    - Surface pressure (mb)
c   TEMP2D(mxnx,mxny)) - real array    - Surface Air temperature (deg. K)
c        Parameters: MXSS, NEARS,NX,NY
c
c --- OUTPUT:
c            RHO(mxnx,mxny) - real array    - Air density (kg/m**3)
c
c ---  AIRDEN called by: DIAGNO, COMP
c ---  AIRDEN calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'grid.met'
c
      real pres(mxss)
      real temp2d(mxnx,mxny),rho(mxnx,mxny)

c ---  2-D density
c --- constant 0.3484321 = 100 kg / (m * sec**2) per mb divided by
c --- (287 m**2 / (deg K * sec**2))
c --- use p at nearest stations (should be improved)
      do 200 j=1,ny
      do 200 i=1,nx
          nsta = nears(i,j)
          rho(i,j)=0.3484321*pres(nsta)/temp2d(i,j)
200   continue

c
      return
      end
c-----------------------------------------------------------------------
      subroutine avemix(nx,ny,mnmdav,hafang,dgrid,u,v,zi,ziconv)
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050412              AVEMIX
c ---          R. Yamartino, SRC
c
c --- PURPOSE:  Calculate the average mixing height (m) at each grid
c               point based on an average over MIXHT values at the
c               grid point and grid points upwind.
c
c --- UPDATES:
c     Level  901130 to V5.6b Level 050412 (F.Robe)
c     (1) Add check to ensure upwind averaging of mixing heights 
c         is done over gridpoints within cone of influence and
c         mnmdav square around (i,j) only
c         
c
c --- INPUTS:
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c               MNMDAV - integer       - Max. grid cell search radius
c                                        (outside of HAFANG cone region)
c                                        for mixing depth averaging.
c               HAFANG - real          - Half-angle (degrees) of upwind
c                                        looking cone for averaging.
c                DGRID - real          - Grid size (m)
c         U(mxnx,mxny) - real array    - U component of wind (m/s)
c         V(mxnx,mxny) - real array    - V component of wind (m/s)
c        ZI(mxnx,mxny) - real array    - Mixing height (m) from MIXHT
c    ZICONV(mxnx,mxny) - real array    - Conv. Mix. hgt.(m) from MIXHT
c
c        Parameters: mxnx, mxny, io6
c
c --- OUTPUT:
c        ZI(mxnx,mxny) - real array    - Mixing height (m) -- ave. of
c                                        local and upwind heights.
c    ZICONV(mxnx,mxny) - real array    - Conv. Mix. hgt.(m)-- ave. of
c                                        local and upwind heights.
c
c --- AVEMIX called by:  COMP
c --- AVEMIX calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real u(mxnx,mxny),v(mxnx,mxny)
      real zi(mxnx,mxny),ziconv(mxnx,mxny)
      real ziave(mxnx,mxny),zicave(mxnx,mxny)
c $$$ include a weight array for test purposes 4/16/90.
c $$$ real wtij(mxnx,mxny)
c
      data dtime/3600./,one/1.0/,zero/0.0/,degrad/0.01745329/
c
c --- Define dtdx for Courant number purposes.
      dtdx = dtime / dgrid
c
c --- Define the tangent of the half-angle.
      tanang= tan(degrad * hafang)
c

c --- Loop over grid cells
      do 100 i=1,nx
      ip1 = i + mnmdav
      im1 = i - mnmdav
c
      do 100 j=1,ny
      jp1 = j + mnmdav
      jm1 = j - mnmdav
c
c
      etax = u(i,j) * dtdx
      etay = v(i,j) * dtdx
      eta2 = etax*etax + etay*etay
c
      if(eta2.gt.zero) then
         eta = sqrt(eta2)
         etai = one / eta
c        eta2i = one / eta2
      else
         eta = zero
         etai = zero
c        eta2i = zero
      endif
c
      ietax = int(etax)
      ietay = int(etay)
      icwx = int(etay * tanang)
      icwy = int(etax * tanang)
c
c --- Note that (iu,ju) is the location of the most upwind cell that
c     could have contributed during the time step dt.  The cells
c     (ia,ja) and (ib,jb) are at the same upwind distance but are at
c     a crosswind distance equal in magnitude to the upwind distance
c     times the tangent of the half-angle (HAFANG).
c     Thus, (i,j), (ia,ja), and (ib,jb) form the vertices of a
c     triangle having a 2*HAFANG (degree) opening angle at (i,j).
c
      iu = i  - ietax
      ju = j  - ietay
c
      ia = iu + icwx
      ib = iu - icwx
c
      ja = ju - icwy
      jb = ju + icwy
c     
c --- Wind direction +/- halfang (050412):
      if (i.ne.ia) then 
         alphaa=270.-atan2(float(j-ja),float(i-ia))/degrad
         alphaa=amod(alphaa,360.)
      else
         if(j.ge.ja) alphaa=180.
         if(j.lt.ja) alphaa=0.
      endif
      if (i.ne.ib) then 
         alphab=270.-atan2(float(j-jb),float(i-ib))/degrad
         alphab=amod(alphab,360.)
      else
         if(j.ge.jb) alphab=180.
         if(j.lt.jb) alphab=0.
      endif

c --- Now set the search window: ki from kilow to kihgh
c                                kj from kjlow to kjhgh
      kilow = min0(ia,ib,im1)
      kilow = max0(kilow,1)
c
      kihgh = max0(ia,ib,ip1)
      kihgh = min0(kihgh,nx)
c
      kjlow = min0(ja,jb,jm1)
      kjlow = max0(kjlow,1)
c
      kjhgh = max0(ja,jb,jp1)
      kjhgh = min0(kjhgh,ny)
c
c --- Loop over the nearby neighbor cells, K.
      sumwt = zero
      zibar = zero
      zicbar = zero
c
c $$$ include a weight array for test purposes 4/16/90.
c $$$ do 10 ki=1,nx
c $$$ do 10 kj=1,ny
c $10 wtij(ki,kj) =  zero
c
      do 50 ki=kilow,kihgh
      irel = i - ki
c
      do 50 kj=kjlow,kjhgh
      jrel = j - kj
c
      wt = one
c --- The local cell always gets a weight of one
      if(irel.eq.0 .and. jrel.eq.0) go to 45
c

c --- 050412 - Check if the gridpoint is within mnmdav of (i,j)
c --- (square) -If so, skip the check on the upwind cone (as might
c --- be outside of the cone but should still be kept)
      if ((abs(irel).le.mnmdav).and.(abs(jrel).le.mnmdav)) goto 47

c --- 050412: Check if the gridpoint is within cone of influence
c --- First check that within +/- halfang of wind direction
c --- Direction of (ki,kj) relative to (i,j)
      beta=270.-atan2(float(jrel),float(irel))/degrad
      beta=amod(beta,360.)

      if ((beta.lt.alphaa).or.(beta.gt.alphab)) goto 50

c --- Then check than not beyond maximum upwind distance (050412)
      dist=irel**2+jrel**2
      if (dist.gt.eta2) goto 50

47    continue

c     DELA is the upwind measure of a cell's location, with (iu,ju)
c     corresponding to dela = eta (i.e. ignoring integer truncation).
      dela = (irel*etax + jrel*etay) * etai
c
c --- Zero wind speed (eta=0) gives dela=0.  Reset to dela=r.
      if(eta.eq.zero) then
                      xrel = float(irel)
                      yrel = float(jrel)
                      dela = sqrt(xrel*xrel + yrel*yrel)
                      endif
c
c --- Downwind cells currently penalized as if beyond causal frontier.
      if(dela.lt.zero) dela = eta - dela
c
c --- Now consider all non-local, upwind cells.
c     DELC is the crosswind measure of a cells location.
      delc = abs(irel*etay - jrel*etax) * etai
c
c     cross = 50.0
c     Assume dela > 0 always now.
c     if(dela.gt.zero) cross = delc / dela
c
c --- Note that the weight (wt) favors an upwind-facing cone region.
c     The factor, one/(one + 2.0*cross**2) is a Gaussian-like,
c     crosswind penalty function.
c     wt = one / ( (one + dela) * (one + 2.0*cross**2) )
c
c --- Note that the following weight (wt) is equivalent to 1/r.
c     wt = one / (  dela*sqrt(one + cross**2) )
c or  wt = one / sqrt(dela**2 + delc**2)
c
c --- Note that the following weight (wt) is equivalent to 1/r**2.
c     wt = one / (dela**2 + delc**2)
c
c --- Note that the following weight (wt) is like a displaced 1/r**2.
      wt = one / (dela**2 + (one + abs(delc))**2)
c
   45 sumwt  = sumwt   +  wt
      zibar  = zibar   +  wt * zi(ki,kj)
      zicbar = zicbar  +  wt * ziconv(ki,kj)
c
c $$$ include a weight array for test purposes 4/16/90.
c $$$ wtij(ki,kj) =  wt
c 


   50 continue
c
      ziave(i,j)  = zibar  / sumwt
      zicave(i,j) = zicbar / sumwt

c
c $$$ include a weight array for test purposes 4/16/90.
c $$$ write(6,1001) i,j,etax,etay,sumwt,wtij
c1001 format(' Weight array: i,j,etax,etay,sumwt=',2i5,3f10.3,/,
c    f         10(/,10f7.2))
c
  100 continue
c
c

c --- Loop over grid cells a second time to load the zi array.
      do 200 i=1,nx
      do 200 j=1,ny
c
      zi(i,j)     = ziave(i,j)
      ziconv(i,j) = zicave(i,j)
c
  200 continue
c
      return
      end
c-----------------------------------------------------------------------
      subroutine avetmp(nx,ny,mnmdav,hafang,dgrid,u,v,ztemp)
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050412              AVETMP
c ---          M. Fernau, ETCO/SRC after AVEMIX by R. Yamartino, SRC
c
c --- PURPOSE:  Calculate the average temperature (K) at each grid
c               point based on an average over TEMP values at the
c               grid point and grid points upwind.
c
c --- UPDATES:
c     Level 940930 to V5.6b Level 050412 (F.Robe)
c     (1) Add check to ensure upwind averaging of mixing heights 
c         is done over gridpoints within cone of influence and
c         mnmdav square around (i,j) only
c 
c --- INPUTS:
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c               MNMDAV - integer       - Max. grid cell search radius
c                                        (outside of HAFANG cone region)
c                                        for mixing depth averaging.
c               HAFANG - real          - Half-angle (degrees) of upwind
c                                        looking cone for averaging.
c                DGRID - real          - Grid size (m)
c         U(mxnx,mxny) - real array    - U component of wind (m/s)
c         V(mxnx,mxny) - real array    - V component of wind (m/s)
c     ZTEMP(mxnx,mxny) - real array    - Temperature (K) from TEMP3D
c
c        Parameters: mxnx, mxny, io6
c
c --- OUTPUT:
c     ZTEMP(mxnx,mxny) - real array    - Temperature (K) -- average of
c                                        local and upwind temperatures.
c
c --- AVETMP called by:  TEMP3D
c --- AVETMP calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real u(mxnx,mxny),v(mxnx,mxny)
      real ztemp(mxnx,mxny)
      real ztave(mxnx,mxny)
c $$$ include a weight array for test purposes 4/16/90.
c $$$ real wtij(mxnx,mxny)
c
      data dtime/3600./,one/1.0/,zero/0.0/,degrad/0.01745329/
c
c --- Define dtdx for Courant number purposes.
      dtdx = dtime / dgrid
c
c --- Define the tangent of the half-angle.
      tanang= tan(degrad * hafang)
c
c --- Loop over grid cells
      do 100 i=1,nx
      ip1 = i + mnmdav
      im1 = i - mnmdav
c
      do 100 j=1,ny
      jp1 = j + mnmdav
      jm1 = j - mnmdav
c
c
      etax = u(i,j) * dtdx
      etay = v(i,j) * dtdx
      eta2 = etax*etax + etay*etay
c
      if(eta2.gt.zero) then
         eta = sqrt(eta2)
         etai = one / eta
c        eta2i = one / eta2
      else
         eta = zero
         etai = zero
c        eta2i = zero
      endif
c
      ietax = int(etax)
      ietay = int(etay)
      icwx = int(etay * tanang)
      icwy = int(etax * tanang)
c
c --- Note that (iu,ju) is the location of the most upwind cell that
c     could have contributed during the time step dt.  The cells
c     (ia,ja) and (ib,jb) are at the same upwind distance but are at
c     a crosswind distance equal in magnitude to the upwind distance
c     times the tangent of the half-angle (HAFANG).
c     Thus, (i,j), (ia,ja), and (ib,jb) form the vertices of a
c     triangle having a 2*HAFANG (degree) opening angle at (i,j).
c
      iu = i  - ietax
      ju = j  - ietay
c
      ia = iu + icwx
      ib = iu - icwx
c
      ja = ju - icwy
      jb = ju + icwy
c
c --- Wind direction +/- halfang (050412)
      if (i.ne.ia) then 
         alphaa=270.-atan2(float(j-ja),float(i-ia))/degrad
         alphaa=amod(alphaa,360.)
      else
         if(j.ge.ja) alphaa=180.
         if(j.lt.ja) alphaa=0.
      endif
      if (i.ne.ib) then 
         alphab=270.-atan2(float(j-jb),float(i-ib))/degrad
         alphab=amod(alphab,360.)
      else
         if(j.ge.jb) alphab=180.
         if(j.lt.jb) alphab=0.
      endif

c --- Now set the search window: ki from kilow to kihgh
c                                kj from kjlow to kjhgh
      kilow = min0(ia,ib,im1)
      kilow = max0(kilow,1)
c
      kihgh = max0(ia,ib,ip1)
      kihgh = min0(kihgh,nx)
c
      kjlow = min0(ja,jb,jm1)
      kjlow = max0(kjlow,1)
c
      kjhgh = max0(ja,jb,jp1)
      kjhgh = min0(kjhgh,ny)
c
c --- Loop over the nearby neighbor cells, K.
      sumwt = zero
      ztbar = zero
c
c $$$ include a weight array for test purposes 4/16/90.
c $$$ do 10 ki=1,nx
c $$$ do 10 kj=1,ny
c $10 wtij(ki,kj) =  zero
c
      do 50 ki=kilow,kihgh
      irel = i - ki
c
      do 50 kj=kjlow,kjhgh
      jrel = j - kj
c
      wt = one
c --- The local cell always gets a weight of one
      if(irel.eq.0 .and. jrel.eq.0) go to 45
c
c --- 050412 - Check if the gridpoint is within mnmdav of (i,j)
c --- (square) -If so, skip the check on the upwind cone (as might
c --- be outside of the cone but should still be kept)
      if ((abs(irel).le.mnmdav).and.(abs(jrel).le.mnmdav)) goto 47

c --- 050412: Check if the gridpoint is within cone of influence
c --- First check that within +/- halfang of wind direction
c --- Direction of (ki,kj) relative to (i,j)
      beta=270.-atan2(float(jrel),float(irel))/degrad
      beta=amod(beta,360.)

      if ((beta.lt.alphaa).or.(beta.gt.alphab)) goto 50

c --- Then check than not beyond maximum upwind distance (050412)
      dist=irel**2+jrel**2
      if (dist.gt.eta2)goto 50

47    continue

c     DELA is the upwind measure of a cell's location, with (iu,ju)
c     corresponding to dela = eta (i.e. ignoring integer truncation).
      dela = (irel*etax + jrel*etay) * etai
c
c --- Zero wind speed (eta=0) gives dela=0.  Reset to dela=r.
      if(eta.eq.zero) then
                      xrel = float(irel)
                      yrel = float(jrel)
                      dela = sqrt(xrel*xrel + yrel*yrel)
                      endif
c
c --- Downwind cells currently penalized as if beyond causal frontier.
      if(dela.lt.zero) dela = eta - dela
c
c --- Now consider all non-local, upwind cells.
c     DELC is the crosswind measure of a cells location.
      delc = abs(irel*etay - jrel*etax) * etai
c
c     cross = 50.0
c     Assume dela > 0 always now.
c     if(dela.gt.zero) cross = delc / dela
c
c --- Note that the weight (wt) favors an upwind-facing cone region.
c     The factor, one/(one + 2.0*cross**2) is a Gaussian-like,
c     crosswind penalty function.
c     wt = one / ( (one + dela) * (one + 2.0*cross**2) )
c
c --- Note that the following weight (wt) is equivalent to 1/r.
c     wt = one / (  dela*sqrt(one + cross**2) )
c or  wt = one / sqrt(dela**2 + delc**2)
c
c --- Note that the following weight (wt) is equivalent to 1/r**2.
c     wt = one / (dela**2 + delc**2)
c
c --- Note that the following weight (wt) is like a displaced 1/r**2.
      wt = one / (dela**2 + (one + abs(delc))**2)
c
   45 sumwt  = sumwt   +  wt
      ztbar  = ztbar   +  wt * ztemp(ki,kj)
c
c $$$ include a weight array for test purposes 4/16/90.
c $$$ wtij(ki,kj) =  wt
c
   50 continue
c
      ztave(i,j)  = ztbar  / sumwt
c
c $$$ include a weight array for test purposes 4/16/90.
c $$$ write(6,1001) i,j,etax,etay,sumwt,wtij
c1001 format(' Weight array: i,j,etax,etay,sumwt=',2i5,3f10.3,/,
c    f         10(/,10f7.2))
c
  100 continue
c
c --- Loop over grid cells a second time to load the ztemp array.
      do 200 i=1,nx
      do 200 j=1,ny
        ztemp(i,j) = ztave(i,j)
  200 continue
      return
      end
c-----------------------------------------------------------------------
      subroutine barier(x,y,xs,ys,ok)
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328              BARIER
c
c
c --- PURPOSE: CALCULATE  WHAT SIDE OF A BARRIER A POINT IS ON
C              BARRIERS ARE FINITE LENGTH LINE SEGMENTS
c
c ---UPDATES:
c ---   Level 970825 to Version 5.548a Level 050101 (F.Robe)
c         (1) Replaced common /d3/ by include d3.met and changed variable names from 
c             bas(4,mxbar) to barxy(4,mxbar), and from numbas to nbar
c          
c
c ---    MEF SRC 6/16/94 corrected the way that a vertical (N-S) barrier
c            is handled.  Fix modified 11/96 by J. Scire to work on PC.
c
C
C --- INPUTS: 
C              X (R)        - X-COORDINATE OF POINT OF INTEREST
C              Y (R)        - Y-COORDINATE OF POINT OF INTEREST
C              XS (R)       - X-COORDINATE OF REFERENCE POINT
C              YS (R)       - Y-COORDINATE OF REFERENCE POINT
c
c     Via common d3.met:
c              BARXY(4,mxb) (R) -  COORDINATE OF BARRIER END POINTS
c                                  (in km relative to domain origin)
C              NBAR         (I) - NUMBER OF BARRIERS (UP TO MXBAR)
C              IFIN         (I)    - IF 0 SET UP PT SLOPE LINES
c 
c     Via common params.met: MXBAR
C
C --- OUTPUTS: 
C               OK (R)         - FLAG IF POS (X-Y) IS ON SAME SIDE AS
c                                (XS-YS)
c     Via common d3.met
c               SLPIN(1,mxbar) (R) - SLOPE OF LINE
C               SLPIN(2,mxbar) (R) - INTERCEPT OF LINE
c -------------------------------------------------------------------------------
c --- include parameters
      include 'params.met'
c
      DIMENSION A(3), B(3), C(3)
c --- explicit common replaced by include d3.met 
c     requires to change numbas to nbar and bas to barxy
      include 'd3.met'
c      COMMON /D3/ IFIN,NUMBAS,BAS(4,mxbar),SLPIN(2,mxbar)
C
C
      OK = 1.0
      IF (NBAR .LE. 0) GO TO 140
      IF (IFIN .GT. 0) GO TO 110
C
C     SETUP SLOPE INTERCEPT FORM OF A LINE FOR BARRIER
C
      DO 100 I = 1,NBAR
        DY = BARXY(2,I)-BARXY(4,I)
        DX = BARXY(1,I)-BARXY(3,I)
c
c...Logic to handle North-South vertical barrier with infinite slope.
c
        if (dx.eq.0.0) then
          slpin(1,i) = 9.9E9
        else
          SLPIN(1,I) = DY/DX
        endif
        SLPIN(2,I) = BARXY(2,I)-SLPIN(1,I)*BARXY(1,I)
  100 CONTINUE
      IFIN = 1
C
  110 CONTINUE
c
c...C = vector from station to grid cell
c
      C(1) = XS-X
      C(2) = YS-Y
      A(3) = 0.
      B(3) = 0.
      C(3) = 0.
      DO 120 I = 1,NBAR
c
c...D1 and D2 are distances of vertical lines from station and grid
c...point, respectively, with plane of the barrier.
c
      D1 = YS-SLPIN(1,I)*XS-SLPIN(2,I)
      D2 = Y-SLPIN(1,I)*X-SLPIN(2,I)
c
c...Same sign for D1 and D2 means same side of the barrier.
c
      IF (D1*D2.GE.0.) GO TO 120
c
c...A = vector from grid cell to beginning of barrier.
c
      A(1) = BARXY(1,I)-X
      A(2) = BARXY(2,I)-Y
c
c...B = vector from grid cell to end of barrier.
c
      B(1) = BARXY(3,I)-X
      B(2) = BARXY(4,I)-Y
      COSAB = UNIDOT(A,B)
      COSAC = UNIDOT(A,C)
      COSBC = UNIDOT(B,C)
      IF (COSAC .LT. COSAB .OR. COSBC .LT. COSAB) GO TO 120
c
c...True = clear of barrier, false = blocked by barrier.
c
      OK = -1.0
      GO TO 130
  120 CONTINUE
  130 CONTINUE
C
  140 CONTINUE
      RETURN
      END
c----------------------------------------------------------------------
      subroutine r2interpi(i,j,x,y,zarray,k,zi)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060106          R2INTERPI
c              F.Robe (Earth Tech)
c              after subroutine r2interp
c
c --- PURPOSE:  Interpolate the IGF-CALMET data to the CALMET grid point 
c               using inverse distance squared weighting of four nearest
c               points.
c
c --- INPUTS:
c         I, J - integers   - Row and column of the CALMET grid
c                             being processed
c         X, Y - reals      - Real-space (LCC or UTM) X, Y coordinates 
c                             (km) of CALMET grid point (I,J)
c   ZARRAY(mxnxi,mxnyi,mxnz)- Array of MM4 grid point values to
c                             be used in the interpolation to the
c                             CALMET grid point
c            K - integer    - CALMET layer being processed (NOTE: the
c                             IGF-CALMET data in ZARRAY is horizontally in
c                             the IGF-CALMET grid system, but vertically in
c                             the CALMET system at this point.
c
c    Common block /IGF/:
c          XIGF(mxnxi,mxnyi),YIGF(mxnxi,mxnyi),
c          IGRABi(mxnx,mxny,4),JGRABi(mxnx,mxny,4)
c     Parameters:
c         MXNXi,MXNYi,MXNX,MXNY,MXNZ
c
c --- OUTPUT:
c           ZI - real       - Interpolated value returned for CALMET
c                             grid point (I,J,K)
c
c --- R2INTERPI called by: RDCALMET
c --- R2INTERPI calls:     none
c----------------------------------------------------------------------
c
      include 'params.met'
c
c --- Include common block
      include 'igf.met'
c
      real zarray(mxnxi,mxnyi,mxnz)

      sum = 0.
      sum1 = 0.
c
      do m = 1,4
        pdist = ((xigf(igrabi(i,j,m),jgrabi(i,j,m)) - x) ** 2 +
     &    (yigf(igrabi(i,j,m),jgrabi(i,j,m)) - y) ** 2 )
c
c ---   Minimum distance to avoid computational problems
        if (pdist .lt. 0.001) pdist = 0.001
c
c ---   Convert distance**2 to inverse distance**2
        pdist = 1. / pdist
        sum = sum + zarray(igrabi(i,j,m),jgrabi(i,j,m),k) * pdist
        sum1 = sum1 + pdist
      enddo
      zi = sum / sum1
c
      return
      end
c----------------------------------------------------------------------
      subroutine r2interp(i,j,x,y,zarray,k,zi)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 990228           R2INTERP
c              M. Fernau, Earth Tech
c
c
c --- PURPOSE:  Interpolate the MM4 data to the CALMET grid point using
c               inverse distance squared weighting of four nearest
c               points.
c
c --- INPUTS:
c         I, J - integers   - Row and column of the CALMET grid
c                             being processed
c         X, Y - reals      - Real-space (LCC or UTM) X, Y coordinates 
c                             (km) of CALMET grid point (I,J)
c   ZARRAY(mxnxp,mxnyp,mxnz)- Array of MM4 grid point values to
c                             be used in the interpolation to the
c                             CALMET grid point
c            K - integer    - CALMET layer being processed (NOTE: the
c                             MM4 data in ZARRAY is horizontally in
c                             the MM4 grid system, but vertically in
c                             the CALMET system at this point.
c
c    Common block /MM4HDO/:
c          XLCMM4(mxnxp,mxnyp),YLCMM4(mxnxp,mxnyp),
c          IGRAB(mxnx,mxny,4),JGRAB(mxnx,mxny,4)
c     Parameters:
c         MXNXP,MXNYP,MXNX,MXNY,MXNZ
c
c --- OUTPUT:
c           ZI - real       - Interpolated value returned for CALMET
c                             grid point (I,J,K)
c
c --- R2INTERP called by: RDMM4
c --- R2INTERP calls:     none
c----------------------------------------------------------------------
c
      include 'params.met'
c
c --- Include common block
      include 'mm4hdo.met'
c
      real zarray(mxnxp,mxnyp,mxnz)

      sum = 0.
      sum1 = 0.
c
      do m = 1,4
        pdist = ((xlcmm4(igrab(i,j,m),jgrab(i,j,m)) - x) ** 2 +
     &    (ylcmm4(igrab(i,j,m),jgrab(i,j,m)) - y) ** 2 )
c
c ---   Minimum distance to avoid computational problems
        if (pdist .lt. 0.001) pdist = 0.001
c
c ---   Convert distance**2 to inverse distance**2
        pdist = 1. / pdist
        sum = sum + zarray(igrab(i,j,m),jgrab(i,j,m),k) * pdist
        sum1 = sum1 + pdist
      enddo
      zi = sum / sum1
c
      return
      end
c----------------------------------------------------------------------
      subroutine r2interp2(i,j,x,y,zarray,zi)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 030119          R2INTERP2
c              F.Robe, Earth Tech
c              After r2interp (M.Fernau)
c
c --- PURPOSE:  Interpolate the MM4 data to the CALMET grid point using
c               inverse distance squared weighting of four nearest
c               points (2D arrays)
c
c --- INPUTS:
c         I, J - integers   - Row and column of the CALMET grid
c                             being processed
c         X, Y - reals      - Real-space (LCC or UTM) X, Y coordinates 
c                             (km) of CALMET grid point (I,J)
c      ZARRAY(mxnxp,mxnyp)  - Array of MM4 grid point values to
c                             be used in the interpolation to the
c                             CALMET grid point
c
c    Common block /MM4HDO/:
c          XLCMM4(mxnxp,mxnyp),YLCMM4(mxnxp,mxnyp),
c          IGRAB(mxnx,mxny,4) ,JGRAB(mxnx,mxny,4)
c     Parameters:
c         MXNXP,MXNYP,MXNX,MXNY
c
c --- OUTPUT:
c           ZI - real       - Interpolated value returned for CALMET
c                             grid point (I,J)
c
c --- R2INTERP2 called by: RDMM5
c --- R2INTERP2 calls:     none
c----------------------------------------------------------------------
c
      include 'params.met'
c
c --- Include common block
      include 'mm4hdo.met'
c
      real zarray(mxnxp,mxnyp)

      sum = 0.
      sum1 = 0.
c
      do m = 1,4
        pdist = ((xlcmm4(igrab(i,j,m),jgrab(i,j,m)) - x) ** 2 +
     &    (ylcmm4(igrab(i,j,m),jgrab(i,j,m)) - y) ** 2 )
c
c ---   Minimum distance to avoid computational problems
        if (pdist .lt. 0.001) pdist = 0.001
c
c ---   Convert distance**2 to inverse distance**2
        pdist = 1. / pdist
        sum = sum + zarray(igrab(i,j,m),jgrab(i,j,m)) * pdist
        sum1 = sum1 + pdist
      enddo
      zi = sum / sum1
c
      return
      end
c----------------------------------------------------------------------
      subroutine cinterp(i,j,x,y,zarray,zi)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070202            CINTERP
c              F.Robe, TRC 
c              After R2INTERP2 subroutine 
c
c
c --- PURPOSE:  Interpolate the MM5 ceiling height to the CALMET grid
c               using inverse distance squared weighting of four nearest
c               points but giving no weight to zero values (no cloud)
c
c --- UPDATES:
c --- Level 030119 to V6.223 Level 070702 (F.Robe):
c           - modify subroutine to account for the fact that the ceiling
c             height arrays are 2 D not 3D i.e. model after R2INTERP2 not
c             R2INTERP
c      
c 
c --- INPUTS:
c         I, J - integers   - Row and column of the CALMET grid
c                             being processed
c         X, Y - reals      - Real-space (LCC or UTM) X, Y coordinates 
c                             (km) of CALMET grid point (I,J)
c        ZARRAY(mxnxp,mxnyp)- Array of MM4 grid point values to
c                             be used in the interpolation to the
c                             CALMET grid point
c
c    Common block /MM4HDO/:
c          XLCMM4(mxnxp,mxnyp),YLCMM4(mxnxp,mxnyp),
c          IGRAB(mxnx,mxny,4),JGRAB(mxnx,mxny,4)
c     Parameters:
c         MXNXP,MXNYP,MXNX,MXNY,MXNZ
c
c --- OUTPUT:
c           ZI - real       - Interpolated value returned for CALMET
c                             grid point (I,J,K)
c
c --- CINTERP called by: RDMM5
c --- CINTERP calls:     none
c----------------------------------------------------------------------
c
      include 'params.met'
c
c --- Include common block
      include 'mm4hdo.met'
c
      real zarray(mxnxp,mxnyp)

      sum = 0.
      sum1 = 0.
c
      do 1 m = 1,4
        pdist = ((xlcmm4(igrab(i,j,m),jgrab(i,j,m)) - x) ** 2 +
     &    (ylcmm4(igrab(i,j,m),jgrab(i,j,m)) - y) ** 2 )
c
c ---   Minimum distance to avoid computational problems
        if (pdist .lt. 0.001) pdist = 0.001
c
c ---   Convert distance**2 to inverse distance**2
        pdist = 1. / pdist
        a = zarray(igrab(i,j,m),jgrab(i,j,m))
c ---   don't take zero values into account (zero ceiling height=no clouds)
c ---   allow for round-off errors
        if (a .lt. 1.e-6) go to 1
        sum = sum + zarray(igrab(i,j,m),jgrab(i,j,m)) * pdist
        sum1 = sum1 + pdist
1     continue
      if (sum1.gt.1.e-9) then
         zi = sum / sum1
      else
         zi = 0.
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine box(ibx,xg,yg,ok)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 940616                BOX
c        R. Mentzer, SRC
c --- MEF SRC 6/16/94 changed to include outer row and column of box
c     in the box (better for boxes that abut edge of domain)
C
C     THIS ROUTINE CALCULATES WHETHER A POINT IS WITHIN A DEFINED BOX
C
C     INPUTS:  ibx           - Box number
C              Xg (R)        - X-COORDINATE OF POINT OF INTEREST
C              Yg (R)        - Y-COORDINATE OF POINT OF INTEREST
C
C        Common BREEZ:
C              XG1 (R)       - X-grid line defining a box
C              XG2 (R)       - X-grid line defining a box
C              YG1 (R)       - Y-grid line defining a box
C              YG2 (R)       - Y-grid line defining a box
C        Parameters: MXBAR
C
C     OUTPUTS:
C               OK (R)       - FLAG IF Point is within the box
c
c     CALLED BY: LLBREEZ
c     CALLS    : UNIDOT
c
c----------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'breez.met'

      integer ibx
c
      ok=-1.0
      if (amin1(xg1(ibx),xg2(ibx)) .eq. xg1(ibx)) then
       if (xg .ge. xg1(ibx) .and. xg .le. xg2(ibx)) then
          if (amin1(yg1(ibx),yg2(ibx)) .eq. yg1(ibx)) then
            if (yg .ge. yg1(ibx) .and. yg .le. yg2(ibx)) OK=1.0
          else
            if (yg .le. yg1(ibx) .and. yg .ge. yg2(ibx)) OK=1.0
          endif
       endif
      else
       if (xg .le. xg1(ibx) .and. xg .ge. xg2(ibx)) then
          if (amin1(yg1(ibx),yg2(ibx)) .eq. yg1(ibx)) then
             if (yg .ge. yg1(ibx) .and. yg .le. yg2(ibx)) OK=1.0
          else
             if (yg .le. yg1(ibx) .and. yg .ge. yg2(ibx)) OK=1.0
          endif
       endif
      endif
c
      RETURN
      END
c----------------------------------------------------------------------
      subroutine cgamma(nyrze,njulze,nhrze,nsece,iupt,zupt,ziconv,
     &                  gamma)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 090511             CGAMMA
c ---          J. Scire, SRC
c
c --- PURPOSE:  Compute the average temperature lapse rate in a layer
c               up to the height "ZUPT" at upper station IU
c
c --- UPDATES:
c --- V6.32 Level 080205 to v6.327 LEvel 090511 (FRR)
c       - Remove format statements 1089 and 1090 which are not 
c         used
c --- V6.218 Level 070113 to V6.32 Level 080205(FRR)
c       - Use explicit end times instead of beginning times
c       - Do not interpolate in time if time-average sounding
c         (i.e. AA=BB arrays)
c --- v6.215 Level 061020 to V6.218 Level 070113 (FRR)
c       - Add comment warning that IUPT in this subroutine is an 
c         internal parameter indicating the upper air station number
c         where the lapse rate is computed, which ca be  different from the
c         user-selected flag  "IUPT" (which can be <0)
c --- V5.1 Level 991104 to v6.215 Level 061020 (DGS)
c       - Use explicit beginning times with seconds
c       - JUSDT is now seconds, not hours
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c
c --- INPUTS:
c
c                NYRZE - integer    - Year of current hour (UTC)
c                                       (explicit ending time)
c               NJULZE - integer    - Day of current hour (UTC) 
c                                       (explicit ending time)
c                NHRZE - integer    - Current hour UTC time (0-23)
c                                       (explicit ending time)
C                NSECB - integer    - Current ending second
c                IUPT  - integer    - Station number of the upper air
c                                     sounding where lapse rate is computed
c                                     !!! IUPT in this subroutine is an
c                                     actual station number and not the "IUPT"
c                                     flag in the calmet.inp file (which can
c                                     be -1 if all the upper air stations are used
c                 ZUPT - real       - Height (m) up to which temp.
c                                     lapse rate is computed
c               ZICONV - real       - Convective mixing ht. (m) for
c                                     the grid cell containing upper
c                                     air station no. "IUPT"
c        Parameters: MXUS, MXLEV, IO6
C
c        UPMET.MET: ISNAP(MXUS),JUSTA(MXUS),JUSTD(MXUS), NTZAA(MXUS),NTZBB(MXUS),
C                   JAASEC(MXUS),JBBSEC(MXUS)
c
c --- OUTPUT:
c                GAMMA - real       - Average temperature lapse rate
c                                     (deg. K/m) in the layer up to
c                                     height "ZUPT" at upper air station
c                                     Number iupt -
c
c --- CGAMMA called by:  PREPDI
c --- CGAMMA calls:      INTP, DEDAT, DELTSEC
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      include 'upmet.met'
c

      data nconvdat/-9999/,xmiss/999.9/

c --- Current timestamp (ending UTC time)
      nowtze = nyrze*100000 + njulze*100 + nhrze

      if(ziconv.ge.zupt)then
c
c ---    layer within convective mixing height
c ---    assume dry adiabatic lapse rate
         gamma=-0.0098
c ---    save time -- last convective per of day is used in time interp
         nconvdat=nowtze
         nconvsec=nsece
         return
      endif

C --- Skip time interpolation if time-averaged sounding (080205) 
c --- Requires: ISNAP=0: averaged soundings in UP.DAT (v2.2) (AA=BB arrays)
c ----          JUSTA=+1 (BB time later than AA time) -
c --- If BB sooner than AA (justa=-1), then current time is between 
c --- 2 averaged-soundings and time interpolation must be done
      if (isnap(iupt).eq.0.and.justa(iupt).eq.+1) then
         xmissm=xmiss-0.01
         ts=tzbb(iupt,1)
c ---    Extract temp. at z = ZUPT  via interpolation in height 
         call INTP(tzbb,zlbb,nlbb(iupt),iupt,zupt,xmissm,tt)
         gamma=(tt-ts)/zupt
         return
      endif


c *** rjy additions of 1/26/90 for arbitrary soundings. ***********
      jorder = justa(iupt)
      jdelta = jusdt(iupt)
      ntzaas = ntzaa(iupt)
      call DEDAT(ntzaas,jaayr,jaaday,jaahr)
      ntzbbs = ntzbb(iupt)
      call DEDAT(ntzbbs,jbbyr,jbbday,jbbhr)
      ibbsec=jbbsec(iupt)
      iaasec=jaasec(iupt)

      if(jorder.gt.0) then
c        call deltt(nyrz,njulz,nhrz,jbbyr,jbbday,jbbhr,jtogo)
c        call deltt(jaayr,jaaday,jaahr,nyrz,njulz,nhrz,jpast)
         call DELTSEC(nowtze,nsece,ntzbbs,ibbsec,jtogo)
         call DELTSEC(ntzaas,iaasec,nowtze,nsece,jpast)
      else
c        call deltt(nyrz,njulz,nhrz,jaayr,jaaday,jaahr,jtogo)
c        call deltt(jbbyr,jbbday,jbbhr,nyrz,njulz,nhrz,jpast)
         call DELTSEC(nowtze,nsece,ntzaas,iaasec,jtogo)
         call DELTSEC(ntzbbs,ibbsec,nowtze,nsece,jpast)
      endif

c --- Interpolate in time to current ending time.  Note that xfact starts
c     out at 1.0 and works down to 0 as jtogo gets smaller.
      xfact = float(jtogo) / float(jdelta)

c ********************************************************************
c
c --- Reduce the missing value indicator by a small amount to allow
c --- for machine roundoff
      xmissm=xmiss-0.01
c
c --- Extract the two bounding values of surface temp.
      tsbb=tzbb(iupt,1)
      tsaa=tzaa(iupt,1)
      if(tsbb.ge.xmissm.or.tsaa.ge.xmissm)then
         write(io6,*)'ERROR in subr. CGAMMA -- bottom of sounding is ',
     1   'missing -- TSAA = ',tsaa,' TSBB = ',tsbb,' Date of AA ',
     2   'sounding (YYYYDDDHH) = ',ntzaas,' Date of BB sounding ',
     3   '(YYYYDDDHH) = ',ntzbbs
         stop
      endif
c
c --- Interpolate linearly to obtain the surface temp.,ts, at end time
      if(jorder.lt.0) then
         ts=tsaa-(tsaa-tsbb)*xfact
      else
         ts=tsbb-(tsbb-tsaa)*xfact
      endif
c
c --- Reduce missing value indicator by a slight amount to allow for
c --- machine roundoff
      xmissm=xmiss-0.01
c
c --- Extract the two bounding values of temp. at z = ZUPT
c     via interpolation in height of the two soundings.
         call INTP(tzaa,zlaa,nlaa(iupt),iupt,zupt,xmissm,ttaa)
         call INTP(tzbb,zlbb,nlbb(iupt),iupt,zupt,xmissm,ttbb)
c --- Interpolate linearly to obtain the temp at z=ZUPT at begin time
      if(jorder.lt.0) then
         tt=ttaa-(ttaa-ttbb)*xfact
      else
         tt=ttbb-(ttbb-ttaa)*xfact
      endif
c
c --- Compute  ave. lapse rate (deg. K/m)
      gamma = (tt-ts) / zupt
c

c --- We would normally be finished here, but we want to make use of
c     adiabatic nature of the boundary layer during convective hours.
c --- First skip cases where NCONVDAT undefined.
      if(nconvdat.LT.-9998) return
c --- Also, this additional information is only useful if NCONVDAT
c     lies between the two current soundings.
      if(jorder.gt.0) then
         call DELTSEC(nconvdat,nconvsec,ntzbbs,ibbsec,jtogoc)
         call DELTSEC(ntzaas,iaasec,nconvdat,nconvsec,jpastc)
      else
         call DELTSEC(nconvdat,nconvsec,ntzaas,iaasec,jtogoc)
         call DELTSEC(ntzbbs,ibbsec,nconvdat,nconvsec,jpastc)
      endif
c --- Check that last convective time lies between soundings.  For this
c     to be true, the sum JTOGOC+JPASTC will equal the duration JDELTA.
c --- If outside the interval, quit with the previous gamma definition.
      if((jpastc+jtogoc).ne.jdelta) return
c --- Add a second test just to make sure the convective hour preceeds
c     the current hour.  However, this should be automatic.
      if(jtogoc.le.jtogo) return
c --- Add a third test just to make sure that if the last convective
c     hour is also a sounding hour, the sounding is preferentially used.
      if(jtogoc.ge.jdelta) return
c
      xfactc = float(jtogoc) / float(jdelta)
c --- Interpolate linearly to obtain the surface temp. computed elevated
c     temperature at last convective hour.
c     Assume sounding remains adiabatic up to and including last hour
c     with convective mixing height > ZUPT.
      if(jorder.lt.0) then
         ttc = tsaa-(tsaa-tsbb)*xfactc - 0.0098*zupt
      else
         ttc = tsbb-(tsbb-tsaa)*xfactc - 0.0098*zupt
      endif
c
c --- Now linearly interpolate from this last convective time to the
c     next sounding to obtain the temp. at z=ZUPT at NOWTZE,NSECE.
      xfact = float(jtogo) / float(jtogoc)
c     Note that XFACT has been redefined to deal with the shorter period
c --- Interpolate linearly to obtain the temp at z=ZUPT at NOWTZE,NSECE.
      if(jorder.lt.0) then
         tt=ttaa-(ttaa-ttc)*xfact
      else
         tt=ttbb-(ttbb-ttc)*xfact
      endif
c
c --- Compute  ave. lapse rate (deg. K/m)
      gamma = (tt-ts) / zupt
c
      return
      end
c----------------------------------------------------------------------
      subroutine cgamma2(tprog,ziconv,gamma)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070113            CGAMMA2
c ---          J. Scire, SRC
c
c --- PURPOSE:  Compute a 2-D array of  temperature lapse rate in a layer
c               up to the height "ZUPT" using prognostic data
c               Compute a domain representative temperature TINF
c               based on prognostic surface temperatures 
c
c --- UPDATES:
c --- (99/01-941101) to V6.218 Level 070113 (F.Robe)
c         - Only compute domain representative surface temperature 
c           Tinf if isurft=-2  (if ISURFT=-1,spatially varying surface
c           temperature is used instead of Tinf)
c         - Replace single lapse rate gamma by 2-D array. Spatially
c           variable gamma if iupt=-1 (default); domain average value
c           otherwise (iupt=-2).
c         - Remove itprog from calling list
c 
c --- INPUTS:
c
c                TPROG - real array  - MM4 temperature array on CALMET
c                                      grid
c               ZICONV - real array  - Convective mixing ht. (m) 
c                 ZUPT - real        - Height (m) up to which temp.
c                                      lapse rate is computed
c                                      (from common block WPARM)
c               CELLZC - real array  - Midpoints of CALMET levels
c                                      (from common block D1)
c             NX,NY,NZ - integer     - CALMET grid dimensions
c                                      (from common block D5)
c --- Via common wparm.met:
c
c                 IUPT - integer     - Flag for the computation of lapse-rate
c                                      IUPT=-1 : spatially variable lapse rate
c                                      IUPT=-2: domain average lapse rate
c                                      (IUPT>0: only with upper air soundings)
c                 ZUPT - real        - height up to which lapse rate is computed
c               ISURFT - integer     - Flag for the surface temperature
c                                      used in terrain-induced computations
c                                      - ISURFT=-1: 2-D variable Sf temp.
c                                      - ISURFT=-2:constant Sf temp.(averaged over all
c                                        prognostic temp
c                                      - ISURFT>0: surface station number to used 
c                                        (constant Tinf throughout domain) - Not relevant
c                                        in this subroutine (only for progn.temp.)
c 
c        Parameters: MXNX,MXNY,MXNZ, IO6
c
c --- OUTPUT:
c                GAMMA - real array - Temperature lapse rate (deg. K/m) 
c                                     in the layer up to height "ZUPT".
c                                     Spatially variable if IUPT=-1 (default); 
c                                     Domain average if IUPT=-2 (not recommended)
c  via common wparm.met
c                 TINF - real       - Average surface temperature
c
c --- CGAMMA2 called by:  DIAGNO  
c --- CGAMMA2 calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'd1.met'
      include 'grid.met'
      include 'wparm.met'

      real tprog(mxnx,mxny,mxnz),ziconv(mxnx,mxny)
      real gamma(mxnx,mxny)
c
      avgamma = 0.

c --- initialize tinf
      if (isurft.eq.-2) tinf=0

c --- Find ratio (ZHIGH - ZUPT)/(ZHIGH - ZLOW) for use in interpolation
      do 10 k = 1,nz
        if (cellzc(k) .ge. zupt) then
          nbp = k
          go to 20
        endif
10    continue
c
c --- Sounding does not go high enough
      write(io6,15) zupt,nz,cellzc(nz)
15    format(//1x,'ERROR IN SUBR. CGAMMA2 -- interp. height is ',
     1 'above top model level'//5x,'Height = ',f10.1,5x,
     2 'No. model levels = ',i5,5x,'Top model height = ',f10.1)
      stop
20    continue
      if (nbp .eq. 1) then
        write(io6,*) ' ZUPT is smaller than lowest layer midpoint'
        stop
      else
        nbpm1 = nbp - 1
      end if
      rat = (cellzc(nbp) - zupt) /
     &      (cellzc(nbp) - cellzc(nbpm1))


      do i = 1,nx
      do j = 1,ny
        if (ziconv(i,j) .ge. zupt) then
c
c ---     layer within convective mixing height
c ---     assume dry adiabatic lapse rate
          avgamma= avgamma - 0.0098
          gamma(i,j)=-0.0098

        else
          ts = tprog(i,j,1)
c
c ---     find temperature at ZUPT by interpolation
c
          tu = tprog(i,j,nbp) - (tprog(i,j,nbp) -
     &         tprog(i,j,nbpm1)) * rat
c
c --- Compute  ave. lapse rate (K/m)
          tgamma = (tu - ts) / (zupt - cellzc(1))
          avgamma = avgamma + tgamma
          gamma(i,j)=tgamma
        end if

c frr (09/01)
c ---   Compute domain representative surface temperature TINF
        if (isurft.eq.-2) tinf=tinf+tprog(i,j,1)
      end do
      end do

c --- If users-selected, fill in gamma array with domain average lapse rate
c --- (not recommended but allowed for consistency purposes with older versions)
      if (iupt.eq.-2) then
         do i=1,nx
         do j=1,ny
            gamma(i,j) = avgamma / (nx * ny)
         end do
         end do
      endif

      if (isurft.eq.-2) tinf = tinf/(nx * ny)

      return
      end
c----------------------------------------------------------------------
      subroutine chksum(x,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130             WRTI2D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Sum all values of an array -- QA checking purposes
c
c----------------------------------------------------------------------
c
      real x(mxnx,mxny,mxnz)
      character*80 cmesag
c
c --- sum all values of an array -- QA checking purposes
      sum=0.0
      do 100 i=1,nx
      do 100 j=1,ny
      do 100 k=1,nz
      sum=sum+x(i,j,k)
100   continue
c
      write(io6,102)cmesag
102   format(1x,a80)
      write(io6,*)'CHECK SUM = ',sum
c
      return
      end
c----------------------------------------------------------------------
      subroutine cmpd2(xref,yref,x,y,nsta,dist2)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130              CMPD2
c ---          J. Scire, SRC
c
c --- PURPOSE:  Compute the (distance)**2 from each station to the
c               reference coordinates (XREF, YREF)
c
c --- INPUTS:
c          XREF - real     - X coordinate of reference point
c          YREF - real     - Y coordinate of reference point
c       X(nsta) - real     - Array of X coordinates of stations
c       Y(nsta) - real     - Array of Y coordinates of stations
c          NSTA - integer  - Number of stations
c
c --- OUTPUT:
c   DIST2(nsta) - real     - Distance**2 from each station to the
c                            reference point (XREF, YREF)
c
c --- CMPD2 called by:  MISSFC
c --- CMPD2 calls:      none
c----------------------------------------------------------------------
c
      real x(nsta),y(nsta),dist2(nsta)
c
c --- Compute the (distance)**2 from (XREF, YREF) to each
c --- station
      do 10 i=1,nsta
      dist2(i)=(x(i)-xref)**2+(y(i)-yref)**2
10    continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine comp
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203               COMP
c ---          J. Scire, R. Yamartino, SRC
c ---          Modified by M. Fernau, X. Zhang, J. Scire
c
c --- PURPOSE:  CALMET Computational Routine -- contains main time
c               loop and calls routines performing hourly computations
c
c --- UPDATES:
c
c --- v6.330 (101006) to v6.4.0 (121203)
c        - Add AUXOUT
c
c --- v6.327 (090511) to v6.330 (101006) (CEC)
c        - Change ICLOUD into MCLOUD (and ICLDOUT)
c
c --- v6.321 (080325) to v6.327 (090511) (FRR)
c        - Revised write Formats 75,1311,1312 to add more information
c          at stop 
c ---   V6.32 (080205) (FRR) to v6.321 (080325)
c        - Remove nsecdt from calling list to rdupn2
c
c --- 6.3 (070717) to V6.32 (080205) (FRR)
c        - Compare end time of calmet timestep with end time
c          of upper air soundings (instead of beginning times)
c        - Allow new UP.DAT format (dataveru=2.2) in which
c          beginning = end times indicate an instantaneous sounding
c          begining < end times indicate a time-averaged sounding
c        - Initialize Snapshot vs. time-averaged sounding flag: 
c          ISNAP(mxus): time-averaged=0  / snapshot=1
c        - Ensure that data frequency is no higher than CALMet sampling
c          frequency
c
c --- V6.222 (070404) to v6.3 (070717)
c        - Add IPSIFCN to ELUSTR argument list
c        - Add ISFCMET option for 2D surface temperatures and density
c        - Add IUPT to calling list to MIXHT
c        - compute ending GMT time and pass it on to DIAGNO, WATER and WATERP
c          rather than the beginning time (for use in COARE)
c
c --- V6.221 (070327)to V6.222 (070404)(FRR)
c        - Pass on observed ceiling height iceil(mxss) and icloud
c          to RADFLX (icloud=1)
c        - Fill in gridded cloud array with observations sooner
c          in the code (icloud=1) 
c        - Decode  beginning date of precipitation record in 2.1 format
c          for proper debug writing (debug mode only)
c
c --- V6.218 (070113) to V6.221 (070327)(FRR)
c        - Save ldbhr in OUTPT.MET and do not declare it here anylonger
c        - initialize idathrb, idathre,ipdathrb, ipdathre (B. Brashers)
c          and isecb,isece,ipsecb,ipsece
c        - Print out requested variables in list file on hourly basis 
c          (i.e. use nsecb for test instead of isecb)
c
c --- v6.215 (061020) to V6.218 (070113) (FRR)
c        - Remove beta2 from PREPDI and DIAGNO calling lists
c        - Make former scalar gamma a 2-D array
c        - Remove nz,nssta,nusta,noobs from PREPDI calling list 
c        - Remove iupt from MIXHT calling list
c
c --- v6.208 (060329) to v6.215 (061020) (DGS) 
c        - Modified calling args for RDUP, RDUPN
c        - Fix diagnostic write statements that use old hour-ending
c          variable names
c        - Activate hour-ending times for MESOPAC output option
c          and restrict output to NSECDT=3600
c
c --- v6.205 (060309) to v6.208 (060329) (DGS) 
c        - Fix date matching test on precip.dat file dates for old
c          file format (MOD5)
c
c --- v6.202 to v6.205 (060309)(F.Robe) 
c        - Correct matching test on calmet/surf.dat dates for old surf.dat
c          file format
c        - No longer compute nowtz as nhr,njul,nyr are no longer updated 
c          (can crash call to indecr)
c        - Replace nhr by nhrb at end of day loop
c
c --- v6.2 (060215)to v6.202 (F.Robe) 
c        - Correct linear interpolation of solar angle between 1800 and
c          3600sec
c
c --- v5.611 (051113)to v6.2 (060215) (F.Robe) 
c        - Use explicit beginning/ending times instead of hour-ending
c          convention
c        - Loop over sub-hourly timesteps and flag last one
c        - Call to RDS/RDSN,RDP/RDPN,RDUP/RDUPN depending on data version
c          number (explicit or hour-ending times)
c
c --- V5.6 (050328) to v5.611 (051113) (F.Robe)
c        - Allow option to use prognostic offshore data (3D.DAT) instead
c          of SEA.DAT with itwprog=2 (call to WATERP or WATER)
c        - Add itwprog to DIAGNO calling list
c
c --- V5.55 (041030) to V5.6 (050328) (F.Robe)
c             - remove nssta from calling list to airden
c             - pass on value of imixh to water in order to compute the
c               convective mixing height according to the user-selected
c               method
c 
c --- V5.547 to V5.55 (041030)  (F.Robe)
c              - Rationalize computation and use of 2D surface variables
c                (change in calling lists, split of surfvar into 
c                 surftemp and surfvar (rh,ipcode, cloud)
c              - Change order of call to various subroutines to ensure
c                that necessary variables are available for calls to COARE
c              - Add itimstep variable to track timestep
c                timestep stored in GEN.MET for use in COARE and
c                passed to SOLAR
c              - Compute Downward Long Wave radiative flux
c
c --- V5.5 (030402) to V5.547 (041010) (FRR)
c              - Remove nears from calling list to MIXHT and NOOBS from 
c                list to WATER
c
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c               - Add list-file unit to GRDAY, INDECR calls
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c        Common blocks:
c         /GEN/, /GRID/, /OUTPT/, /MET1/, /MET2/, /MET3/, /UPMET/,
c         /METGRD/, /GEO/, /HFLUX/, /OVRWAT/, /WPARM/, /D1/, /FLAGS/,
c         /METPAC/, /ZIPARM/, /TMP/
c        Parameters: mxnx, mxny, mxnz, mxss, mxus, mxps, mxbar,
c                    mxows, mxlev, mxlu, io6
c                    mxwnd, mxnzp1, mxxy
c
c --- OUTPUT:  none
c
c ---  COMP called by:  MAIN
c ---  COMP calls:      VERTAV, SOLAR,  PREPDI, DIAGNO, WATER,  PGTSTB,
c                       HEATFX, AIRDEN, ELUSTR, MIXHT,  WSTARR, GRIDE,
c                       RDUP,   RDS,    RDP,    RDOW,   DIAG2, INDECR,
c                       DELTT, OUT, OUTHR, GRDAY, TEMP3D, FACET, DEDAT,
c                       MISSFC, AVEMIX, OUTPC,  PACAVE, AVETMP, OUTCLD,
c                       RDCLD, WATERP
c                       AIRDEN_NS, TEMP3D_back, SURFVAR_back
c --- v6.4.0, Level 121203
c ---                   AUXOUT
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real ziconv(mxnx,mxny)
      real rho(mxnx,mxny),qsw(mxnx,mxny)
      real uaveaa(mxnz,mxus),uavebb(mxnz,mxus)
      real vaveaa(mxnz,mxus),vavebb(mxnz,mxus)
      real tzgraa(mxnzp1,mxus),tzgrbb(mxnzp1,mxus)
c     real otempk(mxss)   : otempk saved in met2.met (050328)
      real tprog(mxnx,mxny,mxnz),vptprog(mxnx,mxny,mxnz)
      real ccgrid(mxnx,mxny)
      character*70 messag
      character*4 namst
      real temp2d (mxnx,mxny)
c --- Add 2D temperature array for nearest surface station/prognostic
c --- temperatures (ISFCMET=1 option)
      real tsfnsp(mxnx,mxny)
      integer irh2d(mxnx,mxny),ipcode2d(mxnx,mxny)
      integer iceilg(mxnx,mxny)
c frr 050328 (long wave rad. flx)
      real qlw(mxnx,mxny)

c --- 2-D lapse rate (070113)
      real gamma(mxnx,mxny)
c
      logical ldate,lprthr 
c
      include 'd1.met'
      include 'flags.met'
      include 'gen.met'
      include 'geo.met'
      include 'grid.met'
      include 'hflux.met'
      include 'met1.met'
      include 'met2.met'
      include 'met3.met'
      include 'metgrd.met'
      include 'metpac.met'
      include 'outpt.met'
      include 'ovrwat.met'
      include 'upmet.met'
      include 'wparm.met'
      include 'ziparm.met'
      include 'tmp.met'
      common /salp/ ihr2gmt,sinalp2(mxnx,mxny)
c
      data nh/0/,ldate/.true./,iconvrt/1/,ziconv/mxxy*0.0/
      data maxsep/14/
c     sub-hourly timestep counter(replaces hourly counter nh)
      data nsubh/0/

c     initialize dataset time variables:
      data idathrb, idathre /0,0/ ! BAB bug fix (un-initialized variables)
      data ipdathrb,ipdathre/0,0/ ! BAB bug fix (un-initialized variables)
      data isecb, isece /0,0/ !  
      data ipsecb,ipsece/0,0/ ! 

c --- Initialize upper air sounding flags (080205)
      do k=1,nusta
         isnap(k)=1
      end do 

      if(lmesg)then
         write(iomesg,*)'ENTERING COMPUTATIONAL PHASE'
         write(iomesg,*)
      endif
c
c --- QA check on ISFCMET value
      if(isfcmet.NE.0 .AND. isfcmet.NE.1) then
         write(io6,*)'ERROR in COMP:  invalid ISFCMET provided'
         write(io6,*)'  Expected isfcmet = 0 or1'
         write(io6,*)'     Found isfcmet = ',isfcmet
         stop 'ERROR in COMP -- see list file'
      endif
c

c --- v6.4.0, Level 121203
c --- Set flag for processing AUX output arrays (full max dims)
      ifull=0
      if(mxnx.EQ.nx .AND. mxny.EQ.ny) ifull=1

c --- determine loop range & initialize date/time variables
c --- ("idays" sized at length plus TWO days to account for case
c --- when starting hour is not hour 0, e.g., so that a 24-hour
c --- run can span two days)
      idays=(irlg-1)/24+2
      if(mod(ibyrn,4).eq.0)then
         mxdays=366
      else
         mxdays=365
      endif

c --- Initialize MOD6 explicit beginning time
c --- nyrb=ibyr  --- bug fix 101206
      nyrb=ibyrn
      njulb=ibjuln-1
      nhrb=ibhrn-1
      nsecb=ibsecn-nsecdt
c
c --- Determine the sub-hourly update frequency (#timesteps in 1 hour)
c --- (nsecdt is a fraction of 3600 - This is ensured in READCF)
      nsubst=3600/nsecdt
c
c --- Begin DAY loop
      do 1000 idy=1,idays
c
c --- increment date/time
c --- beginning time of the current timestep
      njulb=njulb+1
      if(njulb.gt.mxdays)then
         nyrb=nyrb+1
         njulb=1
         if(mod(nyrb,4).eq.0)then
            mxdays=366
         else
            mxdays=365
         endif
      endif
      call grday(io6,nyrb,njulb,nmob,ndayb)

c --- ending time of the current timestep 
c --- (everything except seconds are the same as beginning time because
c --- (the ending seconds isece are allowed to be =3600)
      njule=njulb      
      nyre=nyrb
      nmoe=nmob
      ndaye=ndayb

c --- compute sin(solar elevation angles) at all gridpoints
c --- MOD6: compute 26 hourly values (between 23:30 previous day and 0:30 next day)
c --- Hourly alues are linearly interpolated to the half-time step and stored
c --- in SINALPC(mxnx,mxny)


      call solar (njulb,ibtz,sinalp)
c


c --- Begin HOUR loop
      do 900 ih=1,24
c

c --- increment hour variables
      nh=nh+1

c --- current timestep (saved in GEN.MET - frr050328 - Used in COARE) 
      itimstep= nh

c --- flag last hour of run - must be last timestep in MOD6 (060215)
c      if (nh.eq.irlg) nendhr =1

c --- end of run no longer determined by last hour
c --- but by last sub-hourly step (060215)
c     if(nh.gt.irlg)go to 1001


c --- Increment hour of the day (beg/ending)
      nhrb=nhrb+1
      if(nhrb.gt.23)then
         nhrb=-1
         nh=nh-1
         go to 1000
      endif
      nhre=nhrb

c --- nhrind is hour variable ranging from 1-24 instead of 0-23
c --- (used as array index for sinalp (i,j,1-24) so must be >0)
      nhrind=nhrb+1

c --- compute MOD6 explicit beginning date/hour variable (YYYYJJJHH)
      ndathrb=nyrb*100000+njulb*100+nhrb

c --- MOD6 explicit ending date/hour variable (YYYYJJJHH)- (051116)
      ndathre=ndathrb

c --- MOD5 hour-ending date/hour variables (end of current hour)
c --- This assumes that current times always finish an hour with
c --- seconds=3600
      nyr=nyrb
      njul=njulb      
      nmo=nmob
      nday=ndayb
      nhr=nhrb
      call INCR(io6,nyr,njul,nhr,1)
      ndathr=nyr*100000+njul*100+nhr


c frr 050328 - Compute GMT time whether noobs or not (needed in several 
c              places (upper air soundings and overwater coare method)

c --- compute the current GMT (or Z) date/hr variable, NOWTZ (YYYYJJJHH)
c --- (MOD5 hour-ending)
c      nhrz = nhr
c      njulz = njul
c      nyrz = nyr
c      call indecr(io6,nyrz,njulz,nhrz,ibtz,0,23)
c     nowtz = nyrz*100000 + njulz*100 + nhrz

c --- compute the current GMT (or Z) beginning date/hr variable, NOWTZB (YYYYJJJHH)
      nhrzb = nhrb
      njulzb = njulb
      nyrzb = nyrb
c *** Use the more general INDECR subroutine which allows
c *** negative values of IBTZ
c *** call incr(nyrz,njulz,nhrz,ibtz)
      call indecr(io6,nyrzb,njulzb,nhrzb,ibtz,0,23)
      nowtzb = nyrzb*100000 + njulzb*100 + nhrzb
c
c
c --- Begin SUB-HOUR loop
      do 800 isub=1,nsubst

c --- increment sub-hourly timestep counter 
      nsubh=nsubh+1

c --- flag last timestep of run (for use in rdmm5) 051128
      if (nsubh.eq.irsublg) nendhr = 1

c --- end run if arrives at final sub-hourly timestep
      if(nsubh.gt.irsublg)go to 1001

c --- increment seconds
      nsecb=nsecb+nsecdt

c --- Current timestep beginning at (ndathrb,nsecb)

c --- Go to next hour if exceed last sub-hourly step of that hour
      if(nsecb.eq.3600) then
         nsecb=-nsecdt
         nsubh=nsubh-1
         go to 900
      endif

c --- Update current timestep ending time
c --- (seconds up to 3600 so that do not update hour,day,etc)
      nsece=nsecb+nsecdt
c
c --- update current timestep ending GMT time (070717)
c --- compute the current GMT (or Z) ending date/hr variable, NOWTZE (YYYYJJJHH)
c --- Note: INCRS subroutine will convert 3600sec into 1 hour
      nhrze = nhrzb
      njulze = njulzb
      nyrze = nyrzb
      nsecze=0
      call incrs(io6,nyrze,njulze,nhrze,nsecze,nsece)
      nowtze = nyrze*100000 + njulze*100 + nhrze

c --- Compute current sine of solar angle sinalpc stored in GEN.MET
c --- Interpolate from hourly values to mid-timestep
c --- Array index (k) has value for time (k-2) hours and 30 minutes
c --- For hourly timesteps, identical values as in  MOD5
      Do j=1,ny
         do i=1,nx
            nsecm=nsecb+nsecdt/2   
            dsec=abs( (float(nsecm)-1800.)/3600. )
            if (nsecm.eq.1800) then   
               sinalpc(i,j)=sinalp(i,j,nhrb+2)   
            else if (nsecm.gt.1800) then
               sinalpc(i,j)=sinalp(i,j,nhrb+2)*(1.-dsec)
     :                    + sinalp(i,j,nhrb+3)*dsec
            else
c               sinalpc(i,j)=sinalp(i,j,nhrb+1)*(1.-dsec)
c     :                    + sinalp(i,j,nhrb+2)*dsec
               sinalpc(i,j)=sinalp(i,j,nhrb+1)*dsec
     :                    + sinalp(i,j,nhrb+2)*(1-dsec)
             endif
         end do
      end do         
c

c --- write sine (solar elev. angle) if LDB switch is on
      if(ldbhr)then
         write(io6,95)nyrb,njulb,nhrb,sinalpc(1,1)
95       format(/2x,'Computed solar elevation angle data at point ',
     1   '1,1 -- Year: ',i4,2x,'Julian day: ',i3,3x,'Hour: ',i2//
     2   3x,'Sine (solar elev. angle)',2x,f7.5)
      endif
 
      if(lmesg)print 788,nyrb,njulb,nhrb,nsecb,nyre,njule,nhre,nsece
788   format('+','Processing Year, Day, Hour, Sec from: ',
     :            i4,1x,i3,1x,i2,1x,i4,' to:', i4,1x,i3,1x,i2,1x,i4)

c
c --- set print variables for this hour and sub-hourly step
c --- at this point only prints out on hourly basis max (051116)
      if((lprint.and.mod(nh,iprinf).eq.0).and.(nsecb.eq.0)) then
         lprthr=.true.
      else
         lprthr=.false.
      endif
c
      if(ldb.and.nh.ge.nn1.and.nh.le.nn2)then
         ldbhr=.true.
      else
         ldbhr=.false.
      endif
c

c
c --- read surface meteorological data for current hour
c --- (idiopt(4) is 1 if using preprocessed surface data)
c FRR (09/2001) No surface obs option (noobs=2)
c      if(idiopt(4).eq.1)go to 111
      if(idiopt(4).eq.1 .or. noobs .eq. 2)go to 111

c --- Surface records

c --- Surface records
      if (datavers.eq.'2.1') then
c ---    explicit beg/ending time with seconds
c ---    whether a new record is read or not is decided in rdsn not here
         call rdsn(iforms,nssta,ispack,ios,0,ibuf,
     1       ndathrb,nsecb,idathrb,isecb,idathre,isece,
     1       ws,wd,iceil,icc,tempk,irh,pres,ipcode)

c ---    Ensure data frequency is no higher than CALMET frequency (080205)
         call deltsec(idathrb,isecb,idathre,isece,ndatdt)
         if(ndatdt.lt.nsecdt) then
c           frequency too high
            write(6,*)'STOP in subroutine COMP - see list file'
            write(io6,*)'STOP in subroutine COMP'
            write(io6,*)'Surface record frequency is too high'
            write(io6,*)'Record ending at (YYYYJJJHH-SEC)',idathre,
     :                  '-',isece
            write(io6,*)'Time between sf records (sec): ',ndatdt
            write(io6,*)'Should be less than CALMET timestep (sec): ',
     :                  nsecdt
            STOP
         endif

      else if (nsecb.eq.0) then
c ---    hour-ending time format - Update only every hour when nsecb=0
        
         call rds(iforms,nssta,ispack,ios,0,ibuf,iyr,ijul,ihr,ws,wd,
     1       iceil,icc,tempk,irh,pres,ipcode)
c
c        idathr=iyr*100000+ijul*100+ihr
         idathre=iyr*100000+ijul*100+ihr
         call incr(io6,iyr,ijul,ihr,-1)
         idathrb=iyr*100000+ijul*100+ihr
 
c            
         if(idathrb.ne.ndathrb)then
            write(io6,102)ndathre,idathre
102         format(//1x,'ERROR IN SUBR. COMP',
     1      '-- Expected date/hour does ',
     1      'not match values read from SURFACE DATA file'/
     2      5x,'Expected year, Julian day, hour = ',i9/
     3      5x,'Values read from file           = ',i9)
            stop
         endif
      endif


c --- echo back surface met. data if "debug write" option is on
c --- (BEFORE missing data is replaced)
      if(ldbhr)then
         write(io6,108)idathrb,isecb,idathre,isece
108      format(/1x,'SURFACE MET. INPUT DATA -- YYYYJJJHH: ',i10,3x,
     1   'seconds: ',i5,'  to -- YYYYJJJHH: ',i10,3x,
     1   'seconds: ',i5,/1x,'Station ID',6x,
     2   'WS',4x,'   WD  ',3x,'Ceil Ht',3x,'Cloud Cover',4x,'Temp',
     3   4x,'Rel Hum',4x,'Pres',3x,'Precip Code'/16x,'(m/s)',3x,
     4   '(deg)',3x,'(100s FT)',4x,'(tenths)',4x,'(deg K)',4x,'(%)',
     5   6x,'(mb)')
         do 110 kk=1,nssta
         write(io6,109)idssta(kk),ws(kk),wd(kk),iceil(kk),icc(kk),
     1   tempk(kk),irh(kk),pres(kk),ipcode(kk)
109      format(1x,i9,4x,f7.2,2x,f6.1,5x,i4,8x,i4,6x,f7.2,4x,i4,4x,
     1   f7.2,5x,i4)
110      continue
      endif
c
c
c --- Replace missing surface data (ICEIL, ICC, IRH, and PRES)
c --- missing TEMPK replaced in TEMPK array, but original data is
c --- saved in the OTEMPK array
c --- 050328 - otempk stored in MET2.MET
c     call missfc(iyr,ijul,ihr,otempk)
      call missfc(iyr,ijul,ihr)
c
111   continue
c
c --- Read gridded CLOUD data for current hour (hourly records)
ccec101006  if(icloud.eq.2 .and. nsecb.eq.0)then
c      if(mcloud.eq.2 .and. nsecb.eq.0)then
c         call rdcld(iformc,nx,ny,ndathrb,ccgrid)
c      endif
c --- Read gridded CLOUD data for at each timestep 
c --- with beginning and ending times
      if(mcloud.eq.2)then
        call rdcldn(iformc,nx,ny,ndathrb,nsecb,ndathre,nsece,ccgrid)
      endif
     
c --- Fill in gridded cloud array with observations 
c --- Must be done sooner in the code (i.e. here) to avoid 
c --- un-initialized variables at first time step, and one 
c --- timestep lagging for subsequent timesteps(070404)
c --- And must be done for icloud=0 (eq. mcloud=1) as well 
c --- otherwise no gridded cloud data when observations
c --- Compute and output gridded cloud data
ccec101006  if(icloud.le.1)call outcld(ndathrb,nx,ny,nssta,icc,nears,
ccec101006 1  iformc,icloud,ccgrid)
c --- Write out cloud records with beginning and ending times (101206)
c      if(icldout.eq.1.and.mcloud.eq.1)call outcld(ndathrb,nx,ny,
c     1  nssta,icc,nears,iformc,icldout,mcloud,ccgrid)    
      if(icldout.eq.1.and.mcloud.eq.1)
     :   call outcld(ndathrb,nsecb,ndathre,nsece,nx,ny,
     :   nssta,icc,nears,iformc,icldout,mcloud,ccgrid)    
c

c --- Echo back gridded cloud data (if debug option is on)
      if(ldbhr)then
         messag='Gridded input cloud fraction field'
         call out(ccgrid,idum,1,5,ldate,messag,nx,ny)
      endif
c

c --- read precipitation data for current timestep

      if(npsta.gt.0)then
         if (dataverp.eq.'2.1')then
c ---        2.1 time format with explicit beg/ending times with seconds 
             call rdpn(iformp,npsta,ippack,iop,0,ndathrb,nsecb,
     1                 ipdathrb,ipsecb,ipdathre,ipsece,xprecp)

c ---       Ensure data frequency is no higher than CALMET frequency (080205)
            call deltsec(ipdathrb,ipsecb,ipdathre,ipsece,ndatdt)
            if(ndatdt.lt.nsecdt) then
c           frequency too high
            write(6,*)'STOP in subroutine COMP - see list file'
            write(io6,*)'STOP in subroutine COMP'
            write(io6,*)'Precipitaion record frequency is too high'
            write(io6,*)'Record ending at (YYYYJJJHH-SEC)',ipdathre,
     :                  '-',ipsece
            write(io6,*)'Time between prec. records (sec): ',ndatdt
            write(io6,*)'Should be less than CALMET timestep (sec): ',
     :                  nsecdt
             STOP
            endif

         else if (nsecb.eq.0) then
c ---        hour-ending time format - Update only every hour when nsecb=0        
             call rdp(iformp,npsta,ippack,iop,0,iyr,ijul,ihr,xprecp)
c           idathr=iyr*100000+ijul*100+ihr
            ipdathre=iyr*100000+ijul*100+ihr
            call incr(io6,iyr,ijul,ihr,-1)
            ipdathrb=iyr*100000+ijul*100+ihr
            
c DGS       if(ipdathrb.ne.ndathr)then
c DGS          write(io6,1022)ndathr,ipdathre
            if(ipdathrb.ne.ndathrb)then
               write(io6,1022)ndathrb,ipdathre
1022            format(//1x,'ERROR IN SUBR. COMP',
     1         '-- Expected date/hour does ',
     1         'not match values read from PRECIPITATION DATA file'/
     2         5x,'Expected year, Julian day, hour = ',i9/
     3         5x,'Values read from file           = ',i9)
               stop
            endif
         endif
c  

c
c ---    echo back precip. input data if "debug write" option is on
         if(ldbhr)then
            if(dataverp.eq.'2.1')call dedat(ipdathrb,iyr,ijul,ihr)
            write(io6,118)iyr,ijul,ihr
118         format(/1x,'PRECIPITATION INPUT DATA -- Year: ',i4,3x,
     1      'Julian day: ',i3,3x,'Starting Hour: ',i2/1x,'Station ID',
     2      5x,'Precip. rate'/18x,'(mm/hr)')
            do 120 kk=1,npsta
            write(io6,119)idpsta(kk),xprecp(kk)
119         format(2x,i8,5x,f9.3)
120         continue
         endif
      endif
c

c --- read overwater data
      if(nowsta.gt.0)then
         call rdow(ndathrb)
         if(ldbhr)then
            write(io6,128)nyrb,njulb,nhrb,nsecb
128         format(/1x,'OVERWATER INPUT DATA -- Year: ',i4,3x,
     1      'Julian day: ',i3,3x,'Hour: ',i2,3x,'SECOND: ',i4/1x,
     2      'Station No',3x,'Rel. X',4x,'Rel. Y',6x,'Z',4x,'Beg. Time',
     3      3x,'End. Time',3x,'Delta T',3x,'Air T',3x,'Rel Hum',3x,
     4      'Mix Ht'/16x,'(m)',6x,'(m)',7x,'(m)',1x,'(YYYYJJJHH)',1x,
     5      '(YYYYJJJHH)',3x,'(Deg K)',2x,'(Deg K)',4x,'(%)',7x,'(m)')
            do 130 kk=1,nowsta
            write(io6,129)kk,xowsta(kk),yowsta(kk),zowsta(kk),
     1      iowbeg(kk),iowend(kk),dtow(kk),tairow(kk),rhow(kk),ziow(kk)
129         format(4x,i4,5x,f9.1,1x,f9.1,1x,f5.1,4x,i9,5x,i9,5x,f6.2,
     1      3x,f6.2,3x,f5.1,4x,f7.1)
130         continue
         endif
c ---    Fill in wind module common with OW values
         call diag2(nssta,nowsta,chowsta,xowsta,yowsta)
      endif
c

c --- read upper air data
c
c *** rjy modified the following section on 1/24/90 ******************
c --- (idiopt(5) is 1 if using preprocessed upper air data)
c FRR (09/2001) additional option for noobs
c      if(idiopt(5).eq.1 .or. noobs.eq.1)go to 145
      if(idiopt(5).eq.1 .or. noobs.ge.1)go to 145
c

c --- begin loop over upper air station data.
      io=iou-1
      do 140 iu=1,nusta
      io=io+1
c
c --- check if both current soundings straddle the current hour
  131 ntzaas = ntzaa(iu)
c     check first if some data in place.
      if(ntzaas.eq.0) go to 138
c
      ntzbbs = ntzbb(iu)

       if(ntzbbs.eq.0) go to 132
c
      justas = justa(iu)


c --- justas indicates the direction of time interpolation
c     relative to the aa and bb arrays.
c     justas=+1 implies ntzbbs > ntzaas so that bb arrays are freshest
c     justas=-1 implies ntzbbs < ntzaas so that aa arrays are freshest
c     Now insert logic to ensure the soundings either straddle current
c     time, or one (or both) of these arrays are updated.
c
c ----Must check on seconds as well for sub-hourly timesteps (051116)
cc     if(justas.eq.+1 .and. nowtz.lt.ntzaas) stop -- have read too far
c      if(justas.eq.+1 .and. nowtz.ge.ntzbbs) go to 138
cc     if(justas.eq.-1 .and. nowtz.lt.ntzbbs) stop -- have read too far
c      if(justas.eq.-1 .and. nowtz.ge.ntzaas) go to 132

c --- Ensure that time between soundings is longer than CALMET timestep
c --- (080205)
      call deltsec(ntzbbs,jbbsec(iu),ntzaas,jaasec(iu),iupsec)
      if(abs(iupsec).lt.nsecdt.and.iupsec.ne.0) then
c         sounding frequency too high
c ---     Convert to Gregorian Day for output purposes
            ntzlow = min0(ntzaas,ntzbbs)
            ntzhgh = max0(ntzaas,ntzbbs)
          call dedat(ntzlow,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)    
          call dedat(ntzhgh,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)    

          write(6,*)'STOP in subroutine COMP - see list file'
          write(io6,*)'STOP in subroutine COMP'
          write(io6,*)'Soundings frequency is too high for station:',iu
          write(io6,*)'Time between soundings (sec): ',abs(iupsec)
          write(io6,*)'Should be less than CALMET timestep (sec): ',
     :                  nsecdt   

          write(io6,75)ioutya,ioutja,ioutma,ioutda,ioutha,jaasec(iu),
     :                 ioutyb,ioutjb,ioutmb,ioutdb,iouthb,jbbsec(iu)
75       format(/,2x,'Consecutive UP.DAT records are at: ',/
     1    2x,'Year  Julian Day  Month  Day  Hour  Seconds (GMT-UTC)',/
c            xxxx      xxx       xx    xx   xx    xxxx
     2    i6.4,i9.3,i9.2,i6.2,i5.2,i8.4,' ',/
     3    i6.4,i9.3,i9.2,i6.2,i5.2,i8.4,' '/)

          STOP
      endif

c --- Compare ending times (080205)
c     call deltsec(ntzbbs,jbbsec(iu),nowtzb,nsecb,nowdtb)
      call deltsec(ntzbbs,jbbsec(iu),nowtze,nsecze,nowdtb)

      if (isnap(iu).eq.0) then
c        time-averaged soundings - do not read further if nowdtb=0 (080205)
         if(justas.eq.+1 .and. nowdtb.gt.0) go to 138
       else
         if(justas.eq.+1 .and. nowdtb.ge.0) go to 138
       endif

c --- Compare ending times (080205)
c     call deltsec(ntzaas,jaasec(iu),nowtzb,nsecb,nowdta)
      call deltsec(ntzaas,jaasec(iu),nowtze,nsecze,nowdta)
      if(justas.eq.-1 .and. nowdta.ge.0)go to 132
c
c --- if the above tests are satisfied, we don't need any new data, but
c     do additional tests and terminate on unacceptable situations,
c     such as, having read too far (due to missing or incorrect data).
c

c      if(((ntzaas-nowtz)*(ntzbbs-nowtz)) .gt. 0) then
      if((nowdta*nowdtb) .gt. 0) then
c     the two upper air times do not straddle the current time
            ntzlow = min0(ntzaas,ntzbbs)
            ntzhgh = max0(ntzaas,ntzbbs)
c ---     Convert to Gregorian Day for output purposes
          call dedat(nowtzb,ioutyz,ioutjz,iouthz) 
          call grday(io6,ioutyz,ioutjz,ioutmz,ioutdz)    
          call dedat(ntzlow,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)    
          call dedat(ntzhgh,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)    
            write(io6,1311)iu,
     :        ioutyz,ioutjz,ioutmz,ioutdz,iouthz,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,jaasec(iu),
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,jbbsec(iu)
1311        format(//1x,'ERROR IN SUBR. COMP -- Required dates/hours'/
     1      5x,'do not match values read from UPPER AIR STATION no.',i3/
     2   32x,'Year  Julian Day  Month  Day  Hour  Seconds (UTC-GMT) '/
c             xxxx      xxx       xx    xx   xx    xxxx
     3   5x,'Current Model date/time      : ',
     3    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/
     4   5x,'Date/time in UP.DAT file     : ',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/
     5   5x,'Next Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4)

            stop
         endif
c
c --- Test for excessive time separation of the soundings.
c *** rjy modified the following on 1/30/90 ******************
      jdelta = jusdt(iu)


c      if(jdelta.gt.maxsep) then
      if(jdelta.gt.maxsep*3600) then
c --- The two upper air times are more than "maxsep*3600" seconds apart.
            gap=jdelta/3600.
            ntzlow = min0(ntzaas,ntzbbs)
            ntzhgh = max0(ntzaas,ntzbbs)
c ---     Convert to Gregorian Day for output purposes
          call dedat(ntzlow,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)    
          call dedat(ntzhgh,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)    

            write(io6,1312)maxsep,iu,gap,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,jaasec(iu),
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,jbbsec(iu)

1312        format(//1x,'ERROR IN SUBR. COMP -- Missing upper air data',
     1      ' or record gap > ',i2,' hours',
     2      /23x,' for UPPER AIR STATION no.',i3,
     2      //,'Time Interval between records is: ',f9.3,' hours',//
     2   31x,'Year  Julian Day  Month  Day  Hour  Seconds (UTC-GMT) '/
c             xxxx      xxx       xx    xx   xx    xxxx
     4   ,'Date/time in UP.DAT file     :',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/
     5   ,'Next Date/time in UP.DAT file:',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4)

           stop

         endif
c ************************************************************
c
c --- Current upper air soundings acceptable; thus, proceed.
      go to 140
c
  132 continue
      if(dataveru.eq.'2.2') then
c ---    explicit beginning/ending times with seconds
c ---    where identical beg.end  times mean instantaneous soundings
c ---    and different beg. /end  times mean time-average soundings
c         call rdupn2(iu,io,1,iconvrt,nsecdt,jbbsec(iu),jbbhr,
         call rdupn2(iu,io,1,iconvrt,jbbsec(iu),jbbhr,
     &              jbbday,jbbyr)
      else if(dataveru.eq.'2.1') then
c ---    explicit beginning/ending times with seconds
         call rdupn(iu,io,1,iconvrt,jbbsec(iu),jbbhr,
     &              jbbday,jbbyr)
      else
c ---    single hour-ending times (older format compatible MOD5)
c         call rdup(iu,io,1,iconvrt,nsecdt,jbbsec(iu),jbbhr,
c     &             jbbday,jbbyr)
c ---    USe ending times (no seconds and no timesteps)
         call rdup(iu,io,1,iconvrt,jbbhr,jbbday,jbbyr)   
         jbbsec(iu)=0
      endif

      ntzbbs = jbbyr*100000 + jbbday*100 + jbbhr
      ntzbb(iu) = ntzbbs
      justa(iu) = +1
c
c --- Compute the time separation in seconds of the two upper air soundings.
c *** rjy addition of the following on 1/30/90 ***************
      ntzaas = ntzaa(iu)
      if(ntzaas.gt.0) then
c ***    call dedat(ntzaas,jaayr,yaaday,jaahr)
c        call dedat(ntzaas,jaayr,jaaday,jaahr)
c ---    include seconds as well
c         call deltt(jaayr,jaaday,jaahr,jbbyr,jbbday,jbbhr,jdelta)
         call deltsec(ntzaas,jaasec(iu),ntzbbs,jbbsec(iu),jdelta)
c ---    jdelta is now in seconds (051116)
         jdelta = iabs(jdelta)
         jusdt(iu) = jdelta
      endif
c ************************************************************
c
c --- perform vertical averaging through depth of each cell
      call vertav(iu,ubb,vbb,zlbb,nlbb(iu),nz,zface,uavebb(1,iu),
     1vavebb(1,iu))
c
c --- Calculate the vertical grid face temperatures
c     using sounding data only.  If LCALGRD only! 1/31/90.
      if(LCALGRD)then
         call facet(iu,tzbb,zlbb,nlbb,nzp1,zface,tzgrbb(1,iu))
      endif
c
c --- echo back upper air input data if "debug write" switch is on
      if(ldbhr)then
            write(io6,133)jbbyr,jbbday,jbbhr
133         format(/2x,'UPPER AIR DATA  --  Year:',i4,2x,'Julian Day:',
     1      i3,2x,'Hour:',i2,' (GMT)')
            write(io6,134)
134         format(/2x,'STA',2x,'PRES',3x,'HEIGHT',4x,'TEMP',6x,'U',
     1      7x,'V'/7x,'(mb)',3x,'(m LGL)',3x,'(K)',5x,'(m/s)',3x,
     2      '(m/s)')
            write(io6,135)(iu,pbb(iu,jp),zlbb(iu,jp),tzbb(iu,jp),
     1      ubb(iu,jp),vbb(iu,jp),jp=1,nlbb(iu))
135         format(1x,i3,2x,f6.1,2x,f7.1,2x,f6.2,2x,f6.2,2x,f6.2)
c
c ---       write vertically averaged winds
            write(io6,136)'U -- cell averaged',(uavebb(n,iu),n=1,nz)
            write(io6,136)'V -- cell averaged',(vavebb(n,iu),n=1,nz)
      if(LCALGRD)then
            write(io6,136)'T -- cell face    ',(tzgrbb(n,iu),n=1,nzp1)
                 endif
136         format(1x,a20,' = ',10f10.3,10(/24x,10f10.3))
      endif
c
      go to 131
c
  138 continue
      if(dataveru.eq.'2.2') then
c ---    explicit beginning/ending times with seconds
c ---    where identical beg.ending times mean instantaneous sounding
c ---    and different beg. /ending times mean time-average sounding
         call rdupn2(iu,io,-1,iconvrt,jaasec(iu),jaahr,
     &              jaaday,jaayr)
      else if(dataveru.eq.'2.1') then
c ---    explicit beginning/ending times with seconds
         call rdupn(iu,io,-1,iconvrt,jaasec(iu),jaahr,
     &              jaaday,jaayr)
      else
c ---    single hour-ending times records
c         call rdup(iu,io,-1,iconvrt,nsecdt,jaasec(iu),jaahr,
c     &             jaaday,jaayr)
c ---    USe ending times (no seconds and no timestep)(080205)
         jaasec(iu)=0
         call rdup(iu,io,-1,iconvrt,jaahr,jaaday,jaayr)
      endif

      ntzaas = jaayr*100000 + jaaday*100 + jaahr
      ntzaa(iu) = ntzaas
      justa(iu) = -1
c
c --- Compute the time separation in seconds of the two upper air soundings.
c *** rjy addition of the following on 1/30/90 ***************
      ntzbbs = ntzbb(iu)
      if(ntzbbs.gt.0) then
c         call dedat(ntzbbs,jbbyr,jbbday,jbbhr)
c         call deltt(jaayr,jaaday,jaahr,jbbyr,jbbday,jbbhr,jdelta)
         call deltsec(ntzaas,jaasec(iu),ntzbbs,jbbsec(iu),jdelta)
c ---    jdelta is now in seconds (051116)
         jdelta = iabs(jdelta)
         jusdt(iu) = jdelta
      endif
c


c --- perform vertical averaging through depth of each cell

      call vertav(iu,uaa,vaa,zlaa,nlaa(iu),nz,zface,uaveaa(1,iu),
     1vaveaa(1,iu))
c

c --- Calculate the vertical grid face temperatures
c     using sounding data only.  If LCALGRD only! 1/31/90.
      if(LCALGRD)then
         call facet(iu,tzaa,zlaa,nlaa,nzp1,zface,tzgraa(1,iu))
      endif

c
c --- echo back upper air input data if "debug write" switch is on
      if(ldbhr)then
            write(io6,133)jaayr,jaaday,jaahr
            write(io6,134)
            write(io6,135)(iu,paa(iu,jp),zlaa(iu,jp),tzaa(iu,jp),
     1      uaa(iu,jp),vaa(iu,jp),jp=1,nlaa(iu))
c
c ---       write vertically averaged winds
            write(io6,136)'U -- cell averaged',(uaveaa(n,iu),n=1,nz)
            write(io6,136)'V -- cell averaged',(vaveaa(n,iu),n=1,nz)
      if(LCALGRD)then
            write(io6,136)'T -- cell face    ',(tzgraa(n,iu),n=1,nzp1)
                 endif
      endif
c
      go to 131
c
  140 continue
c
  145 continue

c ********************************************************************
c
c --- read and setup for diagnostic wind field module
c frr (09/01) no call if no upper and no surface stations
c --- 060215: pass on explicit beg. time to prepdi
c --- 080205: pass on explicit end time to prepdi
      if (noobs.ne.2)then
c ---    beta2 is defined but never used  (remove from calling list 070113) 
         call prepdi(ws,wd,tempk,uaveaa,uavebb,vaveaa,vavebb,
     1   nhre,nyrze,njulze,nhrze,nsecze,ziconv,
     2   gamma,um,vm,wt,us,vs,nowsta,wsow,wdow)
c

c ---   Use explicit end times (consistent with MOD5)
        if(ldbhr)then
           if (noobs .eq. 0) then
            write(io6,152)nyre,njule,nhre,nsece,gamma(1,1),tinf,um,vm
152         format(/2x,'Diagnostic wind field data -- Year: ',i4,3x,
     1      'Julian day: ',i3,3x,'Hour: ',i2,3x,'Second: ',i4/
     1           2x,'Domain-scale temp. lapse rate at point (1,1)',
     1           '(GAMMA) = ',f10.5,
     1      ' (deg. K/m)'/
     2           2x,'Domain scale surf. temperature (TINF) = ',f10.2,
     2      ' (deg. K)'/
     3           2x,'Domain-scale U-component of wind (UM) = ',f10.3,
     3      ' (m/s)'/
     4           2x,'Domain-scale V-component of wind (VM) = ',f10.3,
     4      ' (m/s)')
           else 
            write(io6,153)nyre,njule,nhre,nsece,tinf
153         format(/2x,'Diagnostic wind field data -- Year: ',i4,3x,
     1      'Julian day: ',i3,3x,'Hour: ',i2,3x,'Second: ',i4/
     2           2x,'Domain scale surf. temperature (TINF) = ',f10.2,
     2      ' (deg. K)'/
     1           2x,'Domain-scale temp. lapse rate (GAMMA) is not yet ',
     1      ' defined'/
     3           2x,'Domain-scale U-component of wind (UM) is not yet ',
     3      ' defined'/
     4           2x,'Domain-scale V-component of wind (VM) is not yet ',
     4      ' defined')
           end if

           write(io6,154)nyre,njule,nhre,nsece
154        format(/2x,'Surface station data for wind field module -- ',
     1     'Year: ',i4,3x,'Julian day: ',i3,3x,'Hour: ',i2,3x,
     2     'Second: ',i4/5x,'Station',2x,'Station',4x,'U-CMPT',4x,
     3     'V-CMPT'/6x,'Name',5x,'Number',5x,'(m/s)',5x,'(m/s)')
           write(io6,156)(namst(n),n,us(1,n),vs(1,n),n=1,nssta+nowsta)
156        format(6x,a4,5x,i4,5x,f7.2,3x,f7.2)

c
           if (noobs .eq. 0) then
            do 162 nups = 1,nusta
              ii = nssta + nowsta + nups
              write(io6,158)namst(ii),nups,nyre,njule,nhre,nsece
158           format(/2x,'Upper air station: ',a4,3x,'Number: ',i4,3x,
     1        'Year: ',i4,3x,'Julian day: ',i3,3x,'Hour: ',i2,3x,
     2        'Second: ',i4/8x,'Level',3x,'U-CMPT',3x,'V-CMPT'/17x,
     3        '(m/s)',4x,'(m/s)')
              write(io6,159)(n,us(n,ii),vs(n,ii),n=1,nz)
159           format(7x,i4,4x,f7.2,2x,f7.2)
162         continue
           else
            write(io6,*)' upper air data not yet defined...'
           end if
         endif
c
c frr (09/01) noobs
      else
         if(ldbhr)then
           write(io6,*)' No observation mode'
           write(io6,*)' upper air data not yet defined...'
           write(io6,*)' surface   data not yet defined...'
         endif
      endif
c

c --- load elevation angle common block for use in wind extrapolation
c frr (09/01) sinalp computed at all gridpoints
      do j=1,ny
      do i=1,nx
c         sinalp2(i,j) = sinalp(i,j,nhrind)
         sinalp2(i,j) = sinalpc(i,j)
      end do
      end do

c --- current timestep GMT hour (stored in internal common salp)
      ihr2gmt=nhrzb


c --- compute diagnostic winds
c --- also return the array of surface temperatures using nearest
c --- surface station or prognostic data for later use (ISFCMET)
c --- remove beta2 from calling list (never used) (070113)
c --- Pass on ending GMT time (070717)
      call diagno(nhrze,nhrind,gamma,um,vm,nowsta,zowsta,
     &   itwprog,zlogwsta,ziconv,tsfnsp,tprog,vptprog,
     &   ccgrid,iceilg,rho)
       
c

c --- print wind field for levels and time periods requested
      if(lprthr)then
         do 142 kk=1,nz
         if(iuvout(kk).eq.1)then
            messag='U-component (m/s) -- Level: '
            write(messag(29:31),'(i3)')kk
            call out(u(1,1,kk),idum,1,5,ldate,messag,nx,ny)
            messag(1:1)='V'
            call out(v(1,1,kk),idum,1,5,ldate,messag,nx,ny)
         endif
c
c ---    print W component (at TOP of cell face, i.e., kk+1)
         if(iwout(kk).eq.1)then
            messag='W-component (m/s) -- Level: '
            write(messag(29:31),'(i3)')kk
            call out(w(1,1,kk+1),idum,1,5,ldate,messag,nx,ny)
         endif
142      continue
      endif
c
c --- if computing only wind field AND using preprocessed dT/dz data
c --- (i.e., not computing dT/dz from upper air data), skip met. model
      if(irtype.eq.0.and.idiopt(2).eq.1)go to 799

c --- grid precipitation data using nearest station technique
c --- *** ALL CELLS -- LAND & WATER ***
c --- frr 050328 precipitation rates computed before call to WATER as rain is a required
c --- input to the COARE method (passed to water via common block metgrd.met)

      if(npsta.GT.0)then
         call gride(npsta,xprecp,xpsta,ypsta,nearp,dgrid,nx,ny,rmm,
     1              nflagp,sigmap,cutp)
c frr (09/01)
c       else if( npsta.eq.-1) then
c         Use prognostic rain data (computed in rdmm5)
       endif

      if(lprthr.and.imtout(6).eq.1)then
            messag='Precipitation rate (mm/hr)'
            call out(rmm,idum,1,5,ldate,messag,nx,ny)
      endif

c frr 050328
c --- Compute surface temperature, RH and precip code
c --- Was done later in previous codes but can be done now to
c --- rationalize computations in heatfx and radfx (temp2d needed in heatfx)
c --- 050328: add flag to compute all sf. variables

c --- Add ISFCMET control for SURFVAR call
      if(isfcmet.EQ.0) then
         call surfvar(u(1,1,1),v(1,1,1),tprog,temp2d,irh2d,ipcode2d,1)
      endif

c --- frr 050328: Call heatfx before subroutine WATER because the short
c     wave flux is a required input for the overwater COARE method
c
c --- compute surface sensible heat flux  *** LAND CELLS ***
c --- (NOTE: nighttime conditions (negative heat flux) flagged with
c --- qh = -0.1 W/m**2 -- actual nighttime value computed in
c --- subr. ELUSTR)
c --- also computes short-wave radiation (W/m**2) at ALL gridpoints

c --- Pass either the nearest surface station/prognostic surface
c --- temperatures, or the full 2D temperatures
      if(isfcmet.EQ.0) then
c ---    Use full 2D surface temperature array
         call heatfx(sinalpc,nears,temp2d,icc,ilandu,iwat1,
ccec101006     1              iwat2,nx,ny,icloud,ccgrid,qh,qsw)
     1              iwat2,nx,ny,mcloud,ccgrid,qh,qsw)
      elseif(isfcmet.EQ.1) then
         call heatfx(sinalpc,nears,tsfnsp,icc,ilandu,iwat1,
ccec101006     1              iwat2,nx,ny,icloud,ccgrid,qh,qsw)
     1              iwat2,nx,ny,mcloud,ccgrid,qh,qsw)
      endif 

c --- compute met. fields for WATER CELLS (except precip. rate)
c --- Compute downward long wave radiation at the surface 
      if(isfcmet.EQ.0) then
c ---    Use full 2D surface temperature and RH arrays
ccec101006         call radflx(icloud,iceil,ccgrid,iceilg,temp2d,irh2d,qlw)
         call radflx(mcloud,iceil,ccgrid,iceilg,temp2d,irh2d,qlw)
      elseif(isfcmet.EQ.1) then
c ---    Use 2D temperature array of either nearest station temperature
c ---    or prognostic temperature, but values in irh2d are not correct!
c ---    RADFLX output is only for COARE option, which should not be
c ---    allowed with ISFCMET=1
         if(icoare.NE.0) then
            write(io6,*)'ERROR in COMP:  invalid ISFCMET/ICOARE'
            write(io6,*)'  Expected icoare = 0 with isfcmet = 1'
            write(io6,*)'    Found isfcmet = ',isfcmet
            write(io6,*)'     Found icoare = ',icoare
            stop 'ERROR in COMP -- see list file'
         endif
      endif
     
c --- frr050328 (additional parameters passed on to water for COARE method)
c --- 051113 2 options : use SEA.DAT or 3D.DAT
c --- pass on ending GMT time rather than beginning GMT time (COARE)
      if (itwprog.eq.2) then
         call waterp(u,v,imixh,qsw,qlw,dcoast,zmid(1),ilandu,iwat1,
     &           iwat2,nx,ny,dgrid,fcori,nhrze,z0)
      else
         call water(u,v,imixh,qsw,qlw,dcoast,zmid(1),ilandu,iwat1,iwat2,
     &           nx,ny,dgrid,fcori,nhrze,z0)
      endif
c

c --- compute PGT stability class  *** LAND CELLS ***
c      call pgtstb(u,v,nears,icc,iceil,sinalp(1,1,nhrind),ilandu,
      call pgtstb(u,v,nears,icc,iceil,sinalpc,ilandu,
ccec101006     1 iwat1,iwat2,nx,ny,icloud,ccgrid,iceilg,ipgt)
     1 iwat1,iwat2,nx,ny,mcloud,ccgrid,iceilg,ipgt)
c
      if(lprthr.and.imtout(1).eq.1)then
         messag='PGT stability class'
         call out(xdum,ipgt,2,2,ldate,messag,nx,ny)
      endif

c --- compute air density at surface met. stations
c     if 3D temp mode, 2D air density is computed in RDMM5 (called by diagno)
c      if (noobs .eq. 0) then
      if (itprog.lt.2) then
         if(isfcmet.EQ.0) then
c ---       Use 2D temperature field
            call airden(pres,temp2d,rho)
         elseif(isfcmet.EQ.1) then
c ---       Use surface stations
            call airden_ns(pres,tempk,nssta,rho)
         endif
      endif
c
      if(ldbhr)then
         write(io6,172)nyrb,njulb,nhrb,nsecb,rho(1,1),qsw(1,1)
172      format(/2x,'Computed surface parameters -- Year: ',i4,3x,
     1   'Julian day: ',i3,3x,'Hour: ',i2,3x,'Second: ',i4,3x,
     2   'At point (1,1):',/7x,'Air Density',12x,f6.3,4x,'(kg/m**3)',
     3   /7x,'Short-Wave Radiation',3x,f7.2,4x,'(W/m**2)')
      endif
c
c --- compute friction velocity, Monin-Obukhov length, and nighttime
c --- surface sensible heat flux *** LAND CELLS ***
c
c --- Compute u-star, L, and for stable hours, Qh
      if(isfcmet.EQ.0) then
c ---    Use 2D temperature field
         call elustr(z0,u,v,zmid(1),nears,rho,temp2d,icc,ilandu,
ccec101006     1   iwat1,iwat2,nx,ny,icloud,ccgrid,ipsifcn,qh,ustar,el)
     1   iwat1,iwat2,nx,ny,mcloud,ccgrid,ipsifcn,qh,ustar,el)
      elseif(isfcmet.EQ.1) then
c ---    Use surface stations
         call elustr(z0,u,v,zmid(1),nears,rho,tsfnsp,icc,ilandu,
ccec101006     1   iwat1,iwat2,nx,ny,icloud,ccgrid,ipsifcn,qh,ustar,el)
     1   iwat1,iwat2,nx,ny,mcloud,ccgrid,ipsifcn,qh,ustar,el)
      endif
c

      if(lprthr)then
         if(imtout(7).eq.1)then
            messag='Surface sensible heat flux (W/m**2)'
            call out(qh,idum,1,5,ldate,messag,nx,ny)
         endif
         if(imtout(2).eq.1)then
            messag='Friction velocity (m/s)'
            call out(ustar,idum,1,5,ldate,messag,nx,ny)
         endif
         if(imtout(3).eq.1)then
            messag='Monin-Obukhov length (m)'
            call out(el,idum,1,5,ldate,messag,nx,ny)
         endif
      endif
c
c --- compute mixing heights  *** LAND CELLS ***
c --- (ihrgmt is GMT time for current hour -- can be >= 24)
c      ihrgmt=nhr+ibtz
      if (itprog .eq. 0) then
        call mixht(el,ustar,qh,nx,ny,rho,nhrzb,nearu,iupt,
     1             ilandu,iwat1,iwat2,ldbhr,imixh,zi,ziconv)
      else
c
c --- Separate subroutine if using MM5 temperature
        call mixht2(el,ustar,qh,nx,ny,rho,nhrzb,
     1              ilandu,iwat1,iwat2,ldbhr,imixh,zi,ziconv)
      end if

c
      if(ldbhr)then
         if(imtout(4).eq.1)then
            messag='Mixing height (m) -- Before averaging '
            call out(zi,idum,1,5,ldate,messag,nx,ny)
         endif
         if(imtout(8).eq.1)then
            messag='Convective mixing height (m) -- Before averaging'
            call out(ziconv,idum,1,5,ldate,messag,nx,ny)
         endif
      endif
c
c --- Spatially average mixing heights: zi and ziconv
      if(iavezi.eq.1)then
         call avemix(nx,ny,mnmdav,hafang,dgrid,u(1,1,ilevzi),
     1    v(1,1,ilevzi),zi,ziconv)
      endif

c
      if(lprthr)then
         if(imtout(4).eq.1)then
            if(iavezi.eq.1)then
               messag='Mixing height (m) -- After averaging '
            else
               messag='Mixing height (m) -- No averaging '
            endif
            call out(zi,idum,1,5,ldate,messag,nx,ny)
         endif
         if(imtout(8).eq.1)then
            if(iavezi.eq.1)then
               messag='Convective mixing height (m) -- After averaging'
            else
               messag='Convective mixing height (m) -- No averaging'
            endif
            call out(ziconv,idum,1,5,ldate,messag,nx,ny)
         endif
      endif
c

c --- compute convective velocity scale *** LAND CELLS ***
c --- 050328 - use temp2d rather than tempk,tprog,iprog
      if(isfcmet.EQ.0) then
c ---    Use 2D temperature field
         call wstarr(ziconv,qh,temp2d,rho,ilandu,iwat1,iwat2,nx,ny,
     1   wstar)
      elseif(isfcmet.EQ.1) then
c ---    Use surface stations
         call wstarr(ziconv,qh,tsfnsp,rho,ilandu,iwat1,iwat2,nx,ny,
     1   wstar)
      endif
c
      if(lprthr.and.imtout(5).eq.1)then
         messag='Convective velocity scale (m/s)'
         call out(wstar,idum,1,5,ldate,messag,nx,ny)
      endif
c
c

c --- Compute 3-D temperature field if requested
       if( LCALGRD .or. itprog.ge.1 )then
c ---     Add ISFCMET branch to different versions of TEMP3D
          if(isfcmet.EQ.0) then
c ---        frr 050328 temp2d (surface temp) computed earlier on
c ---        frr 060215 Use explicit beginning time 
c ---        frr 080205 Use explicit end times
             call temp3d(nyrze,njulze,nhrze,nsecze,temp2d,ziconv,
     &                tzgraa,tzgrbb,ztemp,zi,tprog)
          elseif(isfcmet.EQ.1) then
             call temp3d_back(nyrze,njulze,nhrze,nsecze,otempk,
     &                  ziconv,tzgraa,tzgrbb,ztemp,zi,tprog,
     &                  mnmdav,hafang,u(1,1,1),v(1,1,1))
          endif
c
c ---    print temp. for levels and time periods requested
      if(lprthr)then
        do 782 kk=1,nz
          if(itout(kk).eq.1)then
            messag='Temperature (K) -- Level: '
            write(messag(27:29),'(i3)')kk
            call out(ztemp(1,1,kk),idum,1,5,ldate,messag,nx,ny)
          endif
782     continue
      endif
      endif
c

c --- output results to disk
799   continue

      if(lsave)then
         if(iformo.eq.1)then

c ---       Align code with previous version for ISFCMET=1
            if(isfcmet.EQ.1) then
               call surfvar_back(tprog,temp2d,irh2d,ipcode2d)
c MCB-C (070501) Ensure Temp2D is the same as ZTEMP(k=1)
c                when LCALGRID=T or itprog.ge.1
               if( LCALGRD .or. itprog.ge.1 )then
                  do j=1,ny
                     do i=1,nx
                         temp2d(i,j)=ztemp(i,j,1)
                      end do
                   end do
               endif
            endif

c
c ---       CALMET output format (non hourly timesteps - 060215)
            call outhr(ndathrb,nsecb,ndathre,nsece,
     1                 nx,ny,nz,npsta,irtype,rho,qsw,
     1                 iomet,lcalgrd,temp2d,irh2d,ipcode2d)
c --- v6.4.0, Level 121203
            if(iauxlwc.EQ.1) call AUXOUT(ndathrb,nsecb,ndathre,nsece,
     &                                   nx,ny,nz,ifull,ioaux)

c ---    Restrict MESOPAC to hourly runs
         else if(iformo.eq.2 .AND. nsecdt.EQ.3600)then
c
c ---       MESOPAC II output format
c
c ---       Vertically average winds into MESOPAC II layers
            ztop=3000.
            zincr=300.
            call pacave(u,v,zi,zface,nx,ny,nz,ztop,zincr,ul,vl,uup,vup)
c
c ---       MESOPAC II units of radiations are W/m**2 (same as CALMET)
c frr (09/01) QSW at all gridpoints-pick nearest i,j to the station
            do l=1,nssta
               iss=ist(l)
               jss=jst(l)
               iss = max0(1,iss)
               iss = min0(iss,nx)
               jss = max0(1,jss)
               jss = min0(jss,ny)
c              srad(i)=qsw(i)
              srad(l)=qsw(iss,jss)
            enddo
c
c ---       Compute average air density (in kg/m**3)
            avrho=0.0
c frr (09/01): rho at all gridpoints 
c            do i=1,nssta
c              avrho=avrho+rho(i)
c            enddo
c            avrho=avrho/float(nssta)
            do j=1,ny
            do i=1,nx
              avrho=avrho+rho(i,j)
            enddo
            enddo
c            avrho=avrho/float(nssta)
            avrho=avrho/float(nx*ny)
c
c ---       Write the data for this hour in MESOPAC II format
            call outpc(ldbhr,nyr,njul,nhr,ul,vl,uup,vup,zi,ustar,
     1       wstar,el,ipgt,rmm,avrho,tempk,srad,irh,ipcode,
     2       nx,ny,nssta)
         endif
      endif
c

c --- Compute and output gridded cloud data
c --- Must be done earlier in the code (070404)
ccec101006 - Allow to output gridded cloud data here for
c            input gridded clouds: mcloud=3 or 4
c            no data are output if CLOUD.DAT is read
c            if observations from surf.dat - output data
c            are written earlier
c     if(icloud.eq.1)call outcld(ndathrb,nx,ny,nssta,icc,nears,
c     1  iformc,ccgrid)
c --- Write out cloud records with beginning and ending times (101206)
      if(icldout.eq.1) then
        if(mcloud.ge.3)
     :      call outcld(ndathrb,nsecb,ndathre,nsece,nx,ny,nssta,
     1      icc,nears,iformc,icldout,mcloud,ccgrid)
      endif

c --- end of sub-hourly loop
800   continue


c --- set sub-hourly step for next pass through hour loop
      nsecb=-nsecdt

c --- end of hour loop
900   continue
c
c --- set hour for next pass through day loop
c     nhr=-1
      nhrb=-1

c --- end of day loop
1000  continue
c
c --- end of run
1001  continue
      return
      end
c----------------------------------------------------------------------
      subroutine diag2(nssta,nowsta,chowsta,xowsta,yowsta)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 941018              DIAG2
c ---          M. Fernau, based on DIAGI by J. Scire, SRC
c
c --- PURPOSE: fill wind field common blocks for overwater sites
c
c --- INPUTS:
c                  NSSTA - integer    - No. surface wind stations
c                 NOWSTA - integer    - No. water wind stations
c          XOWSTA(MXOWS) - real array - Water station relative X
c                                       coordinate (m) (relative to grid
c                                       origin)
c          YOWSTA(MXOWS) - real array - Water station relative Y
c                                       coordinate (m) (relative to grid
c                                       origin)
c         CHOWSTA(MXOWS) - char array - Water station name (character*4)
c         Common block variables:
c          /WPARM/ variables
c            IWFCOD
c          /D5/ variables
c            DX,DY
c         Parameters: MXWND, MXOWS
c
c --- OUTPUT:
c         Common block variables:
c          /D1/ variables
c          /WPARM/ variables
c
c --- DIAG2  called by:  COMP
c --- DIAG2  calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real xowsta(mxows),yowsta(mxows)
      character*4 chowsta(mxows),namst
c
      include 'wparm.met'
      include 'd1.met'
      include 'grid.met'
c
c --- IWFCOD = wind field code (0=objective analysis, 1=diagnostic
c              model, 2=single station wind model)
c -- ERROR checks for analysis.........
      if(iwfcod.eq.2)return
c
c --- transfer surface station names and coordinates to wind module
c --- arrays (convert relative station coordinates to km)
      nstat = nssta + nowsta
      do 35 i=nssta+1,nstat
        namst(i)=chowsta(i - nssta)
        utmxst(i)=0.001 * xowsta(i - nssta)
        utmyst(i)=0.001 * yowsta(i - nssta)
        ist(i)=xowsta(i - nssta) / dx + 1
        jst(i)=yowsta(i - nssta) / dy + 1
35    continue
      return
      end
c----------------------------------------------------------------------
      subroutine diagi(elev,z0,nowsta)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070113              DIAGI
c ---          J. Scire, SRC
c --           Modified by M. Fernau to add separate overwater winds
c --           (some of overwater assignments done in DIAG2)
c
c --- PURPOSE:  Set default variables for diagnostic wind field model
c               fill wind field common blocks
c
c --- UPDATES:
c --- V5.6 Level 050328 to v6.218 (070113)(F.Robe) 
c         - Compute nearest (i,j) to all upper air stations and store in
c           IIUP(mxus) and JJUP(mxus) in MET1.MET
c
c --- V5.548a (050101) to V5.6 Level 050328 (F.Robe)
c         - Compute adjustment coefficients at each surface station
c           to ensure that observed surface winds are scaled down from
c           the anemometer height to the first gridpoint level (usually 10m)
c           Neutral log profile with Zo at gridpoint where station is located
c
c         - Include MET1.MET in subroutine and change calling list
c           accordingly. 
c
c --- Level 000602c to V5.548a (050101) (F.Robe)
c         - No need to redefine/scale barriers variables as they are now
c           in d3.met with the correct units (km) (no longer in wparm.met) 
c         
c
c --- INPUTS:
c        ELEV(MXNX,MXNY) - real array - Terrain elevations (m)
c          Z0(MXNX,MXNY) - real array - Gridded roughness length (m)
c                 NOWSTA - integer    - No. water wind stations
c     Via Common grid.met
c                 XORIGR - real       - Grid origin - X coordinate (m)
c                 YORIGR - real       - Grid origin - Y coordinate (m)
c     Via Common met1.met
c                  NSSTA - integer    - No. surface wind stations
c                  NUSTA - integer    - No. upper air wind stations
c            XSSTA(MXSS) - real array - Surface station relative X
c                                       coordinate (m) (relative to grid
c                                       origin)
c            YSSTA(MXSS) - real array - Surface station relative Y
c                                       coordinate (m) (relative to grid
c                                       origin)
c            CSNAM(MXSS) - char array - Surface station name (character*4)
c            XUSTA(MXUS) - real array - Upper air station relative X
c                                       coordinate (m) (relative to grid
c                                       origin)
c            YUSTA(MXUS) - real array - Upper air station relative Y
c                                       coordinate (m) (relative to grid
c                                       origin)
c            CUNAM(MXUS) - char array - Upper air station name (character*4)
c                  NOOBS - integer    - Flag for use of prognostic data only
c
c         Common block variables:
c          /WPARM/ variables
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1, MXWND, MXBAR,
c                     MXSS, MXUS, MXOWS
c         /GRID/ variables used in this subroutine
c                    NX2 - integer    - No. X grid cells
c                    NY2 - integer    - No. Y grid cells
c                    NZ2 - integer    - No. vertical layers
c                  DGRID - real       - Horizontal grid size (m)
c          ZFACE(MXNZP1) - real array - Vertical cell face heights (m)
c                                       above ground
c             ZMID(MXNZ) - real array - Vertical cell center heights (m)
c                                       above ground
c
c --- OUTPUT:
c         Common block variables:
c          all /D4/ variables
c          all /D5/ variables
c          ird, iwr, ifile, irdp   -- /D6/ common block
c          cellzb, cellzc, nintrp  -- /D1/ common block
c          /WPARM/ variables 
c
c         To MET1.MET: zlogsta(mxss) - log factor to scale surface wind
c            observations to first CALMET level
c                      IIUP(MXUS),JJUP(mxus): nearest gridpoint (i,j) to
c                      upper air stations (used if iupt=-1) 
c
c
c --- DIAGI  called by:  SETUP
c --- DIAGI  calls:      TERSET
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real elev(mxnx,mxny),z0(mxnx,mxny)
      character*4 namst
c
      include 'wparm.met'
      include 'd1.met'
      include 'd3.met'
      include 'd4.met'
      include 'grid.met'
      include 'd6.met'
      include 'met1.met'

c
c --- IWFCOD = wind field code (0=objective analysis, 1=diagnostic
c              model, 2=single station wind model)
c -- ERROR checks for analysis.........
      if(iwfcod.eq.2)return
c

c**** below is checked in READCF so it is redundant...
c
c     if(iwfcod.eq.1.and.iprog.eq.1)then
c       write (*,*)'  ERROR -- RUN STOPPED IN SUB DIAGI'
c       write (*,*)'Only objective analysis can be selected if'
c       write (*,*)'prognostic model inputs are used as STEP 1 inputs'
c       stop
c     endif
c
c --- duplicate model parameters in both model and wind field module
c --- common blocks
      i3dctw=iwfcod
      dx=dgrid
      dy=dgrid
      nzprnt = nzprn2
c --- grid origin -- change to km for wind module
      utmxor=0.001*xorigr
      utmyor=0.001*yorigr
c
c --- I/O unit number for prognostic wind field data (irdp)
c --- and preprocessed met. inputs (ird)
      irdp=io20
      ird=io2
c
c --- if using upper air data to compute diagnostic wind parameters,
c --- determine closest grid point to reference upper air stations
      if(idiopt(2).eq.0 .and. noobs.eq.0)then

         do i=1,nusta
            iiup(i)=xusta(i)/dgrid+1.5
            jjup(i)=yusta(i)/dgrid+1.5

            if(iiup(i).lt.1)iiup(i)=1
            if(iiup(i).gt.nx)iiup(i)=nx
            if(jjup(i).lt.1)jjup(i)=1
            if(jjup(i).gt.ny)jjup(i)=ny

         end do

c ---    If single upper air station is selected (iupt>0) store
c ---    value in IiUPt,jjupt
         if (iupt.ge.1) then
             iiupt=iiup(iupt)
             jjupt=jjup(iupt)
         endif

      endif
c
c --- transfer surface station names and coordinates to wind module
c --- arrays (convert relative station coordinates to km)
c --- over water sites will be done in DIAG2
c frr(09/01) noobs option
      if (noobs.lt.2) then
        nstat = nssta + nowsta
        do 35 i=1,nssta
          namst(i)=csnam(i)
          utmxst(i)=0.001 * xssta(i)
          utmyst(i)=0.001 * yssta(i)
          ist(i)=xssta(i) / dx + 1
          jst(i)=yssta(i) / dy + 1
35      continue
      endif
c --- transfer upper air station names and coordinates to wind module
c --- arrays (convert relative station coordinates to km)
      if (noobs .eq. 0) then
        ii = nstat
        do 37 i=1,nusta
          ii=ii+1
          namst(ii)=cunam(i)
          utmxst(ii)=0.001*xusta(i)
          utmyst(ii)=0.001*yusta(i)
          ist(ii)=xusta(i)/dx+1
          jst(ii)=yusta(i)/dy+1
37      continue
      end if
c
      nzp1=nz+1
      do 5 i=1,nz
      dz(i)=zface(i+1)-zface(i)
      cellzc(i)=zmid(i)
      cellzb(i)=zface(i)
      nintrp(i)=nintr2(i)
c --- Add assignment of user-defined wind extrapolation factors
c --- (JSS 1/12/01)
      fextrp(i)=fextr2(i)
5     continue
      cellzb(nzp1)=zface(nzp1)

c
c --- Compute scaling factors to extrapolate surface wind observations
c --- to first CALMET level (logarithmic profile)
c --- frr 050328
      do n=1,nssta
c ---    z0: roughness length of gridpoint where station is located
c ---    if station outside of domain use z0 at gridpoint closest to station
c ---    Note: eventually will want to use z0 at station itself
         isc=ist(n)
         jsc=jst(n)
         if(isc.gt.nx)isc=nx
         if(isc.lt.1)isc=1
         if(jsc.gt.ny)jsc=ny
         if(jsc.lt.1)jsc=1

         xlnzo=alog(z0(isc,jsc))
c ---    z1: first CALMET level
         xlnz1=alog(cellzc(1))
c ---    z2: anemometer height
         xlnz2=alog(zanem(n))
c ---    Logarithmic profile scaling factor
c        u(k=1)=zlogsta*u(zanem)
         zlogsta(n)=(xlnz1-xlnzo)/(xlnz2-xlnzo)
      end do

c --- set missing data flags
      edit=999.
      editl=900.
      iedit=999
      ieditl=900
c
c --- set no. surf., upper, and total wind stations
      nsurf = nssta + nowsta
      nupper = nusta
      nwind = nssta + nowsta + nusta
      if (nwind .gt. mxwnd) then
       write(io6,101)nssta,mxss,nowsta,mxows,nusta,mxus,nwind,mxwnd
101    format(//2x,'ERROR in SUBR. DIAGI -- too many wind stations ',
     1   ' for array dimensions'/2x,'nssta = ',i5,3x,'mxss = ',i5
     2   /2x,'nowsta = ',i5,3x,'mxows = ',i5
     2   /2x,'nusta = ',i5,3x,'mxus = ',i5
     3   /2x,'nwind = ',i5,3x,'mxwnd = ',i5)
         stop
      endif
c
c --- No longer need to change variable names as all barriers parameters
c     (nbar, barxy...) are now stored in d3.met (not in wparm.met)
c     and are in km already (050101)
c --- set no. barriers and barrier coordinates
c      numbar=nbar
c      do 110 j=1,numbar
c --- convert to km for wind module
c      barxy(1,j)=0.001*xybar(1,j)
c      barxy(2,j)=0.001*xybar(2,j)
c      barxy(3,j)=0.001*xybar(3,j)
c      barxy(4,j)=0.001*xybar(4,j)
c110   continue
c
c --- set internal wind model control variable
      icalc=1
c
c --- copy terrain heights into wind module common block
      do 30 i=1,nx
      do 30 j=1,ny
      htopo(i,j)=elev(i,j)
30    continue
c
c --- determine maximum terrain height within a given radius for
c --- each grid point
      if(i3dctw.eq.1)call terset(htopo,hmax,terrad)
c
c --- determine which wind field output files are needed
      i21=ipr0+ipr1+ipr2+ipr3+ipr4+ipr5+ipr6+ipr7+ipr8
      i22=ipr8+ioutd
      i23=ipr5+ioutd
      i24=ipr6+ioutd
      i25=ipr7+ioutd
c
c --- initialize and then copy test file unit numbers into internal
c --- wind module variables
      iwr=0
      ifile=0
      ifilek=0
      ifilef=0
      ifiles=0
      if(i21.ge.1)iwr=io21
      if(i22.eq.2)ifile=io22
      if(i23.eq.2)ifilek=io23
      if(i24.eq.2)ifilef=io24
      if(i25.eq.2)ifiles=io25
c
      return
      end
c----------------------------------------------------------------------
      subroutine diagno(nhrz,nh,gamma,um,vm,nowsta,zowsta,
     &        itwprog,zlogwsta,ziconv,tsfnsp,tprog,vptprog,ccgrid,
     &        iceilg,rho)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 080205             DIAGNO
c ---          R. KESSLER, S. DOUGLAS, SAI
c ---          Modified by M. Fernau, J. Scire, F.Robe, EARTH TECH
C
C     DIAGNO IS A DIAGNOSTIC WIND MODULE WHICH GENERATES A THREE-
C     DIMENSIONAL, NON-DIVERGENT WIND FIELD IN TERRAIN FOLLOWING
C     COORDINATES.  BEGINNING WITH A DOMAIN-SCALE MEAN WIND, THE
C     VERTICAL VELOCITY DUE TO TOPOGRAPHIC EFFECTS IS CALCULATED.
C     THE HORIZONTAL VELOCITY FIELD IS THEN ADJUSTED TO MINIMIZE
C     THE DIVERGENCE SUBJECT TO THE CONSTRAINT THAT THE VERTICAL
C     VELOCITY IS HELD CONSTANT.  THERMALLY-INDUCED SLOPE FLOWS
C     ARE GENERATED AND ADDED TO THE WIND FIELD.  A FROUDE NUMBER
C     ADJUSTMENT PROCEDURE IS USED TO DIVERT THE FLOW AROUND
C     TERRAIN OBSTACLES.  THE COMPUTED FIRST-GUESS FIELD IS THEN
C     COMBINED WITH OBSERVATIONAL DATA TO PRODUCE A GRIDDED WIND
C     FIELD.  FINALLY A NEW VERTICAL VELOCITY IS CAL-
C     CULATED USING THE CONTINUITY EQUATION AND IS ADJUSTED SO THAT
C     THE VERTICAL VELOCITY AT THE TOP OF THE MODEL IS ZERO.  THE
C     DIVERGENCE IS MINIMIZED SUBJECT TO THE CONSTRAINT THAT THE
C     VERTICAL VELOCITY IS UNCHANGED.
C
C     THE DIAGNOSTIC WIND MODULE IS AN ENHANCED VERSION OF THE CIT
C     WIND MODEL (GOODIN,MCRAE AND SEINFELD, 1980).  THE FROUDE
C     NUMBER MODIFICATION SCHEME IS ADAPTED FROM THE MELSAR MODEL
C     (ALLWINE AND WHITEMAN, 1985).  THE KINEMATIC AND SLOPE FLOW
C     PARAMETERIZATIONS ARE DERIVED FORM THE COMPLEX-TERRAIN WIND
C     MODEL (YOCKE, 1979).
C
c UPDATES:
c ********
c --- V6.3 Level 070717 to V6.32 080205
c        - Remove progn record LST time (mhr,mjul,mhr) from calling
c          list to RDMM4/RDMM5 (never used)
c 
c --- V6.223 Level 070702 to V6.3 Level 070717
c        - Add IPSIFCN to ELUSTR argument list
c        - Add IPSIFCN to STHEOR argument list
c        - Add ISFCMET option (pass TSFNSP array back in arg list)
c
c --- V6.222 Level 070404 to V6.223 Level 070702 (FRR)
c    - initialize Temp2d, irh2d, rho2d early on so defined
c      for obj. analysis (iwfcod=0)
c     - make sure vertical extrapolation is not done for iextrp=1
c
c --- V6.218 Level 070113 to V6.222 Level 070404(FRR)
c     - Pass on observed ceiling height iceil(mxss) and icloud
c       to RADFLX
c --- V6.216 Level 061230 to V6.218 Level 070113(F.Robe)
c     - Make an earlier call to sURFVAR to get first estimate of
c       2-D surface temperature (TEMP2D) prior to computing
c       terrain-stability induced effects.
c     - Bit of clean up (delete comments related to very old versions)
c     - Make former scalar gamma a 2-D array 
c     - Remove beta2 from calling list (never used)
c     - Remove iupt from STHEOR calling list and itprog from CGAMMA2 
c       calling list
c
c --- V 6.2 level 060215  to V6.216 Level 061230 (F.RobE)
c     - pass on ending seconds to PROGRD instead of beg. seconds
c
c --- V5.711 Level 060106 to v6.2 Level 060215(F.Robe)
c     - Use explicit times with seconds (sub-hourly timesteps)
c     - Replace sinalp(i,j,nhrind) by sinalpc(i,j)
c
c --- V5.611 Level 051113 to V5.711 Level 060106 (F.Robe)
c     -  Add option to use coarse CALMET winds as IGF
c
c --- Version 5.6 Level 050328 to v5.611 Level 051113
c     -  itwprog in calling list and passed on to rdmm5 and stheor
c 
c --- Version 5.55 Level 050217 V5.6 Level 050328
c     -  Remove nssta from calling list to airden
c     -  Pass on value of imixh (method to compute the convective mixing height)
c        to stheor (wind extrapolation at the stations) 
c     -  Bug fix: water cell not defined by htopo=0 but by ilandu/SEA.DAT
c     -  Adjust winds from anemometer height to first CALMET level
c        using user-selected extrapolation method (iextrp) or neutral
c        log profile if iextrp=1
c
c --- Version 5.548a Level 050101 to Version 5.55 Level 050217
c     - Remove nbar from calling list to inter2 and interp
c       (passed via common d3.met)
c
c --- Version 5.547 Level 041016 to Version 5.548a Level 050101
c     - Replace common /d3/ by include d3.met (and accordingly replaced
c       numbar by nbar)
c
c --- Version 5.546a Level 041001 to Version 5.547 Level 041016
c     - Bug fix: water cell not defined by htopo=0 but by ilandu/SEA.DAT (F.Robe)
c
c --- Modified : Frr (09/01)
c                - Allow no-observation mode
c --- Modified : FRR (12/96)
c                - Calls to subroutines HEATFX,AIRDEN,ELUSTR to 
c                  compute a first estimate of the sensible heat flux
c                - Include common blocks: MET1, MET2, GRID, GEO, METGRD
c                  and GEN - Needed for calls to subroutines 
c                  HEATFX,AIRDEN,ELUSTR
c
c --- include parameters
      include 'params.met'
      include 'breez.met'
      include 'wparm.met'
      include 'd3.met'
c
c NEW - FRR - 12/19/96 -
c --- Include the common blocks needed to compute a first estimate
c     of the sensible heat flux. This estimate is used to compute
c     the slope flows- 
c     Variables used in common blocks:
c     geo.met   : ilandu,iwat1,iwat2
c - MEF -
c     met1.met  : nssta,icloud,zanem,noobs
c     met2.met  : tempk,icc
c     metgrd.met: qh,zi
c - MEF -
c     grid.met  : nears,nx,ny,zmid,dx,dy
c     gen.met   : sinalpc,nhrind,nsecb
c
      include 'geo.met'
      include 'grid.met'
      include 'met1.met'
      include 'met2.met'
      include 'metgrd.met'
      include 'gen.met'
      include 'mm4hdo.met' 
c
      real rho(mxnx,mxny),ccgrid(mxnx,mxny),qsw(mxnx,mxny)      
c frr 050328 - 2D surface arrays
      real temp2d(mxnx,mxny),qlw(mxnx,mxny)

c --- Add 2D array of surface temperatures from nearest stations or
c --- prognostic data
      real tsfnsp(mxnx,mxny)
      logical ltsf

      integer irh2d(mxnx,mxny),ipcode2d(mxnx,mxny)
c -frr(12/96)--  real zanem(mxss),zowsta(mxows)
      real zowsta(mxows),zlogwsta(mxows)
      real uprog(mxnx,mxny,mxnz),vprog(mxnx,mxny,mxnz),
     &     tprog(mxnx,mxny,mxnz),vptprog(mxnx,mxny,mxnz)
      real work3(mxwk3),work4(mxnx,mxny,2)
      real udat(mxnxp,mxnyp,mxnz),vdat(mxnxp,mxnyp,mxnz)
      real ziconv(mxnx,mxny)
      integer iceilg(mxnx,mxny)

c --- IGF-CALMET wind fields (on CALMET Grid)
      real uigf(mxnx,mxny,mxnz),vigf(mxnx,mxny,mxnz)

c --- 2-D lapse rate (070113)
      real gamma(mxnx,mxny)

      CHARACTER*4 namst
c *** character*80 cmesag
C
c frr 050328 - common via include statement 
c      COMMON /D1/ U(mxnx,mxny,mxnz),V(mxnx,mxny,mxnz),
c     1  W(mxnx,mxny,mxnzp1), UB(mxny,2,mxnz), VB(mxnx,2,mxnz),
c     1  USLOPE(mxnx,mxny,mxnz),  VSLOPE(mxnx,mxny,mxnz),
c     1  UG(mxnx,mxny,mxnz),  VG(mxnx,mxny,mxnz),
c     1  HTOPO(mxnx,mxny), HMAX(mxnx,mxny),
c     1  UTMXST(mxwnd), UTMYST(mxwnd), WT(mxwnd),
c     1  RS(mxwnd), IS(mxwnd), IST(mxwnd), JST(mxwnd),
c     1  US(mxnz,mxwnd), VS(mxnz,mxwnd),
c     1  CELLZB(mxnzp1), CELLZC(mxnz),
c     1  PEXP(7), FEXTRP(mxnz), DIV(mxnx,mxny,mxnz),
c     1  NINTRP(mxnz)
c frr 050328 - common via include statement 
      include 'd1.met'

       COMMON /D2/ WORK(mxxy), WORK2(3)
c      COMMON /D3/ IFIN, NUMBAR, BARXY(4,MXBAR), SLPIN(2,MXBAR)
c      COMMON /D4/ EDIT, EDITL, IEDIT, IEDITL
c      COMMON /D6/  IRD, IWR, IFILE, irdp
C
c frr 050328 - replace explicit common by include statements
      include 'd4.met'
      include 'd6.met'


      DATA ZERO /0./
c
c --- Parameters used:
c         MXNX, MXNY, MXNZ, MXSS, MXUS, MXBAR, MXNZP1,
c         MXWND, MXXY, MXWK3
C
C     INITIALIZE SOME PARAMETERS
C
      IFIN = 0
      NZP1=NZ+1
      dxk=0.001*dx
      dyk=0.001*dy
      TIME = (nh-1) * 100

      ltsf=.FALSE.
c
c --- 070702- Must initialize temp2d,irh,rho so that defined when obj.analysis only
      n=mxnx*mxny*mxnz
      call xmit(-n,zero,ug)
      call xmit(-n,zero,vg)
      call surfvar(ug(1,1,1),vg(1,1,1),tprog,temp2d,irh2d,ipcode2d,2)
      if (itprog.lt.2) call airden(pres,temp2d,rho)

C
C --- BEGIN SIMULATION
C
      IF (I3DCTW .NE. 1) GO TO 292
C
C ----- SET UP FIRST GUESS FIELD
C
c
c --- initialize arrays if using prognostic results as input to
c --- diagnostic model
      n=mxnx*mxny*mxnz
      np=mxnxp*mxnyp*mxnz
      call xmit(-np,zero,udat)
      call xmit(-np,zero,vdat)
      call xmit(-n,zero,uprog)
      call xmit(-n,zero,vprog)

      if(iprog.eq.2)then
         call progrd(uprog,vprog,cellzc,utmxor,utmyor,time,nsece)

      elseif(iprog.eq.4)then
c ---     remove time from calling list (never used -080205)
c         call rdmm4(cellzc,udat,vdat,uprog,vprog,
c     1              mhr,mjul,myr,tprog,vptprog,
c     2              icloud,ccgrid,iceilg,rho,npsta)
         call rdmm4(cellzc,udat,vdat,uprog,vprog,
     1              tprog,vptprog,
ccec101006     2              icloud,ccgrid,iceilg,rho,npsta)
     2              mcloud,ccgrid,iceilg,rho,npsta)

c ---    Must define GAMMA  if using prognostic T
         if (itprog.ge.1) then
             call cgamma2(tprog,ziconv,gamma)
		
c ---        Store the sign of GAMMA in BETA2 
c ---        never used so do not compute (070113)
c            IF (GAMMA .LT. 0.) BETA2 = 1.
c            IF (GAMMA .EQ. 0.) BETA2 = 0.
c            IF (GAMMA .GT. 0.) BETA2 = -1.

         end if

      elseif(iprog.eq.14)then
c ---     remove time from calling list (never used -080205)
c         call rdmm5(cellzc,udat,vdat,uprog,vprog,mhr,mjul,myr,
c     1              tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta,
c     2              itwprog)
         call rdmm5(cellzc,udat,vdat,uprog,vprog,
ccec101006     1              tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta,
     1              tprog,vptprog,mcloud,ccgrid,iceilg,rho,npsta,
     2              itwprog)

c ---    Must define GAMMA if using prog T
         if (itprog .ge. 1) then
           call cgamma2(tprog,ziconv,gamma)

c ---      Store the sign of GAMMA in BETA2 
c ---       never used so do not compute (070113)
c           IF (GAMMA .LT. 0.) BETA2 = 1.
c           IF (GAMMA .EQ. 0.) BETA2 = 0.
c           IF (GAMMA .GT. 0.) BETA2 = -1.

         end if

      end if
c

c      DO 400 K = 1,NZ
c      DO 400 J = 1,mxny
c      DO 400 I = 1,mxnx
c        if (iprog.eq.2 .or. iprog.eq.4)then
c          UG(I,J,K) = uprog(i,j,k)
c          VG(I,J,K) = vprog(i,j,k)
c        else
c          UG(I,J,K) = um
c          VG(I,J,K) = vm
c        endif
c 400  CONTINUE
c
c *** JC modifications of 8/23/93 for non-uniform first-guess field. ***
c

c --- initialize arrays if using coarse CALMET results as input to
c --- diagnostic model
c --- n=mxnx*mxny*mxnz (defined above)
      call xmit(-n,zero,uigf)
      call xmit(-n,zero,vigf)
      if (igfmet.eq.1) call rdcalmet(cellzc,uigf,vigf)

      if (iprog.eq.2 .or. iprog.eq.4 .or. iprog.eq.14) then
c Use prognostic wind field as the first-guess field
         DO 400 K = 1,NZ
         DO 400 J = 1,mxny
         DO 400 I = 1,mxnx
            UG(I,J,K) = uprog(i,j,k)
            VG(I,J,K) = vprog(i,j,k)
 400     CONTINUE

      else if (igfmet.eq.1)then
c ---    USE coarse CALMET wind fields (060106)
         DO 401 K = 1,NZ
         DO 401 J = 1,mxny
         DO 401 I = 1,mxnx
            UG(I,J,K) = uigf(i,j,k)
            VG(I,J,K) = vigf(i,j,k)
 401     CONTINUE
       else   
c Otherwise...
         if (idiopt(3).eq.1) then
c   Use preprocessed values from the DIAG.DAT file as the uniform
c   first-guess field
           DO 410 K = 1,NZ
           DO 410 J = 1,mxny
           DO 410 I = 1,mxnx
              UG(I,J,K) = um
              VG(I,J,K) = vm
 410       CONTINUE
         else
c   Otherwise...
           if (iupwnd.gt.0) then
c     Use single upper air station to compute uniform first-guess field.
             DO 420 K = 1,NZ
             DO 420 J = 1,mxny
             DO 420 I = 1,mxnx
                UG(I,J,K) = um
                VG(I,J,K) = vm
 420         CONTINUE
           else
c     Otherwise, compute spatially-varying first-guess field
             call WIND1
           end if
         end if
      endif
C

C ---- SET BOUNDARY CONDITIONS ** insert 10/13/87 **
C
      DO 152 K=1,NZ
      CALL WINDBC(UG,VG,UB,VB,K)
  152 CONTINUE

C

c --- Fill in 2D arrays of surface Temperature TEMP2D (frr 070113)
c --- so (first estimate of )temp2d available for terrain-stability 
c --- induced effects  (if domain representative Tinf is not used)


      if (isurft.lt.0) 
     :  call surfvar(ug(1,1,1),vg(1,1,1),tprog,temp2d,irh2d,ipcode2d,0)

         
C ---- INITIALIZE THE VERTICAL VELOCITY
C
      N = mxnx*mxny*mxnzp1
      CALL XMIT(-N,ZERO,W)

C
C ---- CALCULATE THE VERTICAL VELOCITY DUE TO TOPOGRAPHIC EFFECTS
C
      IF (IKINE .EQ. 1) CALL TOPOF2(UG,VG,W,HTOPO,
     1    CELLZB,GAMMA,ISURFT,TINF,TEMP2D,ALPHA)

C
C ---- GENERATE A NEW HORIZONTAL VELOCITY FIELD USING THE
C      DIVERGENCE MINIMIZATION PROCEDURE
C
      IF (IKINE .EQ. 1) CALL MINIM(UG,VG,W,UB,VB,DIV,
     1     NITER,DIVLIM)
C
C ---- OUTPUT KINEMATIC EFFECTS
C
      IF (IPR5 .LE. 0) GO TO 286
      WRITE(IWR,2904)
      WRITE(IWR,2905)
      CALL WINDPR(UG,VG,W)
      IF (IOUTD .GT. 0) CALL OUTFIL(IFILEK,TIME,UG,VG,W)
  286 CONTINUE

C
C ---- APPLY THE MELSAR FROUDE NUMBER ADJUSTMENT
C
      IF (IFRADJ .EQ. 1) CALL FRADJ(UG,VG,HTOPO,GAMMA,ISURFT,TINF,
     1                   TEMP2D,CRITFN,CELLZB,HMAX)
C
C------- OUTPUT FROUDE NUMBER EFFECTS
C
      IF (IPR6 .LE. 0) GO TO 287
      WRITE(IWR,2906)
      WRITE(IWR,2907)
      CALL WNDPR2(UG,VG)
      IF (IOUTD .GT. 0) CALL OUTFIL(IFILEF,TIME,UG,VG,W)
  287 CONTINUE

c
c --- Set 2D array of surface temperatures using either nearest surface
c --- station or prognostic data (for ISFCMET=1 option)
      call T2D_NSP(nears,nx,ny,itprog,tprog,tsfnsp)
      ltsf=.TRUE.
c

c --- Update  2D arrays of surface Temperature (frr 050328)
c --- so temp2d available for heatfx -Note not final U,V field yet so
c --- upwind temperature averaging is not final (surfvar called again later)
c --- 050328: no need to compute rh and ipcode at this point so skip

c --- Add ISFCMET control for SURFVAR call
      if(isfcmet.EQ.0) then
         call surfvar(ug(1,1,1),vg(1,1,1),tprog,temp2d,irh2d,ipcode2d,0)
      endif

c NEW: frr (12/96) --- SENSIBLE HEAT FLUX ----------------------------
c --- Compute a first estimate of the heat fluxes in order to
c     compute the slope flows based on local sensible heat flux

c --- First daytime fluxes (over land) - 
c --- calling list has changed (frr 050328 as temp2d is available)

c --- Add branch for surface temperature option:
c --- Pass either the nearest surface station/prognostic surface
c --- temperatures, or the full 2D temperatures
      if(isfcmet.EQ.0) then
c ---    Use full 2D surface temperature array
c ---    First daytime fluxes (over land) - 
c ---    calling list has changed (frr 050328 as temp2d is available)
         call heatfx(sinalpc,nears,temp2d,icc,ilandu,iwat1,
ccec101006     1              iwat2,nx,ny,icloud,ccgrid,qh,qsw)
     1              iwat2,nx,ny,mcloud,ccgrid,qh,qsw)
c ---    Then nightime fluxes (over land) 
c        RHO based on sf data if itprog<2 and on MM5 data if itprog=2
c        call airden(pres,tempk,nssta,rho)
         if (itprog.lt.2) call airden(pres,temp2d,rho)
         call elustr(z0,ug,vg,zmid(1),nears,
     1               rho,temp2d,icc,ilandu,iwat1,iwat2,
ccec101006     2               nx,ny,icloud,ccgrid,ipsifcn,qh,ustar,el)
     2               nx,ny,mcloud,ccgrid,ipsifcn,qh,ustar,el)
      elseif(isfcmet.EQ.1) then
c ---    Use 2D temperature array of either nearest station temperature
c ---    or prognostic temperature
c ---    First daytime fluxes (over land) - 
c ---    calling list has changed (frr 050328 as temp2d is available)
         call heatfx(sinalpc,nears,tsfnsp,icc,ilandu,iwat1,
ccec101006     1              iwat2,nx,ny,icloud,ccgrid,qh,qsw)
     1              iwat2,nx,ny,mcloud,ccgrid,qh,qsw)
c ---    Then nightime fluxes (over land) 
c        RHO based on sf data if itprog<2 and on MM5 data if itprog=2
         if (itprog.lt.2) call airden_ns(pres,tempk,nssta,rho)
         call elustr(z0,ug,vg,zmid(1),nears,
     1               rho,tsfnsp,icc,ilandu,iwat1,iwat2,
ccec101006     2               nx,ny,icloud,ccgrid,ipsifcn,qh,ustar,el)
     2               nx,ny,mcloud,ccgrid,ipsifcn,qh,ustar,el)
      else
         write(io6,*)'ERROR in DIAGNO:  invalid ISFCMET provided'
         write(io6,*)'  Expected isfcmet = 0 or1'
         write(io6,*)'     Found isfcmet = ',isfcmet
         stop 'ERROR in DIAGNO -- see list file'
      endif

c NEW END --------------------------------------------------------------

C     CALCULATE THE SLOPE FLOW
      if (ISLOPE.EQ.1)CALL SLOPE(USLOPE,VSLOPE,HTOPO,ISURFT,TINF,TEMP2D,
     :                           HMAX)
C
C     ADD THE SLOPE FLOW COMPONENT TO THE HORIZONTAL WIND FIELD
C
      DO 300 K=1,NZ
      DO 300 J=1,NY
      DO 300 I=1,NX
        UG(I,J,K)=UG(I,J,K)+USLOPE(I,J,K)
        VG(I,J,K)=VG(I,J,K)+VSLOPE(I,J,K)
  300 CONTINUE

C
C     OUTPUT SLOPE FLOW EFFECTS
C
      IF (IPR7 .LE. 0) GO TO 288
      WRITE(IWR,2908)
      WRITE(IWR,2909)
      CALL WNDPR2(UG,VG)
      IF (IOUTD .GT. 0) CALL OUTFIL(IFILES,TIME,UG,VG,W)
  288 CONTINUE
C

C     SET BOUNDARY CONDITIONS
C
      DO 290 K=1,NZ
      CALL WINDBC(UG,VG,UB,VB,K)
  290 CONTINUE
C
C     IN THE CASE OF NO OBSERVATIONS, PROCEED DIRECTLY TO THE
C     SMOOTHING STEP 
c     (true only for IWFCOD=1, otherwise the code has already stepped to 292)
C
      IF (NWIND .EQ. 0) THEN
        DO 291 K = 1,NZ
        DO 291 J = 1,NY
        DO 291 I = 1,NX
          U(I,J,K) = UG(I,J,K)
          V(I,J,K) = VG(I,J,K)
  291   CONTINUE
      ENDIF
      IF (NWIND .EQ. 0) GO TO 285

c     This is where one lands if i3dctw=0 (objective analysis only)
292   continue

c frr(09/01)note: icalc is hardcoded to 1 in subroutine diagi so what's the point???
   52 IF(ICALC.LT.0)  GO TO 850
C
C     EXTRAPOLATE SURFACE WINDS
C     EXTRAPOLATION OPTIONS:
C       1) IF IABS(IEXTRP)=1, THEN DO NOT EXTRAPOLATE FROM SURFACE DATA
c          Except from anemometer height to first CALMET level (050328)
C       2) IF IABS(IEXTRP)=2, THEN USE POWER LAW
C       3) IF IABS(IEXTRP)=3, THEN USE FEXTRP MULTIPLIER
C       4) IF       IEXTRP=4, THEN USE SIMILARITY THEORY
C       5) IF IEXTRP<=0, THEN DO NOT USE LEVEL 1 DATA FROM UA WINDS
C
c --- if iextrp=1, must extrapolate from anemometer to first CALMET level    
c     IF(IABS(IEXTRP).EQ.1) GO TO 91
c --- NSOL is the number of overland surface stations
      nsol=nsurf-nowsta
c --- NSOW is the local counter for of the overwater stations
      nsow=0

      if(.NOT.ltsf .AND. nsurf.GT.0) then
c ---    Diagnostic module was skipped.
c ---    Set 2D array of surface temperatures using nearest surface
c ---    station data (for ISFCMET=1 option) for use if surface data
c ---    are profiled using similarity
         itprog_sfc=1
         call T2D_NSP(nears,nx,ny,itprog_sfc,tprog,tsfnsp)
      endif


      DO 70 L=1,NSURF
c
c --- keep track of overwater station number (NSURF=nssta+nowsta)
      if(L.gt.nsol)nsow=nsow+1
c
c --- Skip upper air check if no stations
c --- (Should also be skipped if using similarity theory, i.e., let
c ---  RMIN2 < 0)
      IF(NUPPER.EQ.0) GO TO 63
C
C     CHECK FOR CLOSE UPPER AIR STATION WITH VALID WIND DATA
C     SKIP EXTRAPOLATION IF CLOSE UPPER AIR DATA EXISTS
C
      N = NSURF + 1
      CALL XMIT(-NUPPER,EDIT,RS(N))
C
C     CHECK IF UPPER AIR STATION HAS SOME VALID DATA
C
      DO 64 I = 1,NUPPER
      lup=nsurf+i
      DO 61 K = 1,NZ
        IF(US(K,Lup).LT.EDITL.OR.VS(K,Lup).LT.EDITL)  GO TO 62
   61 CONTINUE
      GO TO 64
C
C     COMPUTE DISTANCES BETWEEN SURFACE STATION AND UPPER STATIONS
C
   62 J = NSURF + I
      RSX = (UTMXST(J)  - UTMXST(L))/DXK
      RSY = (UTMYST(J)  - UTMYST(L))/DYK
      RS(I) = RSX**2 + RSY**2
      RS(I) = SQRT(RS(I))
   64 CONTINUE
      CALL FMINF(RS,NUPPER,FMIN,NMIN)
      IF(FMIN.LT.RMIN2)  GO TO 70

c ---    Anemometer height and neutral log adjustment coefficient
         if(L.le.NSOL)then
c ---       Station is an overland surface station
            zwsref=zanem(L)
            zlog=zlogsta(l)
         else
c ---       Station is an overwater station
            zlog=zlogwsta(nsow)
            zwsref=zowsta(nsow)
c ---       Use 10 m overwater anemometer height if not specified
            if(zwsref.ge.9998.)zwsref=10.
         endif

       IF (IABS(IEXTRP) .EQ. 1) THEN
c ---    Adjust from Anenometer height to first CALMET level only 
c ---    using neutral log profile (050328 - Frr) if non missing
         IF(US(1,L).GT.EDITL .OR. VS(1,L).GT.EDITL) GOTO 70
         us(1,l)=us(1,l)*zlog
         vs(1,l)=vs(1,l)*zlog
      ENDIF

   63 IF (IABS(IEXTRP) .EQ. 2)  THEN
C
C     EXTRAPOLATE WITH POWER LAW PROFILE
C
        IG = IST(L)
        JG = JST(L)
c --- Pick nearest grid cell if station is off grid
        ig = max0(1,ig)
        ig = min0(ig,nx)
        jg = max0(1,jg)
        jg = min0(jg,ny)
        DO 67 K=2,NZ

          KM1=K-1

          IF(US(KM1,L).GT.EDITL .OR. VS(KM1,L).GT.EDITL) GOTO 70
          pexp2 = 0.143
c ---     041010: Bug fix (F.Robe). Overwater cell not defined by htopo=0
c ---     but either by OW station or LU=water tagged for OW treatment
c         IF (HTOPO(IG,JG) .EQ. 0.) pexp2 = 0.286
          if( ( (l.gt.nssta).and.(l.le.nsurf) ) .OR.
     :        ( (ilandu(ig,jg).ge.iwat1).and.(ilandu(ig,jg).le.iwat2)))
     :        pexp2=0.286

          IF (K .EQ. 2) THEN
            PADJ = (CELLZC(K)/zwsref)**pexp2
          ELSE
            PADJ = ( CELLZC(K)/CELLZC(KM1) )**pexp2
          END IF
          US(K,L) = US(KM1,L)*PADJ
          VS(K,L) = VS(KM1,L)*PADJ
   67   CONTINUE
c ---   Also adjust winds from anenometer height to first calmet level
c ---   050328 (frr)
        PADJ = (zwsref/CELLZC(1))**pexp2
        US(1,L) = US(1,L)/PADJ
        VS(1,L) = VS(1,L)/PADJ

      ELSE IF (IABS(IEXTRP) .EQ. 3)  THEN
C
C     EXTRAPOLATE WITH USER'S EXTRAPOLATION MULTIPLIERS

c --- Bug fix (050328- Frr) extrapolate only if not missing
        IF(US(1,L).GT.EDITL .OR. VS(1,L).GT.EDITL) GOTO 70

c --- 050328-frr: NZ values of fextrp => use the first value
c --- to scale from anenometer height to 1st CALMET level

C       DO 69 K=2,NZ
        DO 69 K=NZ,1,-1
          US(K,L) = US(1,L)*FEXTRP(K)
          VS(K,L) = VS(1,L)*FEXTRP(K) 
   69   CONTINUE
c      ELSE   : must specify 4 otherwise also redone if iextrp=1
      ELSE IF (IABS(IEXTRP) .EQ. 4)  THEN
C
C     EXTRAPOLATE WITH SIMILARITY THEORY
C
        IG = IST(L)
        JG = JST(L)
c --- Pick nearest grid cell if station is off grid
        ig = max0(1,ig)
        ig = min0(ig,nx)
        jg = max0(1,jg)
        jg = min0(jg,ny)

c ---   frr 021105: allow vertical extrapolation if noobs=1
c       CALL STHEOR(ZI,ZICONV,US,VS,L,IG,JG,NSURF,IUPT,icloud,ccgrid)
c ---   frr 050328: pass short and long wave fluxes (Qsw-QLW) to stheor
c       for COARE computations in WATER2 subroutine
c ---   compute long wave radiation (needed in water2 called by stheor)
c ---   Note : qsw and qlw are not quite the final values yet as temp2d
c       at this point is not quite final (u,v because umv were not final 
c       when temp2d computed) - At this point rmm is filled with current 
c       values  only  if npsta=-1 (prognostic rainfall rates passed via METGRD)
c  
        if(isfcmet.EQ.0) then
c ---      Use full 2D surface temperature and RH arrays
ccec101006           call radflx(icloud,iceil,ccgrid,iceilg,temp2d,irh2d,qlw)
           call radflx(mcloud,iceil,ccgrid,iceilg,temp2d,irh2d,qlw)
        elseif(isfcmet.EQ.1) then
c ---      Use 2D temperature array of either nearest station temperature
c ---      or prognostic temperature, but values in irh2d are not correct!
c ---      RADFLX output is only for COARE option, which should not be
c ---      allowed with ISFCMET=1 --- do nothing here
        endif

        if(isfcmet.EQ.0) then
c ---     pass interpolated surface temperatures (temp2d) rather than tprog
          CALL STHEOR(NHRZ,ZI,ZICONV,US,VS,L,IG,JG,NSURF,iupt,itwprog,
ccec101006     :              icloud,ccgrid,rho,temp2d,rmm,qsw,qlw,
     :              mcloud,ccgrid,rho,temp2d,rmm,qsw,qlw,
     &                ipsifcn,isfcmet)
        elseif(isfcmet.EQ.1) then
c ---     pass surface temperature field as tsfnsp rather than tprog
          CALL STHEOR(NHRZ,ZI,ZICONV,US,VS,L,IG,JG,NSURF,iupt,itwprog,
ccec101006     :              icloud,ccgrid,rho,tsfnsp,rmm,qsw,qlw,
     :              mcloud,ccgrid,rho,tsfnsp,rmm,qsw,qlw,
     &                ipsifcn,isfcmet)
        endif
c ---   Note: after call to STHEOR, the "surface observations" are no longer
c ---   at anemometer height but at zmid(1) (first CALMET level) - 050328

      END IF
   70 CONTINUE
   91 CONTINUE
c
c --- initialize arrays if using prognostic results as input to
c --- diagnostic model
      if(iprog.eq.1.and.i3dctw.ne.1)then
         n=mxnx*mxny*mxnz
         call xmit(-n,zero,uprog)
         call xmit(-n,zero,vprog)
         call progrd(uprog,vprog,cellzc,utmxor,utmyor,time,nsece)
      elseif(iprog.eq.3 .AND. i3dctw.ne.1)then
         n=mxnx*mxny*mxnz
         np=mxnxp*mxnyp*mxnz
         call xmit(-np,zero,udat)
         call xmit(-np,zero,vdat)
         call xmit(-n,zero,uprog)
         call xmit(-n,zero,vprog)
c ---    remove time from calling list (never used -080205)
c         call rdmm4(cellzc,udat,vdat,uprog,vprog,
c     1              mhr,mjul,myr,tprog,vptprog,
c     2              icloud,ccgrid,iceilg,rho,npsta)
         call rdmm4(cellzc,udat,vdat,uprog,vprog,tprog,vptprog,
ccec101006     1              icloud,ccgrid,iceilg,rho,npsta)
     1              mcloud,ccgrid,iceilg,rho,npsta)
      elseif(iprog.eq.13 .AND. i3dctw.ne.1)then
         n=mxnx*mxny*mxnz
         np=mxnxp*mxnyp*mxnz
         call xmit(-np,zero,udat)
         call xmit(-np,zero,vdat)
         call xmit(-n,zero,uprog)
         call xmit(-n,zero,vprog)
c ---    remove time from calling list (never used -080205)
c         call rdmm5(cellzc,udat,vdat,uprog,vprog,mhr,mjul,myr,
c     1              tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta
c     2              ,itwprog)
         call rdmm5(cellzc,udat,vdat,uprog,vprog,
ccec101006     1              tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta
     1              tprog,vptprog,mcloud,ccgrid,iceilg,rho,npsta
     2              ,itwprog)
      endif
c
c --- Initialize arrays if using prognostic data as observations
c frr (09/01) BUG- MM4 data should be read independently of i3dctw
c      if(iprog.EQ.5 .and. i3dctw .ne. 1)then
      if(iprog.EQ.5)then
         np=mxnxp*mxnyp*mxnz
         call xmit(-np,zero,udat)
         call xmit(-np,zero,vdat)
c ---    remove time from calling list (never used -080205)
c         call rdmm4(cellzc,udat,vdat,uprog,vprog,
c     1              mhr,mjul,myr,tprog,vptprog,
c     2              icloud,ccgrid,iceilg,rho,npsta)
         call rdmm4(cellzc,udat,vdat,uprog,vprog,tprog,vptprog,
ccec101006     1              icloud,ccgrid,iceilg,rho,npsta)
     1              mcloud,ccgrid,iceilg,rho,npsta)

c frr (09/01) BUG- MM5 data should be read independently of i3dctw
c      else if(iprog.EQ.15 .and. i3dctw .ne. 1)then
      else if(iprog.EQ.15)then
         np=mxnxp*mxnyp*mxnz
         call xmit(-np,zero,udat)
         call xmit(-np,zero,vdat)
c ---    remove time from calling list (never used -080205)
c         call rdmm5(cellzc,udat,vdat,uprog,vprog,mhr,mjul,myr,
c     1              tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta
c     2              ,itwprog)
         call rdmm5(cellzc,udat,vdat,uprog,vprog,
ccec101006     1              tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta
     1              tprog,vptprog,mcloud,ccgrid,iceilg,rho,npsta
     2              ,itwprog)
      endif
C

      if(.NOT.ltsf) then
c ---    Diagnostic module was skipped.
c ---    Set 2D array of surface temperatures using nearest surface
c ---    station or prognostic data (for ISFCMET=1 option)
         call T2D_NSP(nears,nx,ny,itprog,tprog,tsfnsp)
         ltsf=.TRUE.
      endif


C     INITIALIZE GLOBAL ARRAYS                                     .
C
      N = mxnx*mxny*mxnz
      CALL XMIT(-N,ZERO,U)
      CALL XMIT(-N,ZERO,V)
      CALL XMIT(-N,ZERO,DIV)
      N = mxnx*mxny*mxnzp1
      CALL XMIT(-N,ZERO,W)
C
C     INTERPOLATE WIND FIELD IN EACH VERTICAL LAYER

C
      IF (I3DCTW .EQ. 1) THEN
c ---    i3dctw=iwfcod=1: diagnostic wind model

         CALL INTER2(US,NWIND,UTMXST,UTMYST,
     1      NINTRP,RS,IS,work3,U,UG,ILANDU,
     2      iwat1,iwat2,udat,noobs)

         CALL INTER2(VS,NWIND,UTMXST,UTMYST,
     1      NINTRP,RS,IS,work3,V,VG,ILANDU,
     2      iwat1,iwat2,vdat,noobs)

      ELSE
c ---    i3dctw=iwfcod=0: objective analysis

         CALL INTERP(US,NWIND,UTMXST,UTMYST,RMIN,RMAX1,LVARY,NINTRP,
     1              RS,IS,work3,U,iprog,rprog,uprog,
     2              udat,noobs)
         CALL INTERP(VS,NWIND,UTMXST,UTMYST,RMIN,RMAX1,LVARY,NINTRP,
     1              RS,IS,work3,V,iprog,rprog,vprog,
     2              vdat,noobs)
      ENDIF


C
C    Lake breeze region calculations....                   ----- CALL LLBREEZ
C
      if (llbreze) then
        call llbreez
      endif
C
C     OUTPUT INTERPOLATED WIND FIELD                            
C
      IF(IPR0.LE.0) GO TO 250
      WRITE(IWR,2900)
      WRITE(IWR,2901)
      CALL WNDPR2(U,V)
  250 CONTINUE
C
C     ADJUST SURFACE LAYER WIND FOR TERRAIN EFFECTS
C
      IF(HTFAC.LE.0.) GO TO 285
      IF (I3DCTW .NE. 1) CALL ADJUST(U,V,W,HTOPO,CELLZB(NZP1),
     1                               UB,VB)
C
C
C     SET BOUNDARY CONDITIONS
C
      DO 1810 K = 1,NZ
        CALL WINDBC(U,V,UB,VB,K)
 1810 CONTINUE
C
C     OUTPUT ADJUSTED WIND FIELD                            .
C
      IF(IPR1.LE.0) GO TO 285
      WRITE(IWR,2902)
      WRITE(IWR,2903)
      CALL WNDPR2(U,V)
  285 CONTINUE
C
c**********************************************************************
c *** cmesag='CHECK SUM -- U FIELD -- after 285'
c *** call chksum(u,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c *** cmesag='CHECK SUM -- V FIELD -- after 285'
c *** call chksum(v,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c**********************************************************************
C     SMOOTH HORIZONTAL FIELDS
C
      CALL SMOOTH(U,V,UB,VB,NSMTH)
C
C     REINITIALIZE VERTICAL VELOCITY
C
      N=mxnx*mxny*mxnzp1
      CALL XMIT(-N,ZERO,W)
C
C     COMPUTE DIVERGENCE FIELDS AND VERTICAL VELOCITIES
C
      DIVMAX=-1.0E+09
      DO 330 K=1,NZ
        CALL DIVCEL(U,V,W,DIV,UB,VB,DIVMAX,K)
  330 CONTINUE
c**********************************************************************
c *** cmesag='CHECK SUM -- U FIELD -- after 330'
c *** call chksum(u,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c *** cmesag='CHECK SUM -- V FIELD -- after 330'
c *** call chksum(v,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c**********************************************************************
C
      DO 345 K=1,NZ
      DO 340 J=1,NY
      DO 340 I=1,NX
        W(I,J,K+1)=-DZ(K)*DIV(I,J,K)+W(I,J,K)
  340 CONTINUE
C
C     SET BOUNDARY CONDITIONS
C
      CALL WINDBC(U,V,UB,VB,K)
  345 CONTINUE
C
C     ADJUST VERTICAL VELOCITY AS SUGGESTED BY OBRIEN (1970)
C     (JAM, V.9, NO.2), WITH ERROR IN W PROPORTIONAL TO HEIGHT
C
      IF (IOBR .EQ. 1) THEN
      DO 350 K=1,NZ
      DO 350 J=1,NY
      DO 350 I=1,NX
        W(I,J,K+1)=W(I,J,K+1)-CELLZB(K+1)/CELLZB(NZP1)*W(I,J,NZP1)
  350 CONTINUE
      ENDIF
C
C     OUTPUT INITIAL WIND AND DIVERGENCE FIELDS
C
      IF (IPR2 .LE. 0) GO TO 360
      WRITE(IWR,2400)
      WRITE(IWR,2402)
      CALL WINDPR(U,V,W)
      WRITE(IWR,2401) DIVMAX
      CALL DIVPR(DIV)
  360 CONTINUE
c**********************************************************************
c *** cmesag='CHECK SUM -- U FIELD -- after 360'
c *** call chksum(u,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c *** cmesag='CHECK SUM -- V FIELD -- after 360'
c *** call chksum(v,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c**********************************************************************
C
C     ITERATE TO MINIMIZE DIVERGENCE
C
c *** CALL MINIM(U,V,W,UB,VB,DIV,NITER,DIVLIM)
      IF (IOBR .EQ. 1) CALL MINIM(U,V,W,UB,VB,DIV,NITER,DIVLIM)
C
C     OUTPUT FINAL WIND FIELDS
C
      if(ipr8.gt.0)then
         WRITE(IWR,2800) TIME,NH
         WRITE(IWR,2801)
         CALL WINDPR(U,V,W)
      endif
c**********************************************************************
c *** cmesag='CHECK SUM -- U FIELD'
c *** call chksum(u,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c *** cmesag='CHECK SUM -- V FIELD'
c *** call chksum(v,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c *** cmesag='CHECK SUM -- W FIELD'
c *** call chksum(w,mxnx,mxny,mxnz,nx,ny,nz,cmesag,io6)
c**********************************************************************
C
C     OUTPUT FINAL DIVERGENCE FIELDS
C
      IF(IPR4.LE.0)  GO TO 560
      WRITE(IWR,2803)
      CALL DIVPR(DIV)
C
C     OUTPUT FINAL WIND SPEED AND DIRECTION FIELDS
C
  560 IF(IPR3.LE.0) GO TO 800
      WRITE(IWR,2820) TIME,NH
      WRITE(IWR,2821)
      CALL RTHETA(U,V,work4)
  800 CONTINUE
C


C     OUTPUT FINAL WIND FIELD
C
      if(ipr8.gt.0.and.ioutd.gt.0)CALL OUTFIL(IFILE,TIME,U,V,W)
850   continue
  900 CONTINUE
      return
C
C     FORMAT SPECIFICATIONS
C
 2400 FORMAT(/,10X,'SMOOTHED WIND AND INITIAL DIVERGENCE FIELDS')
 2401 FORMAT(//,20X,'MAXIMUM DIVERGENCE = ',E12.4)
 2402 FORMAT(10X,43('-'))
 2800 FORMAT(10X,'FINAL WIND FIELD AT TIME = ',F7.0,
     1 5X,'(SIMULATION HOUR NO.',I3,' )')
 2801 FORMAT(10X,63(1H-))
 2803 FORMAT(/,10X,'FINAL DIVERGENCE FIELD AT TIME = ' ,F7.0,
     1         5X,'(SIMULATION HOUR NO.',I3,' )',/,10X,66('-'))
 2820 FORMAT(/,10X,'FINAL WIND SPEED AND DIRECTION AT TIME = ',F7.0,
     1              '(SIMULATION HOUR NO.  ,I3)')
 2821 FORMAT(10X,72('-'))
 2900 FORMAT(' ',10X,'INTERPOLATED WIND FIELD')
 2901 FORMAT(11X,23('-'))
 2902 FORMAT(/,10X,'TERRAIN ADJUSTED SURFACE WINDS')
 2903 FORMAT(10X,30('-'))
 2904 FORMAT(/,10X,'KINEMATIC EFFECTS')
 2905 FORMAT(10X,17('-'))
 2906 FORMAT(/,10X,'FROUDE NUMBER EFFECTS')
 2907 FORMAT(10X,21('-'))
 2908 FORMAT(/,10X,'SLOPE EFFECTS')
 2909 FORMAT(10X,13('-'))
      END
c----------------------------------------------------------------------
      subroutine divcel(u,v,w,div,ub,vb,divmax,k)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 940304             DIVCEL
c
c --- include parameters
      include 'params.met'
c NEW -frr (12/96) - D5 replaced by grid.met
c      COMMON /D5/ NX,NY,NZ,DX,DY,dz(mxnz),NZPRNT
      include 'grid.met'
      DIMENSION U(mxnx,mxny,*),V(mxnx,mxny,*)
      DIMENSION W(mxnx,mxny,*),DIV(mxnx,mxny,*)
      DIMENSION UB(mxny,2,*),VB(mxnx,2,*)
C
C     COMPUTES THE 3-D DIVERGENCE IN EACH GRID CELL
C
C     INPUTS:  U (R ARRAY)  - GRIDDED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY)  - GRIDDED Y-DIRECTION WIND COMPONENTS
C              W (R ARRAY)  - GRIDDED VERTICAL WIND COMPONENTS
C              UB (R ARRAY) - U-COMPONENT BOUNDARY VALUES
C              VB (R ARRAY) - V-COMPONENT BOUNDARY VALUES
c       Parameters:  MXNX, MXNY, MXNZ, MXNZP1
C
C     OUTPUTS:  DIV (R ARRAY) - GRIDDED 3-D DIVERGENCE
C
      HTOP=1.0
      DXI=1.0/(2.0*DX)
      DYI=1.0/(2.0*DY)
      DZI=1.0/DZ(K)
      DO 100 J=1,NY
      DO 100 I=1,NX
      DIV(I,J,K)=0.
      WPH=W(I,J,K+1)
      WMH=W(I,J,K)
      UPH=UB(J,2,K)
      IF(I.LT.NX) UPH=U(I+1,J,K)
      VPH=VB(I,2,K)
      IF(J.LT.NY) VPH=V(I,J+1,K)
      UMH=UB(J,1,K)
      IF(I.GT.1) UMH=U(I-1,J,K)
      VMH=VB(I,1,K)
      IF(J.GT.1) VMH=V(I,J-1,K)
C
C     DIVERGENCE IS EVALUATED USING CENTRAL DIFFERENCES
C
      DUDX=(UPH-UMH)*DXI
      DVDY=(VPH-VMH)*DYI
      DWDZ=(WPH-WMH)*DZI
      DIV(I,J,K)=HTOP*(DUDX+DVDY)+DWDZ
      DIVABS=ABS(DIV(I,J,K))
      DIVMAX=AMAX1(DIVABS,DIVMAX)
  100 CONTINUE
C
C     SCALE DIVERGENCE FOR TERRAIN-CONFORMAL SYSTEM
C
      DIVMAX=DIVMAX/HTOP
      RETURN
      END
c----------------------------------------------------------------------
      subroutine divpr(div)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328              DIVPR
c
c --- include parameters
      include 'params.met'
      include 'd6.met'
      include 'grid.met'
c --- frr 050328 - explicit common D6 replaced by include d6.met
c      COMMON /D6/ IRD,IWR,IFILE,irdp
      DIMENSION DIV(mxnx,mxny,*)
C
C     DIVPR PRINTS OUT DIVERGENCE FIELD AT EACH LAYER .
C
C     INPUTS:  DIV (R ARRAY) - GRIDDED 3-D DIVERGENCE
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
      DO 100 K=1,NZPRNT
      if(iwr.gt.0)WRITE(IWR,40) K
   40 FORMAT(//,5X,'DIVERGENCE AT LEVEL = ',I4)
      if(iwr.gt.0)WRITE(IWR,41)
   41 FORMAT(5X,24('-'))
      CALL WNDLPT(DIV(1,1,K))
  100 CONTINUE
      RETURN
      END
c----------------------------------------------------------------------
      subroutine elustr(z0,u1,v1,zm,nears,rho,temp2d,icc,ilandu,
ccec101006     1 iwat1,iwat2,nx,ny,icloud,ccgrid,ipsifcn,qh,ustar,el)
     1 iwat1,iwat2,nx,ny,mcloud,ccgrid,ipsifcn,qh,ustar,el)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 101006             ELUSTR
c ---          J. Scire, SRC
c
c --- PURPOSE:  Compute the friction velocity (m/s) and Monin-Obukhov
c               length (m) for land cells using the methods of
c               Holtslag & van Ulden (1983) (daytime) or
c               Venkatram (1980) and Weil & Brower (1983) (nighttime)
c
c --- UPDATES:
c --- V6.3 (070717) to V6.330 (101006)
c      - Change ICLOUD into MCLOUD and ICLDOUT
c --- v6.217 (061231) to V6.3 (070717)
c          - add new control variable IPSIFCN to select call to PSIU
c            functions
cc   - v5.612 (051214) to v6.217 (061231)(FRR)
c          - allow new icloud=4 option
c   - V5.6 (050328) to v5.612 (051214) (DGS-FRR)
c          - use double precision argument for psiud
c   - (09/01) to V5.6 050328  (Frr)
c          - Use consistent similarity relations
c            (COARE stability function PSIU with Dyers fit )
c          - Use already computed 2-D field of surface temperature (Temp2d)
c            rather than tprog/tempk based on itprog (calling list change)
c    
c   - F.Robe(09/01) 2D array of air density, NOOBS mode okay
c
c   - FRR (1/97) Minimum wind speed (0.5 m/s=sigmav minimum
c         in CALPUFF) for the computation of U*, theta* and HQ
c         during stable conditions
c
c
c --- INPUTS:
c        Z0(mxnx,mxny) - real array    - surface roughness lengths (m)
c        U1(mxnx,mxny) - real array    - U component of the wind (m/s)
c                                        in the lowest layer (i.e.,10 m)
c        V1(mxnx,mxny) - real array    - V component of the wind (m/s)
c                                        in the lowest layer (i.e.,10 m)
c                   ZM - real          - Height (m) of the cell center
c                                        in the lowest layer
c     NEARS(mxnx,mxny) - integer array - Station number of surface
c                                        station closest to each grid pt
c      RHO(mxnx,mxny)) - real array    - Air density (kg/m**3)
c    TEMP2D(mxnx,mxny) - real array    - Surface Air temperature (deg. K)
c            ICC(mxss) - integer array - Cloud cover (tenths)
c    ILANDU(mxnx,mxny) - integer array - Land use category at each
c                                        grid point
c         IWAT1, IWAT2 - integers      - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c               MCLOUD - integer       - Flag indicating if gridded
c                                        cloud data are available
c                                        (2,3,4 = yes, otherwise, no)
c    CCGRID(mxnx,mxny) - real array    - Gridded cloud fraction
c                                        (Used only if MCLOUD=2,3,4)
c              IPSIFCN - integer       - Flag controlling choice of PSI
c                                        stability correction for wind
c                                        profile
c                                       (IPSIFCN=0 use CALMET v5.6;
c                                        IPSIFCN=1 use CALMET v5.53)
c        QH(mxnx,mxny) - real array    - Sensible heat flux (W/m**2)
c                                        (only positive values are valid
c                                        -- nightime hours are flagged
c                                        with QH = -0.1)
c        Parameters: MXNX, MXNY, MXSS
c
c --- OUTPUT:
c        QH(mxnx,mxny) - real array    - Sensible heat flux (W/m**2) --
c                                        (only nightime (negative)
c                                        values are updated)
c     USTAR(mxnx,mxny) - real array    - Friction velocity (m/s)
c        EL(mxnx,mxny) - real array    - Monin-Obukhov length (m)
c
c ---  ELUSTR called by:  DIAGNO,COMP
c ---  ELUSTR calls:      function PSIUD, PSIUC
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real qh(mxnx,mxny),ustar(mxnx,mxny),el(mxnx,mxny)
      real u1(mxnx,mxny),v1(mxnx,mxny),z0(mxnx,mxny)
      real temp2d(mxnx,mxny),rho(mxnx,mxny)
      real ccgrid(mxnx,mxny)

      real*8 psiud,r8
c
      integer nears(mxnx,mxny),ilandu(mxnx,mxny)
      integer icc(mxss)
c
c --- NOTE:  a value of vk = 0.4 has been assumed in some of the
c --- other constants
      data vk/0.4/,xcrit/0.05/,wsmin/0.001/
c
c --- loop over grid cells
      do 200 i=1,nx
      do 200 j=1,ny
c
c ---   skip over water grid cells (OCD method is used over water)
        if(ilandu(i,j).ge.iwat1.and.ilandu(i,j).le.iwat2)go to 200
c
c ---   frr (09/01) Surface temperature from surface obs. or from MM5
c ---   050328: temp2d is the surface temperature in all cases
        tsf=temp2d(i,j)
c
      ws=sqrt(u1(i,j)**2+v1(i,j)**2)
c --- prevent numerical problems
      ws=amax1(ws,wsmin)
      xlnzz0=alog(zm/z0(i,j))
c
c --- daytime method -- use Holtslag and van Ulden (1983)
      if(qh(i,j).lt.0.0)go to 100
c
c --- first guess -- assume neutral conditions
      xl=-9.9e9
      xustar=vk*ws/xlnzz0
c --- prevent numerical problems - assume reasonable lower bound
      xustar=amax1(xustar,0.05)
c --- actual conditions are neutral if heat flux is zero
      if(qh(i,j).eq.0.0)go to 181
c
c --- iterate to refine estimate of u* and L
      maxit=5
      xlold=xl
      do 180 niter=1,maxit
c
c --- new estimate of L
c --- constant 253.8226 = cp/(vk*g) with cp=996 m**2/(s**2 deg.),
c --- vk=0.4, g=9.81 m/s**2
c
      xl=-253.8226*rho(i,j)*tsf*xustar**3/qh(i,j)
c
c --- new estimate of ustar
c
c --- stability correction factors (psim(z/L), psim(z0/L)) -- unstable
c --- conditions
c --- 050328 (frr) use consistent PSI functions (same as COARE)
      if(ipsifcn.EQ.0) then
         r8=zm/xl
         psizl  = PSIUD(r8)
         r8=z0(i,j)/xl
         psiz0l = PSIUD(r8)
      elseif(ipsifcn.EQ.1) then
         psizl  = PSIUC(zm,xl,15)
         psiz0l = PSIUC(z0(i,j),xl,15)
      else
         write(io6,*)'ERROR in ELUSTR:  invalid IPSIFCN'
         write(io6,*)'  Expected IPSIFCN = 0 or 1'
         write(io6,*)'     Found IPSIFCN = ',ipsifcn
         stop 'ERROR in ELUSTR -- see list file'
      endif

      xustar=vk*ws/(xlnzz0-psizl+psiz0l)
c --- prevent numerical problems - assume reasonable lower bound
      xustar=amax1(xustar,0.05)
c
c --- check for convergence (5% criterion)
      if(abs((xl-xlold)/xl).lt.0.005)go to 181
      xlold=xl
180   continue
181   continue
c
c --- insert final values into arrays
      ustar(i,j)=xustar
      el(i,j)=xl
      go to 200
c
c --- stable conditions -- use Venkatram(1980), Weil & Brower(1983)
100   continue
c
c NEW (frr: 1/21/97) : Minimum wind speed for the computation of 
c      Ustar, ThetaStar and HQ (stable conditions)
      ws=max(ws,0.5)
c --- Determine cloud cover (tenths) for this grid cell
ccec101006      if(icloud.gt.1)then
      if(mcloud.gt.1)then
c ---    Use gridded cloud data - convert from fraction to tenths
         jcc=10.*ccgrid(i,j)+0.5
      else
c ---    Use NWS cloud data (in tenths)
c         jcc=icc(nsta)
         jcc=icc(nears(i,j))
      endif
c
c --- constant 5.e-3 is 0.5 * (0.1)**2 -- factor of 0.1 converts
c --- cloud cover from tenths to a fraction
      theta1=0.09*(1.-5.e-3*jcc**2)
c
c --- constant 184.428 = 4*gamma*g with gamma=4.7, g=9.81 m/s**2
      cdn=vk/xlnzz0

      theta2=tsf*cdn*ws**2/(184.428*zm)

      thetas=amin1(theta1,theta2)
c --- prevent numerical problems
      thetas=amax1(thetas,1.e-9)
c
c --- compute ustar
c --- constant 46.107 = gamma*g, with gamma=4.7, g=9.81 m/s**2
      u02=46.107*zm*thetas/tsf

      cu2=amax1(0.0,ws*ws-4.*u02/cdn)
      ustar(i,j)=0.5*cdn*(ws+sqrt(cu2))
c --- prevent numerical problems - assume a reasonable lower bound
      ustar(i,j)=amax1(ustar(i,j),0.05)
c
c --- product of (u*)(theta*) is not allowed to exceed XCRIT (=0.05)
      if(ustar(i,j)*thetas.gt.xcrit)then
         maxit=3
c ---    tolerance set at 5% above xcrit
         toler=1.05*xcrit
         do 190 k=1,maxit
         thetas=xcrit/ustar(i,j)

         u02=46.107*zm*thetas/tsf

         cu2=amax1(0.0,ws*ws-4.*u02/cdn)
         ustar(i,j)=0.5*cdn*(ws+sqrt(cu2))
         if(ustar(i,j)*thetas.le.toler)go to 191
190      continue
191      continue
      endif
c
c --- replace arbitrary nighttime heat flux indicator (-0.1 W/m**2)
c --- with actual value
c --- constant 996 m**2/(s**2 deg K) = cp
c frr (09/01 2d array of rho
c      qh(i,j)=-996.*rho(nsta)*ustar(i,j)*thetas
      qh(i,j)=-996.*rho(i,j)*ustar(i,j)*thetas
c
c --- compute Monin-Obukhov length
c --- constant 253.8226 = cp/(vk*g) with cp=996 m**2/(s**2 deg.),
c --- vk=0.4, g=9.81 m/s**2
      el(i,j)=-253.8226*rho(i,j)*tsf*ustar(i,j)**3/qh(i,j)
c
200   continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine elustr2(ziconv,us,vs,ns,zzanem,is,js,
ccec101006     &     icc,iupt,icloud,itprog,ccgrid,zi,temp,rho,ipsifcn)
     &     icc,iupt,mcloud,itprog,ccgrid,zi,temp,rho,ipsifcn)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 101006            ELUSTR2
c ---          M. Fernau, Earth Tech after ELUSTR by J. Scire, SRC
c              Modified by f.Robe, Earth Tech
c
c --- PURPOSE:  Compute the friction velocity (m/s), Monin-Obukhov
c               length (m), and mixing height (m) for land cells using
c               the methods of Holtslag & van Ulden (1983) (daytime) or
c               Venkatram (1980) and Weil & Brower (1983) (nighttime)
c               so that similarity theory extrapolation can be done
c
c --- UPDATES:
c --- V6.3 (070717) to V6.330 (101006) CEC
c           - Change ICLOUD into MCLOUD (and ICLDOUT)
c --- V6.221 (070327)to V6.3 (070717)
c            - add new control variable IPSIFCN to select call to PSIU
c              functions
c            - Add IUPT to calling list (to pass to MIXHTST)
c
c --- V6.218 (070113) to v6.221 (070327)(F.Robe)
c            - Remove ldbhr from calling list to MIXHTST and MIXHST2
c              (was not defined)
c
c --- v6.217 (061231) to V6.218 (070113)(FRR)
c            - Remove iupt from calling list and from MIXHT calling list
c
c   - v5.612 (051214) to v6.217 (061231)(FRR)
c            - allow new icloud=4 option
c            - fix bug that ignore icloud=3 option (cloud fraction
c              therefore assumed to be zero in stable conditions
c              with icloud=3 
c --- V5.6 (040830) to V5.612 (051214) (DGS)
c            - Use double precision argument for PSIUD 
c --- V5.55 021105 to V5.6 040830 (F.Robe)
c            - Use actual anemometer height zanem for extrapolation
c            - Use already computed interpolated surface temperature
c              and density (do not recompute here)
c            - Use new PSIUD function 
c
c --- INPUTS:
c      ZICONV(mxnx,mxny) - real array - Convective mixing heights (m)
c                                       of previous hour
c          ZI(mxnx,mxny) - real array - Previous hour mixing height (m)
c         US(MXNZ,MXWND) - real array - U component of observed winds
c         VS(MXNZ,MXWND) - real array - V component of observed winds
c                     NS - integer    - Location of station in surface
c                                       array
c                 ZZANEM - real       - Anemometer height at surface station
c                  IS,JS - integer    - Coordinates of grid cell in 
c                                       which station is located
c              ICC(mxss) - integer array - Cloud cover (tenths)
c                   IUPT - integer    - Upper air station to use for
c                                       computing the domain-scale
c                                       lapse rate
c                 MCLOUD - integer    - Flag indicating if gridded
c                                       cloud data are available
c                                       (2,3,4=yes, otherwise, no)
c                 ITPROG - integer    - Temperature flag for use
c                                       of prognostic data and/or observations
c      CCGRID(mxnx,mxny) - real array - Gridded cloud fraction
c                                       (Used only if MCLOUD=2,3,4)
c                 NOOBS  - integer    - Flag for noobs mode
c                  TEMP  - real       - Surface temperature at station (or
c                                       at gridpoint where station is located
c                   RHO  - real       - Surface density at station (or
c                                       at gridpoint where station is located
c                                       at gridpoint where station is located
c               IPSIFCN - integer     - Flag controlling choice of PSI
c                                       stability correction for wind
c                                       profile
c                                      (IPSIFCN=0 use CALMET v5.6;
c                                       IPSIFCN=1 use CALMET v5.53)
c
c        Common block /HFLUX/ variables:
c           qf(mxnx,mxny),hcg(mxnx,mxny),
c           albedo(mxnx,mxny),bowen(mxnx,mxny),
c           ha1,ha2,hb1,hb2,hc1,hc2,hc3,hc3p1
c        Common block /ZIPARM/ variables:
c           zimax,zimin,constn,dzzi,dptmin,twodte,onedte,cmech          
c        Common block /GRID/ variables:
c           nears,nearu,zmid
c        Common block /UPMET/
c           justa, nlaa, nlbb, zlaa, tzaa, zlbb, tzbb
c        Parameters: MXNZ, MXWND, MXNX, MXNY, MXSS
c
c --- OUTPUT:
c         US(MXNZ,MXWND) - real array - U component of observed winds
c         VS(MXNZ,MXWND) - real array - V component of observed winds
c                                       (extrapolated aloft)
c
c ---  ELUSTR2 called by:  STHEOR
c ---  ELUSTR2 calls:      SIMILT, PSIUD, PSIUC
c----------------------------------------------------------------------
c
      include 'params.met'
      include 'hflux.met'
      include 'ziparm.met'
      include 'grid.met'
      include 'upmet.met'
      include 'geo.met'

      common /salp/ ihr2gmt,sinalp2(mxnx,mxny)
      common /tjump/ dptt(mxnx,mxny)
      real us(mxnz,mxwnd),vs(mxnz,mxwnd),
     &     ziconv(mxnx,mxny),zi(mxnx,mxny)
      real ccgrid(mxnx,mxny)
      integer icc(mxss)
      real*8 psiud,r8
c
c --- NOTE:  a value of vk = 0.4 has been assumed in some of the
c --- other constants
      data   vk/0.4/, xcrit/0.05/, xmissm/990./  
      data wsmin/0.001/
c

c --- If surface wind components missing, don't bother to extrapolate
      if (us(1,ns) .gt. xmissm .or. vs(1,ns) .gt. xmissm) return
c                                     
      ws = sqrt(us(1,ns) **2 + vs(1,ns) **2)
c --- Do not extrapolate calm winds
      if (ws .lt. wsmin) return
      xlnzz0 = alog(zmid(1) / z0(is,js))
c
c
c --- Calculate heat flux at the station:
c --- Compute short-wave radiation (W/m**2)
c
c --- Determine cloud cover (tenths) for this grid cell
ccec101006      if(icloud.gt.1)then
      if(mcloud.gt.1)then
c ---    Use gridded fractional cloud data
         ccfrac=ccgrid(is,js)
      else
c ---    Use NWS cloud data (in tenths) - convert to fraction
         ccfrac = 0.1 * icc(ns)
      endif
c

c frr (09/01) 2d-sinalp
c      qsw = (ha1 * sinalp2(ns) + ha2) * (1. + hb1 * ccfrac ** hb2)
      qsw = (ha1 * sinalp2(is,js) + ha2) * (1. + hb1 * ccfrac ** hb2)
      qsw = amax1(qsw,0.0)
c
c --- Flag nighttime periods with negative sensible heat flux
c frr (09/01) 2D sinalp
c      if (sinalp2(ns) .le. 0.0) then
      if (sinalp2(is,js) .le. 0.0) then
        qqh = -0.1
      else
c
c ---   Compute net radiation (W/m**2), QSTAR using the method of
c ---   Holtslag and van Ulden (1983)
c ---   constant 5.67e-8 W/m**2/deg. K**4 is the Stefan-Boltzmann constant

         qstar = ((1. - albedo(is,js)) * qsw + hc1 * temp**6
     &     - 5.67e-8 * temp** 4 + hc2 * ccfrac) / hc3p1
c
c ---    Compute sensible heat flux (w/m**2), QH
c ---    qf is the anthropogenic heat flux (W/m**2)
         qqh = bowen(is,js) * (qstar * (1. - hcg(is,js))
     &       + qf(is,js)) / (1. + bowen(is,js))
c
      end if

c 
c
c --- Daytime method -- use Holtslag and van Ulden (1983)
      if(qqh .lt. 0.0) goto 100
c
c --- First guess -- assume neutral conditions
      xl = -9.9e9
      xustar = vk * ws / xlnzz0
c --- Prevent numerical problems - assume reasonable lower bound
      xustar = amax1(xustar,0.05)
c --- Actual conditions are neutral if heat flux is zero
      if (qqh .eq. 0.0) goto 181
c
c --- Iterate to refine estimate of u* and L
      maxit = 5
      xlold = xl
      do 180 niter = 1,maxit
c
c --- New estimate of L
c --- Constant 253.8226 = cp/(vk*g) with cp=996 m**2/(s**2 deg.),
c --- vk=0.4, g=9.81 m/s**2
      xl = -253.8226 * rho * temp * xustar ** 3 / qqh
c
c --- New estimate of ustar
c
c --- Stability correction factors (psim(z/L), psim(z0/L)) -- unstable
c --- Conditions
c --- 050328 (frr) use consistent PSI function (same as COARE)
c --- 050328: Winds (ws) in this subroutine are at zanem (not zmid)
      if(ipsifcn.EQ.0) then
         r8=zzanem/xl
         psizl  = PSIUD(r8)
         r8=z0(is,js)/xl
         psiz0l = PSIUD(r8)
      elseif(ipsifcn.EQ.1) then
c ---    Use explicit code from old subroutine
         psizl  = PSIUC(zzanem,xl,15)
         psiz0l = PSIUC(z0(is,js),xl,15)
      else
         write(io6,*)'ERROR in ELUSTR:  invalid IPSIFCN'
         write(io6,*)'  Expected IPSIFCN = 0 or 1'
         write(io6,*)'     Found IPSIFCN = ',ipsifcn
         stop 'ERROR in ELUSTR -- see list file'
      endif

      xustar = vk * ws / (xlnzz0 - psizl + psiz0l)
c --- Prevent numerical problems - assume reasonable lower bound
      xustar = amax1(xustar,0.05)
c
c --- Check for convergence (5% criterion)
      if (abs((xl - xlold) / xl) .lt. 0.005) go to 181
      xlold = xl
180   continue
181   continue
c
c --- Assign final values
      ustar = xustar
      el = xl

      go to 200
c
c --- stable conditions -- use Venkatram(1980), Weil & Brower(1983)
100   continue
c
c --- Determine cloud cover (tenths) for this grid cell
c     if(icloud.eq.2)then
c     (061230: bug fix (should already have had icloud=3); add option icloud=4 (061231)
ccec101006      if(icloud.gt.1)then
      if(mcloud.gt.1)then
c ---    Use gridded cloud data - convert from fraction to tenths
         jcc=10.*ccgrid(is,js)+0.5
      else
c ---    Use NWS cloud data (in tenths)
         jcc=icc(ns)
      endif
c
c --- Constant 5.e-3 is 0.5 * (0.1)**2 -- factor of 0.1 converts
c --- Cloud cover from tenths to a fraction
      theta1 = 0.09 * (1. -5.e-3 * jcc ** 2)
c
c --- Constant 184.428 = 4*gamma*g with gamma=4.7, g=9.81 m/s**2
      cdn = vk / xlnzz0
      theta2 = temp * cdn * ws ** 2 / (184.428 * zmid(1))
      thetas = amin1(theta1,theta2)
c --- Prevent numerical problems
      thetas = amax1(thetas,1.e-9)
c
c --- Compute ustar
c --- Constant 46.107 = gamma*g, with gamma=4.7, g=9.81 m/s**2
      u02 = 46.107 * zmid(1) * thetas / temp
      cu2 = amax1(0.0,ws * ws - 4. * u02 / cdn)
      ustar = 0.5 * cdn *(ws + sqrt(cu2))
c --- Prevent numerical problems - assume a reasonable lower bound
      ustar = amax1(ustar,0.05)
c
c --- Product of (u*)(theta*) is not allowed to exceed XCRIT (=0.05)
      if (ustar * thetas .gt. xcrit) then
         maxit = 3
c ---    Tolerance set at 5% above xcrit
         toler = 1.05 * xcrit
         do 190 k = 1,maxit
         thetas = xcrit / ustar
         u02 = 46.107 * zmid(1) * thetas / temp
         cu2 = amax1(0.0,ws * ws - 4. * u02 / cdn)
         ustar = 0.5 * cdn * (ws + sqrt(cu2))
         if (ustar * thetas .le. toler) go to 191
190      continue
191      continue
      endif
c
c --- Replace arbitrary nighttime heat flux indicator (-0.1 W/m**2)
c --- With actual value
c --- Constant 996 m**2/(s**2 deg K) = cp
      qqh = -996. * rho * ustar * thetas
c
c --- Compute Monin-Obukhov length
c --- Constant 253.8226 = cp/(vk*g) with cp=996 m**2/(s**2 deg.),
c --- vk=0.4, g=9.81 m/s**2
      el = -253.8226 * rho * temp * ustar ** 3 / qqh
c



200   continue

c   Calculate mixing heights

c frr 021105 previous timestep mixing heights:
      zii=zi(is,js)
      ziconvi=ziconv(is,js)

c frr 021105
      if (itprog.eq.0)then
         call mixhtST(el,ustar,qqh,rho,ihr2gmt,is,js,nearu(is,js),
     :         iupt,ilandu(is,js),iwat1,iwat2,imixh,zii,ziconvi)
      else
         call mixht2ST(el,ustar,qqh,rho,ihr2gmt,is,js,
     :                 ilandu(is,js),iwat1,iwat2,imixh,zii,
     :                 ziconvi)
      endif
c

c
c --- Call extrapolation routine
c --- 050328 - Frr- Use Actual anemometer height not arbitrary one
c     zzanem = 10.
      call similt(zzanem,el,z0(is,js),zii,ns,ipsifcn,us,vs,zimin)
      return
      end 
c----------------------------------------------------------------------
      function esat(tdegc)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130               ESAT
c ---          J. Scire, SRC
c
c --- PURPOSE:  Compute the saturation water vapor pressure (mb) using
c               the method of Lowe (1977) (JAM, 16, pp 100-103).
c
c --- INPUT:
c                TDEGC - real          - Air temperature (deg. C)
c
c --- OUTPUT:
c                 ESAT - real          - Saturation water vapor
c                                        pressure (mb)
c
c --- ESAT called by: WATER
c --- ESAT calls:     none
c----------------------------------------------------------------------
      data a0/6.107799961/,a1/4.436518521e-1/,a2/1.428945805e-2/
      data a3/2.650648471e-4/,a4/3.031240396e-6/,a5/2.034080948e-8/
      data a6/6.136820929e-11/
c
c --- compute saturation water vapor pressure (mb)
c --- NOTE: temperature is in deg. C
      esat=a0+tdegc*(a1+tdegc*(a2+tdegc*(a3+tdegc*(a4+tdegc*
     1 (a5+tdegc*a6)))))
c
      return
      end
c----------------------------------------------------------------------
      subroutine facet(iu,tt,zz,nlev,nzp1,zface,tface)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 920831              FACET
c ---          R. Yamartino, SRC
c ---          Modified by J. Scire to allow missing data
c
c --- PURPOSE:  Calculate the vertical grid face temperatures
c               using sounding data only.
c
c --- INPUTS:
c                   IU - integer    - Upper air station number
c                                     (1, 2, ..., nusta)
c       TT(mxus,mxlev) - real array - Temperatures (deg K)
c       ZZ(mxus,mxlev) - real array - Height (m) of TT (above LGL)
c           NLEV(mxus) - int. array - Number of sounding levels
c                 NZP1 - integer    - Number of vertical grid faces
c        ZFACE(mxnzp1) - real array - Height (m) of cell face
c
c        Parameters: MXUS, MXLEV, MXNZP1
c
c --- OUTPUT:
c        TFACE(mxnzp1) - real array - Layer averaged Temperatures
c                                     (deg K)
c
c --- FACET called by:  COMP
c --- FACET calls:      INTP
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real tt(mxus,mxlev),zz(mxus,mxlev)
      integer nlev(mxus)
      real zface(mxnzp1)
      real tface(mxnzp1)
c
      data xmiss/999.9/
c
c --- Reduce missing value indicator by a slight amount to allow for
c --- machine roundoff
      xmissm=xmiss-0.01
c
c --- Interpolate temperatures to cell face heights (zface) for all
c --- nzp1 values
      do 15 k=1,nzp1
      znow = zface(k)
      call intp(tt,zz,nlev(iu),iu,znow,xmissm,ttzz)
      tface(k) = ttzz
15    continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine fillgeo(iogeo,iopt,ilucat,nlu,varlu,ilandu,nx,ny,var)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130            FILLGEO
c ---          J. Scire, SRC
c
c --- PURPOSE:  Fill geophysical parameter arrays with data computed
c               from land use category or read gridded values from
c               the control file
c               Parameters include: surface roughness (z0),
c               albedo (ALBEDO), Bowen ratio (BOWEN), soil heat flux
c               parameter (HCG), anthropogenic heat flux (QF),
c               leaf area index (XLAI)
c
c --- INPUTS:
c               IOGEO - integer      - Fortran unit number of
c                                      geophysical data file (GEO.DAT)
c                IOPT - integer       - Option flag:
c                                         0=compute parameter from land
c                                           use using default table
c                                         1=read new values for each
c                                           land use catgeory
c                                         2=read gridded field of values
c         ILUCAT(NLU) - integer array - Array of allowable values of
c                                       land use
c                 NLU - integer       - Number of land use categories
c          VARLU(NLU) - real array    - Value of geophysical parameter
c                                       for each land use category
c   ILANDU(mxnx,mxny) - integer array - Land use category at each
c                                       grid point
c                  NX - integer       - Number of grid cells in X
c                                       direction
c                  NY - integer       - Number of grid cells in Y
c                                       direction
c        Parameters: MXNX, MXNY
c
c --- OUTPUT:
c      VAR(mxnx,mxny) - real array    - Gridded geophysical parameter
c                                       computed from land use data or
c                                       read from control file
c
c ---  FILLGEO called by:  READGE
c ---  FILLGEO calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real varlu(nlu),var(mxnx,mxny)
      integer ilucat(nlu),ilandu(mxnx,mxny)
c
      if(iopt.eq.0)then
c
c ---    compute parameter value from land use data -- use default
c ---    values
         do 110 i=1,nx
         do 110 j=1,ny
         ilu=ilandu(i,j)
c
         do 105 k=1,nlu
         if(ilu.eq.ilucat(k))then
            var(i,j)=varlu(k)
            go to 107
         endif
105      continue
c
c ---    land use category not found in table
         write(io6,106)i,j,ilu,nlu,(ilucat(n),n=1,nlu)
106      format(//2x,'ERROR IN SUBR. FILLGEO -- Land use category ',
     1   'not found in table'/2x,'I = ',i5,2x,'J = ',i5,2x,'ILU = ',
     2   i5,2x,'NLU = ',i5/2x,'Values in table (ILUCAT) = ',20i5/
     3   10(28x,20i5/))
         stop
107      continue
110      continue
      else if(iopt.eq.1)then
c
c ---    read new table relating geophysical parameter to land use
         do 120 i=1,nlu
         read(iogeo,*)ilu,varlu(i)
c
         if(ilu.ne.ilucat(i))then
            write(io6,118)i,ilu,nlu,ilucat(i)
118         format(//2x,'ERROR IN SUBR. FILLGEO -- land use catgeory ',
     1      'does not match expected value'/2x,'i = ',i5,'ILU = ',i5,
     2      2x,'NLU = ',i5,2x,'ILUCAT(i) = ',i5)
            stop
         endif
120      continue
c
c ---    compute geophysical parameter from USER-INPUT table
         do 130 i=1,nx
         do 130 j=1,ny
         ilu=ilandu(i,j)
c
         do 125 k=1,nlu
         if(ilu.eq.ilucat(k))then
            var(i,j)=varlu(k)
            go to 127
         endif
125      continue
         write(io6,106)i,j,ilu,nlu,(ilucat(n),n=1,nlu)
         stop
127      continue
130      continue
      else if(iopt.eq.2)then
c
c ---    read gridded field of geophysical parameters
         do 150 j=ny,1,-1
         read(iogeo,*)(var(n,j),n=1,nx)
150      continue
      else
c
c ---    invalid value of flag -- IOPT must be 0, 1, or 2
         write(io6,165)iopt
165      format(//2x,'ERROR IN SUBR. FILLGEO -- Invalid value of ',
     1   'IOPT -- IOPT = ',i5)
         stop
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine fin(itest)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 090511                FIN
c ---          J. Scire
c
c --- PURPOSE:  Run termination routine -- compute runtime,
c               write last day processed
c
c --- UPDATES:
c --- V6.208 (060329) to V6.327 (090511) (DGS)
c               - Reformat date reported at end of run
c
c --- V6.2 (060215) to V6.208 (060329) (DGS)
c               - Revise text for last period time
c
c --- V5.5 (030402) to V6.2 (060215) (F.Robe)
c               - Change date format to beg/ending times
c
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c               - Add list-file unit to JULDAY, GRDAY, INDECR calls
c               - rdate, rdate2 changed to include YYYY format for 
c                 year (MM-DD-YYYY)
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c          ITEST - integer - Flag indicating if execution is to
c                            include COMPUTATIONAL phase
c                            (ITEST = 1 to STOP program after
c                                       SETUP phase,
c                             ITEST = 2 to CONTINUE execution to
c                                       include computations)
c
c       Common block /GEN/
c          nyr, nmo, nday, njul, nhr
c       Common block /QA/
c          rdate, rtime
c       Common block /FLAGS/
c          lmesg, iomesg
c       Parameters: IO6
c
c --- OUTPUT:  none
c
c --- FIN called by:  MAIN
c --- FIN calls:      DATETM, GRDAY, JULDAY, DELTT, INDECR, YR4C,
c                     FMT_DATE
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      character*8 rtime2
      character*10 rdate2
      character*12 rdate12
c
      include 'gen.met'
      include 'qa.met'
      include 'flags.met'
c
      if(lmesg)write(iomesg,*)'ENTERING TERMINATION PHASE'
c
      if(itest.eq.2)then
c ---    write last day/hour processed

         if(nsecb.lt.0)then
            nsecb=3600+nsecb
            nhrb=nhrb-1
            if(nhrb.EQ.-1)then
               nhrb=0
               call indecr(io6,nyrb,njulb,nhrb,-1,0,23)
               call grday(io6,nyrb,njulb,nmob,ndayb)
            endif
         endif

c DGS    Switch from (HH-1) 3600 to HH 000 for end of run
         nsece0=nsece
c ---    Reset ending hour if nsece=3600 (as hour is incremented 
c ---    before the check is done for the last step )
         if (nsece.eq.3600.)then
            nsece0=0
c DGS       call indecr(io6,nyre,njule,nhre,-1,0,23)
c DGS       call grday(io6,nyre,njule,nmoe,ndaye)
         endif

         write(io6,5)nyre,nmoe,ndaye,njule,nhre,nsece0
5        format(//2x,'LAST PERIOD PROCESSED ENDS AT:'/5x,
     1          '  Year: ',i4,2x,'Month: ',i2,3x,'Day: ',i2,3x,
     2          'Julian day: ',i3,3x,'Hour: ',i2,3x,'Second: ',i4)
      else
c
c ---    TEST mode -- COMPUTATIONAL phase skipped
         write(io6,12)
12       format(/1x,13('----------')//1x,
     1   'Completion of CALMET test mode run -- run terminating ',
     2   'normally'//1x,13('----------'))
      endif

c
c --- get system date & time at end of run
      call datetm(rdate2,rtime2,rcpu)
c
c --- compute runtime
      read(rtime(1:2),10)ihr1
      read(rtime(4:5),10)imin1
      read(rtime(7:8),10)isec1
10    format(i2)
      t1=ihr1*3600.+imin1*60.+isec1

      read(rtime2(1:2),10)ihr2
      read(rtime2(4:5),10)imin2
      read(rtime2(7:8),10)isec2
      t2=ihr2*3600.+imin2*60.+isec2

      if(rdate.eq.rdate2)then
         delt=t2-t1
      else
         read(rdate(1:2),10)imo1
         read(rdate(4:5),10)iday1
         read(rdate(7:10),'(i4)')iyr1
         call julday(io6,iyr1,imo1,iday1,ijul1)

         read(rdate2(1:2),10)imo2
         read(rdate2(4:5),10)iday2
         read(rdate2(7:10),'(i4)')iyr2
         call julday(io6,iyr2,imo2,iday2,ijul2)

c ---    compute no. hours from beg. of first hour of run to
c ---    ending hour of ending day of the run
         call deltt(iyr1,ijul1,ihr1,iyr2,ijul2,ihr2,idelhr)

c ---    adjust for minutes and seconds
         delt=idelhr*3600.-imin1*60.-isec1+imin2*60.+isec2
      endif

c --- On the PC, the runtime and CPU time are the same
c --- (DATETM provides RCPU = 0.0 on the PC)
      if(rcpu.eq.0.0)rcpu=delt

c --- Report current date
      rdate12=rdate2(1:10)//'  '
      call FMT_DATE(io6,'MM-DD-YYYY','DD-MMM-YYYY',rdate12)
      write(io6,1402)rtime2,rdate12,delt,rcpu
1402  format(//2x,'End of run -- Clock time: ',a8/
     1         2x,'                    Date: ',a12//
     2         2x,'      Elapsed clock time: ',f10.1,' (seconds)'//
     3         2x,'                CPU time: ',f10.1,' (seconds)')

      return
      end
c----------------------------------------------------------------------
      subroutine fminf(f,nf,fmin,nmin)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130              FMINF
C
      DIMENSION F(NF)
C
C     FMINF LOCATES THE MINIMUM VALUE AMONG NF CONSECUTIVE
C     MEMBERS OF THE F ARRAY AND RETURNS BOTH THE VALUE FMIN
C     AND ITS ARRAY INDEX NMIN
C
C     INPUTS:  F (R ARRAY) - DISTANCES FROM STATION TO GRID POINT
C              NF (I)      - NUMBER OF STATIONS
C
C     OUTPUTS:  FMIN (R ARRAY) - MINIMUM STATION DISTANCE
C               NMIN (I)       -INDEX OF CLOSEST STATION
C
C
      N = 1
      A = F(N)
      IF(NF.LT.2) GO TO 120
      DO 100 N=2,NF
      A = AMIN1(F(N),A)
  100 CONTINUE
      DO 110 N=1,NF
      IF(A-F(N)) 110,120,120
  110 CONTINUE
      N = NF
  120 NMIN = N
      FMIN = A
      RETURN
      END
c----------------------------------------------------------------------
      subroutine fradj(u,v,htopo,gamma,isurft,tinf,temp2d,critfn,
     1                 cellzb,hmax)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070717              FRADJ
c              S.DOUGLAS, SAI
c              Modified by J. Scire, F.Robe
c
c --- PURPOSE: THIS SUBROUTINE IS ADAPTED FROM THE MELSAR MODEL.
C     THE LOCAL FROUDE NUMBER FOR EACH GRID POINT IS CALCULATED
C     IF THIS EXCEEDS A CRITICAL VALUE AND IF THE WIND IS BLOWING
C     TOWARD THE OBSTACLE, THE U AND V WIND COMPONENTS ARE
C     ADJUSTED.
c
c
c --- UPDATES:
c --- V6.218 (070113) to V6.3 (070717)(F. Robe)
c     (1) Use average surface temperature for ISURFT=-2
c
c --- V5.6 (970825) to V6.218 (070113) (F. Robe)
c     (1) Reformat header
c     (2) Add option to use spatially varying temp2D instead of domain 
c         repreentative Tinf  
c     (3) Make former scalar gamma a 2D array           
C
C ---  INPUTS:
c             U (R ARRAY)     - GRIDDED X-DIRECTION WIND COMPONENTS
C             V (R ARRAY)     - GRIDDED Y-DIRECTION WIND COMPONENTS
C             HTOPO (R ARRAY) - GRIDDED TERRAIN HEIGHTS
C             GAMMA (R ARRAY) - TEMPERATURE LAPSE RATES
c             ISURFT (I)      - Surface station number where domain 
c                               representative temperature is used from
c                               or trigger for using 2-D surface temp
c                               (ISURFT=-1; default)
C             TINF (R)        - DOMAIN REPRESENTATIVE TEMPERATURE
C             CRITFN (R)      - CRITICAL FROUDE NUMBER
C             HMAX (R ARRAY)  - MAXIMUM TERRAIN HEIGHTS WITHIN A
C                               GIVEN RADIUS
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C --- OUTPUTS:
c              U (R ARRAY) - ADJUSTED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY) - ADJUSTED Y-DIRECTION WIND COMPONENTS
C
c --- FRADJ called by:  DIAGNO
c --- FRADJ calls:      none
c -------------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'grid.met'
      include 'd6.met'
c
      DIMENSION U(mxnx,mxny,*), V(mxnx,mxny,*),
     1          HTOPO(mxnx,*), HMAX(mxnx,*), CELLZB(mxnzp1),
     2          temp2D(mxnx,mxny), gamma (mxnx,mxny)
C

C     COMPUTE THE STABILITY PARAMETER
C
      TAU=-0.01
C
C     MELSAR FROUDE NUMBER ADJUSTMENT
C
      RPD=0.017453
      DPR=57.296
      DO 100 J=1,NY
      DO 100 I=1,NX
C
      GAMMA2=GAMMA(i,j) - TAU

C     CALCULATE THE TOPOGRAPHIC GRADIENTS
C
      DXI=0.5/DX
      DYI=0.5/DY
      HTOIM1=HTOPO(I,J)
      HTOJM1=HTOPO(I,J)
      IF (I .GT. 1) HTOIM1=HTOPO(I-1,J)
      IF (J .GT. 1) HTOJM1=HTOPO(I,J-1)
      HTOIP1=HTOPO(I,J)
      HTOJP1=HTOPO(I,J)
      IF (I .LT. NX) HTOIP1=HTOPO(I+1,J)
      IF (J .LT. NY) HTOJP1=HTOPO(I,J+1)
      DELHI=(HTOIP1-HTOIM1)*DXI
      DELHJ=(HTOJP1-HTOJM1)*DYI
      IF (ABS(DELHI) .LT. 0.00015 .AND. ABS(DELHJ) .LT. 0.00015) THEN
        DELHI = 0.
        DELHJ = 0.
      ENDIF
C
c --- Use spatially varying temperature unless specifically requested
c ---    070717  
c        if (isurft.gt.0) then
c             temp=tinf
c         else
c            temp=temp2d(i,j)
c         endif
         if (isurft.eq.-1) then
            temp=temp2d(i,j)
         else
             temp=tinf
         endif

      DO 100 K=1,NZ
C
C     CALCULATE THE LOCAL FROUDE NUMBER
C
      SPEED=(U(I,J,K)**2+V(I,J,K)**2)**0.5
      if(speed.le.0.)go to 100
      OBSHGT=HMAX(I,J)-(HTOPO(I,J)+CELLZB(K)+DZ(K)/2.)
      IF (OBSHGT .LE. 0.) GO TO 100
      IF (GAMMA2 .LE. 0.) GO TO 100
      FROUDE=SPEED/(((9.8*GAMMA2/temp)**0.5)*OBSHGT)
      IF (FROUDE .GT. CRITFN) GO TO 100
C
C     SET UP DRAINAGE VECTOR DIRECTIONS
C
      IF (DELHI .EQ. 0.) THEN
        IF (DELHJ .EQ. 0.) GO TO 100
        IF (DELHJ .LT .0.) THET=270.
        IF (DELHJ .GT. 0.) THET=90.
      ELSE
        THETP=ATAN(DELHJ/DELHI)*DPR
      ENDIF
      IF (DELHI .LT. 0.) THET=THETP+180.
      IF (DELHI .GT. 0.) THEN
        IF (DELHJ .GT. 0.) THEN
          THET=THETP
        ELSE
          THET=THETP+360.
        ENDIF
      ENDIF
      IF (THET .GE. 0. .AND. THET .LE. 90) THETD=90.-THET
      IF (THET .GT. 90. .AND. THET .LE. 360) THETD=450.-THET
C
C     RESOLVE DRAINAGE VECTOR INTO COMPONENTS
C
      ANG=(270.-THETD)*RPD
      DRX=-COS(ANG)
      DRY=-SIN(ANG)
C
C     ADJUST WINDS
C     FIRST NORMALIZE WIND VECTOR
C
      UN=U(I,J,K)/SPEED
      VN=V(I,J,K)/SPEED
C
C     DETERMINE IF WIND IS BLOWING TOWARD OBSTACLE (AA>0)
C
      AA=DRX*UN+DRY*VN
      IF (AA .LE. 0) GO TO 100
C
C     DETERMINE TANGENT WIND VECTOR
C
      TT=-DRY*UN+DRX*VN
      IF (TT .GT. 0.) THEN
        TAX=-DRY
        TAY=DRX
      ELSE
        TAX=DRY
        TAY=-DRX
      ENDIF
      U(I,J,K)=TAX*SPEED
      V(I,J,K)=TAY*SPEED
  100 CONTINUE
C
      RETURN
      END
c----------------------------------------------------------------------
      subroutine gride(npsta,xprecp,xpsta,ypsta,nearp,dgrid,nx,ny,rmm,
     1                 nflag,usersig,usercut)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 941215              GRIDE
c ---          Xiaoming (John) Zhang, SRC
c              Joseph Scire, SRC
c
c --- PURPOSE:  Assign precipitation rates (mm/hr) to each grid point
c               using objective mapping technique
c               ***  ALL CELLS -- LAND & WATER ***
c
c --- INPUTS:
c                NPSTA - integer       - Number of precipitation
c                                        stations
c         XPRECP(mxps) - real array    - Precipitation rate (mm/hr) at
c                                        each station (9999. used to
c                                        indicate a missing value)      
c          XPSTA(mxps) - real array    - Relative X-coordinates (m) of
c                                        precipitation stations
c          YPSTA(mxps) - real array    - Relative Y-coordinates (m) of
c                                        precipitation stations
c     NEARP(mxnx,mxny) - integer array - Station number of precip.
c                                        station closest to each grid pt
c                DGRID - real          - Horizontal grid size (m)
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c                NFLAG - integer       - =1, for 1/R     interpolation
c                                        =2, for 1/R**2  interpolation
c                                        =3, for exp(-R**2/sigma**2)/R**2
c                                            interpolation
c                                        where R = radius
c              USERSIG - real          - User specified radius of
c                                        influence or weighting (sigma)
c                                        factor (km)
c                                          If NFLAG=1,2 -- radius of
c                                             influence (km)
c                                          If NFLAG=3 -- sigma weighting
c                                             factor (km) -- if 0.0,
c                                             USERSIG will be computed
c                                             internally as 1/2 dist.
c                                             between nearest stations
c                                             w/ and w/o precipitation
c              USERCUT - real          - User specified cutoff value
c                                        for computed precipitation rate
c                                        (mm/hr) --  (values < USERCUT
c                                        are set equal to 0.0 mm/hr)
c        Common block /gen/
c           nyr, nmo, nday, nhr, njul
c        Parameters: mxnx, mxny, mxps, io6
c
c --- OUTPUT:
c       RMM(mxnx,mxny) - real array    - Precipitation rate (mm/hr) at
c                                        each grid point
c
c --- GRIDE called by:  COMP
c --- GRIDE calls:      CMPD2
c----------------------------------------------------------------------
c --- include parameters
      include 'params.met'
c
      real xprecp(mxps),xpsta(mxps),ypsta(mxps)
      real x(mxps),y(mxps),p(mxps),dis2(mxps)
      real rmm(mxnx,mxny)
      integer nearp(mxnx,mxny)
c
      include 'gen.met'
c
      data dismin/0.01/,xmax/1.e37/
c
c --- Compute the number of precip stations with good values and their
c     locations
c
      np=0
      do 300 i=1,npsta
      if(XPRECP(i).lt.9998.) then
         np=np+1
         x(np)=xpsta(i)
         y(np)=ypsta(i)
         p(np)=xprecp(i)
      endif
300   continue
c
c ---    If all precip. data is missing for this hour, assume
c ---    precip. rate = 0.0, and write warning message
         if(np.eq.0)then
            do 55 ii=1,nx
            do 55 jj=1,ny
            rmm(ii,jj)=0.0
55          continue
            write(io6,15)nyr,nmo,nday,nhr,njul
15          format(//1x,'WARNING -- All precip. data missing on ',
     1      'YEAR, MONTH, DAY, HOUR = ',4i4,3x,'Julian day = ',i3/
     2      1x,'Precip. rate assumed to be zero for this hour')
            goto 999
         endif
c
c ---    If user-defined radius not used, then find radius of influence
c ---    which is defined as half of the minimum distance between any
c ---    nonzero precip. stations and any zero precip. stations.
c
         if (nflag.eq.3.and.usersig .eq. 0.0) then
           sigma2=xmax
           do 60 k1=1,np
           do 70 k2=1,np
              test1=p(k1)*p(k2)
              test2=p(k1)+p(k2)
              if((test1.eq.0.0).and.(test2.gt.0.0)) then
                 d2=(x(k1)-x(k2))**2+(y(k1)-y(k2))**2
                 if(d2.lt.sigma2) sigma2=d2
              endif
70         continue
60         continue
           sigma = sqrt(sigma2)
           sigma = 0.5 * sigma
         else
c
c ---      SIGMA is in meters (USERSIG is in km)
           sigma = 1000.*usersig
           sigma2= sigma*sigma
         end if
c
c ---    Compute precipitation rate at each grid point
         if(nflag.eq.1)then
c
c ---      1/R INTERPOLATION METHOD
           do 110 i=1,nx
              xgm=(float(i)-0.5)*dgrid
              do 105 j=1,ny
                ygm=(float(j)-0.5)*dgrid
c
                top=0.0
                bot=0.0
c
c ---           Compute distance**2 of each precip. station with
c               VALID (non-missing) data to grid point
                call cmpd2(xgm,ygm,x,y,np,dis2)
c
c ---           Compute weighting functions for 1/R method
                do 103 k=1,np
                if(dis2(k).le.sigma2)then
c
c ---              Station is within radius of influence
                   dis=sqrt(dis2(k))
c ---              Minimum value of distance to avoid numerical problems
                   dis=amax1(dis,dismin)
c
                   top=top+p(k)/dis
                   bot=bot+1.0/dis
                endif
103             continue
c
c ---           If there are NO stations within region of influence,
c               use value at nearest station with valid data
                if(bot.eq.0.0)then
c
c ---              NOTE: NEARP array contains index of XPRECP, not P
                   ista=nearp(i,j)
                   if(xprecp(ista).lt.9998.)then
                      rmm(i,j)=xprecp(ista)
                      go to 105
                   else
c
c ---                 Precip. at nearest station is missing -- find
c                     nearest station with VALID data
c                     (note: all stations in P array have valid data)
                      dmin2=xmax
                      do 101 k=1,np
                      if(dis2(k).lt.dmin2)then
                         dmin2=dis2(k)
                         ksta=k
                      endif
101                  continue
                     rmm(i,j)=p(ksta)
                     go to 105
                  endif
                else
c
c ---             Compute precipitation rate with 1/R method
                  rmm(i,j)=top/bot
                  if(rmm(i,j).lt.usercut)rmm(i,j)=0.0
                endif
105         continue
110         continue
       else if(nflag.eq.2)then
c
c ---     1/R**2 INTERPOLATION METHOD
          do 210 i=1,nx
             xgm=(float(i)-0.5)*dgrid
             do 205 j=1,ny
                ygm=(float(j)-0.5)*dgrid
c
                top=0.0
                bot=0.0
c
c ---           Compute distance**2 of each precip. station with
c               VALID (non-missing) data to grid point
                call cmpd2(xgm,ygm,x,y,np,dis2)
c
c ---           Compute weighting functions for 1/R**2 method
                do 203 k=1,np
                if(dis2(k).le.sigma2)then
c
c ---              Station is within radius of influence
c ---              Minimum value of dist**2 to avoid numerical problems
                   dis2saf=amax1(dis2(k),dismin)
c
                   top=top+p(k)/dis2saf
                   bot=bot+1.0/dis2saf
                endif
203             continue
c
c ---           If there are NO stations within region of influence,
c               use value at nearest station with valid data
                if(bot.eq.0.0)then
c
c ---              NOTE: NEARP array contains index of XPRECP, not P
                   ista=nearp(i,j)
                   if(xprecp(ista).lt.9998.)then
                      rmm(i,j)=xprecp(ista)
                      go to 205
                   else
c
c ---                 Precip. at nearest station is missing -- find
c                     nearest station with VALID data
c                     (note: all stations in P array have valid data)
                      dmin2=xmax
                      do 201 k=1,np
                      if(dis2(k).lt.dmin2)then
                         dmin2=dis2(k)
                         ksta=k
                      endif
201                   continue
                      rmm(i,j)=p(ksta)
                      go to 205
                   endif
                else
c
c ---              Compute precipitation rate with 1/R**2 method
                   rmm(i,j)=top/bot
                   if(rmm(i,j).lt.usercut)rmm(i,j)=0.0
                endif
205         continue
210       continue
       else if(nflag.eq.3)then
c
c ---     Exponential interpolation method
          do 310 i=1,nx
          xgm=(float(i)-0.5)*dgrid
          do 305 j=1,ny
            ygm=(float(j)-0.5)*dgrid
            bot=0.0
            top=0.0
c
c ---       Compute distance**2 of each precip. station with
c           VALID (non-missing) data to grid point
            call cmpd2(xgm,ygm,x,y,np,dis2)
c
            do 301 k=1,np
               expo=dis2(k)/sigma2
               if(expo.gt.60.0) then
                  bbb=0.0
               else 
                  bbb=exp(-expo)
               endif
c ---          Minimum value of dist**2 to avoid numerical problems
               dis2saf=amax1(dis2(k),dismin)
               bot=bot+bbb/dis2saf
               top=top+p(k)*bbb/dis2saf
301         continue
c
            if(top.lt.1.0e-30) then
               rmm(i,j)=0.0
            else
               rmm(i,j)=top/bot
               if(rmm(i,j).lt.usercut) rmm(i,j)=0.0
            endif
305         continue
310         continue
       else
          write(io6,*)'ERROR in Subr. GRIDE -- Invalid value ',
     1    'of NFLAG -- NFLAG = ',nflag
          stop
      endif
c
999   continue
      return
      end
c----------------------------------------------------------------------
      subroutine INTERPQR(qrprog,rmm)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0      Level: 050328          INTERPQR
c ---          F.Robe Earth Tech
c              after subroutine GRIDE
c
c --- PURPOSE:  Assign precipitation rates (mm/hr) to each grid point
c               using objective mapping technique of MM5 rainfall rates
c               Use the 4 closest MM5 gridpoints
c               ***  ALL CELLS -- LAND & WATER ***
c
c --- UPDATES:
c
c  - V5.546 (040924) to V5.55 (050328) frr
c         - no need to declare x(mxnx,xmny) and y(mxnx,mxny) any longer
c  - 030830 to V5.546 (040924) frr
c         - Locations of MM5 gridpoints relative to CALMET grid origin
c           are computed in RDHD5 & stored as X04,Y04 in MM4HD0
c           (units changed from km to meters- bug fix)
c         - Do not initialize rmm each time
c
c   - 030830(FRR)- Bug fix- Use consistent coordinate systems
c                           for MM5 and CALMET grdipoints.
c               
c
c --- INPUTS:
c
c  QRPROG(mxnxp,mxnyp) - real array    - Precipitation rate (mm/hr) at
c                                        each MM5 gridpoint
c    Via common MET1.MET:
c
c                NFLAGP - integer     - =1, for 1/R     interpolation
c                                       =2, for 1/R**2  interpolation
c                                       =3, for exp(-R**2/sigma**2)/R**2
c                                            interpolation
c                                        where R = radius
c              SIGMAP - real          - User specified radius of
c                                        influence or weighting (sigma)
c                                        factor (km)
c                                          If NFLAGP=1,2 -- radius of
c                                             influence (km)
c                                          If NFLAGP=3 -- sigma weighting
c                                             factor (km) -- if 0.0,
c                                             SIGMAP will be computed
c                                             internally as 1/2 dist.
c                                             between nearest stations
c                                             w/ and w/o precipitation
c              CUTP   - real          - User specified cutoff value
c                                        for computed precipitation rate
c                                        (mm/hr) --  (values < CUTP
c                                        are set equal to 0.0 mm/hr)
c    Via MM4HDO.MET
c              XLCMM4
c              YLCMM4
c              IGRAB
c              JGRAB
c
c --- OUTPUT:
c       RMM(mxnx,mxny) - real array    - Precipitation rate (mm/hr) at
c                                        each grid point
c
c --- INTERPQR called by:  RDMM5
c --- INTERPQR calls:      CMPD2
c----------------------------------------------------------------------
c --- include parameters
      include 'params.met'
c
      real qrprog(mxnxp,mxnyp)
      real p(mxnxp*mxnyp)
      real dis2(mxnxp*mxnyp)
      real rmm(mxnx,mxny)
c
      include 'met1.met'
      include 'grid.met'
      include 'mm4hdo.met'
c
      data dismin/0.01/,xmax/1.e37/
c
c --- 040924 (frr) no need to initialize rmm each time.
c --- Initialise precip rate
c      do 55 i=1,nx
c      do 55 j=1,ny
c         rmm(i,j)=0.0
c55    continue
c
c --- 040924 (frr) Locations of MM5 gridpoints is computed in RDHD5
c --- (and units are in meters -bug fix) 
c
c --- Compute the number of MM5 gridpoints and fill in progn. precip.
      np=0
      do 300 ip=1,nxp
      do 300 jp=1,nyp
         np=np+1
         p(np)=qrprog(ip,jp)
300   continue


c ---    If user-defined radius not used, then find radius of influence
c ---    which is defined as half of the minimum distance between any
c ---    nonzero precip. stations and any zero precip. stations.
c
c
         if (nflagp.eq.3.and.sigmap .eq. 0.0) then
           sigma2=xmax
           do 60 k1=1,np
           do 70 k2=1,np
              test1=p(k1)*p(k2)
              test2=p(k1)+p(k2)
              if((test1.eq.0.0).and.(test2.gt.0.0)) then
                 d2=(x04(k1)-x04(k2))**2+(y04(k1)-y04(k2))**2
                 if(d2.lt.sigma2) sigma2=d2
              endif
70         continue
60         continue
           sigma1 = sqrt(sigma2)
           sigma1 = 0.5 * sigma1
         else
c
c ---      sigma1 is in meters (sigmap is in km)
           sigma1 = 1000.*sigmap
           sigma2= sigma1*sigma1
         end if
c
c ---    Compute precipitation rate at each grid point
         if(NFLAGP.eq.1)then
c
c ---      1/R INTERPOLATION METHOD
           do 110 i=1,nx
              xgm=(float(i)-0.5)*dgrid
              do 105 j=1,ny
               ygm=(float(j)-0.5)*dgrid
c
                top=0.0
                bot=0.0
c
c ---           Compute distance**2 of each precip. station with
c               VALID (non-missing) data to grid point
                call cmpd2(xgm,ygm,x04,y04,np,dis2)
c
c ---           Compute weighting functions for 1/R method
                do 103 k=1,np
                if(dis2(k).le.sigma2)then
c
c ---              Station is within radius of influence
                   dis=sqrt(dis2(k))
c ---              Minimum value of distance to avoid numerical problems
                   dis=amax1(dis,dismin)
c
                   top=top+p(k)/dis
                   bot=bot+1.0/dis
                endif
103             continue
c
c ---           If there are NO gridpoint within region of influence,
c               use value at nearest MM5 gridpoint 
                if(bot.eq.0.0)then
                   rmm(i,j)=qrprog(igrab(i,j,1),jgrab(i,j,1))
                else
c ---             Compute precipitation rate with 1/R method
                  rmm(i,j)=top/bot
                  if(rmm(i,j).lt.CUTP)rmm(i,j)=0.0
                endif
105         continue
110         continue

       else if(NFLAGP.eq.2)then
c
c ---     1/R**2 INTERPOLATION METHOD
          do 210 i=1,nx
             xgm=(float(i)-0.5)*dgrid
             do 205 j=1,ny
                ygm=(float(j)-0.5)*dgrid
c
                top=0.0
                bot=0.0
c
c ---           Compute distance**2 of each precip. station with
c               VALID (non-missing) data to grid point
                call cmpd2(xgm,ygm,x04,y04,np,dis2)
c
c ---           Compute weighting functions for 1/R**2 method
                do 203 k=1,np
                if(dis2(k).le.sigma2)then
c
c ---              Station is within radius of influence
c ---              Minimum value of dist**2 to avoid numerical problems
                   dis2saf=amax1(dis2(k),dismin)
c
                   top=top+p(k)/dis2saf
                   bot=bot+1.0/dis2saf
                endif
203             continue
c
c ---           If there are NO gridpoint within region of influence,
c               use value at nearest gridpoint
                if(bot.eq.0.0)then
                   rmm(i,j)=qrprog(igrab(i,j,1),jgrab(i,j,1))
                else
c ---              Compute precipitation rate with 1/R**2 method
                   rmm(i,j)=top/bot
                   if(rmm(i,j).lt.CUTP)rmm(i,j)=0.0
                endif
205         continue
210       continue

       else if(NFLAGP.eq.3)then
c
c ---     Exponential interpolation method
          do 310 i=1,nx
          xgm=(float(i)-0.5)*dgrid
          do 305 j=1,ny
            ygm=(float(j)-0.5)*dgrid
            bot=0.0
            top=0.0
c
c ---       Compute distance**2 of each precip. station with
c           VALID (non-missing) data to grid point
            call cmpd2(xgm,ygm,x04,y04,np,dis2)
c
            do 301 k=1,np
               expo=dis2(k)/sigma2
               if(expo.gt.60.0) then
                  bbb=0.0
               else 
                  bbb=exp(-expo)
               endif
c ---          Minimum value of dist**2 to avoid numerical problems
               dis2saf=amax1(dis2(k),dismin)
               bot=bot+bbb/dis2saf
               top=top+p(k)*bbb/dis2saf
301         continue
c
            if(top.lt.1.0e-30) then
               rmm(i,j)=0.0
            else
               rmm(i,j)=top/bot
               if(rmm(i,j).lt.CUTP) rmm(i,j)=0.0
            endif
305         continue
310         continue
       else
          write(io6,*)'ERROR in Subr. GRIDE -- Invalid value ',
     1    'of NFLAGP -- NFLAGP = ',NFLAGP
          stop
      endif
c
999   continue
      return
      end
c----------------------------------------------------------------------
      subroutine heatfx(sinalp,nears,temp2d,icc,ilandu,iwat1,iwat2,
ccec101006     1                  nx,ny,icloud,ccgrid,qh,qsw)
     1                  nx,ny,mcloud,ccgrid,qh,qsw)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 101006             HEATFX
c ---          J. Scire, SRC
c              Modified by F.Robe,Earth Tech Inc.(09/01) 
c
c --- PURPOSE:  Compute the sensible heat flux (W/m**2) at each
c               non-water grid point using the energy budget method
c               Compute also the solar radiation at ALL gridpoints
c
c --- CHANGES:
c
c --- V6.217 level 061231 to V6.330 Level 101006 (CEC)
c      - Change Cloud option from ICLOUD to ICLDOUT and MCLOUD
c
c --- 951021 (MOD5) to V6.217 Level 061231
c     - Allow icloud=4 option
c
c --- 951021  to MOd5
c     - Short wave radiation computed at all gridpoints
c              
c --- INPUTS:
c    SINALP(mxnx,mxny) - real array    - Sine of the solar elevation
c                                        angle at each grid point
c     NEARS(mxnx,mxny) - integer array - Station number of surface
c                                        station closest to each grid pt
c    TEMP2D(mxnx,mxny) - real array    - Surface Air temperature (deg. K)
c            ICC(mxss) - integer array - Cloud cover (tenths)
c    ILANDU(mxnx,mxny) - integer array - Land use category at each
c                                        grid point
c         IWAT1, IWAT2 - integers      - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c                NSSTA - integer       - Number of surface stations
c               MCLOUD - integer       - Flag indicating if gridded
c                                        cloud data are available
c                                        (2,3 = yes, otherwise, no)
c    CCGRID(mxnx,mxny) - real array    - Gridded cloud fraction
c                                        (Used only if MCLOUD=2,3,4)
c
c        Common block /HFLUX/ variables:
c           qf(mxnx,mxny),hcg(mxnx,mxny),
c           albedo(mxnx,mxny),bowen(mxnx,mxny),
c           ha1,ha2,hb1,hb2,hc1,hc2,hc3,hc3p1
c        Parameters: MXNX, MXNY, MXSS
c
c --- OUTPUT:
c        QH(mxnx,mxny) - real array    - Sensible heat flux (W/m**2) at
c                                        each grid point
c       QSW(mxnx,mxny) - real array    - Short-wave radiation (W/m**2)
c                                        at each grid point
c
c ---  HEATFX called by: DIAGNO, COMP
c ---  HEATFX calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real qh(mxnx,mxny)
      real sinalp(mxnx,mxny),temp2d(mxnx,mxny),qsw(mxnx,mxny)
      real ccgrid(mxnx,mxny)
c
      integer nears(mxnx,mxny),ilandu(mxnx,mxny)
      integer icc(mxss)
c
      include 'hflux.met'
c
c --- compute short-wave radiation (W/m**2) at all gridpoints, QSW

c --- loop over grid cells
      do 200 i=1,nx
      do 200 j=1,ny
c
c ---    Station number of the nearest surface met. station to
c ---    the current grid point (i,j)-NSTA

c        Compute short-wave radiation QSW
ccec101006  if(icloud.gt.1)then
         if(mcloud.gt.1)then
c ---       use gridded cloud data (2:from cloud.dat - 3,4: from MM5)
            ccfrac = ccgrid(i,j)
         else
c ---       use cloud fraction at surface stations
c ---       convert cloud cover (tenths) to fractional value
            ccfrac = 0.1*icc(nears(i,j))
         endif
         qsw(i,j)=(ha1*sinalp(i,j)+ha2)*(1.+hb1*ccfrac**hb2)
         qsw(i,j)=amax1(qsw(i,j),0.0)
c ---    skip water grid cells -- (DT method used to compute heat flux
c ---    over water)
         if(ilandu(i,j).ge.iwat1.and.ilandu(i,j).le.iwat2)go to 200
c
c
c ---    flag nighttime periods with negative sensible heat flux
c        if(sinalp(nsta).le.0.0)then
         if(sinalp(i,j).le.0.0)then
            qh(i,j)=-0.1
            go to 200
         endif
cc
c --- compute net radiation (W/m**2), QSTAR using the method of
c --- Holtslag and van Ulden (1983)
c --- constant 5.67e-8 W/m**2/deg. K**4 is the Stefan-Boltzmann constant
      qstar=((1.-albedo(i,j))*qsw(i,j)+hc1*temp2d(i,j)**6
     :       -5.67e-8*temp2d(i,j)**4+hc2*ccfrac)/hc3p1
c

c --- compute sensible heat flux (w/m**2), QH
c --- qf is the anthropogenic heat flux (W/m**2)
      qh(i,j)=bowen(i,j)*(qstar*(1.-hcg(i,j))+qf(i,j))/(1.+bowen(i,j))
c
200   continue

676   format(4(1x,i2),2x,3f10.5)
c
      return
      end
c----------------------------------------------------------------------
      subroutine inter2(stdat1,nst,xst,yst,
     1 nintrp,rs,is,work,field1,fgfld,ilandu,
     2 iwat1,iwat2,pdat,noobs)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050217             INTER2
c              Earth Tech
c              based on DWM subroutine by S.DOUGLAS, SAI
c              Modified by Earth Tech
c
c --- UPDATES:
c --- V5.548a (050101) to V5.551 Level 050217(FRR)
c       - Iflag removed from calling list (=nbar, which is passed via
c         common d3.met)
c       - call barier only if nbar>0 (for prog. data)

c --- V5.5 (030402) to V5.548a (050101) (FRR)
c       - Implemented level dependent barriers (up to KBAR)
c       - Rearrange comments/declations to fit convention
c         (purpose, update, input, output, declarations)
c
c --- V5.4 (990228) to V5.5 (030402)  (DGS)
c       - Change documentation:  coordinates may be other than
c         UTM or LLC
c
c --- PREVIOUS UPDATES:
c --- Modifed by F.Robe to pass arguemtns bia wparm.met (021105) 
c --- Modified to use sigma weighting in interpolation, EMI 920923
c --- Modified to allow gridded MM4 prognostic winds to be treated as
c     observations             EMI 920925
c
c --- Modified by Ed Chang; 3/8/94; SRC
c       - Initialize JS array in 121-loop
c       - Changed loop index of 135- & 185- loop from N to N44.
c
c --- Modified by E. Insley & J. Scire; 940331; SRC
c       - When using the LVARY option, change the variables dealing with
c         the closest station to a grid cell into arrays over levels
c         (i.e., RS2(mxnz) & NRS2(mxnz)) and only use a station as the
c         closest station if it has valid (non-missing) data.
c     --- Modified to use RMAX3 over water cells in 160 loop.
c   
c --- Modified by M. Fernau, 941101; ETCO
c     --- Can handle MM4 only; no upper air NWS data
c   
c --- Modified by M. Fernau (2/99) to handle arbitrary coordinates correctly
c   
C
C --- INPUTS:
c              STDAT1 (R ARRAY) - WIND COMPONENT STATION DATA
C              NST (I)          - NUMBER OF STATIONS
C              XST (R ARRAY)    - LOCAL X-COORDINATES OF STATIONS
C              YST (R ARRAY)    - LOCAL Y-COORDINATES OF STATIONS
C              RMIN (R)         - MINIMUM RADIUS OF INFLUENCE
C              RMAX1 (R)        - MAXIMUM RADIUS OF INFLUENCE OVER
C                                 LAND IN THE SURFACE LAYER
C              RMAX2 (R)        - MAXIMUM RADIUS OF INFLUENCE OVER
C                                 LAND IN UPPER LAYERS
C              RMAX3 (R)        - MAXIMUM RADIUS OF INFLUENCE OVER
C                                 WATER
C              R1 (R)           - WEIGHTING PARAMETER FOR SURFACE
C                                 LAYER
C              R2 (R)           - WEIGHTING PARAMETER FOR UPPER
C                                 LAYERS
C            FGFLD (R ARRAY)    - DIAGNOSTIC WIND FIELD
C            ilandu (I ARRAY)   - GRIDDED SURFACE TYPE INDICATORS
C              UTMXOR (R)       - DIAGNOSTIC WIND MODEL X COORD OF ORIGIN (KM)
C              UTMYOR (R)       - DIAGNOSTIC WIND MODEL Y COORD OF ORIGIN (KM)
C              IPROG (I)        - FLAG FOR USING PROGNOSTIC WIND FIELDS
C              PDAT (R ARRAY)   - GRIDDED PROGNOSTIC MODEL WINDS ON
C                                 HORIZONTAL PROGNOSTIC GRID
C            XMAP0,YMAP0        - REAL SPACE COORDINATES OF GRID ORIGIN (KM)
C            (FROM GRID.MET)       
C
c        Parameters: MXNX, MXNY, MXNZ, MXNZP1, MXSS, MXUS, MXWND, IO6
C
C --- OUTPUTS:
c              FIELD1 (R ARRAY) - INTERPOLATED WIND COMPONENT
C                                  ARRAY
C
c --- INTER2 called by: DIAGNO
c --- INTER2 calls    : XMIT,BARIER,FMINF
c
c ----------------------------------------------------------------------

c --- include parameters

      include 'params.met'
c --- Relative weighting between obs and MM4 (wo(i,j,k)):
      include 'wtgrd.met'
      include 'wparm.met'

      logical lland

      include 'grid.met'
      include 'mm4hdo.met'
c     need kbar and pass nbar through common (050101)
      include 'd3.met'
      include 'd4.met'
      include 'd6.met'


      DIMENSION STDAT1(mxnz,*), XST(*), YST(*), RS(*),
     1 IS(*), WORK(*), FIELD1(mxnx,mxny,*), JS(mxwnd),
     2 FGFLD(mxnx,mxny,*), FIELD2(mxnx,mxny,mxnz),NINTRP(*),
     3 ilandu(mxnx,mxny),
     4 FIELD3(mxnx,mxny,mxnz), FIELD4(mxnx,mxny,mxnz),
     5 PDAT(mxnxp,mxnyp,mxnz),RSQM(4),
     6 IJOUT(4,mxnz)
c ---  IJOUT: level dependent as barriers are level dependent (050101)

c --- level and station dependent barrier flag (050101)
      real okk(mxnz,mxwnd)
c
c --- Declare closest station arrays
      real rs2(mxnz)
      integer nrs2(mxnz)
c ---
      DOUBLE PRECISION WT
      double precision wt2,wt3
C
      DATA ZERO/0./
      DATA one/1./
      DATA npts/4/
C

C     INITIALIZE FIELD2 ARRAY
C
      N = mxnx * mxny * mxnz
      CALL XMIT(-N,ZERO,FIELD2)
C
      if(iprog.EQ.5 .or. iprog.eq.15)then
c ---   Initialize field3 & field4 arrays (sum arrays for prognostic
c ---   data as observations)
        call xmit(-N,ZERO,FIELD3)
        call xmit(-N,ZERO,FIELD4)
      endif
c
C     CONVERT GRID SPACING TO KM
C
      DXK=DX*0.001
      DYK=DY*0.001
      rminsq = rmin * rmin
C
C     DETERMINE RMAX
C
      RMAX = AMAX1(RMAX1,RMAX2)
      RMAX = AMAX1(RMAX,RMAX3)
C
      DO 200 J=1,NY
      DO 200 I=1,NX
c
c ***   Initialize closest station arrays
c ---   (if using variable radius of influence option)
        if(LVARY)then
           do 210 k=1,nz
             rs2(k) = 9.9e9
             nrs2(k)= 0
210        continue
        endif
c ***
c --- set LLAND = .true. if land use category is not water
      if(ilandu(i,j).ge.iwat1.and.ilandu(i,j).le.iwat2)then
         lland=.false.
      else
         lland=.true.
      endif
c
c     (x,y) = CALMET grid point relative to CALMET origin
      X = (float(I)-0.5)*DXK
      Y = (float(J)-0.5)*DYK
      CALL XMIT(-NST,EDIT,RS)

c --- initialize level and station dependent barrier flags:
      ok=1
      call xmit(-mxnz*mxwnd,1.,okk)

      DO 120 L=1,NST
      IF(NBAR.LE.0) GO TO 90
C
C     CHECK FOR BARRIERS TO INTERPOLATION
C
      CALL BARIER(X,Y,XST(L),YST(L),OK)

c --- vertical extent of barriers (050101)
      IF(OK.LE.0. ) then
         do k=1,kbar
            okk(k,l)=-1.
         end do
         if (kbar.eq.nz) GO TO 115
      endif

C     SKIP STATION IF NO DATA AT ANY ELEVATION
C
   90 DO 100 K=1,NZ
      IF(STDAT1(K,L).LT.EDITL) GO TO 110
  100 CONTINUE
      GO TO 115
C
C     COMPUTE DISTANCE TO STATIONS LESS THAN RMAX AWAY
C
  110 RSX = X - XST(L)
      RSY = Y - YST(L)
      RS(L) = RSX**2 + RSY**2
      RS(L) = SQRT(RS(L))
c
c *** Loop over levels to find closest station with valid data
c *** (done independently for EACH layer)
c --- add check for barriers (050101)

       if(LVARY)then
         do 111 k=1,nz
           if (ok.gt.0 .or. k.gt.kbar) then
              if(stdat1(k,L).LT.editl)then
                 if(rs(L).lt.rs2(k))then
                    rs2(k)=rs(L)
                    nrs2(k)=L
                 endif
              endif
           endif
111      continue
      endif
c ***
      IF(RS(L).LT.RMIN) RS(L)=RMIN
      IF(RS(L) .LE. RMAX)  GO TO 115
      RS(L) = EDIT
  115 CONTINUE
  120 CONTINUE
c
c *** Check to make sure there is valid data from at least one station,
c *** when using LVARY option -- if not write message and stop
c *** program
      if(LVARY)then
         do 121 k=1,nz
           if(nrs2(k).EQ.0)then
             if (k .eq. 1 .or. noobs .eq. 0) then
c
c --- It's OK if there are no upper air observations if MM4 data are
c --- being used...
c     Note that if noobs=2 (no sf or upper air data, the program skips
c     this subroutine) i.e. noobs mode here means noobs=1
               write(io6,2063) i,j,k
               stop
             end if
           endif
121      continue
      endif
c ***
c
C     ORDER STATIONS
C
c...  First initialize arrays IS and JS
      DO 122 NN = 1,NST
        IS(NN) = IEDIT
        js(nn) = iedit
  122 CONTINUE
c
      CALL XMIT(NST,RS,WORK)
      N = 0
      DO 130 L = 1,NST
      CALL FMINF(WORK,NST,FMIN,NMIN)
      WORK(NMIN) = EDIT + L
      IS(L) = NMIN
      IF(FMIN.GT.EDITL)  GO TO 150
      N = N + 1
  130 CONTINUE
  150 CONTINUE

      if(iprog.EQ.5 .or. iprog.eq.15) then
c
c ---   Initialize ijout array (flag for using the prognostic grid
c ---   data at that point in the interpolation; 0=do not use,1=use)
        call xmit(-npts,one,ijout)
c
c ---   Initialize rm array (distances from prognostic grid point to
c ---   diagnostic grid point)
        call xmit(-npts,zero,rsqm)
c
c *** New code
c
c --- Get absolute x/y of CALMET point
c ***   xcm = x + utmxor
c ***   ycm = y + utmyor
c --- Compute CALMET grid coordinates in real space coordinates
        xcm = x + xmap0
        ycm = y + ymap0
c
        do 135 n44 = 1,npts
c
c --- Get MM4 coordinates relative to CALMET origin
c --- (XLCMM4,YLCMM4 are in real space coordinates)
c ***     xpc = xlcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - utmxor
c ***     ypc = ylcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - utmyor
          xpc = xlcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - xmap0
          ypc = ylcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - ymap0
c
c --- Check for barriers to interpolation
c --- Check for barriers to interpolation of MM4/5 data
          ok=1.
          if (nbar.le.0) goto 91

          call barier(x,y,xpc,ypc,ok)
          if(ok.LE.0.0) then
             do k=1,kbar
               ijout(n44,k) = 0
             end do
c ---        skip only if barriers up to the top (050101)
             if(kbar.eq.nz)  go to 135
          endif
c
91        continue
c
c --- Calculate distance from MM4 grid point to diagnostic grid point
          rsqm(n44) = (xlcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - xcm)
     &      ** 2. +
     &      (ylcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - ycm) ** 2.
          rsqm(n44) = AMAX1(rsqm(n44),rminsq)
135     continue
      endif
c
      DO 190 K=1,NZ
c
c...skip observations from NWS if only using MM4 data
c frr(020511): ok to use vertically extrapolated surface winds if noobs=1
c FRR (09/2001) additional option for noobs
c        if (k .gt. 1 .and. noobs .eq. 1) goto 181
c        if (k .gt. 1 .and. noobs .ge. 1) goto 181
        if (k .gt. 1 .and. noobs .ge. 1 .and. abs(iextrp).eq.1) goto 181
C
C     FIND STATIONS WITH DATA FOR THIS LEVEL
C
      IF (K .EQ. 1 ) THEN
        R = R1
      ELSE
        R = R2
      ENDIF
      wt2 = (1-wo(i,j,k))/R**2
c
c --- Determine the closest NINTRP stations which are within radius
c --- of influence, are not blocked by barriers and which have valid data
      NK = 0
      if(n.eq.0)go to 161
      DO 160 M=1,N
      L=IS(M)
c --- skip station if no valid data at that level
      IF(STDAT1(K,L).GT.EDITL)  GO TO 160
c --- skip station if blocked by barrier at that level
      if(okk(k,l).lt.0.) go to 160

      if(lland)then
c
c ---    Land cells
         if(k.eq.1)then
c
c ---       Surface layer over land
            if(rs(L).gt.rmax1)go to 160
         else
c
c ---       Layers aloft over land
            if(rs(L).gt.rmax2)go to 160
         endif
      else
c
c ---    Water cells
         if(rs(L).gt.rmax3)go to 160
      endif
      NK = NK + 1
      JS(NK) = IS(M)
      IF(NK.EQ.NINTRP(K)) GO TO 165
160   CONTINUE
161   continue

      IF (NK .GT. 0) GO TO 165
c
c --- If using LVARY option, and no stations with valid data are within
c --- RMAX, use closest station
      if (LVARY) then
        nk = 1
        js(nk)=nrs2(k)
        L=nrs2(k)
        rs(L)=rs2(k)
        if(rs(L).lt.rmin)rs(L)=rmin
        goto 165
      endif
c
c FRR (12/16/96): next section commented - No special treatment of water
c      if (lland) go to 165
c      if(iwr.gt.0)WRITE(IWR,2065) I,J,K
c      WRITE(io6,2065) I,J,K
c      STOP

  165 CONTINUE

C
C     FIND THE INTERPOLATION WEIGHTING FACTOR FOR EACH VALID STATION
C
      if(nk.EQ.0) go to 181
      DO 180 M = 1,NK
      L=JS(M)
      IF(STDAT1(K,L) .GT. EDITL)  GO TO 180
c --- Compute weighting factors ( wt is for sfc obs, wt3 is for Step 1 field
c**   WT = 1./(RS(L)**2)
      wt = wo(i,j,k)/(RS(L)**2)
c
C
C     APPLY WEIGHTING FACTOR
C
      FIELD1(I,J,K) = FIELD1(I,J,K) + STDAT1(K,L)*WT
      FIELD2(I,J,K) = FIELD2(I,J,K) + WT


  180 CONTINUE
181   continue
c
      if(iprog.EQ.5 .or. iprog.eq.15) then
c ---   Compute weighting factor for prognostic data used as observations
c ---   Compute weighted sums
        do 185 n44=1,npts
          if(ijout(n44,k).EQ.1) then
            wt2 = (1-wo(i,j,k))/rsqm(n44)
            field3(i,j,k) = field3(i,j,k) +
     &        pdat(igrab(i,j,n44),jgrab(i,j,n44),k)*wt2
c ***
            field4(i,j,k) = field4(i,j,k) * wt2
          endif
185     continue
      endif
c
c *** IF (LNDWTR(I,J) .EQ. 1) THEN
c**   IF (lland) THEN
c**     FIELD1(I,J,K) = (FIELD1(I,J,K) + FGFLD(I,J,K)/R**2)/
c**  1                  (FIELD2(I,J,K) + 1./R**2)
c**     FIELD1(I,J,K) = (FIELD1(I,J,K) + FGFLD(I,J,K)*wt2)/
c**  1                  (FIELD2(I,J,K) + wt2)
c**   ELSE
c**     if(field2(i,j,k).eq.0.)then
c**        write(io6,*)'ERROR in SUBR. INTER2 -- WATER CELL -- ',
c**  1     ' FIELD2 = 0.0 -- I,J,K = ',i,j,k
c**        stop
c**     endif
c**     FIELD1(I,J,K) = FIELD1(I,J,K)/FIELD2(I,J,K)
c**   ENDIF
c
c --- Compute weighting factor (wt3 is for Step 1 field)
      wt3 = 1./(R**2)
c
      if(iprog.EQ.0) then
c FRR (12/16/96): No distinction between water and land
c        if(lland) then
          field1(i,j,k) = (field1(i,j,k) + fgfld(i,j,k) * wt3)/
     1                    (field2(i,j,k) + wt3)
c        else
c          if(field2(i,j,k).eq.0.)then
c             write(io6,*)'ERROR in SUBR. INTER2 -- WATER CELL -- ',
c     1       ' FIELD2 = 0.0 -- I,J,K = ',i,j,k
c             stop
c          endif
c          field1(i,j,k) = field1(i,j,k)/field2(i,j,k)
c        endif
      else if(iprog.EQ.2 .OR. iprog.EQ.4 .OR. iprog.eq.14) then
c ---   If using noobs, then levels 2 to nz will just be the MM4-based
c       step 1 field (field 1 and field 2 = 0)
   
        field1(i,j,k) = (field1(i,j,k) + fgfld(i,j,k) * wt3)/
     1                  (field2(i,j,k) + wt3)
        

      else if(iprog.EQ.5 .OR. iprog.eq.15) then
        if(lland) then
c ---   If using noobs, at levels 2 to nz field 1 and field 2 = 0;
c       first-guess field will be specified in DIAG.DAT
          field1(i,j,k) = (field1(i,j,k) + field3(i,j,k) +
     1                    fgfld(i,j,k) * wt3)/
     2                  (field2(i,j,k) + field4(i,j,k) + wt3)
        else
c ---   If using noobs, then levels 2 to nz will just be the MM4 "obs"
c       (field 1 and field 2 = 0)
          field1(i,j,k) = (field1(i,j,k) + field3(i,j,k))/
     1                  (field2(i,j,k) + field4(i,j,k))
        endif
      else
         write(io6,*) 'ERROR in Subr. INTER2 - Invalid value of IPROG; '
     1                ,' IPROG = ',iprog
         stop
      endif
  190 CONTINUE
  200 CONTINUE
      RETURN
2063  format(' JOB ABORTED--THERE ARE NO STATIONS WITH VALID DATA FOR ',
     1 'I = ',i4,' J = ',i4,' K = ',i4,' IN SUBR. INTER2')
2065  FORMAT('  JOB ABORTED  --  THERE ARE NO CLOSE STATIONS FOR',
     1  ' I = ',I4,' J = ',I4,' K = ',I4,' IN SUBR. INTER2')
      END
c----------------------------------------------------------------------
      subroutine interb(sdat,gdat,dp,nlbs,dg,gridsign,statsign)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0      Level: 950531            INTERb
c             R. MENTZER, SRC
c ---         Modified by M. Fernau
c
c    PURPOSE:  To interpolate the obs. data in the lake breeze region
c              to the CALMET grid
c
C    INPUTS:  SDAT (R ARRAY) - station obs data
c             DP (R ARRAY)   - distance from stations to the shore
c             DG (R)         - distance from grid point to the shore
c             nlbs           - number of stations in the region
c             gridsign (R)   - vertical distance from grid cell to shore
c             statsign (R array)
c                            - vertical distance from stations to shore
C
c    OUTPUTS:  GDAT  -- Gridded station data
c
c    INTERb CALLED BY: LLBREEZ
c
c    INTER CALLS:  NONE
c----------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      DIMENSION SDAT(mxwnd),dp(mxwnd),statsign(mxwnd)
      double precision dpr,wt(mxwnd),bot
      bot = 0.000000
      top = 0.000000
      do 170 l = 1,nlbs
c    get the weighting factor for each station
        if (statsign(l) * gridsign .ge. 0.) then
c...same side of shore
          dpr = dp(l) - dg
        else
c...opposite sides of shore
          dpr = dp(l) + dg
        end if
        dpr = dmax1(dabs(dpr),1.d-10)
        wt(l) = 1. / (dpr**2)
170     continue
C
C         APPLY WEIGHTING FACTOR
c
      gdat = 999.
      ngood = 0
      do 180 l = 1,nlbs
c...omit missing data
        if (sdat(l) .lt. 990.) then
          top=top + (sdat(l) * wt(l))
          bot=bot + wt(l)
          ngood = ngood + 1
        end if
180   CONTINUE
      if (ngood .gt. 0) gdat = top / bot
      RETURN
      END
c----------------------------------------------------------------------
      subroutine interp(stdat1,nst,xst,yst,rmin,rmax,lvary,
     1     nintrp,rs,is,work,field1,iprog,rprog,prog,
     2     pdat,noobs)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328             INTERP
c              S.DOUGLAS, SAI
c
c      
c --- PURPOSE: COMPUTES 3-D WIND FIELD FROM STATION DATA
C              BY THE ERT INTERPOLATION SCHEME
c
c --- UPDATES:
c --- V5.55(050217) to V5.6 (050328) (FRR)
c       - Explicit D4/D6 common replaced by include
c
c --- V5.548a (050101) to V5.55 (FRR)
c       - IFlag removed from calling list (=nbar, which is passed via
c         common d3.met)
c       - call barier only if nbar>0
c
c --- V5.5 (030402) to V5.548a (050101) (FRR)
c        - Implemented vertical limitation (KBAR) to barriers
c        - shift initial comments and declarations to fit conventions
c          (purposes, updates, inputs, output, declarations, include)
c --- V5.4 (990228) to V5.5 (030402)  (DGS)
c        - Change documentation:  coordinates may be other than
c          UTM or LLC
c
c --- Modified to allow gridded MM4 prognostic winds to be treated as
c     observations             EMI 920925
c
c --- Modified by Ed Chang & Liz Insley; 940309; SRC
c       - Add comment at various places to explain the code
c       - Initialize JS array with constant IEDIT (=999) in 121-loop
c       - Changed from 'NST=1' to 'N=1' in logical 'LVARY'-block after
c         statement-140
c       - Changed upper limit of 160-loop from NST TO N.
c       - Changed loop index of 135- and 185- loop from N to N44.
c       - Re-activate the IF-check after 160-loop
c
c --- Modified by E. Insley & J. Scire; 940331; SRC
c       - When using the LVARY option, change the variables dealing with
c         the closest station to a grid cell into arrays over levels
c         (i.e., RS2(mxnz) & NRS2(mxnz)) and only use a station as the
c         closest station if it has valid (non-missing) data.
c   
c --- Modified by M. Fernau, 941101; ETCO
c       - Can handle MM4 only; no upper air NWS data
c   
c --  Modified by M. Fernau (2/99) to handle arbitrary coordinates correctly
c
C
C
C --- INPUTS:
c              STDAT1 (R ARRAY) - WIND COMPONENT STATION DATA
C              NST (I)          - NUMBER OF STATIONS
C              XST (R ARRAY)    - LOCAL X-COORDINATES OF STATIONS
C              YST (R ARRAY)    - LOCAL Y-COORDINATES OF STATIONS
C              RMIN (R)         - MINIMUM RADIUS OF INFLUENCE
C              RMAX (R)         - MAXIMUM RADIUS OF INFLUENCE
C              NINTRP(I)        - NO. OF STATIONS USED IN THE
C                                 INTERPOLATION TO A GRID POINT
C              IPROG (I)        - FLAG FOR USING PROGNOSTIC WIND FIELDS
C              RPROG (R)        - WEIGHTING PARAMETER FOR PROGNOSTIC
C                                 WIND FIELDS
C              PROG (R ARRAY)   - GRIDDED PROGNOSTIC MODEL WINDS
c                                 INTERPOLATED TO DIAGNOSTIC GRID
C              UTMXOR (R)       - DIAGNOSTIC WIND MODEL X COORD OF ORIGIN (KM)
C              UTMYOR (R)       - DIAGNOSTIC WIND MODEL Y COORD OF ORIGIN (KM)
C              PDAT (R ARRAY)   - GRIDDED PROGNOSTIC MODEL WINDS ON
C                                 HORIZONTAL PROGNOSTIC GRID
c                                 INTERPOLATED TO DIAGNOSTIC MODEL LEVELS
c              NOOBS            - FLAG FOR MM5 REPLACING OBSERVATIONS
c                                 = 1: use sf obs and MM5 aloft
c                                 = 2: use MM5 at the sf and aloft 
c
C            XMAP0,YMAP0        - REAL SPACE COORDINATES OF GRID ORIGIN (KM)
C            (FROM GRID.MET)      
c        Parameters: MXNX, MXNY, MXNZ, MXNZP1, MXSS, MXUS, MXWND, IO6
C
C     OUTPUTS:
c             FIELD1 (R ARRAY) - INTERPOLATED WIND COMPONENT ARRAY
c
c --- INTERP called by: DIAGNO
c --- INTERP calls:     XMIT,BARRIER,FMINF
c ----------------------------------------------------------------------

c --- include parameters
      include 'params.met'
      include 'wtgrd.met'
c
      include 'grid.met'
      include 'mm4hdo.met'
      include 'd3.met'

      COMMON /D4/ EDIT,EDITL,IEDIT,IEDITL
      COMMON /D6/ IRD,IWR,IFILE,IRDP

      DIMENSION STDAT1(mxnz,*), XST(*), YST(*), RS(*),
     1 IS(*), WORK(*), FIELD1(mxnx,mxny,*), JS(mxwnd), NINTRP(*),
     2 PROG(mxnx,mxny,*), FIELD2(mxnx,mxny,mxnz),
     3 FIELD3(mxnx,mxny,mxnz), FIELD4(mxnx,mxny,mxnz),
     4 PDAT(mxnxp,mxnyp,mxnz),RSQM(4),
     5 IJOUT(4,mxnz)
c
c --- Level and station dependent barrier flags
      real okk(mxnz,mxwnd)

c *** Declare closest station arrays
      real rs2(mxnz)
      integer nrs2(mxnz)
c ***
      DOUBLE PRECISION WT
      double precision wt2,wt3
c
      LOGICAL LVARY
C
      DATA ZERO/0./
      DATA npts/4/
C
C     INITIALIZE FIELD2 ARRAY
C
      N = mxnx * mxny * mxnz
      CALL XMIT(-N,ZERO,FIELD2)
c
      if(iprog.EQ.5 .OR. iprog.eq.15)then
c ---   Initialize field3 & field4 arrays (sum arrays for prognostic
c ---   data as observations)
        call xmit(-N,ZERO,FIELD3)
        call xmit(-N,ZERO,FIELD4)
      endif
C
C     CONVERT GRID SPACING TO KM
C
      DXK=DX*0.001
      DYK=DY*0.001
      rminsq = rmin * rmin
C
      DO 200 J=1,NY
      DO 200 I=1,NX
c
c ***   Initialize closest station arrays
c ---   (if using variable radius of influence option)
        if(LVARY)then
           do 210 k=1,nz
             rs2(k) = 9.9e9
             nrs2(k)= 0
210        continue
        endif
c ***
c     (x,y) = CALMET grid point relative to CALMET origin
      X = (float(I)-0.5)*DXK
      Y = (float(J)-0.5)*DYK
      CALL XMIT(-NST,EDIT,RS)
      DO 120 L=1,NST
c      IF(NBAR.LE.0) GO TO 90
C
C     CHECK FOR BARRIERS TO INTERPOLATION

c --- initialize level and station dependent barrier flags:
      call xmit(-mxnz*mxwnd,1.,okk)
      ok=1.

      if (nbar.le.0) goto 90

C
      CALL BARIER(X,Y,XST(L),YST(L),OK)


c --- vertical extent of barriers (050101)
c     IF(OK.LE.0.) GO TO 115
      IF(OK.LE.0. ) then
         do k=1,kbar
            okk(k,l)=-1
         end do
         if (kbar.eq.nz) GO TO 115
      endif
C
C
C     SKIP STATION IF NO DATA AT ANY ELEVATION
C
   90 DO 100 K=1,NZ
      IF(STDAT1(K,L).LT.EDITL) GO TO 110
  100 CONTINUE
      GO TO 115
c
c --- COMPUTE DISTANCE TO STATIONS LESS THAN RMAX AWAY
c --- RS2(mxnz):  Distance of closest station with valid data to
c                 present grid cell (whose coordinate is (X,Y))
c --- NRS2(mxnz): Station number of the closest station.
  110 RSX = X - XST(L)
      RSY = Y - YST(L)
      RS(L) = RSX**2 + RSY**2
      RS(L) = SQRT(RS(L))
c
c *** Loop over levels to find closest station with valid data
c *** (done independently for EACH layer)
c --- add check for barriers (050101)
      if(LVARY)then
         do 111 k=1,nz
           if (ok.gt.0 .or. k.gt.kbar) then
              if(stdat1(k,L).LT.editl)then
                 if(rs(L).lt.rs2(k))then
                    rs2(k)=rs(L)
                    nrs2(k)=L
                 endif
              endif
           endif
111      continue
      endif
c ***
c
      IF(RS(L).LT.RMIN) RS(L)=RMIN
      IF(RS(L) .LE. RMAX)  GO TO 115
      RS(L) = EDIT
  115 CONTINUE
  120 CONTINUE
c
c *** Check to make sure there is valid data from at least one station,
c *** when using LVARY option -- if not write message and stop
c *** program
      if(LVARY)then
         do 121 k=1,nz
           if(nrs2(k).EQ.0)then

c frr (09/01)if ( k .eq. 1 .or. noobs .eq. 0) then
             if ( (k .eq. 1 .and. noobs.ne.2) .or. noobs .eq. 0) then
c ---          It's OK if there are no observations if MM5 are used (NOOBS=1,2)
               write(io6,2063) i,j,k
               stop
             end if
           endif
121      continue
      endif
c ***
C
C     ORDER STATIONS
C
c...  First initialize arrays IS and JS
      DO 122 NN = 1,NST
        IS(NN)=IEDIT
        js(nn)=iedit
  122 CONTINUE
c
      CALL XMIT(NST,RS,WORK)
c
c...  Loop-130 is to put station sequence in near-to-far order.  Once
c...  a station is chosen, its distance value to the present grid cell
c...  in the WORK array is added to 999.0 so that you will not pick up
c...  that same station next round!
      N = 0
      DO 130 L = 1,NST
      CALL FMINF(WORK,NST,FMIN,NMIN)
      WORK(NMIN) = EDIT + L
      IS(L) = NMIN
      IF(FMIN.GT.EDITL)  GO TO 140
      N = N + 1
  130 CONTINUE
c
  140 IF (N .GT. 0 .OR. IPROG .GE. 1) GO TO 150
c
c...  LVARY =.true. means use a variable radius of influence so that if no
c...  stations were found within the radius of influence, N=0, the closest
c...  station to the grid point will be used (even though it is outside the
c...  radius of influence).
      if (LVARY)go to 150
c
c...  Fail the model only when no stations are within RMAX,
c...  LVARY=.false., and IPROG = 0
  145 if(iwr.gt.0)WRITE(IWR,2064) I,J
      WRITE(io6,2064) I,J
      STOP
c
  150 CONTINUE
c
      if(iprog.EQ.5 .OR. iprog.eq.15) then
c
c ---   Initialize ijout array (flag for using the prognostic grid
c ---   data at that point in the interpolation; 0=do not use,1=use)
c        do 125 m=1,npts
c          ijout(m) = 1
c125     continue
         call xmit (-npts*mxnz,1,ijout)
c
c ---   Initialize rm array (distances from prognostic grid point to
c ---   diagnostic grid point)
        call xmit(-npts,zero,rsqm)
c
c *** New code
c
c --- Get absolute x/y of CALMET point
c ***   xcm = x + utmxor
c ***   ycm = y + utmyor
c --- Compute CALMET grid coordinates in real space coordinates
        xcm = x + xmap0
        ycm = y + ymap0
c
        do 135 n44 = 1,npts
c
c --- Get MM4 coordinates relative to CALMET origin
c --- (XLCMM4,YLCMM4 are in real space coordinates)
c ***     xpc = xlcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - utmxor
c ***     ypc = ylcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - utmyor
          xpc = xlcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - xmap0
          ypc = ylcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - ymap0
c
c --- Check for barriers to interpolation of MM4/MM5/3D.DAT
          ok=1.
          if (nbar.le.0) goto 91

          call barier(x,y,xpc,ypc,ok)
          if(ok.LE.0.0) then
             do k=1,kbar
               ijout(n44,k) = 0
             end do
c ---        skip only if barriers up to the top (050101)
             if(kbar.eq.nz)  go to 135
          endif
c
91        continue

c --- Calculate distance from MM4 grid point to diagnostic grid point
          rsqm(n44) = (xlcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - xcm)
     &      ** 2. +
     &      (ylcmm4(igrab(i,j,n44),jgrab(i,j,n44)) - ycm) ** 2.
          rsqm(n44) = AMAX1(rsqm(n44),rminsq)
 135    continue
      endif

c --- END OF IPROG=5,15 computations

C
      DO 190 K=1,NZ
c
c...skip observations from NWS if only using MM4 data
c frr (09/01) noobs=1,2
c       if (k .gt. 1 .and. noobs .eq. 1) goto 181
        if ( (noobs.eq.2) .or. ( k.gt.1 .and. noobs.eq.1) ) goto 181
C
C...  Identify closest NINTRP stations which are within RMAX and which
c...  have valid data
      NK = 0
      if(n.eq.0)go to 161
      do 160 M=1,n
      L=IS(M)
      IF(STDAT1(K,L).GT.EDITL)  GO TO 160
      IF (RS(L) .GT. RMAX) GO TO 160
      NK = NK + 1
      JS(NK) = IS(M)
      IF (NK .EQ. NINTRP(K)) GO TO 165
160   CONTINUE
161   continue
c
      IF(NK .GT. 0 .OR. IPROG .GE. 1) GO TO 165
c
c --- If using LVARY option, and no stations with valid data are within
c --- RMAX, use closest station
      if (LVARY) then
        nk = 1
        js(nk)=nrs2(k)
        L=nrs2(k)
        rs(L)=rs2(k)
        if(rs(L).lt.rmin)rs(L)=rmin
        goto 165
      endif
      if(iwr.gt.0)WRITE(IWR,2065) I,J,K
      WRITE(io6,2065) I,J,K
      STOP
  165 CONTINUE
C
C     FIND THE INTERPOLATION WEIGHTING FACTOR FOR EACH VALID STATION
C
      if(nk.EQ.0)go to 181
      DO 180 M = 1,NK
      L=JS(M)
      IF(STDAT1(K,L) .GT. EDITL)  GO TO 180
c --- Compute weighting factor ( wt is for sfc obs, wt3 is for prognostic
c --- data as Step 1 Field)
c **  WT = 1./RS(L)**2
c
      wt = wo(i,j,k)/RS(L)**2
C
C     APPLY WEIGHTING FACTOR
C
      FIELD1(I,J,K) = FIELD1(I,J,K) + STDAT1(K,L)*WT
      FIELD2(I,J,K) = FIELD2(I,J,K) + WT
  180 CONTINUE
181   continue
c
      if(iprog.EQ.5 .OR. iprog.eq.15) then
c ---   Compute weighting factor for prognostic data used as observations
c ---   Compute weighted sums
        do 185 n44=1,npts
          if(ijout(n44,k).EQ.1) then
            wt2 = (1.0-wo(i,j,k))/rsqm(n44)
            field3(i,j,k) = field3(i,j,k) +
     &        pdat(igrab(i,j,n44),jgrab(i,j,n44),k)*wt2
c ***
            field4(i,j,k) = field4(i,j,k) + wt2
          endif
185     continue
      endif
c
c **  IF (IPROG .GE. 1) THEN
c **      FIELD1(I,J,K) = (FIELD1(I,J,K) + PROG(I,J,K)/RPROG**2)/
c ** 1                    (FIELD2(I,J,K) + 1./RPROG**2)
c **  ELSE
c **    FIELD1(I,J,K) = FIELD1(I,J,K)/FIELD2(I,J,K)
c **  ENDIF
      if(iprog.EQ.0) then
        if(field2(i,j,k).eq.0.)then
          write(io6,*)'ERROR in SUBR. INTERP -- ',
     1       ' FIELD2 = 0.0 -- I,J,K = ',i,j,k
          stop
        endif
        field1(i,j,k) = field1(i,j,k)/field2(i,j,k)
      else if(iprog.EQ.1 .OR. iprog.EQ.3  .OR. iprog.eq.13) then
c ---   Compute weighting factor (wt3 is for prognostic data as Step 1 Field)
        wt3 = (1-wo(i,j,k))/rprog**2
c ---   If using noobs=1(2), then levels 2(1) to nz will just be the step 1 field
c       (field 1 and field 2 = 0)
        field1(i,j,k) = (field1(i,j,k) + prog(i,j,k) * wt3)/
     1                  (field2(i,j,k) + wt3)
      else if(iprog.EQ.5 .OR. iprog.eq.15) then
c ---   If using noobs=1(2), then levels 2(1) to nz will just be the MM4 "obs"
c       (field 1 and field 2 = 0)
        field1(i,j,k) = (field1(i,j,k) + field3(i,j,k))/
     1                  (field2(i,j,k) + field4(i,j,k))
      else
         write(io6,*) 'ERROR in Subr. INTERP - Invalid value of IPROG; '
     1                ,' IPROG = ',iprog
         stop
      endif
  190 CONTINUE
  200 CONTINUE
 2063 format('JOB ABORTED--THERE ARE NO STATIONS WITH VALID DATA FOR ',
     1 'I = ',i4,' J = ',i4,' K = ',i4,' IN SUBR. INTERP')
 2064 FORMAT('JOB ABORTED--THERE ARE NO CLOSE STATIONS FOR I = ',
     1 I4,' J = ',I4,' IN SUBR. INTERP')
 2065 FORMAT('JOB ABORTED--THERE ARE NO CLOSE STATIONS FOR I = ',
     1 I4,' J = ',I4,' K = ',I4,' IN SUBR. INTERP')
      RETURN
      END
c----------------------------------------------------------------------
      subroutine intp(xparm,zl,nl,ius,z,xmissm,xint)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 970825               INTP
c ---          J. Scire, SRC
c              Modified to check for sounding layers at same height & 
c              verify lower height is below Z (J. Scire, 8/97)
c
c --- PURPOSE:  Interpolate an upper air parameter to height "z"
c
c --- INPUTS:
c
c    XPARM(mxus,mxlev) - real array - Upper air parameter to interpolate
c       ZL(mxus,mxlev) - real array - Height (m) of observations
c                   NL - integer    - Number of levels
c                  IUS - integer    - Station number of the upper air
c                                     sounding to interpolate
c                    Z - real       - Height (m) to interpolate
c               XMISSM - real       - Missing value indicator for the
c                                     upper air parameter
c        Parameters: MXUS, MXLEV, IO6
c
c --- OUTPUT:
c                 XINT - real       - Interpolated value of XPARM at
c                                     height Z
c
c --- INTP called by:  CGAMMA, FACET
c --- INTP calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real xparm(mxus,mxlev),zl(mxus,mxlev)
c
c --- Find the first level at or just above Z with valid data
      do 10 j=2,nl
       if(zl(ius,j).ge.z.and.xparm(ius,j).lt.xmissm)then
         nbp=j
         go to 20
      endif
10    continue
c
c --- Sounding does not go high enough
      write(io6,15)z,nl,zl(ius,nl)
15    format(//1x,'ERROR IN SUBR. INTP -- interpolation height is ',
     1 'above top sounding level'//5x,'Height = ',f10.1,5x,
     2 'No. sounding levels = ',i5,5x,'Top sounding height = ',f10.1)
      stop
c
c --- Find the next lowest layer with valid data
20    continue
      nbpm1=nbp-1
      do 22 j=nbpm1,1,-1
      if(xparm(ius,j).lt.xmissm)then
         nbm=j
         go to 28
      endif
22    continue
c
c --- Bottom of sounding is missing
      write(io6,27)nl,zl(ius,1),xparm(ius,1)
27    format(//1x,'ERROR IN SUBR. INTP -- bottom level of sounding ',
     1 'is missing'//5x,'No. sounding levels = ',i5,5x,
     2 'Bottom sounding height = ',f10.1,'Value = ',f10.2)
      stop
c
28    continue
c --- Check that layer "NBM" is at or below height "Z"
      if(zl(ius,nbm).gt.z)then
         write(io6,29)
29       format(//1x,'ERROR IN SUBR. INTP -- Sounding below height Z ',
     1   'is missing')
         write(io6,*)'NL = ',nl,' IUS = ',ius,' Z = ',z
         write(io6,*)'ZL = ',(zl(ius,n),n=1,nl)
         write(io6,*)'XPARM = ',(xparm(ius,n),n=1,nl)
      endif
c
c --- Compute delta Z of layer containing height "Z"
      dz=zl(ius,nbp)-zl(ius,nbm)
c
c --- Check for possible identical layer heights
      if(abs(dz).lt.1.e-5)then
c ---    Identical layer heights -- average two values
         xint=0.5*(xparm(ius,nbp)+xparm(ius,nbm))
      else
c ---    Interpolate parameter to height Z
         rat=(zl(ius,nbp)-z)/dz
         xint=xparm(ius,nbp)-(xparm(ius,nbp)-xparm(ius,nbm))*rat
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine ireplac(dist2,nsta,iarr,imiss,ideflt,ivalue)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130            IREPLAC
c ---          J. Scire, SRC
c
c --- PURPOSE:  Replace the missing value of an INTEGER variable with
c               the value from the closest station with valid data --
c               If all values are missing, set variable equal to the
c               default value (IDEFLT)
c
c --- INPUTS:
c   DIST2(nsta) - real     - Distance**2 from each station to the
c                            current station with missing data
c          NSTA - integer  - Number of stations
c    IARR(nsta) - integer  - Array of values at each station
c         IMISS - integer  - Missing value indicator
c        IDEFLT - integer  - Default value to be returned if all values
c                            are missing
c
c --- OUTPUT:
c        IVALUE - integer  - Value of the variable to be used in
c                            replacement of the missing value
c                            NOTE: if all values are missing,
c                            IVALUE is set equal to IDEFLT
c
c --- IREPLAC called by:  MISSFC
c --- IREPLAC calls:      none
c----------------------------------------------------------------------
c
      real dist2(nsta)
      integer iarr(nsta)
c
      data xmax/1.e38/
c
      dmin2=xmax
      ista=0
c
c --- Loop over stations
      do 10 i=1,nsta
c
c --- Find the closest non-missing value
      if(iarr(i).lt.imiss)then
c
         if(dist2(i).lt.dmin2)then
            dmin2=dist2(i)
            ista=i
         endif
      endif
10    continue
c
c --- Return the appropriate value
      if(ista.ge.1)then
c
c ---    At least one station with non-missing data
         ivalue=iarr(ista)
      else
c
c ---    All values missing -- use default value
         ivalue=ideflt
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine llbreez
c----------------------------------------------------------------------
c --- CALMET   Version: 6.4.0     Level: 940930            LLBREEZ
c         R. Mentzer, SRC
c         Modified by M. Fernau
c
c    This routine will set up for the lake breeze region of
c    influence
c
c --- NOTE: If an upper air station is co-located with a surface
c           station and the IDs are the same, then the surface
c           station will be used.  If IDs are different, then
c           both will be used.
c
c    INPUTS   XBCST,YBCST  The first point defining the coastline
c             XECST,YECST  The last point defining the coastline
c             NLB          The number of surface stations within the
c                          box
c             IBOXID      Array of surf.sta. id's that are in the box
c
c    OUTPUTS  Updated U avd V values
c
c    CALLS :  COORD, INTERB, BOX
c
c    CALLED BY: DIAGNO
c
c*********************************************************************
      include 'params.met'
      include 'grid.met'
      include 'met1.met'
      include 'breez.met'
      include 'd1.met'
      include 'ovrwat.met'
      real ubsta(mxwnd),vbsta(mxwnd)
      real dp(mxwnd)
      real ug1,ug2,xbsta(mxwnd),ybsta(mxwnd)
      real xsta(mxwnd),ysta(mxwnd),ista(mxwnd)
      real dg,gridsign,statsign(mxwnd)
c
c...Loop over the regions to be used
c
      do 500 ibx = 1,nbox
c
c...calculate the line equation of the coast
c
        xcd = xbcst(ibx) - xecst(ibx)
        ycd = ybcst(ibx) - yecst(ibx)
        if (xcd .eq. 0) then
          cslope = 9.9E19
        else
          cslope = ycd / xcd
        end if
        yinter = ybcst(ibx) - cslope * xbcst(ibx)
c
c...get proper met stations; load location and data
c
        nsta = nssta + nowsta + nusta
        nstat = nssta + nowsta
        do 95 k = 1,nstat
          if (k .le. nssta) then
            ista(k) = idssta(k)
            xsta(k) = xssta(k)
            ysta(k) = yssta(k)
          else
            ista(k) = idowsta(k - nssta)
            xsta(k) = xowsta(k - nssta)
            ysta(k) = yowsta(k - nssta)
          end if
 95     continue
        if (nusta .gt. 0) then
          do 98 k=1,nusta
            ista(nstat+k) = idusta(k)
            xsta(nstat+k) = xusta(k)
            ysta(nstat+k) = yusta(k)
 98       continue
        end if
        do 100 j = 1,nlb(ibx)
          do 105 k = 1,nsta
            if(iboxid(ibx,j) .eq. ista(k)) then
              ubsta(j) = us(1,k)
              vbsta(j) = vs(1,k)
              xbsta(j) = xsta(k)
              ybsta(j) = ysta(k)
              goto 100
            endif
105       continue
100     continue
c
c   find the distance from the station to the shore
c
        do 107 kk = 1,nlb(ibx)
          if (xcd .eq. 0.) then
c
c...vertical coast
c
            dp(kk) = abs(xbsta(kk) - xecst(ibx))
          else if (ycd .eq. 0) then
c
c...horizontal coast
c
            dp(kk) = abs(ybsta(kk) - yecst(ibx))
          else
c
c...slanted coast line; create a right triangle between the station
c...and the coast line or its extension.
c
            yc1 = xbsta(kk) * cslope + yinter
            xc2 = (ybsta(kk) - yinter) / cslope
c
c...calculate the length of the three sides of the right triangle
c
            a = abs(yc1 - ybsta(kk))
            b = abs(xc2 - xbsta(kk))
            c = sqrt(a**2 + b**2)
c
c...drop a perpendicular from the station to the coast and calculate
c...its distance
c
            if (c .gt. 0.) then
              dp(kk) = a * b / c
            else
              dp(kk) = 0.
            end if
          end if
c
c...drop a vertical line from the station to the coast and calculate
c...its distance; it will be compared to a vertical line from the
c...grid cell to the coast; same sign means same side of coast; this
c...info is used in INTERB to get proper distance differential
c
          statsign(kk) = ybsta(kk) - cslope * xbsta(kk) - yinter
 107    continue
        do 110 i = 1,nx
          do 115 j = 1,ny
            call box(ibx,float(i),float(j),ok)
            if (ok .le. 0.) goto 115
c
c...grid point is inside lake breeze box
c
c...convert grid point to relative utm coordinates in meters
c
            xgc = (float(i) - 0.5) * dgrid
            ygc = (float(j) - 0.5) * dgrid
c
c   find the distance from the grid cell to the shore....
c
            if (xcd .eq. 0.) then
c
c...vertical coast
c
              dg = abs(xgc - xecst(ibx))
            else if (ycd .eq. 0) then
c
c...horizontal coast
c
              dg = abs(ygc - yecst(ibx))
            else
c
c...slanted coast line; create a right triangle between the grid cell
c...and the coast line or its extension.
c
              yc1 = xgc * cslope + yinter
              xc2 = (ygc - yinter) / cslope
c
c...calculate the length of the three sides of the right triangle
c
              a = abs(yc1 - ygc)
              b = abs(xc2 - xgc)
              c = sqrt(a**2 + b**2)
c
c...drop a perpendicular from the grid cell to the coast and calculate
c...its distance
c
              if (c .gt. 0.) then
                dg = a * b / c
              else
                dg = 0.
              end if
            end if
c...drop a vertical line from the grid cell to the coast and calculate
c...its distance; it will be compared to a vertical line from the
c...station to the coast; same sign means same side of coast; this
c...info is used in INTERB to get proper distance differential
c
            gridsign = ygc - cslope * xgc - yinter
c
c...use weighted interpolation for the grid cell; weight is the
c...difference in the relative distances from coastline for station
c...and cell (does not consider directly the actual geographical
c...distance between grid cell and station)
            call interb(ubsta,ug1,dp,nlb(ibx),dg,gridsign,statsign)
            call interb(vbsta,ug2,dp,nlb(ibx),dg,gridsign,statsign)
c
c...if any observations were present, substitute new lake breeze
c...vector for the original CALMET vector
c
            mefskip = 0
            if (ug1.gt.990. .or. ug2.gt.990.) then
              write(33,*) ' no wind data in region, cell: ',i,j
c             stop
              mefskip = 1
            end if
            if (mefskip.eq.0) then
              u(i,j,1) = ug1
              v(i,j,1) = ug2
            end if
115       continue
110     continue
500   continue
      return
      end
c----------------------------------------------------------------------
      subroutine microi(nsecdt)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060218             MICROI
c ---          J. Scire, SRC
c
c --- PURPOSE:  Set-up computations for micrometeorological model
c               including latitudes & longitudes of all gridpoints,
c               and gridded Coriolis parameter
c
c --- UPDATES:
c
c --- V6.2 Level 060215 to v6.201 Level 060218 (F.Robe)
c             (1) dgrid used instead of dx,dy in computation of xkm,ykm,lat,long 
c                 because dx,xy not yet defined (done in diagi)
c
c --- V5.6 (050328) to V6.2 Level 060215  (F.Robe)
c             (1) compute constants onedte and  twodte using actual timestep
c                 (not necessarily one hour in MOD6)
c
c --- V5 Level 000602b to V5.6 (050328) - F.Robe
c
c             (1) Compute mapping parameters from (X,Y)-CALMET to (Lat,Lon)
c                 (same datum) and store them in MAP.MET 
c                 so they can be used for other similar transformations
c                 (e.g. in RDOW)
c
c             (2) Compute gridded lat,lon and store them in grid.met
c
c             (3) Compute gridded field of Coriolis parameter and 
c                 make cmech an array (mxnx x mxny) 
c
c --- 000602b - Modified to allows default values of ha1,ha2,hb1,hb2,
c               hc1,hc2,hc3 to be set in block data and modified
c               in control file inputs
c
c --- INPUT:
c       Common block /ZIPARM/ variables
c          constb,conste,
c       Common block /HFLUX/ variables
c          hc3       
c       Common block /MAP/ variables
c          utmhem,datum,pmap,xlat1,xlat2,rnlat0,relon0,feast,fnorth
c       Common block /GRID/ variables
c           xmap0,ymap0,xy,xy,nx,ny
c
c       Parameters: MXNX, MXNY, MXOWS
c
c --- OUTPUT:
c       Common block /HFLUX/ variables
c          hc3p1
c       Common block /ZIPARM/ variables
c          fcori(mxnx,mxny),cmech(mxnx,mxny), twodte, onedte
c
c       Common block /GRID/ variables
c          xlat(mxnx,mxny),xlon(mxnx,mxny)
c
c       Common block /MAP/ variables
c          cactionll, vectill,vectoll
c
c --- MICROI called by: SETUP
c --- MICROI calls: GLOBE1,GLOBE
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      include 'map.met'
      include 'grid.met'
      include 'hflux.met'
      include 'ziparm.met'

      character*8 cmapi,cmapo
      character*4 c4hem

c
c --- COMPUTE MAPPING PARAMETERS from projection (x,y)km to N.lat/E.lon
c
c --- Scale factor for Tangential TM projection
      tmsone=1.00000
c --- Set translation vectors going from projection(x,y)km
c --- to N.lat/E.lon
      iutmi=iutmzn
      if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmi=-iutmi
      cmapi=pmap
      if(cmapi.EQ.'TTM     ') cmapi='TM      '
      cmapo='LL      '
      idum=0
      rdum=0.0
      call GLOBE1(cmapi,iutmi,tmsone,xlat1,xlat2,rnlat0,relon0,
     &            feast,fnorth,
     &            cmapo,idum,rdum,rdum,rdum,rdum,rdum,
     &            rdum,rdum,
     &            cactionll,vectill,vectoll)

c --- Compute latitude/longitude of each gridpoint
      twopi=2*3.141592

      do j=1,ny
         do i=1,nx
c ---       Compute coordinates of gridpoint (in km)
c           xkm= xmap0 +(float(i)-0.5)*dx*0.001
c           ykm= ymap0 +(float(j)-0.5)*dy*0.001
            xkm= xmap0 +(float(i)-0.5)*dgrid*0.001
            ykm= ymap0 +(float(j)-0.5)*dgrid*0.001

c ---       Compute the N.lat/W.lon for (xkm,ykm)
            call GLOBE(io6,cactionll,datum,vectill,datum,vectoll,
     &              xkm,ykm,xelon,xnlat,izone,c4hem)
            xlat(i,j)=xnlat
            xlon(i,j)=xelon

c ---       Compute the gridded field of Coriolis parameter values
c           f=2 *omega *sin(lat) - unless f is given by the user
            if (fcoriol.gt.998.) then
               f= 2*(twopi/86400.)*sin(xlat(i,j)*twopi/360.)
            else
               f=fcoriol
            endif
c ---       Set a minimum value to avoid divisions by 0- Use Absolute value
c ---       min corresponds to a latitude of about 10degrees
            fcori(i,j)=max(abs(f),0.25e-4)

c ---       CMECH is constb/sqrt(f), where f is the absolute value of
c ---       the Coriolis parameter 
            cmech(i,j)=constb/sqrt(fcori(i,j))


         enddo
      enddo

 
c --- Energy budget variables -- Holtslag and van Ulden (1973)
c        UNITS:  HA1 (W/m**2),   HA2 (W/m**2),
c                HB1 (no units), HB2 (no units)
c                HC1 (W/m**2/deg. K**6), HC2 (W/m**2), HC3 (no units)

      hc3p1=hc3+1.0
c
c --- compute other mixing height variables in common
c     Assume time step of one hour (3600. sec)
c     twodte=7200.*conste
c     onedte=3600.*(1.+conste)
c --- In MOD6, timestep can be sub-hourly
c     twodte=7200.*conste
c     onedte=3600.*(1.+conste)
      twodte=2.*nsecdt*conste
      onedte=nsecdt*(1.+conste)
c
      return
      end
c----------------------------------------------------------------------
      subroutine minim(u,v,w,ub,vb,div,niter,divlim)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328              MINIM
c ---          S.DOUGLAS, SAI
C
c
c --- UPDATES:
c --- V5.6 (050328)- explicit common replaced by include 'd6.met'
c
c --- include parameters
      include 'params.met'
c
      DIMENSION U(mxnx,mxny,*),V(mxnx,mxny,*),W(mxnx,mxny,*),
     1          UB(mxny,2,*),VB(mxnx,2,*),DIV(mxnx,mxny,*)

      include 'grid.met'

      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,irdp
C
C     ITERATIVE SCHEME TO MINIMIZE DIVERGENCE
C
C     INPUTS:  U (R ARRAY)   - GRIDDED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY)   - GRIDDED Y-DIRECTION WIND COMPONENTS
C              W (R ARRAY)   - GRIDDED VERTICAL WIND COMPONENTS
C              UB (R ARRAY)  - U-COMPONENT BOUNDARY VALUES
C              VB (R ARRAY)  - V-COMPONENT BOUNDARY VALUES
C              DIV (R ARRAY) - 3-D DIVERGENCE
C              NITER (I)     - MAXIMUM NUMBER OF ITERATIONS
C              DIVLIM (R)    - MAXIMUM DIVERGENCE
c        Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C
C     OUTPUTS:  U (R ARRAY) - NON-DIVERGENT X-DIRECTION WIND
C                             COMPONENT
C               V (R ARRAY) - NON-DIVERGENT Y-DIRECTION WIND
C                             COMPONENT
      if(iwr.gt.0)WRITE(IWR,2809)
      DO 10 K=1,NZ
      ITER=0
C
C     COMPUTE DIVERGENCE
C
      DIVMAX=-1.0E+09
      CALL DIVCEL(U,V,W,DIV,UB,VB,DIVMAX,K)
      IF (DIVMAX .LE. DIVLIM) GO TO 10
C
C     ADJUST HORIZONTAL WIND FIELDS
C
      DO 20 ITER=1,NITER
      DO 30 IDIR=1,4
      DO 40 JJ=1,NY
      DO 40 II=1,NX
      GO TO (50,60,70,80), IDIR
  50  I=II
      J=JJ
      GO TO 90
  60  I=NX-II+1
      J=JJ
      GO TO 90
  70  I=II
      J=NY-JJ+1
      GO TO 90
  80  I=NX-II+1
      J=NY-JJ+1
  90  CONTINUE
      IF (DIV(I,J,K) .EQ. 0.) GO TO 40
      IP1=I+1
      IM1=I-1
      JP1=J+1
      JM1=J-1
      UIM1=UB(J,1,K)
      IF (I .GT. 1) UIM1=U(IM1,J,K)
      VJM1=VB(I,1,K)
      IF (J .GT. 1) VJM1=V(I,JM1,K)
      UIP1=UB(J,2,K)
      IF (I .LT. NX) UIP1=U(IP1,J,K)
      VJP1=VB(I,2,K)
      IF (J .LT. NY) VJP1=V(I,JP1,K)
      ALPHA1=0.5
      ALPHA2=0.5
      ALPHA3=0.5
      ALPHA4=0.5
      AL1234=ALPHA1+ALPHA2+ALPHA3+ALPHA4
      IF (AL1234 .LT. 1.E-6) GO TO 40
      UT=-2.*(DIV(I,J,K)*DX)/AL1234
      VT=-2.*(DIV(I,J,K)*DY)/AL1234
      UIP1=UIP1+ALPHA1*UT
      UIM1=UIM1-ALPHA2*UT
      VJP1=VJP1+ALPHA3*VT
      VJM1=VJM1-ALPHA4*VT
      IF (I .GT. 1) U(IM1,J,K)=UIM1
      IF (I .LT. NX) U(IP1,J,K)=UIP1
      IF (J .GT. 1) V(I,JM1,K)=VJM1
      IF (J .LT. NY) V(I,JP1,K)=VJP1
  40  CONTINUE
      DIVMAX=-1.0E+09
      CALL DIVCEL(U,V,W,DIV,UB,VB,DIVMAX,K)
C
C     RESET BOUNDARY CONDITIONS
C
      CALL WINDBC(U,V,UB,VB,K)
   30 CONTINUE
C
C     CONVERGENCE TEST FOR DIVERGENCE MAGNITUDE
C
      IF (DIVMAX .LE. DIVLIM) GO TO 10
   20 CONTINUE
   10 if(iwr.gt.0)WRITE(IWR,2810) K,ITER,DIVMAX
C
 2809 FORMAT(//,5X,'SUMMARY OF DIVERGENCE MINIMIZATION'
     1,//,'  LEVEL   ITERATIONS   MAXIMUM DIVERGENCE (/SEC)')
 2810 FORMAT(3X,I2,I11,12X,E10.3)
      RETURN
      END
c----------------------------------------------------------------------
      subroutine missfc(iyr,ijul,ihr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level:  101006            MISSFC
c ---          J. Scire, SRC
c
c --- PURPOSE:  Fill in missing values of certain surface met.
c               variables using data from the nearest station with
c               non-missing data  -- Met. variables checked in this
c               routine are: Ceiling height (ICEIL), cloud cover (ICC),
c               air temperature (TEMPK), relative humidity (IRH), and
c               surface pressure (PRES)
c
c               NOTE: wind speed (WS), wind direction (WD), and
c               precipitation code (IPCODE) are NOT checked because
c               missing values are allowed for these variables.
c
c               ALSO NOTE that the original temp. data (i.e., with
c               missing values) is saved in OTEMPK.
c
c --- UPDATES:
c
c---  V6.217 Level 061231 to V6.330 Level 101006 (CEC)
c           - Change ICLOUD into MCLOUD (and ICLDOUT)
c
c---  V5.6 Level 050328 to V6.217 Level 061231 (Frr):
c           - Allow icloud=4 option
c
c---  V5.1 Level 991104 to V5.6 Level 050328 (Frr):
c           - Store OTEMPK in MET2.MET (no longer in calling list)
c
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c           IYR - integer  - Year
c          IJUL - integer  - Julian day
c           IHR - integer  - Hour (NOTE: date/hr used in printing of
c                            error messages)
c       Common block /MET1/ variables:
c             nssta,xssta(mxss),yssta(mxss),mcloud,icldout
c       Common block /MET2/ variables:
c             iceil(mxss),icc(mxss),tempk(mxss),irh(mxss),pres(mxss)
c       Parameters: MXSS, MXUS, MXPS, IO6
c
c --- OUTPUT:
c       Common block /MET2/ variables:
c             iceil(mxss),icc(mxss),tempk(mxss),irh(mxss),pres(mxss)
c             OTEMPK(mxss):Original temperatures at surface stations
c             (deg. K) BEFORE replacing missing values (in met2 since 050328)
c --- MISSFC called by:  COMP
c --- MISSFC calls:      CMPD2, IREPLAC, RREPLAC
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      real dist2(mxss)
c     real otempk(mxss): otempk stored in met2.met (050328)
      real opres(mxss)
      integer jceil(mxss),jcc(mxss),jrh(mxss)
      logical ldist
c
c --- Include common blocks
      include 'met1.met'
      include 'met2.met'
c
      data imiss/9999/,xmiss/9999./
      data ierr/0/
c
c --- Reduce real missing value indicator by a slight amount
c --- to allow for machine roundoff
      xmissm=xmiss-0.01
c
c --- Store original values in local arrays
      do 10 i=1,nssta
         jceil(i)=iceil(i)
         jcc(i)=icc(i)
         otempk(i)=tempk(i)
         jrh(i)=irh(i)
         opres(i)=pres(i)
10    continue
c
c ------------------------------
c --- Loop over surface stations
c ------------------------------
      do 100 i=1,nssta
c
c --- LDIST tracks whether distance**2 from station "i" to every other
c --- surface station have been computed (i.e., LDIST=.true.) or not
c --- (i.e., LDIST=.false.)
      ldist=.false.
c
c ------------------
c --- Ceiling height
c ------------------
c frr (021105): okay if all missing if cloud ceiling and cover from MM5
ccec101006      if(iceil(i).ge.imiss. and. icloud.lt.3)then
      if(iceil(i).ge.imiss. and. mcloud.lt.3)then
c
c ---    Ceiling height is missing at station "i"
         if(.not.ldist)then
c
c ---       Distance**2 not yet computed -- therefore compute them now
            ldist=.true.
            call cmpd2(xssta(i),yssta(i),xssta,yssta,nssta,dist2)
         endif
c
c ---    Replace missing value with nearest non-missing station value
         call ireplac(dist2,nssta,jceil,imiss,imiss,iceil(i))
c
c ---    If all data missing, write error message
         if(iceil(i).ge.imiss)then
            write(io6,9992)iyr,ijul,ihr
9992        format(/1x,'ERROR in SUBR. MISSFC -- IYR = ',i4,2x,
     1       'IJUL = ',i3,2x,'IHR = ',i2)
            write(io6,*)'CEILING HEIGHT data at all stations ',
     1       'missing for this hour -- At least one station must ',
     2       'have non-missing data -- NSSTA = ',nssta,
     3       ' JCEIL = ',(jceil(n),n=1,nssta)
            ierr=1
         endif 
      endif
c
c ---------------
c --- Cloud cover
c ---------------
c frr (021105): okay if all missing if cloud ceiling and cover from MM5
ccec101006      if(icc(i).ge.imiss .and. icloud.lt.3)then
      if(icc(i).ge.imiss .and. mcloud.lt.3)then
c
c ---    Cloud cover is missing at station "i"
         if(.not.ldist)then
c
c ---       Distance**2 not yet computed -- therefore compute them now
            ldist=.true.
            call cmpd2(xssta(i),yssta(i),xssta,yssta,nssta,dist2)
         endif
c
c ---    Replace missing value with nearest non-missing station value
         call ireplac(dist2,nssta,jcc,imiss,imiss,icc(i))
c
c ---    If all data missing, write error message
         if(icc(i).ge.imiss)then
            write(io6,9992)iyr,ijul,ihr
            write(io6,*)'CLOUD COVER data at all stations ',
     1       'missing for this hour -- At least one station must ',
     2       'have non-missing data -- NSSTA = ',nssta,
     3       ' JCC = ',(jcc(n),n=1,nssta)
            ierr=1
         endif
      endif
c
c -------------------
c --- Air Temperature
c -------------------
c frr (021105): okay if all missing if sf temp from MM5
      if(tempk(i).ge.xmissm .and. itprog.ne.2)then
c
c ---    Temperature is missing at station "i"
         if(.not.ldist)then
c
c ---       Distance**2 not yet computed -- therefore compute them now
            ldist=.true.
            call cmpd2(xssta(i),yssta(i),xssta,yssta,nssta,dist2)
         endif
c
c ---    Replace missing value with nearest non-missing station value
         call rreplac(dist2,nssta,otempk,xmissm,xmiss,tempk(i))
c
c ---    If all data missing, write error message
         if(tempk(i).ge.xmissm)then
            write(io6,9992)iyr,ijul,ihr
            write(io6,*)'AIR TEMPERATURE data at all stations ',
     1       'missing for this hour -- At least one station must ',
     2       'have non-missing data -- NSSTA = ',nssta,
     3       ' OTEMPK = ',(otempk(n),n=1,nssta)
            ierr=1
         endif
      endif
c
c ---------------------
c --- Relative humidity
c ---------------------
      if(irh(i).ge.imiss)then
c
c ---    Relative humidity is missing at station "i"
         if(.not.ldist)then
c
c ---       Distance**2 not yet computed -- therefore compute them now
            ldist=.true.
            call cmpd2(xssta(i),yssta(i),xssta,yssta,nssta,dist2)
         endif
c
c ---    Replace missing value with nearest non-missing station value
         call ireplac(dist2,nssta,jrh,imiss,imiss,irh(i))
c
c ---    If all data missing, write error message
         if(irh(i).ge.imiss)then
            write(io6,9992)iyr,ijul,ihr
            write(io6,*)'RELATIVE HUMIDITY data at all stations ',
     1       'missing for this hour -- At least one station must ',
     2       'have non-missing data -- NSSTA = ',nssta,
     3       ' JRH = ',(jrh(n),n=1,nssta)
            ierr=1
         endif
      endif
c
c --------------------
c --- Surface pressure
c --------------------
      if(pres(i).ge.xmissm)then
c
c ---    Pressure is missing at station "i"
         if(.not.ldist)then
c
c ---       Distance**2 not yet computed -- therefore compute them now
            ldist=.true.
            call cmpd2(xssta(i),yssta(i),xssta,yssta,nssta,dist2)
         endif
c
c ---    Replace missing value with nearest non-missing station value
         call rreplac(dist2,nssta,opres,xmissm,xmiss,pres(i))
c
c ---    If all data missing, write error message
         if(pres(i).ge.xmissm)then
            write(io6,9992)iyr,ijul,ihr
            write(io6,*)'SURFACE PRESSURE data at all stations ',
     1       'missing for this hour -- At least one station must ',
     2       'have non-missing data -- NSSTA = ',nssta,
     3       ' OPRES = ',(opres(n),n=1,nssta)
            ierr=1
         endif
      endif
c
c --- If all data missing for any variable, terminate execution
      if(ierr.eq.1)stop
c
c --- End of loop over surface stations
100   continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine mixdt(ihrgmt,i,j,ista,htold,nlev,zl,tz,dptmin,dzzi,
     1 tht,thtp,dtheta)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 950825              MIXDT
c ---          J. Scire, SRC
c              Modified 8/97 - J. Scire
c
c --- PURPOSE:  Calculate the potential temperature lapse rate
c               (deg. K/m) in a layer "DZZI" meters deep above the
c               previous hour's convective mixing height
c
c --- INPUTS:
c               IHRGMT - integer       - Local time (GMT) (IHRGMT can
c                                        be >= 24)
c                  I,J - integers      - Grid cell indexes
c                 ISTA - integer       - Number of nearest upper air
c                                        station to grid cell (I,J)
c                HTOLD - real          - Height (m) of previous hour's
c                                        convective mixing height
c                 NLEV - integer       - Number of levels in current
c                                        temperature sounding
c       ZL(mxus,mxlev) - real array    - Height (m) of each level in
c                                        current sounding
c       TZ(mxus,mxlev) - real array    - Temperature (deg. K) at each
c                                        height in current sounding
c               DPTMIN - real          - Minimum potential temperature
c                                        lapse rate (deg. K/m)
c                 DZZI - real          - Depth (m) of layer above
c                                        mixing height through which
c                                        potential temp. lapse rate is
c                                        computed
c       Common block /gen/ variables
c           NYR, NJUL
c       Parameters: MXUS, MXLEV, IO6
c
c --- OUTPUT:
c                  THT - real          - Temperature (deg. K) at height
c                                        "HTOLD" meters
c                 THTP - real          - Temperature (deg. K) at height
c                                        "HTOLD + DZZI" meters
c               DTHETA - real          - Potential temperature lapse rate
c                                        (deg. K) in "DZZI" meter layer
c                                        above convective mixing height
c
c --- MIXDT called by:  MIXHT
c --- MIXDT calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real zl(mxus,mxlev),tz(mxus,mxlev)
c
      include 'gen.met'
c
      data xmiss/999.9/
c
c --- Reduce missing value indicator by a slight amount to allow for
c --- machine roundoff
      xmissm=xmiss-0.01
c
c ------------------------------------------------------------
c --- Find highest level w/ valid data at or below HTOLD -- KL
c ------------------------------------------------------------
      kl=0
      do k=1,nlev
c
c ---    At first height above HTOLD, skip out of loop
         if(zl(ista,k).gt.htold)go to 12
c
c ---    If data is valid, keep store this level
         if(tz(ista,k).lt.xmissm)kl=k
      enddo
c
c --- If search unsuccessful, write error message
12    continue
      if(kl.eq.0)then
         write(io6,15)
15       format(//1x,'ERROR in subr. MIXDT -- no valid data below ',
     1   'HTOLD found in the sounding')
         write(io6,*)'ISTA = ',ista,' NLEV= ',nlev
         write(io6,*)'IHRGMT = ',ihrgmt,' I = ',I,' J = ',j
         write(io6,*)'HTOLD = ',htold,' DZZI = ',dzzi
         do nl=1,nlev
            write(io6,*)'NL: ',nl,' ZL: ',zl(ista,nl),' TZ: ',
     1       tz(ista,nl)
         enddo
         stop
      endif
c
c ------------------------------------------------------
c --- Find lowest level w/ valid data above HTOLD -- KLP
c ------------------------------------------------------
      klp=0
      klp1=kl+1
      do k=klp1,nlev
c
c ---    Level must be above HTOLD & data valid
         if(zl(ista,k).gt.htold.and.tz(ista,k).lt.xmissm)then
            klp=k
            go to 27
         endif
      enddo
c
c --- If search unsuccessful, write error message
      if(klp.eq.0)then
         write(io6,25)
25       format(//1x,'ERROR in subr. MIXDT -- no valid data above ',
     1   'HTOLD found in the sounding')
         write(io6,*)'ISTA = ',ista,' NLEV= ',nlev
         write(io6,*)'IHRGMT = ',ihrgmt,' I = ',I,' J = ',j
         write(io6,*)'HTOLD = ',htold,' DZZI = ',dzzi
         do nl=1,nlev
            write(io6,*)'NL: ',nl,' ZL: ',zl(ista,nl),' TZ: ',
     1       tz(ista,nl)
         enddo
         stop
      endif
27    continue
c
c -----------------------------------------------------------------
c --- Find highest level w/ valid data at or below HTOLD+DZZI -- KU
c -----------------------------------------------------------------
      htpdz=htold+dzzi
      ku=0
      do k=kl,nlev
c
c ---    At first height above HTOLD+DZZI, skip out of loop
         if(zl(ista,k).gt.htpdz)go to 32
c
c ---    If data is valid, keep store this level
         if(tz(ista,k).lt.xmissm)ku=k
      enddo
32    continue
c
c --- If search unsuccessful, write error message
      if(ku.eq.0)then
         write(io6,35)
35       format(//1x,'ERROR in subr. MIXDT -- no valid data below ',
     1   'HTOLD+DZZI found in the sounding')
         write(io6,*)'ISTA = ',ista,' NLEV= ',nlev
         write(io6,*)'IHRGMT = ',ihrgmt,' I = ',I,' J = ',j
         write(io6,*)'HTOLD = ',htold,' DZZI = ',dzzi,' HTPDZ = ',htpdz
         do nl=1,nlev
            write(io6,*)'NL: ',nl,' ZL: ',zl(ista,nl),' TZ: ',
     1       tz(ista,nl)
         enddo
         stop
      endif
c
c -----------------------------------------------------------
c --- Find lowest level w/ valid data above HTOLD+DZZI -- KUP
c -----------------------------------------------------------
      kup=0
      kup1=ku+1
      do k=kup1,nlev
c
c ---    Level must be above HTOLD+DZZI & data valid
         if(zl(ista,k).gt.htpdz.and.tz(ista,k).lt.xmissm)then
            kup=k
            go to 47
         endif
      enddo
c
c --- If search unsuccessful, write error message
      if(kup.eq.0)then
         write(io6,45)
45       format(//1x,'ERROR in subr. MIXDT -- no valid data above ',
     1   'HTOLD+DZZI found in the sounding')
         write(io6,*)'ISTA = ',ista,' NLEV= ',nlev
         write(io6,*)'IHRGMT = ',ihrgmt,' I = ',I,' J = ',j
         write(io6,*)'HTOLD = ',htold,' DZZI = ',dzzi,' HTPDZ = ',htpdz
         do nl=1,nlev
            write(io6,*)'NL: ',nl,' ZL: ',zl(ista,nl),' TZ: ',
     1       tz(ista,nl)
         enddo
         stop
      endif
47    continue
c
c --- Compute temperature at HTOLD by interpolation
      tht=tz(ista,klp)-(tz(ista,klp)-tz(ista,kl))*
     1    (zl(ista,klp)-htold)/(zl(ista,klp)-zl(ista,kl))
c
c --- Compute temperature at HTOLD+DZZI by interpolation
      thtp=tz(ista,kup)-(tz(ista,kup)-tz(ista,ku))*
     1   (zl(ista,kup)-htpdz)/(zl(ista,kup)-zl(ista,ku))
c
c --- Compute potential temperature lapse rate (deg. K/m)
      dtheta=(thtp-tht)/dzzi+0.0098
c
c --- dptmin is minimum stable pot. temp. lapse rate
      dtheta=amax1(dtheta,dptmin)
c
      return
      end
c----------------------------------------------------------------------
      subroutine mixdt2(ihrgmt,i,j,htold,dptmin,dzzi,tsf,tht,thtp,
     :                  dtheta)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328             MIXDT2
c ---          F.Robe based on MIXDT (J. Scire, SRC)
c              
c
c --- PURPOSE:  Calculate the potential temperature lapse rate
c               (deg. K/m) in a layer "DZZI" meters deep above the
c               previous hour's convective mixing height
c               Based on prognostic input only (no upper air obs.)
c               MIXDT2 uses the latest actual MM5 sounding
c               (i.e. no time interpolation)
c
c --- UPGRADES:
c --- Level 020211 to V5.6 Level 050328
c        - Add surface temperature to calling list
c
c
c --- INPUTS:
c               IHRGMT - integer       - Local time (GMT) (IHRGMT can
c                                        be >= 24)- Beginning time
c                  I,J - integers      - Grid cell indexes
c                HTOLD - real          - Height (m) of previous hour's
c                                        convective mixing height
c               DPTMIN - real          - Minimum potential temperature
c                                        lapse rate (deg. K/m)
c                 DZZI - real          - Depth (m) of layer above
c                                        mixing height through which
c                                        potential temp. lapse rate is
c                                        computed
c       INPUT via COMMON /MM5TEMP/
c                   ZL - real array    - Heights (m) of MM5 levels at MM5 gridpoint
c                                        closest to CALMET gridpoint
c                   TZ - real array    - MM5 Temperature (deg. K) at MM5 levels of
c                                        MM5 gridpoint closest to CALMET gridpoint
c                  NLEV- integer       - Number of vertical levels in MM5 + 1(sf)
c
c       Common block /gen/ variables
c           NYR, NJUL
c       Parameters: MXUS, MXLEV, IO6
c
c --- OUTPUT:
c                  TSF - real          - Surface Air Temperature (deg. K) 
c                  THT - real          - Temperature (deg. K) at height
c                                        "HTOLD" meters
c                 THTP - real          - Temperature (deg. K) at height
c                                        "HTOLD + DZZI" meters
c               DTHETA - real          - Potential temperature lapse rate
c                                        (deg. K) in "DZZI" meter layer
c                                        above convective mixing height
c
c --- MIXDT2 called by:  MIXHBG, MIXHMC
c --- MIXDT2 calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c --- do not need mm4hdo.met and gen.met(050328)
c     include 'mm4hdo.met'
c     include 'gen.met'  

c     Prognostic temperature soundings at each gridpoint (read in rdmm5)
      common /mm5temp/nlev,zl(mxnx,mxny,mxnzp+1),
     :        tz(mxnx,mxny,mxnzp+1)
c
      data xmiss/999.9/
c
c --- Reduce missing value indicator by a slight amount to allow for
c --- machine roundoff
      xmissm=xmiss-0.01

c --- Surface Air temperature at MM5 gridpoint nearest to CALMET  (i,j)
      tsf=tz(i,j,1)

c ------------------------------------------------------------
c --- Find highest level w/ valid data at or below HTOLD -- KL
c ------------------------------------------------------------
      kl=0
      do k=1,nlev
c
c ---    At first height above HTOLD, skip out of loop
         if(zl(i,j,k).gt.htold)go to 12
c
c ---    If data is valid, keep store this level
         if(tz(i,j,k).lt.xmissm)kl=k
      enddo
c
c --- If search unsuccessful, write error message
12    continue
      if(kl.eq.0)then
         write(io6,15)
15       format(//1x,'ERROR in subr. MIXDT2 -- no valid data below ',
     1   'HTOLD found in the prognostic data')
         write(io6,*)'IHRGMT = ',ihrgmt,' I = ',I,' J = ',j
         write(io6,*)'HTOLD = ',htold,' DZZI = ',dzzi
         do nl=1,nlev
            write(io6,*)'NL: ',nl,' ZL: ',zl(i,j,nl),' TZ: ',
     1       tz(i,j,nl)
         enddo
         stop
      endif
c
c ------------------------------------------------------
c --- Find lowest level w/ valid data above HTOLD -- KLP
c ------------------------------------------------------
      klp=0
      klp1=kl+1
      do k=klp1,nlev
c
c ---    Level must be above HTOLD & data valid
         if(zl(i,j,k).gt.htold.and.tz(i,j,k).lt.xmissm)then
            klp=k
            go to 27
         endif
      enddo
c
c --- If search unsuccessful, write error message
      if(klp.eq.0)then
         write(io6,25)
25       format(//1x,'ERROR in subr. MIXDT2 -- no valid data above ',
     1   'HTOLD found in the sounding')
         write(io6,*)'IHRGMT = ',ihrgmt,' I = ',I,' J = ',j
         write(io6,*)'HTOLD = ',htold,' DZZI = ',dzzi
         do nl=1,nlev
            write(io6,*)'NL: ',nl,' ZL: ',zl(i,j,nl),' TZ: ',
     1       tz(i,j,nl)
         enddo
         stop
      endif
27    continue
c
c -----------------------------------------------------------------
c --- Find highest level w/ valid data at or below HTOLD+DZZI -- KU
c -----------------------------------------------------------------
      htpdz=htold+dzzi
      ku=0
      do k=kl,nlev
c
c ---    At first height above HTOLD+DZZI, skip out of loop
         if(zl(i,j,k).gt.htpdz)go to 32
c
c ---    If data is valid, keep store this level
         if(tz(i,j,k).lt.xmissm)ku=k
      enddo
32    continue
c
c --- If search unsuccessful, write error message
      if(ku.eq.0)then
         write(io6,35)
35       format(//1x,'ERROR in subr. MIXDT2 -- no valid data below ',
     1   'HTOLD+DZZI found in the sounding')
2         write(io6,*)'IHRGMT = ',ihrgmt,' I = ',I,' J = ',j
         write(io6,*)'HTOLD = ',htold,' DZZI = ',dzzi,' HTPDZ = ',htpdz
         do nl=1,nlev
            write(io6,*)'NL: ',nl,' ZL: ',zl(i,j,nl),' TZ: ',
     1       tz(i,j,nl)
         enddo
         stop
      endif
c
c -----------------------------------------------------------
c --- Find lowest level w/ valid data above HTOLD+DZZI -- KUP
c -----------------------------------------------------------
      kup=0
      kup1=ku+1
      do k=kup1,nlev
c
c ---    Level must be above HTOLD+DZZI & data valid
         if(zl(i,j,k).gt.htpdz.and.tz(i,j,k).lt.xmissm)then
            kup=k
            go to 47
         endif
      enddo
c
c --- If search unsuccessful, write error message
      if(kup.eq.0)then
         write(io6,45)
45       format(//1x,'ERROR in subr. MIXDT2 -- no valid data above ',
     1   'HTOLD+DZZI found in the sounding')
         write(io6,*)'IHRGMT = ',ihrgmt,' I = ',I,' J = ',j
         write(io6,*)'HTOLD = ',htold,' DZZI = ',dzzi,' HTPDZ = ',htpdz
         do nl=1,nlev
            write(io6,*)'NL: ',nl,' ZL: ',zl(i,j,nl),' TZ: ',
     1       tz(i,j,nl)
         enddo
         stop
      endif
47    continue
c
c --- Compute temperature at HTOLD by interpolation
      tht=tz(i,j,klp)-(tz(i,j,klp)-tz(i,j,kl))*
     1    (zl(i,j,klp)-htold)/(zl(i,j,klp)-zl(i,j,kl))
c
c --- Compute temperature at HTOLD+DZZI by interpolation
      thtp=tz(i,j,kup)-(tz(i,j,kup)-tz(i,j,ku))*
     1   (zl(i,j,kup)-htpdz)/(zl(i,j,kup)-zl(i,j,ku))
c
c --- Compute potential temperature lapse rate (deg. K/m)
      dtheta=(thtp-tht)/dzzi+0.0098
c
c --- dptmin is minimum stable pot. temp. lapse rate
      dtheta=amax1(dtheta,dptmin)
c
      return
      end
c----------------------------------------------------------------------
      subroutine mixht(el,ustar,qh,nx,ny,rho,ihrgmt,nearu,iupt,
     1 ilandu,iwat1,iwat2,ldbhr,imixh,zi,ziconv)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 110421              MIXHT
c ---          J. Scire, SRC
c
c --- PURPOSE:  Calculate the convective and mechanical mixing
c               height (m) at each grid cell over LAND
c
c ---           Daytime mixing height are computed as the MAXIMUM of
c ---           convective ((Maul, 1980, or Batchvarovan & Gryning, 1990,1994)
c ---           and mechanical (Venkatram,1980b) values.
c ---           Mixing heights during stable conditions
c ---           are determine as the MINIMUM produced by two schemes
c ---           (Venkatram, 1980a) and Zilitinkevich (1972).
c
c ---           All mixing heights over land are subject to the
c ---           MIN/MAX values specified by user inputs ZIMIN and
c ---           ZIMAX.
c
c ---           MIXHT is called when lapse rates above mixing heights
c ---           are extracted from upper air soundings (UP.DAT). MIXHT2 is 
c ---           the equivalent subroutine called when lapse rates come
c ---           from prognostic data (3D.DAT)
c
c
c --- UPDATES
c
c---  V6.3 (070707) to v6.334 (110421) (JSS)
c         - Ensure that the station which is used to define older/newer
c           sounding and that which is used to provide lapse rate at top
c           of the convective mixing height and in MIXHBG are identical.
c           
c---  V6.218 (070113) to V6.3 (070707) (FRR)
c         - Use IUPT sounding if IUPT>0  for consistency with MOD5 and 
c           use nearest sounding otherwise (IUPT passed through calling 
c           list)
c
c --- v5.611 (051113) to V6.218 (070113)- (FRR)
c        - Get sounding order at nearest upper air station rather than at 
c          iupt station (which is no longer always defined since iupt can be <0)
c        - Remove iupt from calling list
c
c --- V5.6 (050328) to v5.611 (051113)- (FRR)
c        - Remove zimin from calling list to MIXHMC
c
c --- V5.547 (041010) to v5.6 (050328)- (FRR)
c        - Add new convective mixing height parameterization (Batchvarova
c          and Gryning). 
c        - Add buoyancy flux threshold for convective growth (dissipation)
c        
c --- V5.546 (950201) to V5.547 (041010) - (FRR)
c        - Bug fix: RHO is 2D not 1D 
c        - NEARS no longer needed so removed from in calling list
c
c --- INPUTS:
c        EL(mxnx,mxny) - real array    - Monin-Obukhov Length (m)
c     USTAR(mxnx,mxny) - real array    - Friction velocity (m/s)
c        QH(mxnx,mxny) - real array    - Sensible heat flux (W/m**2)
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c       RHO(mxnx,mxny) - real array    - Air density (kg/m**3)
c               IHRGMT - integer       - Local time (GMT) (IHRGMT can
c                                        be >= 24)beginning time
c     NEARU(mxnx,mxny) - integer array - Station number of upper air
c                                        station closest to each grid pt
c                 IUPT - integer       - Upper air station to use for
c                                        computing the domain-scale
c                                        lapse rate (if >0)
c    ILANDU(mxnx,mxny) - integer array - Land use category at each
c                                        grid point
c         IWAT1, IWAT2 - integers      - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c                LDBHR - logical       - Control variable determining
c                                        the printing of intermediate
c                                        results useful for debugging
c                  IMIXH - integer    - Method for convective mixing height
c                                       1: Maul Carson overland and overwater
c                                       2: Batchvarova-Gryning overland and OW
c                                      -1: MC overland, OCD mechanical OW
c                                      -2: BG overland, OCD mechanical OW
c        Common block /ziparm/
c           constn,dptmin,dzzi,zimax,zimin,cmech,twodte,onedte,fcoriol,threshl
c        Common block /upmet/
c           zlaa, tzaa, zlbb, tzbb
c        Parameters: mxnx, mxny, mxss, mxus, mxlev, io6, mxxy
c
c --- OUTPUT:
c        ZI(mxnx,mxny) - real array    - Mixing height (m) -- max. of
c                                        convective and mechanical hts.
c    ZICONV(mxnx,mxny) - real array    - Convective mixing height (m)
c
c --- MIXHT called by:  COMP
c --- MIXHT calls:      MIXDT, MIXHBG, MIXHMC, OUT
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      real ustar(mxnx,mxny),qh(mxnx,mxny),el(mxnx,mxny)
      real zi(mxnx,mxny),ziconv(mxnx,mxny)
      real rho(mxnx,mxny)
      integer nearu(mxnx,mxny)
      integer ilandu(mxnx,mxny)
      character*70 messag
      logical ldbhr,ldate
c
      include 'ziparm.met'
      include 'upmet.met'
      common /tjump/ dptt(mxnx,mxny)
c
      data cp/996./,g/9.81/,ldate/.true./
c

c --- Loop over grid cells -- Process only LAND cells
      do 100 i=1,nx
      do 100 j=1,ny
c
c --- Check if cell is land or water
      if(ilandu(i,j).ge.iwat1.and.ilandu(i,j).le.iwat2) go to 100
c
c --- Nearest upper air station to current grid cell
      iusta=nearu(i,j)
c
c --- Check if heat flux is positive (daytime) or negative (nighttime)
      if(qh(i,j).lt.0.0)go to 300
c
c -----------------------------------------------------------------
c --- Daytime -- calculate convective and mechanical mixing heights
c -----------------------------------------------------------------
c
c --- Convert heat flux (W/m**2) to w'theta' (m * deg. K/s)
      wt=qh(i,j)/(rho(i,j)*cp)

c *** rjy modifications of 1/29/90 for arbitrary soundings. *******
c --- for any hour, use the most recent past sounding to
c     calculate pot. temp. gradient.
c     JORDER = +1 implies that the contents of the aa arrays is older.
c     JORDER = -1 implies that the contents of the bb arrays is older.
c     (070717) - Use iupt if >0 for consistency with MOD5
c     110421: ensure that whatever sounding is used for jorder (kusta)
c     is also used in the call to mixdt to determinde lapse rate above Zic 
      if (iupt.gt.0) then
        jorder = justa(iupt)
c ---   110421
        kusta=iupt
      else
        jorder = justa(iusta)
c ---   110421
        kusta=iusta
      endif
      if(jorder.gt.0) go to 200
c *****************************************************************
c
c --- Use 12z sounding to determine potential temperature lapse rate 
c --- in 'dzzi'-meter layer above last timestep's convective mixing ht.
      htold=ziconv(i,j)
c     110421: ensure that whatever sounding is used for jorder (kusta)
c     is also used in the call to mixdt to determinde lapse rate above Zic 
c      nlev=nlbb(iusta)
c      call mixdt(ihrgmt,i,j,iusta,htold,nlev,zlbb,tzbb,dptmin,dzzi,
      nlev=nlbb(kusta)
      call mixdt(ihrgmt,i,j,kusta,htold,nlev,zlbb,tzbb,dptmin,dzzi,
     1    tht,thtp,dtheta)

      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height 
c        110421 - kusta instead of iusta
c        call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzbb(iusta,1),2,THRESHL,
         call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzbb(kusta,1),2,THRESHL,
     :               ZIMAX,ZIMIN,USTAR(i,j),EL(i,j),HTOLD,ZICONV(I,J),
     :               THT,THTP)

      else if (abs(imixh).eq.1) then
c---    Carson convective mixing height 
        call MIXHMC(ihrgmt,i,j,wt,DTHETA,2,threshl,zimax,
     :              htold,ziconv(i,j),dptt(i,j),tht,thtp)
      endif

c --- Upper bound to conv. mixing height:
      ziconv(i,j)=amin1(zimax,ziconv(i,j))

c
c --- Calculate daytime(neutral) mechanical mixing height
      tave=(thtp+tht)/2.
c --- BVF is sqrt(Brunt-Vaisala frequency) = (N**2)**0.25
      bvf=(g*dtheta/tave)**0.25
c
c --- CMECH is constb/sqrt(f), where f is the Coriolis parameter
c --- Default values -- constb=1.41, conste=0.15, constn=2400.
      hmech=cmech(i,j)*ustar(i,j)/bvf
      zi(i,j)=amax1(zimin,hmech,ziconv(i,j))
      zi(i,j)=amin1(zimax,zi(i,j))
      go to 100
c
c --- For daytime hours after 00z (4 pm PST, 7 pm EST), use 00z
c --- sounding to determine lapse rate above mixing ht.
200   continue

      htold=ziconv(i,j)
c     110421: ensure that whatever sounding is used for jorder (kusta)
c     is also used in the call to mixdt to determinde lapse rate above Zic 
c     nlev=nlaa(iusta)
c     call mixdt(ihrgmt,i,j,iusta,htold,nlev,zlaa,tzaa,dptmin,dzzi,
      nlev=nlaa(kusta)
      call mixdt(ihrgmt,i,j,kusta,htold,nlev,zlaa,tzaa,dptmin,dzzi,
     1 tht,thtp,dtheta)

      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height 
c        110421 - kusta instead of iusta
c        call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzaa(iusta,1),2,THRESHL,
         call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzaa(kusta,1),2,THRESHL,
     :               ZIMAX,ZIMIN,USTAR(i,j),EL(i,j),HTOLD,ZICONV(I,J),
     :               tht,thtp)

      else if (abs(imixh).eq.1) then
c---    Carson convective mixing height 
        call MIXHMC(ihrgmt,i,j,wt,DTHETA,2,threshl,zimax,
     :              htold,ziconv(i,j),dptt(i,j),tht,thtp)
      endif

c --- Upper bound to conv. mixing height:
      ziconv(i,j)=amin1(zimax,ziconv(i,j))

c --- Calculate daytime (neutral) mechanical mixing height using 00z
c --- sounding
      tave=0.5*(thtp+tht)
      bvf=(g*dtheta/tave)**0.25
      hmech=cmech(i,j)*ustar(i,j)/bvf
      zi(i,j)=amax1(zimin,hmech,ziconv(i,j))
      zi(i,j)=amin1(zimax,zi(i,j))

      go to 100
c
c -----------------------------------------------------------
c --- Nighttime (stable) conditions -- mechanical mixing only
c -----------------------------------------------------------
c --- Default value for constn is 2400.
300   continue
c
c --- Take the minimum of constn*ustar(i,j)**1.5 and 
c --- 0.4*sqrt(ustar(i,j)*el(i,j)/abs(fcori(i,j)))
c
c --- Stable mixing ht. - Venkatram (1980a)
      zi1=constn*ustar(i,j)**1.5
c
c --- Stable mixing ht. - Zilitinkevich (1972)
      zi2=0.4*sqrt(ustar(i,j)*el(i,j)/fcori(i,j))
c
c --- Mixing height must be between user-specified MIN/MAX range
      zi(i,j)=amin1(zi1,zi2,zimax)
      zi(i,j)=amax1(zimin,zi(i,j))
c
      ziconv(i,j)=0.0
      dptt(i,j)=0.0
c
100   continue



c --- DEBUG write option
      if(ldbhr)then
         messag='Temperature jump at top of mixed layer (deg. K)'
         call out(dptt,idum,1,5,ldate,messag,nx,ny)
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine mixhtST(el,ustar,qh,rho,ihrgmt,ist,jst,nearus,
     1 iupt,ilandu,iwat1,iwat2,imixh,zi,ziconv)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 110421            MIXHTST
c ---          F. Robe after MIXHT (J. Scire, SRC)
c
c --- PURPOSE:  Calculate the convective and mechanical mixing
c               height (m) at one grid cell only (ist,jst)
c
c ---           Daytime mixing height are computed as the MAXIMUM of
c ---           convective (Maul, 1980) and mechanical (Venkatram,
c ---           1980b) values.  Mixing heights during stable conditions
c ---           are determine as the MINIMUM produced by two schemes
c ---           (Venkatram, 1980a) and Zilitinkevich (1972).
c
c ---           All mixing heights over land are subject to the
c ---           MIN/MAX values specified by user inputs ZIMIN and
c ---           ZIMAX.
c
c ---           MIXHTST is called when lapse rates above mixing heights
c ---           are extracted from  upper air soundings (UP.DAT). MIXHT2ST is the
c ---           the equivalent subroutine when lapse rates come from
c ---           prognostic data (3D.DAT)
c
c --- UPGRADES:
c---  V6.3 (070707) to v6.334 (JSS)
c         - Ensure that the station which is used to define older/newer
c           sounding and that which is used to provide lapse rate at top
c           of the convective mixing height and in MIXHBG are identical.
c
c---  V6.221 (070327) to V6.3 (070707) (FRR)
c         - Use IUPT sounding if IUPT>0  for consistency with MOD5 and use
c           nearest sounding otherwise (IUPT passed through calling list)
c
c --- V6.218 (070113)to V6.221 (070327)- (FRR)
c        - Include 'grid.met' for debug option call to out and change variable 
c          name nearu to nearus to avoid conflict with common variable
c        - Remove ldbhr from calling list (was not defined) and include
c          outpt.met where ldbhr is now defined
c
c --- v5.611 (051113) to V6.218 (070113)- (FRR)
c        - Get sounding order at nearest upper air station rather than at iupt station
c          (which is no longer always defined since iupt can be <0)
c        - Remove iupt from calling list
c     V5.6 (050328) to v5.611 (051113)- (FRR)
c        - Remove zimin from calling list to MIXHMC
c --- Level 021105 to v5.6 (050328) - (FRR)
c        - Add new convective mixing height parameterization (Batchvarova
c          and Gryning). 
c        - Add buoyancy flux threshold for convective growth (dissipation)

c
c --- INPUTS:
c                  EL  - real     - Monin-Obukhov Length (m) at point (ist,jst)
c               USTAR  - real     - Friction velocity (m/s) at point (ist,jst)
c                  QH  - real     - Sensible heat flux (W/m**2)at point (ist,jst)
c                  IST - integer  - I of the gridpoint
c                  JST - integer  - J of the gridpoint
c                 RHO  - real     - Air density (kg/m**3) at point (ist,jst)
c               IHRGMT - integer       - Local time (GMT) (IHRGMT can
c                                        be >= 24)
c                NEARUS - integer  - Station number of surface
c                                        station closest to point (ist,jst)
c               ILANDU - integer  - Land use category at point (ist,jst)
c         IWAT1, IWAT2 - integers - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c              IMIXH - integer    - Method for convective mixing height
c                                    1: Maul Carson overland and overwater
c                                    2: Batchvarova-Gryning overland and OW
c                                   -1: MC overland, OCD mechanical OW
c                                   -2: BG overland, OCD mechanical OW
c        Common block /ziparm/
c           constn,dptmin,dzzi,zimax,zimin,cmech,fcoriol,threshl
c        Common block /upmet/
c           zlaa, tzaa, zlbb, tzbb
c        Parameters: mxnx, mxny, mxss, mxus, mxlev, io6, mxxy
c
c --- OUTPUT:
c        ZI - real     - Mixing height (m) at point (ist,jst)-- max. of
c                                        convective and mechanical hts.
c    ZICONV - real     - Convective mixing height (m)at point (ist,jst)
c                                                     
c --- MIXHTST called by:  ELUSTR2
c --- MIXHTST calls:      MIXDT, MIXHBG, MIXHMC, OUT
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      character*70 messag
      logical ldate

      include 'outpt.met'
      include 'grid.met'
c
      include 'ziparm.met'
      include 'upmet.met'
      common /tjump/ dptt(mxnx,mxny)
c
      data cp/996./,g/9.81/,ldate/.true./
c
c --- Only one gridpoint
      i=ist
      j=jst

c
c --- Check if cell is land or water
      if(ilandu.ge.iwat1.and.ilandu.le.iwat2) go to 100
c
c --- Nearest upper air station to current grid cell
      iusta=nearus 
c
c --- Check if heat flux is positive (daytime) or negative (nighttime)
      if(qh.lt.0.0)go to 300
c
c -----------------------------------------------------------------
c --- Daytime -- calculate convective and mechanical mixing heights
c -----------------------------------------------------------------
c
c --- Convert heat flux (W/m**2) to w'theta' (m * deg. K/s)
      wt=qh/(rho *cp)

c
c *** rjy modifications of 1/29/90 for arbitrary soundings. *******
c --- for any hour, use the most recent past sounding to
c     calculate pot. temp. gradient.
c     JORDER = +1 implies that the contents of the aa arrays is older.
c     JORDER = -1 implies that the contents of the bb arrays is older.
c     Use IUPT if  >), otherwise use nearest station (070717)
c     110421: ensure that whatever sounding is used for jorder (kusta)
c     is also used in the call to mixdt to determinde lapse rate above Zic 
      if (iupt.gt.0) then
        jorder = justa(iupt)
        kusta=iupt
      else
        jorder = justa(iusta)
        kusta=iusta
      endif
      if(jorder.gt.0) go to 200
c *****************************************************************
c
c --- Use 12z sounding to determine lapse rate in 'dzzi'-meter layer
c --- above last hour's convective mixing ht.
      htold=ziconv 
c     110421: ensure that whatever sounding is used for jorder (kusta)
c     is also used in the call to mixdt to determinde lapse rate above Zic 
c     nlev=nlbb(iusta)
c     call mixdt(ihrgmt,i,j,iusta,htold,nlev,zlbb,tzbb,dptmin,dzzi,
      nlev=nlbb(kusta)
      call mixdt(ihrgmt,i,j,kusta,htold,nlev,zlbb,tzbb,dptmin,dzzi,
     1 tht,thtp,dtheta)

      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height 
c        110421 - kusta instead of iusta
c        call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzbb(iusta,1),2,THRESHL,
         call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzbb(kusta,1),2,THRESHL,
     :               ZIMAX,ZIMIN,USTAR,EL,HTOLD,ZICONV,
     :               THT,THTP)

      else if (abs(imixh).eq.1) then
c---    Carson convective mixing height 
        call MIXHMC(ihrgmt,i,j,wt,DTHETA,2,threshl,zimax,htold,
     :              ziconv,dptt(i,j),THT,THTP)
      endif

c --- Upper bound to conv. mixing height:
      ziconv=amin1(zimax,ziconv)
c
c --- Calculate daytime(neutral) mechanical mixing height
      tave=(thtp+tht)/2.
c --- BVF is sqrt(Brunt-Vaisala frequency) = (N**2)**0.25
      bvf=(g*dtheta/tave)**0.25
c
c --- CMECH is constb/sqrt(f), where f is the Coriolis parameter
c --- Default values -- constb=1.41, conste=0.15, constn=2400.
      hmech=cmech(i,j)*ustar/bvf
      zi=amax1(zimin,hmech,ziconv)
      zi=amin1(zimax,zi)
      go to 100
c
c --- For daytime hours after 00z (4 pm PST, 7 pm EST), use 00z
c --- sounding to determine lapse rate above mixing ht.
200   continue
      htold=ziconv
c     110421: ensure that whatever sounding is used for jorder (kusta)
c     is also used in the call to mixdt to determinde lapse rate above Zic 
c     nlev=nlaa(iusta)
c     call mixdt(ihrgmt,i,j,iusta,htold,nlev,zlaa,tzaa,dptmin,dzzi,
      nlev=nlaa(kusta)
      call mixdt(ihrgmt,i,j,kusta,htold,nlev,zlaa,tzaa,dptmin,dzzi,
     1      tht,thtp,dtheta)
c

      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height 
c        110421 - kusta instead of iusta
c         call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzaa(iusta,1),2,THRESHL,
         call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzaa(kusta,1),2,THRESHL,
     :               ZIMAX,ZIMIN,USTAR,EL,HTOLD,ZICONV, THT,THTP)

      else if (abs(imixh).eq.1) then
c---    Carson convective mixing height 
        call MIXHMC(ihrgmt,i,j,wt,DTHETA,2,threshl,zimax,
     :              htold,ziconv,DPTT(i,j),THT,THTP)
      endif

c --- Upper bound to conv. mixing height:
      ziconv=amin1(zimax,ziconv)
c
c --- Calculate daytime (neutral) mechanical mixing height using 00z
c --- sounding
      tave=0.5*(thtp+tht)
      bvf=(g*dtheta/tave)**0.25
      hmech=cmech(i,j)*ustar/bvf
      zi=amax1(zimin,hmech,ziconv)
      zi=amin1(zimax,zi)
      go to 100
c
c -----------------------------------------------------------
c --- Nighttime (stable) conditions -- mechanical mixing only
c -----------------------------------------------------------
c --- Default value for constn is 2400.
300   continue
c
c --- Take the minimum of constn*ustar**1.5 and 
c --- 0.4*sqrt(ustar*el/abs(fcori))
c
c --- Stable mixing ht. - Venkatram (1980a)
      zi1=constn*ustar**1.5
c
c --- Stable mixing ht. - Zilitinkevich (1972)
      zi2=0.4*sqrt(ustar*el/fcori(i,j))
c
c --- Mixing height must be between user-specified MIN/MAX range
      zi=amin1(zi1,zi2,zimax)
      zi=amax1(zimin,zi)
c
      ziconv=0.0
      dptt(i,j)=0.0
c
100   continue
c
c --- DEBUG write option
      if(ldbhr)then
         messag='Temperature jump at top of mixed layer (deg. K)'
         call out(dptt,idum,1,5,ldate,messag,nx,ny)
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine mixht2(el,ustar,qh,nx,ny,rho,ihrgmt,
     1                  ilandu,iwat1,iwat2,ldbhr,imixh,zi,ziconv)
c----------------------------------------------------------------------
c
c --- CALMET    Version: 6.4.0     Level: 051113            MIXHT2
c ---          
c               F.Robe (09/2001) 
c               Based on MIXHT (J. Scire, SRC)
               
c --- PURPOSE:  Calculate the convective and mechanical mixing
c               height (m) at each grid cell over LAND in the NOOBS mode
c               (i.e. based on prognostic input - no observations)
c
c ---           Each mixing height is computed based on the MM5 temperature
c ---           profile at the MM5 gridpoint closest to the CALMET gridpoint
c
c ---           Daytime mixing height are computed as the MAXIMUM of
c ---           convective (Maul, 1980) and mechanical (Venkatram,
c ---           1980b) values.  Mixing heights during stable conditions
c ---           are determine as the MINIMUM produced by two schemes
c ---           (Venkatram, 1980a) and Zilitinkevich (1972).
c
c ---           All mixing heights over land are subject to the
c ---           MIN/MAX values specified by user inputs ZIMIN and
c ---           ZIMAX.
c
c ---           MIXHT2 is called when lapse rates above mixing heights
c ---           are extracted from prognostic data (3D.DAT). MIXHT is the
c ---           equivalent subroutine when lapse rates are extracted from
c ---           upper air soundings (UP.DAT)
c
c
c --- UPDATES:
c --- v5.611 (051113) to V6.223 Level 070702- (FRR)
c        - HTOLD uses last zi even if less than zimin
c
c     V5.6 (050328) to v5.611 (051113)- (FRR)
c        - Remove zimin from calling list to MIXHMC
c --- Level 020211 to v5.6 (050328) - (FRR)
c        - Add new convective mixing height parameterization (Batchvarova
c          and Gryning). 
c        - Add buoyancy flux threshold for convective growth (dissipation)
c        - Move details of mix. hgt computation and call to mixdt2 to 
c          subroutines mixhbg and mixhmc
c
c --- INPUTS:
c        EL(mxnx,mxny) - real array    - Monin-Obukhov Length (m)
c     USTAR(mxnx,mxny) - real array    - Friction velocity (m/s)
c        QH(mxnx,mxny) - real array    - Sensible heat flux (W/m**2)
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c               IHRGMT - integer       - Local time (GMT) (IHRGMT can
c                                        be >= 24)
c       RHO(mxnx,mxny) - real array    - Air density
c    ILANDU(mxnx,mxny) - integer array - Land use category at each
c                                        grid point
c         IWAT1, IWAT2 - integers      - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c                LDBHR - logical       - Control variable determining
c                                        the printing of intermediate
c                                        results useful for debugging
c                IMIXH - integer       - Method for convective mixing height
c                                       1: Maul Carson overland and overwater
c                                       2: Batchvarova-Gryning overland and OW
c                                      -1: MC overland, OCD mechanical OW
c                                      -2: BG overland, OCD mechanical OW
c        Common block /ziparm/
c           constn,dptmin,dzzi,zimax,zimin,cmech,threshl
c        Parameters: mxnx, mxny, mxss, mxus, mxlev, io6, mxxy
c
c --- OUTPUT:
c        ZI(mxnx,mxny) - real array    - Mixing height (m) -- max. of
c                                        convective and mechanical hts.
c    ZICONV(mxnx,mxny) - real array    - Convective mixing height (m)
c
c --- MIXHT2 called by:  COMP
c --- MIXHT2 calls:      MIXHBG, MIXHMC, OUT
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      real ustar(mxnx,mxny),qh(mxnx,mxny),el(mxnx,mxny)
      real zi(mxnx,mxny),ziconv(mxnx,mxny),rho(mxnx,mxny)
      integer ilandu(mxnx,mxny)
      character*70 messag
      logical ldbhr,ldate
c
      include 'ziparm.met'
c --- mm4hdo.met not needed (050328)
c     include 'mm4hdo.met'
      common /tjump/ dptt(mxnx,mxny)
c
      data cp/996./,g/9.81/,ldate/.true./
c

c --- Loop over grid cells -- Process only LAND cells
      do 100 i=1,nx
      do 100 j=1,ny
c
c --- Check if cell is land or water
      if(ilandu(i,j).ge.iwat1.and.ilandu(i,j).le.iwat2) go to 100
c
c --- Check if heat flux is positive (daytime) or negative (nighttime)
      if(qh(i,j).lt.0.0)go to 300
c
c -----------------------------------------------------------------
c --- Daytime -- calculate convective and mechanical mixing heights
c -----------------------------------------------------------------
c
c --- Convert heat flux (W/m**2) to w'theta' (m * deg. K/s)
      wt=qh(i,j)/(rho(i,j)*cp)

c --- previous hour mixing height
c      htold=max(ziconv(i,j),zimin)  - 070702
      htold=ziconv(i,j)

c --- MIXDT2 is now called in mixhbg/mixhmc (050328)
c     call mixdt2(ihrgmt,i,j,htold,dptmin,dzzi,tsf,tht,thtp,dtheta)


      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height 
         call MIXHBG (ihrgmt,I,J,WT,DTHETA,TSF,1,THRESHL,
     :               ZIMAX,ZIMIN,USTAR(i,j),EL(i,j),HTOLD,ZICONV(I,J),
     :               THT,THTP)
        

      else if (abs(imixh).eq.1) then
c---     Carson convective mixing height 
         call MIXHMC(ihrgmt,i,j,wt,DTHETA,1,threshl,zimax,
     :               htold,ziconv(i,j),DPTT(i,j),THT,THTP)

      endif

c --- Upper bound to conv. mixing height:
      ziconv(i,j)=amin1(zimax,ziconv(i,j))

c
c --- Calculate daytime(neutral) mechanical mixing height
c --- average potential temperature in DZZI above previous hour mix. height
      tave=(thtp+tht)/2.
c --- BVF is sqrt(Brunt-Vaisala frequency) = (N**2)**0.25
      bvf=(g*dtheta/tave)**0.25
c
c --- CMECH is constb/sqrt(f), where f is the Coriolis parameter
c --- Default values -- constb=1.41, conste=0.15, constn=2400.
      hmech=cmech(i,j)*ustar(i,j)/bvf
      zi(i,j)=amax1(zimin,hmech,ziconv(i,j))
      zi(i,j)=amin1(zimax,zi(i,j))

      go to 100
c
c -----------------------------------------------------------
c --- Nighttime (stable) conditions -- mechanical mixing only
c -----------------------------------------------------------
c --- Default value for constn is 2400.
300   continue
c
c --- Take the minimum of constn*ustar(i,j)**1.5 and 
c --- 0.4*sqrt(ustar(i,j)*el(i,j)/abs(fcori(i,j)))
c
c --- Stable mixing ht. - Venkatram (1980a)
      zi1=constn*ustar(i,j)**1.5
c
c --- Stable mixing ht. - Zilitinkevich (1972)
      zi2=0.4*sqrt(ustar(i,j)*el(i,j)/fcori(i,j))
c
 
c --- Mixing height must be between user-specified MIN/MAX range
      zi(i,j)=amin1(zi1,zi2,zimax)
      zi(i,j)=amax1(zimin,zi(i,j))
c
      ziconv(i,j)=0.0
      dptt(i,j)=0.0
c
100   continue
c

c --- DEBUG write option
      if(ldbhr)then
         messag='Temperature jump at top of mixed layer (deg. K)'
         call out(dptt,idum,1,5,ldate,messag,nx,ny)
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine mixht2ST(el,ustar,qh,rho,ihrgmt,is,js,
     1                  ilandu,iwat1,iwat2,imixh,zi,ziconv)
c----------------------------------------------------------------------
c
c --- CALMET    Version: 6.4.0     Level: 070702          MIXHT2ST
c ---          
c               F.Robe (09/2001) 
c               Based on MIXHT (J. Scire, SRC)
               
c --- PURPOSE:  Calculate the convective and mechanical mixing
c               height (m) at one gridpoint  over LAND in the NOOBS mode
c               quick version of MIXHT2
c
c ---           Each mixing height is computed based on the MM5 temperature
c ---           profile at the MM5 gridpoint closest to the CALMET gridpoint
c
c ---           Daytime mixing height are computed as the MAXIMUM of
c ---           convective (Maul, 1980) and mechanical (Venkatram,
c ---           1980b) values.  Mixing heights during stable conditions
c ---           are determine as the MINIMUM produced by two schemes
c ---           (Venkatram, 1980a) and Zilitinkevich (1972).
c
c ---           All mixing heights over land are subject to the
c ---           MIN/MAX values specified by user inputs ZIMIN and
c ---           ZIMAX.
c
c ---           MIXHT2ST is called when lapse rates above mixing heights
c ---           are extracted from prognostic data (3D.DAT). MIXHTST is the
c ---           equivalent subroutine when lapse rates are extracted from
c ---           upper air soundings (UP.DAT)
c
c --- UPGRADES:
c --- V6.221 (070327) to V6.223 (070702)- (FRR)
c        - HTOLD uses last zi even if less than zimin
c
c --- v5.6 (050328) to V6.221 (070327)- (FRR)
c            - Include 'grid.met' for debug option call to out
c            - Remove ldbhr from calling list (was not defined) and 
c              include outpt.met where ldbhr is now defined
c
c --- Level 021105 to v5.6 (050328) - (FRR)
c             - Add new convective mixing height parameterization 
c               (Batchvarova and Gryning). 
c             - Add buoyancy flux threshold for convective growth 
c                (dissipation)
c             - Detailed computation and call to mixdt2 are now done
c               in subroutines MIXHBG or MIXHMC
c
c --- INPUTS:
c                  EL  - real      - Monin-Obukhov Length (m)
c               USTAR  - real      - Friction velocity (m/s)
c                  QH  - real      - Sensible heat flux (W/m**2)
c               IHRGMT - integer   - Local time (GMT) (IHRGMT can
c                                        be >= 24)
c                 RHO  - real      - Air density at gridpoint (is,js)
c                IS,JS - integer   - gridpoint I,J
c               ILANDU - integer   - Land use category 
c         IWAT1, IWAT2 - integers  - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c                                        results useful for debugging
c               IMIXH - integer    - Method for convective mixing height
c                                    1: Maul Carson overland and overwater
c                                    2: Batchvarova-Gryning overland and OW
c                                   -1: MC overland, OCD mechanical OW
c                                   -2: BG overland, OCD mechanical OW
c        Common block /ziparm/
c           constn,dptmin,dzzi,zimax,zimin,cmech,threshl
c
c        Parameters: mxnx, mxny, mxss, mxus, mxlev, io6, mxxy
c
c --- OUTPUT:
c        ZI(mxnx,mxny) - real array    - Mixing height (m) -- max. of
c                                        convective and mechanical hts.
c    ZICONV(mxnx,mxny) - real array    - Convective mixing height (m)
c
c --- MIXHT2ST called by:  COMP
c --- MIXHT2ST calls:      MIXHBG, MIXHMC,OUT
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      character*70 messag
      logical ldate
c
      include 'outpt.met'
 
      include 'ziparm.met'
      include 'grid.met'

c --- mm4hdo.met not needed (050328)
c     include 'mm4hdo.met'
      common /tjump/ dptt(mxnx,mxny)
c
      data cp/996./,g/9.81/,ldate/.true./
c

c --- Check if cell is land or water
      if(ilandu.ge.iwat1.and.ilandu.le.iwat2) go to 100
c
c --- Check if heat flux is positive (daytime) or negative (nighttime)
      if(qh.lt.0.0)go to 300
c
c -----------------------------------------------------------------
c --- Daytime -- calculate convective and mechanical mixing heights
c -----------------------------------------------------------------
c
c --- Convert heat flux (W/m**2) to w'theta' (m * deg. K/s)
      wt=qh/(rho*cp)
c
c --- Previous timestep convective mixing height
c     htold=max(ziconv,zimin)  --- 070702
      htold=ziconv

c     mixdt2 is now called in mixhbg/mixhmc (050328)
c     call mixdt2(ihrgmt,is,js,htold,dptmin,dzzi,tsf,tht,thtp,dtheta)

      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height 
         call MIXHBG (ihrgmt,IS,JS,WT,DTHETA,tsf,1,THRESHL,ZIMAX,ZIMIN,
     :               USTAR,EL,HTOLD,ZICONV,THT,THTP)

      else if (abs(imixh).eq.1) then
c---    Carson convective mixing height 
        call MIXHMC(ihrgmt,is,js,wt,DTHETA,1,threshl,zimax,
     :              htold,ziconv,dptt(is,js),tht,thtp)
      endif

c --- Upper bound to conv. mixing height:
      ziconv=amin1(zimax,ziconv)
c
c --- Calculate daytime(neutral) mechanical mixing height
      tave=(thtp+tht)/2.
c --- BVF is sqrt(Brunt-Vaisala frequency) = (N**2)**0.25
      bvf=(g*dtheta/tave)**0.25
c
c --- CMECH is constb/sqrt(f), where f is the Coriolis parameter
c --- Default values -- constb=1.41, conste=0.15, constn=2400.
      hmech=cmech(is,js)*ustar/bvf
      zi=amax1(zimin,hmech,ziconv)
      zi=amin1(zimax,zi)
      go to 100
c
c -----------------------------------------------------------
c --- Nighttime (stable) conditions -- mechanical mixing only
c -----------------------------------------------------------
c --- Default value for constn is 2400.
300   continue
c
c --- Take the minimum of constn*ustar**1.5 and 
c --- 0.4*sqrt(ustar*el/abs(fcori(is,js)))
c
c --- Stable mixing ht. - Venkatram (1980a)
      zi1=constn*ustar**1.5
c
c --- Stable mixing ht. - Zilitinkevich (1972)
      zi2=0.4*sqrt(ustar*el/fcori(is,js))
c
c --- Mixing height must be between user-specified MIN/MAX range
      zi=amin1(zi1,zi2,zimax)
      zi=amax1(zimin,zi)
c
      ziconv=0.0
      dptt(is,js)=0.0
c
100   continue
c
c --- DEBUG write option
      if(ldbhr)then
         messag='Temperature jump at top of mixed layer (deg. K)'
         call out(dptt,idum,1,5,ldate,messag,nx,ny)
      endif
c
      return
      end
c 
c -------------------------------------------------------------------------
      Subroutine MIXHBG (ihrgmt,IS,JS,WT,GAMMA,TK,ILAPSE,THRESH,
     :                   ZIMX,ZIMN,USTAR,EL,ZICBGOLD,ZICBG,THT,THTP)
c -------------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 110212             MIXHBG
c ---          F. Robe (Earth Tech Inc.)
c
c --- PURPOSE:  Compute the convective mixing height (m) 
c               following Batchvarova and Gryning (1991,1994)
c
c
c --- UPDATES
c---  v6.329 (100719) to v6.332 (110212)(FRR)
c     (1) Apply relaxation of convective mixing height to equilibrium
c         value according to user-input flag IZICRLX
c     (2) USe  user-defined relaxation time TZICRLX rather than 
c         hardwired value of 800s 
c     (3) IZICRLX and TZICRLX are passed on via ZIPARM.MET
c     (4) Make relaxation ZIcbg consistent with the threshold flux 
c         i.e. a function h0 (min of 100m) rather than zicbgold
c
c --- v6.206 Level 060322 to v6.329 (100719) (F.Robe)
c        - Relax convective mixing heigt to equilibrium value based on THRESHW 
c          (or THRESHL) and turbulence timescale of 800s when the buoyancy flux  
c          is positive but lower than the threshold (rather than collapsing
c          the convective mixing height to 0, causing w*=0 eventhough qh>0) 
c          This change can affect Zi and w* prior results for cases where 
c          THRESHW>0 and/or THRESHL>0 during weakly convective times
c
c --- v6.203 Level 060301 to v6.206 Level 060322 
c --- Modifications by F.Robe 
c          (1) Replace Tk by dummy variable tsf in call to mixdt2 
c              otherwise mixdt2 overwrites Tk with MM5 surface temperature
c              (not ok for all options e.g. overwater) (also in V5.718 Level 060305)
c          (2) Add check for negative log arguments and replace zeta2 estimate
c              by average value if necessary (also in V5.722 level 060322)
c
c --- V6.2 Level 060215 to V6.203 Level 060301 (F.Robe)
c          (1) Replace numerical integration of the BG equations by an 
c              analytical integration method ("false images") to optimize 
c              accuracy/CPU time.
c
c --- V5.6 Level 050328 to V6.2 Level 060215 (F.Robe)
c        -  Get CALMET timestep in seconds from GEN.MET and 
c           estimate growth once per timestep
c
c --- INPUTS:
c               IHRGMT - real     - GMT hour 
c              (IS,JS) - integer  - CALMET gridpoints
c                   WT - REAL     - Surface Buoyancy flux in terms of
c                                   <w'Thetav'> (m * deg. K/s)
c               GAMMA - REAL      - potential temperature lapse rate above 
c                                   previous hourmixing height
c                                   (input if ilapse=0 or 2 or if ilapse=1
c                                    and nstep=1 (hourly computational timestep))
c                   TK - real     - Surface air temperature (K) 
c               ILAPSE -  INT     - Lapse rate computational option
c                                   0: read from SEA.DAT file (TGRADA) and
c                                      passed on as dtdz
c                                   1: computed from MM5.DAT (call to mixdt2)
c                                   2: extracted from UP.DAT and passed on
c                                      as gamma
c               THRESH - real     - Threshold surface buoyancy (energy) flux per
c                                   meter of boundary layer to get Mixing
c                                   height growth (units: W/m2/m)
c                                   = THRESHL overland
c                                   = Threshw overwater 
c                ZIMX - REAL      - Maximum mixing height (m)
c                ZIMN - REAL      - Minimum mixing height (m)
c                USTAR - REAL     - Ustar (m/s)
c                   EL - REAL     - Monin-Obuknov length (m)
c             ZICBGOLD - real     - Previous hour convective mixing height (m)
c 
c --- Via common block /ziparm/
c           DPTMIN: minimum potential temp. lapse rate
c           DZZI: thickness of layer above Mix. Height where lapse rate is computed
c           IZICRLX, TZICRLX
c
c --- Via common block /gen/
c           nsecdt: timestep (in seconds)
c
c --- OUTPUT:
c                ZICBG - real     - Convective mixing height 
c                GAMMA - real     - Potential temperature lapse rate above  
c                                   previous hour mixing height
c                                   (output if ilapse=1 and nstep>1)
c                  THT - real     - Temperature (deg. K) at height
c                                   "HTOLD" meters
c                 THTP - real     - Temperature (deg. K) at height
c                                   "HTOLD + DZZI" meters
c
c --- MIXHBG called by : WATER , MIXHT, MIXHT2, MIXHTST, MIXHT2ST
c
c --- MIXHBG calls     : MIXDT2, function FBG
c
c----------------------------------------------------------------------
      include 'params.met'
      include 'ziparm.met'
c --- need nsecdt (060215)
      include 'gen.met'

      data g/9.81/,rho/1.2/,cp/1005./
      data vonk/0.4/,ca/0.2/,cb/2.5/,cc/8./

c --- Initial mixing height
      h0=max(zicbgold,zimin)

c --- Compute temperature lapse rate above current mixing height
c --- if using MM5 profile (non constant)
      if (ilapse.eq.1 ) then
         call MIXDT2(ihrgmt,is,js,h0,dptmin,dzzi,tsf,tht,thtp,
     :               gamma)
      endif

c --- Threshold buoyancy flux to sustain H0 meters of mixing height
      wto=thresh*h0/(rho*cp)

c --- Net buoyancy flux (surface flux - dissipation)
      wptp=wt-wto

c --- Opt for either total collapse (backward compatible with V5.8 and
c     pre v6.329 codes) or relaxation, based upon user input (110212)
      if (izicrlx.eq.0) then

c ---    No convective growth if positive Lmo or negative wptp
         if(el.gt.0. .or. wptp.lt.0) then
            zicbg=0.
            return
         endif
c ---    If no net buoyancy flux, no further growth 
         if(wptp.eq.0) then
            zicbg=zicbgold
           return
         endif

      else
c ---     100719 - Do not totally collapse Zic if 0<wt<wto - Relax to equilibrium value
c ---     No convective growth if positive Lmo or negative buoyoancy flux wt
          if(el.gt.0. .or. wt.lt.0) then
             zicbg=0.
             return
          else if (wptp.le.0) then
c             Equilibrium Ziceq st. wt-wto(ziceq)=0 
              ziceq= rho*cp*wt/thresh
c             110212: user-defined timescale and use H0 rather than Zicbgold
c             (default: 800s (based on MMS study for Oresund)
c              zicbg=ziceq+(zicbgold-ziceq)*exp(-nsecdt/800.)
              zicbg=ziceq+(h0-ziceq)*exp(-nsecdt/tzicrlx)
              return
          endif
      endif

c --- dptmin is minimum stable pot. temp. lapse rate
      gamma=amax1(gamma,dptmin)

c --- Compute parameters for "False Images" solution
      a=wptp/gamma
      b=CC*ustar**2*Tk/(gamma*g)
      c=CB*vonk*el
      d=1.+CA+CA
      e=1.+CA
      d3=d*d*d

      zeta0=d*h0-2.*c
      zetap0=e*h0-c
      r1=8.*c
      r2=r1*c
      r3=2.*b*d3/e
      r4=1./(2.*a*d3)
      r5=e/d
      t0=r4*fbg(zeta0,zetap0,r1,r2,r3)

c --- Calmet timestep
      t=float(nsecdt)

c --- integration time variable
      time=t+t0

c --- First value uses encroachment limit
      if (el.gt.-500.) then
c ---    for h>>-2c (i.e. small abs|L| )
         h=SQRT(h0*h0+2.*d*a*t)
      else
c ---    for h<<-2c (large abs|L|)
         h=(h0**3-6*a*c*t)**0.333
      endif
      zeta1=d*h-2.*c
      zetap1=e*h-c
      f1=r4*fbg(zeta1,zetap1,r1,r2,r3)-time
      h=(zeta1+2.*c)/d
c --- Check if first guess good enough (implied time f1 < 1s)
      if(ABS(f1).LE.1.) goto 20

c --- Second value estimated from zeta1 and zeta0 (h0)
      f0=-t
      zeta2=(f1*zeta0-f0*zeta1)/(f1-f0)
      zetap2=r5*(zeta2+2.*c)-c
      if(zeta2.le.0.or.zetap2.le.0) then
c ---   compute second guess as average z0,z1 instead (definite positive)(060322)
        zeta2=0.5*(zeta0+zeta1)
        zetap2=r5*(zeta2+2.*c)-c
      endif
      f2=r4*fbg(zeta2,zetap2,r1,r2,r3)-time
      h=(zeta2+2.*c)/d
c --- Check if second guess good enough (implied time f2 < 1s)
      if(ABS(f2).LE.1.) goto 20


c --- Maximum 10 iterations
      do n=1,10
c ---    Might have already converged (screen those to avoid dividing by 0)
         if(abs(f1-f2).le.1e-10) goto 20
         zeta3=(f1*zeta2-f2*zeta1)/(f1-f2)
         zetap3=r5*(zeta3+2.*c)-c
c ---    only positive definite arguments to fbg (060322)
         if(zeta3.le.0.or.zetap3.le.0) goto 19
         f3=r4*fbg(zeta3,zetap3,r1,r2,r3)-time
         h=(zeta3+2.*c)/d
         zeta1=zeta2
         zetap1=zetap2
         zeta2=zeta3
         zetap2=zetap3
         f1=f2
         f2=f3
c ---    Done if time difference is less than 1 second
         if(ABS(f3).LE.1.) goto 20
      enddo
19    continue
c --- if solution has not converged in 10 iterations or if negative arguments 
c --- average last 2 values (could be oscillating hence the average)
      h=((zeta1+zeta2)/2. + 2.*c)/d
20    continue

c --- Convective mixing height (within min-max values)
      zicbg=min(h,zimx)
      zicbg=max(h,zimn)
     
      return

      end 
c --------------------------------------------------------------------
      function fbg(zeta,zetap,r1,r2,r3)
c -------------------------------------------------------------------
c --- CALMET   Version: 6.4.0     Level: 060301               FBG
C
C     FBG is a function used by the solver in subroutine MIXHBG
C     INPUT:  Zeta, zetap,R1,R2,R3  - real
C     OUTPUT: FBG                   - real
C

      fbg=zeta**2+r1*zeta+r2*LOG(zeta)+r3*LOG(zetap)
      return
      end
c ---------------------------------------------------------------------
      subroutine mixhmc(ihrgmt,is,js,wt,gamma,ilapse,thresh,zimx,
     :                  htold,zic,dptt,tht,thtp)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 110212             MIXHMC
c ---          F. Robe 
c              after MIXHTST/MIXHTST2 (J. Scire, SRC)
c
c --- PURPOSE:  Compute the convective mixing height (m) 
c               following the Maul-Carson method, upgraded to include
c               a buoyancy threshold (minimum heat flux required to overcome
c               dissipation and allow convective growth)
c
c --- UPDATES
c---  v6.329 (100719) to v6.332 (110212)(FRR)
c     (1) Apply relaxation of convective mixing height to equilibrium
c         value according to user-input flag IZICRLX
c     (2) USe  user-defined relaxation time TZICRLX rather than 
c         hardwired value of 800s 
c     (3) IZICRLX and TZICRLX are passed on via ZIPARM.MET
c
c---  V6.203 (060301) to v6.329 (100719)(FRR)
c        - Relax convective mixing heigt to equilibrium value based on THRESHW 
c          (or THRESHL) and turbulence timescale of 800s when the buoyancy flux  
c          is positive but lower than the threshold (rather than collapsing
c          the convective mixing height to 0, causing w*=0 eventhough qh>0) 
c          This change can affect Zi and w* prior results for cases where 
c          THRESHW>0 and/or THRESHL>0 during weakly convective times
c        - Include GEN.MET to get nsecdt
c
c---  v6.202 (060219) to V6.203 (060301)(FRR)
c        - Test whether convective growth based on net surface buoyancy flux 
c          (wt-wto) (i.e. consider threshold too). 
c        - Calculate values for Tht and THTP even when negative net flux (ilapse=1)
c          as they are needed in mixht/mixht2 in that case too.
c
c --- V6.2 (060215) to v6.202 (060219) (FRR)
c        - Comment out the (hourly) definitions of onedte and twodte (which
c          are correctly done in microi and passed via common ziparm.met
c
c --- V5.7 (051230) to V6.2 (060215) (FRR)
c        - Implement sub-hourly timestep for growth (this is done implicitly
c          via constants onedte and twodte defined in microi as a multiple
c          of the actual timestep (not necessarily 3600sec anylonger)
c
c --- V5.614 (051113) to V5.7 (051230)- J. Scire
c        - Correct checks of mixing ht (ZIC) vs. maximum (ZIMX)
c        - Update of some comments (units added + common block inputs)
c        - Add checks on range of WT variable for testing purposes
c --- V5.6 (050328) to v5.611 (051113)- (FRR)
c        - Remove zimin from calling list (not used)
c --- v5.6 Level 050328 to v5.611 Level 051113  (F.Robe)
c     - Set non-zero minimum mixing height
c
c --- INPUTS:
c               IHRGMT - real     - GMT hour 
c              (IS,JS) - integer  - CALMET gridpoints
c                   WT - REAL     - Surface Buoyancy flux in terms of
c                                   <w'Thetav'> (m * deg. K/s)
c                GAMMA - REAL     - potential temperature lapse rate 
c                                   (deg. K/m) above previous hour's 
c                                   mixing height
c                                   (input when ilapse=0 or 2)
c               ILAPSE -  INT     - Lapse rate computational option
c                                   0: read from SEA.DAT file (TGRADA) and
c                                      passed on as gamma
c                                   1: computed from MM5.DAT (call to mixdt2)
c                                   2: extracted from UP.DAT and passed on
c                                      as gamma
c               THRESH - real     - Threshold surface buoyancy (energy) flux per
c                                   meter of boundary layer to get mixing
c                                   height growth (units: W/m2/m)
c                                   = THRESHL overland
c                                   = Threshw overwater 
c                HTOLD - REAL     - Previous hour convective mixing height (m)
c                DPTT  - real     - Pot. temp. jump (deg. K) at top of 
c                                   previous hour conv. mix. height 
c                                  (updated in this subroutine)
c                ZIMX - REAL      - Maximum mixing height (m)
c
c        Common block /ziparm/
c           dptmin, conste, dzzi , onedte, twodte, izicrlx, tzicrlx
c
c        Common block /gen/
c           nsecdt
c      
c --- OUTPUT:
c                  ZIC - real    - Convective mixing height (m)
c                GAMMA - real    - Lapse rate (deg. K/m) above previous 
c                                  hour's mixing height (output if ilapse=1)
c                 DPTT - real    - Pot. temp. jump (deg. K) at top of new 
c                                  conv. mix. height
c                  THT - real    - Temperature (deg. K) at height
c                                  "HTOLD" meters
c                 THTP - real    - Temperature (deg. K) at height
c                                  "HTOLD + DZZI" meters
c      
c
c --- MIXHMC called by: WATER, MIXHT, MIXHT2, MIXHTST, MIXHT2ST
c --- MIXHMC calls    : MIXDT2
c
c----------------------------------------------------------------------
      include 'params.met'
      include 'ziparm.met'
      include 'gen.met'

      data cp/996./,rho/1.2/



c --- Compute temperature lapse rate above current mixing height
c --- if using MM5 profile (non constant)
      if (ilapse.eq.1) then
         call MIXDT2(ihrgmt,is,js,htold,dptmin,dzzi,tsf,tht,thtp,gamma)
      endif
c --- dptmin is minimum stable pot. temp. lapse rate
      gamma=amax1(gamma,dptmin)

c --- Threshold buoyancy flux
      wto=thresh*htold/(rho*cp)

c --- Opt for either total collapse (backward compatible with V5.8 and
c      pre v6.329 codes) or relaxation, based upon user input (110212)
      if (izicrlx.eq.0) then
c ---    Compute convective growth Only if net positive buoyancy flux 
         if ((wt-wto).le.0) then
             zic=0.
             return
         endif
      else
c ---    100719 - Do not totally collapse Zic if 0<wt<wto
         if (wt.le.0) then
            zic=0.
            return
         else if ((wt-wto).le.0) then
c            Equilibrium Ziceq st. wt-wto(ziceq)=0 
             ziceq= rho*cp*wt/thresh
c            Exponential relaxation to Ziceq using turbulence timescale 
c            110212: user-defined timescale 
c            (default: 800s (based on MMS study for Oresund)
c             zic=ziceq+(htold-ziceq)*exp(-nsecdt/800.)
             zic=ziceq+(htold-ziceq)*exp(-nsecdt/tzicrlx)
             return
         endif
      endif
    
c --- Constant twodte is 2.*dt*conste, where dt=timestep in seconds 
      unsqrt=gamma*twodte*(wt-wto)
      unsqrt=amax1(unsqrt,0.0)
      dpttp1=sqrt(unsqrt)

c --- Constant onedte is dt*(1.+conste), where dt=timestep in seconds
c ***
      if(wt.gt.1000.)then
      write(io6,*)
      write(io6,*)'SUBR. MIXHMC'
      write(io6,*)'IHRGMT = ',ihrgmt,' IS = ',is,' JS = ',js
      write(io6,*)'WT = ',wt,' GAMMA = ',GAMMA,' ILAPSE = ',ilapse
      write(io6,*)'THRESH = ',thresh,' ZIMX = ',zimx,' HTOLD = ',htold
      write(io6,*)'DPTMIN = ',dptmin,' DPTT = ',dptt,' THT = ',tht
      write(io6,*)'THTP = ',thtp,' UNSQRT = ',unsqrt,' DPTTP1 = ',dpttp1
      write(io6,*)'WTO = ',wto,' ONEDTE = ',ONEDTE,' TWODTE = ',twodte
      write(io6,*)'CP = ',cp,' RHO = ',rho
      endif
c ***

      unsqrt=htold*htold+2.*((wt-wto)*onedte-dptt*htold)/gamma
      unsqrt=amax1(unsqrt,0.0)


c --- Update jump of pot. temp. at top of mix. height
      dptt=dpttp1

c --- New convective mixing height
      zic=sqrt(unsqrt)+dpttp1/gamma

c --- Bound convective mixing height
c *** JSS - Change 4 occurrences of "zicbg" to "zic"
      zic=max(zic,0.)
      if (zic.ge.zimx) zic=zimx


      return

      end


c----------------------------------------------------------------------
      subroutine openot
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203             OPENOT
c ---          J. Scire, SRC
c
c --- PURPOSE:  Open all input/output files other than the control
c               file (input) and the list file (output)
c
c --- UPDATES:
c
c --- v6.330 (101006) to v6.4.0 (121203)
c               - Open AUX output file at unit ioaux
c
c --- V5.6 (050328) to V6.330 (101006) (CEC)
c              - Change ICLOUD into MCLOUD and ICLDOUT
c
c --- V5.547(041010) to V5.6 (050328) (F.Robe)
c               - Distance-to-the coast output file
c
c     V5.546 (951022) to V5.547 (041010) (FRR)
c        - Multiple MM4-MM5 filesnames (m3ddat(mxm3d)
c
c
c     DEFAULT      DEFAULT
c     UNIT NO.    FILE NAME       TYPE    FORMAT   CONTENTS
c
c       2        DIAG.DAT         input   form.    Preprocessed inputs
c                                                  for diag. wind module
c       7        CALMET.DAT       output  unform.  Gridded output met.
c             or PACOUT.DAT                        (depending on value
c                                                  of IFORMO)
c       8        GEO.DAT          input   form.    Geophysical data
c      10        SURF.DAT         input   either   Surface met. data
c      12        PRECIP.DAT       input   either   Precip. data
c      14        WT.DAT           input   form.    MM4/obs. weights
c      30,31,... UP1.DAT,UP2...   input   form.    Upper air data
c      80,81,... SEA1.DAT,SEA2... input   form.    Overwater data files
c      20        MM51.DAT,MM52... input   form.    MM5 data files-single
c                                                  file open at one time
c                                                  io20)
c
c                        Wind field debug files
c      21        test.prt         output  form.    Intermed. winds
c      22        test.out         output  form.    Final winds
c      23        test.kin         output  form.    Winds after
c                                                  kinematic effect
c      24        test.frd         output  form.    Winds after Froude
c                                                  No. effect
c      25        test.slp         output  form.    Winds after slope
c                                                  flows
c
c                        Cloud Data
c      26        cloud.dat        output  form.    Gridded cloud data
c                                   or     or
c                                 input   unform.
c      
c      27        dcst.grd         output  form.    distance to the coast
c                                                  gridded
c
c --- INPUTS:
c       Common block /OUTPT/
c             lsave, iformo,ldbcst, iauxlwc
c       Common block /MET1/
c             iforms, iformp, nusta, npsta, noobs, mcloud, icldout, iformc
c       Common block /OVRWAT/
c             nowsta
c       Common block /WPARM/
c             ipr0,ipr1,ipr2,ipr3,ipr4,ipr5,ipr6,ipr7,
c             ioutd, idiopt(5), iprog
c       Common block /FILNAM/
c             geodat,srfdat,prcdat,diadat,prgdat,mm4dat,clddat,
c             updat(mxus),seadat(mxows),metdat,pacdat,tstprt,
c             tstout,tstkin,tstfrd,tstslp,m3ddat(mxm3d),dcstgd
c             
c       Parameters: MXNZ, MXSS, MXUS, MXPS, MXOWS, MXWND, MXBAR, mxm3d
c
c --- OUTPUT:
c       Common block /OUTPT/
c             iomet
c       Common block /MET1/
c             ios, iou, iop
c       Common block /OVRWAT/
c             ioow
c       Common block /GEO/
c             iogeo
c
c --- OPENOT called by:  SETUP
c --- OPENOT calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      character*7 cstat
c
      include 'met1.met'
      include 'geo.met'
      include 'outpt.met'
      include 'ovrwat.met'
      include 'wparm.met'
      include 'filnam.met'
c
c *** data cstat/'new'/
      data cstat/'unknown'/
c
c --- preprocessed diagnostic wind inputs -- unit: io2 (ird)
      do 2 i=1,5
      if(idiopt(i).eq.1)then
c ---    DIAG.DAT
         open(io2,file=diadat,status='old')
         go to 3
      endif
2     continue
3     continue
c
c --- binary met. output file -- unit: io7
      iomet=io7
      if(lsave)then
         if(iformo.eq.1)then
c ---       CALMET-formatted output file
c ---       CALMET.DAT
            open(io7,file=metdat,status=cstat,form='unformatted')

c --- v6.4.0, Level 121203
            if(iauxlwc.EQ.1) open(ioaux,file=TRIM(metdat)//'.aux',
     &                            status=cstat,form='unformatted')

         else if(iformo.eq.2)then
c ---       MESOPAC II-formatted output file
c ---       PACOUT.DAT
            open(io7,file=pacdat,status=cstat,form='unformatted')
         else
            write(io6,*)'Error in Subr. OPENOT -- Invalid value of ',
     1      'IFORMO = ',iformo
            stop
         endif
      endif
c
c --- geophysical data input file -- unit: io8
      iogeo=io8
c --- GEO.DAT
      open(io8,file=geodat,status='old')
c
c --- surface meteorological data inputs -- unit: io10 (saved as ios)
c --- FRR (09/01) - Noobs option
c      if(idiopt(4).eq.1)go to 9
      if(idiopt(4).eq.1 .or.noobs.eq.2)go to 9
      ios=io10
      if(iforms.eq.1)then
c ---    SURF.DAT
         open(io10,file=srfdat,status='old',form='unformatted')
      else if(iforms.eq.2)then
         open(io10,file=srfdat,status='old')
      else
         write(io6,*)'Error -- iforms = ',iforms,' (invalid value)'
         stop
      endif
9     continue
c
c --- precipitation data inputs -- unit: io12 (saved as iop)
      iop=io12
      if(npsta.gt.0)then
         if(iformp.eq.1)then
c ---       PRECIP.DAT
            open(io12,file=prcdat,status='old',form='unformatted')
         else if(iformp.eq.2)then
            open(io12,file=prcdat,status='old')
         else
            write(io6,*)'Error -- iformp = ',iformp,' (invalid value)'
            stop
         endif
      endif
12    continue
c
c --- unit:io26 -- CLOUD.DAT file (gridded cloud fields)
ccec101006      if(icloud.eq.1)then
      if(icldout.eq.1)then
c ---    CLOUD.DAT is generated as an OUTPUT file
         if(iformc.eq.1)then
            open(io26,file=clddat,status=cstat,form='unformatted')
         else
            open(io26,file=clddat,status=cstat,form='formatted')
         endif
ccec101006      else if(icloud.eq.2)then
      else if(mcloud.eq.2.and.icldout.eq.0)then
c ---    CLOUD.DAT is read as an INPUT file
         if(iformc.eq.1)then
            open(io26,file=clddat,status='old',form='unformatted')
         else
            open(io26,file=clddat,status='old',form='formatted')
         endif
      endif
c
c --- upper air data inputs -- units: io30, io30+1, io30+2, ...
c FRR (09/2001) additional option for noobs
c      if(idiopt(5).eq.1 .or. noobs .eq. 1) go to 29
      if(idiopt(5).eq.1 .or. noobs .ge. 1) go to 29
      iou=io30
      do 15 i=1,nusta
         io=iou+i-1
c ---    UPn.DAT, n=1,2,3,...
         open(io,file=updat(i),status='old')
15    continue
29    continue
c
c --- overwater data files -- units: io80, io80+1, io80+2, ...
      if(nowsta.gt.0)then
         do 25 i=1,nowsta
            io=io80+i-1
            ioow(i)=io
c
c ---       SEAn.DAT, n=1,2,3,...
            open(io,file=seadat(i),status='old')
25       continue
      endif
c
c --- First gridded prognostic wind field results -- unit: io20
      if(iprog.eq.1 .or. iprog.eq.2)then
c ---    PROG.DAT
         open(io20,file=prgdat,status='old',form='unformatted')
      elseif(iprog.eq.3 .or. iprog.eq.4 .or. iprog.eq.5 .OR.
     :       iprog.eq.13 .or. iprog.eq.14 .or. iprog.eq.15    )then
c ---  Open first  MM4.DAT or MM5.DAT
c ---  frr 050328 - multiple MM5.DAT files allowed (array m3ddat)
c         open(io20,file=mm4dat,status='old')
         open(io20,file=m3ddat(1),status='old')
      endif
c

c --- File with weighting factors for MM4 data - WT.DAT - unit: io19
c frr (09/01) no need for a weight file if no observations at all (noobs=2)
      if((iprog.EQ.3 .OR. iprog.EQ.5 .OR. iprog.eq.13 .OR. iprog.eq.15)
     :    .and. noobs.lt.2) then
c     :   iprog.eq.13 .OR. iprog.eq.15 ) then
         open(io19,file=wtdat,status='old')
      endif
c
c --- wind field module -- testing & debugging files
      i21=ipr0+ipr1+ipr2+ipr3+ipr4+ipr5+ipr6+ipr7+ipr8
      i22=ipr8+ioutd
      i23=ipr5+ioutd
      i24=ipr6+ioutd
      i25=ipr7+ioutd
c
c --- open appropriate wind module files
c
c --- unit: io21 -- printed intermediate and/or final wind fields
c --- TEST.PRT
      if(i21.ge.1)open(io21,file=tstprt,status=cstat)
c
c --- unit: io22 -- disk output -- final wind fields
c --- TEST.OUT
      if(i22.eq.2)open(io22,file=tstout,status=cstat)
c
c --- unit: io23 -- disk output -- winds after kinematic effects
c --- TEST.KIN
      if(i23.eq.2)open(io23,file=tstkin,status=cstat)
c
c --- unit: io24 -- disk output -- winds after Froude No. adj.
c --- TEST.FRD
      if(i24.eq.2)open(io24,file=tstfrd,status=cstat)
c
c --- unit: io25 -- disk output -- winds after slope flows
c --- TEST.SLP
      if(i25.eq.2)open(io25,file=tstslp,status=cstat)
c

c --- unit: io27 -- disk output -- distance to the coast
c --- DCST.GRD
      if(ldbcst)open(io27,file=dcstgd,status=cstat)
c
      return
      end
c----------------------------------------------------------------------
      subroutine out(rarray,iarray,ityp,nsigd,ldate,messag,nx,ny)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 991104                OUT
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write a gridded field of real or integer numbers
c
c --- UPDATE
c --- V5.1 Level 991104 to V6.2 Level 060215 (F.Robe)
c     - Print out explicit beginning/ending times with seconds
c
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c     RARRAY(MXNX,MXNY) - Real array  - Array of real numbers to print
c                                       (used only if ITYP = 1)
c     IARRAY(MXNX,MXNY) - Int. array  - Array of integer numbers to
c                                       print (used only if ITYP = 2)
c                  ITYP - Integer     - Array type (1=real, 2=integer)
c                 NSIGD - Integer     - No. digits to print (valid range
c                                       for NSIGD is 1 to 5)
c                 LDATE - Logical     - Control variable for printing
c                                       of date (.true. = print date in
c                                       common /GEN/, .false. = do not
c                                       print date)
c                MESSAG - Char.*70    - Label of table
c                    NX - Integer     - No. X grid cells being used in
c                                       array
c                    NY - Integer     - No. Y grid cells being used in
c                                       array
c       Common block /GEN/ variables:(Used only if LDATE=.true.)
c            - NYRB,NMOB,NDAYB,nhrb,NSECB
c            - NYRE,NMOE,NDAYE,NRHE,NSECE
c            
c       Parameters: MXNX, MXNY, IO6
c
c --- OUTPUT:  none
c
c --- OUT    called by:  READGE, SETCOM, COMP, OUTPC1, OUTPC
c --- OUT    calls:      WRT, WRT2
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real rarray(mxnx,mxny)
c
      integer iarray(mxnx,mxny),icol(5)
      integer iout(mxnx)
c
      logical ldate
c
      character*70 messag
      character*1 sign(mxnx),plus,minus
      character*24 form1(5)
      character*21 form2(5)
      character*18 form3(5)
c
      include 'gen.met'
c
      data icol /40,40,30,25,20/
      data plus,minus /'+','-'/
      data form1 /'(1x,i3,1x,1hI,40(i3,1x))',
     1            '(1x,i3,1x,1hI,40(i3,1x))',
     2            '(1x,i3,1x,1hI,40(i3,1x))',
     3            '(1x,i3,1x,1hI,40(i4,1x))',
     4            '(1x,i3,1x,1hI,40(i5,1x))'/
      data form2 /'(5x,1hI,40(2x,a1,1x))',
     1            '(5x,1hI,40(2x,a1,1x))',
     2            '(5x,1hI,40(2x,a1,1x))',
     3            '(5x,1hI,40(3x,a1,1x))',
     4            '(5x,1hI,40(4x,a1,1x))'/
      data form3 /'(6x,40(i3,1x))',
     1            '(6x,40(i3,1x))',
     2            '(6x,40(i3,1x))',
     3            '(6x,40(i4,1x))',
     4            '(6x,40(i5,1x))'/
c
c --- check that valid values of array type (ityp) and print digits
c --- (nsigd) have been passed to routine
      if(ityp.ne.1.and.ityp.ne.2)then
         write(io6,*)'ERROR in SUBR. OUT -- invalid value of ITYP -- ',
     1   'ITYP = ',ityp
         stop
      endif
      if(nsigd.lt.1.or.nsigd.gt.5)then
         write(io6,*)'ERROR in SUBR. OUT -- invalid value of NSIGD -- ',
     1   'NSIGD = ',nsigd
         stop
      endif
c
      icr=2
      if(nsigd.eq.1)icr=1
      if(mod(nx,icol(nsigd)).eq.0)then
         npass=nx/icol(nsigd)
      else
         npass=nx/icol(nsigd)+1
      endif
c
c --- real array -- find min. & max. values
      if(ityp.ne.1)go to 50
      xmax=-1.e-25
      xmin=1.e25
      do 10 i=1,nx
      do 10 j=1,ny
      if(rarray(i,j).gt.xmax)xmax=rarray(i,j)
      if(rarray(i,j).lt.xmin)xmin=rarray(i,j)
10    continue
      if(xmin.ne.0.0.or.xmax.ne.0.0)go to 12
      write(io6,95)messag
      if(ldate)write(io6,944) nyrb,nmob,ndayb,nhrb,nsecb,
     :                        nyre,nmoe,ndaye,nhre,nsece
      write(io6,11)
11    format(1x,'GRID NOT PRINTED -- all values zero')
      return
c
12    continue
      xexp=xmax
      if(abs(xmin).gt.xmax)xexp=abs(xmin)
      iexp=alog10(xexp)
      if(xexp.lt.1.0)iexp=iexp-1
      nexp=iexp-(nsigd-icr)
      xscale=10.**(-nexp)
c
      ic2=0
      do 30 ipass=1,npass
c
c      if(ldate)write(io6,94)messag,nyr,nmo,nday,njul,nhr
94    format(/1x,a70,2x,'year: ',i4,2x,'month: ',i2,2x,'day: ',i2,2x,
     1 'Julian day: ',i3,2x,'hour: ',i2/)
944    format(/1x,'FROM: year: ',i4,2x,'month: ',i2,2x,'day: ',i2,2x,
     1 'hour: ',i2, 2x,'second: ',i4,'  TO: year: ',i4,2x,'month: ',
     2 i2,2x,'day: ',i2,2x,'hour: ',i2, 2x,'second: ',i4/ )
c      if(.not.ldate)write(io6,95)messag
95    format(//1x,a70)
      write(io6,95)messag
      if(ldate)write(io6,944) nyrb,nmob,ndayb,nhrb,nsecb,
     :                        nyre,nmoe,ndaye,nhre,nsece

      write(io6,109)nexp
109   format(1x,'Multiply all values by 10 ** ',i3/)
c
      ic1=ic2+1
      ic2=ic2+icol(nsigd)
      if(ic2.gt.nx)ic2=nx
c
         do 20 jj=ny,1,-1
         icnt=0
c
            do 18 i=ic1,ic2
            icnt=icnt+1
            if(rarray(i,jj).lt.0)then
               iout(icnt)=-(rarray(i,jj)*xscale-0.5)
               sign(icnt)=minus
            else
               iout(icnt)=rarray(i,jj)*xscale+0.5
               sign(icnt)=plus
            endif
18          continue
         call wrt(form1(nsigd),form2(nsigd),jj,iout,sign,icnt,io6)
20       continue
      nund=(nsigd+1)*icnt-1
      if(nsigd.eq.1)nund=(nsigd+2)*icnt-1
      write(io6,101)(minus,n=1,nund)
101   format(5x,128a1)
      call wrt2(form3(nsigd),ic1,ic2,io6)
30    continue
      return
c
c --- integer array -- find min. & max. values
50    continue
      kmax=-9999999
      kmin=9999999
      do 110 i=1,nx
      do 110 j=1,ny
      if(iarray(i,j).gt.kmax)kmax=iarray(i,j)
      if(iarray(i,j).lt.kmin)kmin=iarray(i,j)
110   continue
      if(kmin.ne.0.or.kmax.ne.0)go to 102
      write(io6,95)messag
      if(ldate)write(io6,944) nyrb,nmob,ndayb,nhrb,nsecb,
     :                        nyre,nmoe,ndaye,nhre,nsece
      write(io6,11)
      return
c
102   continue
      xexp=kmax
      if(iabs(kmin).gt.kmax)xexp=iabs(kmin)
      iexp=alog10(xexp)
      if(xexp.lt.1.0)iexp=iexp-1
      nexp=iexp-(nsigd-icr)
      xscale=10.**(-nexp)
c
      ic2=0
      do 130 ipass=1,npass
c
      if(ldate)write(io6,94)messag,nyr,nmo,nday,njul,nhr
      if(.not.ldate)write(io6,95)messag
      write(io6,109)nexp
c
      ic1=ic2+1
      ic2=ic2+icol(nsigd)
      if(ic2.gt.nx)ic2=nx
c
         do 120 jj=ny,1,-1
         icnt=0
c
            do 118 i=ic1,ic2
            icnt=icnt+1
            if(iarray(i,jj).lt.0)then
               iout(icnt)=-(iarray(i,jj)*xscale-0.5)
               sign(icnt)=minus
            else
               iout(icnt)=iarray(i,jj)*xscale+0.5
               sign(icnt)=plus
            endif
118         continue
         call wrt(form1(nsigd),form2(nsigd),jj,iout,sign,icnt,io6)
120      continue
      nund=(nsigd+1)*icnt-1
      if(nsigd.eq.1)nund=(nsigd+2)*icnt-1
      write(io6,101)(minus,n=1,nund)
      call wrt2(form3(nsigd),ic1,ic2,io6)
130   continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine outfil(ifile,time,u,v,w)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 940304             OUTFIL
c              S.DOUGLAS, SAI
c
c --- include parameters
      include 'params.met'
c NEw -frr (12/96) - D5 replaced by grid.met
      include 'grid.met'
c      COMMON /D5/ NX,NY,NZ,DX,DY,dz(mxnz),NZPRNT
      DIMENSION U(mxnx,mxny,*),V(mxnx,mxny,*),
     1          W(mxnx,mxny,*)
C
C     WRITES OUTPUT FILE OF WIND COMPONENTS
C
C     INPUTS:  IFILE (I)   - UNIT NO OF OUTPUT FILE
C              TIME (R)    - SIMULATION TIME
C              U (R ARRAY) - GRIDDED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY) - GRIDDED Y-DIRECTION WIND COMPONENTS
C              W (R ARRAY) - GRIDDED VERTICAL WIND COMPONENTS
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
      WRITE(IFILE,1010) TIME
      WRITE(IFILE,1020) NX,NY,NZ
      DXK=DX*.001
      DYK=DY*.001
      WRITE(IFILE,1030) DXK,DYK
      DO 100 K=1,NZ
      DO 100 J=1,NY
      WRITE(IFILE,1040) (U(I,J,K),I=1,NX)
  100 CONTINUE
      DO 200 K=1,NZ
      DO 200 J=1,NY
      WRITE(IFILE,1040) (V(I,J,K),I=1,NX)
  200 CONTINUE
      NZP1 = NZ + 1
      DO 300 K = 1,NZP1
      DO 300 J = 1,NY
      WRITE(IFILE,1050) (W(I,J,K),I=1,NX)
  300 CONTINUE
 1010 FORMAT(F6.0)
 1020 FORMAT(3I4)
 1030 FORMAT(2F4.0)
 1040 FORMAT(59F7.2)
 1050 FORMAT(59E8.1)
      RETURN
      END
c----------------------------------------------------------------------
      subroutine outhd
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203              OUTHD
c ---          J. Scire
c
c --- PURPOSE:  Write header records to CALMET output file
c
c --- UPDATES:
c
c --- V6.2 (060215) to v6.4.0 (121203)
c               - Do not close scratch file here (still needed)
c               - Model version is 12 characters
c
c --- V5.549 (050128) to V6.2 (060215)  (FRR)
c               - Replace hour-ending times with explicit beginning
c                 ending times in record #NCOM+3
c               - Upgrade CALMET.DAT version number to 2.1

c --- V5.5 (030402) to V5.549 (050128)  (DGS)
c               - Add call to COORDSVER and write info to output file
c                 headers
c                                 
c --- V5.4 (980304) to V5.5 (030402)  (DGS)
c               - Revised header format with control file image
c               - Old record #1 dropped
c               - Old record #2 and #3 modified and combined
c
c ---           Modified 3/98 to include an additional header record
c ---           with grid and map information (Record 3)
c
c --- INPUTS:
c      common block /GEN/
c         ibyrn,ibmon,ibdyn,ibhrn,ibsecn,ieyrn,iemon,iedyn,iehrn,iesecn,
c         axtz,irlg,irtype,lcalgrd
c      common block /GEO/
c         ilandu(mxnx,mxny), elev(mxnx,mxny), z0(mxnx,mxny)
c      common block /GRID/
c         nx, ny, nz, dgrid, zface(mxnz+1), xorigr, yorigr, iutmzn,
c         nears(mxnx,mxny), xlat0, xlon0
c      common block /LON/
c         llconf, conec, xlat1, xlat2, rlat0, rlon0
c      common block /MET1/
c         nssta, nusta, npsta, xssta(mxss), yssta(mxss),
c         xusta(mxus), yusta(mxus), xpsta(mxps), ypsta(mxps)
c      common block /OVRWAT/
c         nowsta
c      common block /WPARM/
c         iwfcod
c      common block /QA/
c         ver, level, ncommout
c      common block /OUTPT/
c         iomet
c      Parameters: MXNX, MXNY, MXNZ, MXNZP1, MXSS, MXUS, MXPS,
c                  MXLEV, MXBAR, MXWND, MXOWS, MXLU, IOMET, IOX
c
c --- OUTPUT:  none
c
c --- OUTHD called by:  SETUP
c --- OUTHD calls:      WRTR1D, WRTR2D, WRTI2D, COORDSVER
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      include 'gen.met'
      include 'geo.met'
      include 'grid.met'
      include 'map.met'
      include 'met1.met'
      include 'ovrwat.met'
      include 'wparm.met'
      include 'qa.met'
      include 'outpt.met'

c --- Local Variables
      real xbuf(mxnx,mxny)
      character*8 clabel
      character*16 dataset,dataver
      character*33 blank33
      character*64 datamod
      character*132 comment1,blank
c
      character*50 verdoc
c
      data idum/0/
      data blank33/'                                 '/

c --- Configure output documentation
      data dataset/'CALMET.DAT'/, dataver/'2.1'/
      data datamod/'No-Obs file structure with embedded control file'/
      data comment1/'Produced by CALMET Version: '/

c --- Set blank (132 characters)
      blank(1:33)=blank33
      blank(34:66)=blank33
      blank(67:99)=blank33
      blank(100:132)=blank33

c --- Construct the version-level comment string
      j=29
c --- v6.4.0, Level 121203
      do i=1,12
         if(ver(i:i).NE.' ') then
            comment1(j:j)=ver(i:i)
            j=j+1
         endif
      enddo
      j=j+1
      comment1(j:j+7)=' Level: '
      j=j+8
      do i=1,8
         if(level(i:i).NE.' ') then
            comment1(j:j)=level(i:i)
            j=j+1
         endif
      enddo

c --- Obtain COORDS version information
      call COORDSVER(io6,verdoc)

c --- Record #1 - File Declaration -- 24 words
      write(iomet) dataset,dataver,datamod
c
c --- Record #2 - Number of comment lines -- 1 word
      ncom=ncommout+2
      write(iomet) ncom
c
c --- Record #3 to NCOM+2 (Comment record section) -- 33 words each
      write(iomet) comment1
c --- Report COORDS version
      comment1=blank
      comment1(1:36)='Internal Coordinate Transformations '
      comment1(37:86)=verdoc
      write(iomet) comment1
c --- Go to beginning of the scratch file with the control file image
      REWIND(iox)
c --- Loop over records
      do i=1,ncommout
         comment1=blank
         read(iox,'(a132)') comment1
         write(iomet) comment1
      enddo

c
c --- record #NCOM+3 - run control parameters -- 39 words
      write(iomet) ibyrn,ibmon,ibdyn,ibhrn,ibsecn,ieyrn,iemon,iedyn,
     1 iehrn,iesecn,axtz,irlg,irtype,
     1 nx, ny, nz, dgrid, xorigr, yorigr, iwfcod, nssta,
     2 nusta, npsta, nowsta, nlu, iwat1, iwat2, lcalgrd,
     3 pmap,datum,daten,feast,fnorth,utmhem,iutmzn,
     4 rnlat0,relon0,xlat1,xlat2
c
c --- record #NCOM+4 - cell face heights (NZ + 1 words)
      nzp1=nz+1
      clabel='ZFACE'
      call wrtr1d(iomet,zface,nzp1,clabel,idum,idum,idum,idum)
c
c --- records #NCOM+5 & 6 - x, y coordinates of surface stations
c --- (NSSTA words each record)
      if(nssta.ge.1)then
         clabel='XSSTA'
         call wrtr1d(iomet,xssta,nssta,clabel,idum,idum,idum,idum)
         clabel='YSSTA'
         call wrtr1d(iomet,yssta,nssta,clabel,idum,idum,idum,idum)
      endif
c
c --- records #NCOM+7 & 8 - x, y coordinates of upper air stations
c --- (NUSTA words each record)
      if(nusta.ge.1)then
         clabel='XUSTA'
         call wrtr1d(iomet,xusta,nusta,clabel,idum,idum,idum,idum)
         clabel='YUSTA'
         call wrtr1d(iomet,yusta,nusta,clabel,idum,idum,idum,idum)
      endif
c
c --- records #NCOM+9 & 10 - x, y coordinates of precipitation stations
c --- (NPSTA words each record)
      if(npsta.ge.1)then
         clabel='XPSTA'
         call wrtr1d(iomet,xpsta,npsta,clabel,idum,idum,idum,idum)
         clabel='YPSTA'
         call wrtr1d(iomet,ypsta,npsta,clabel,idum,idum,idum,idum)
      endif
c
c --- record #NCOM+11 - surface roughness lengths (NX * NY words)
      clabel='Z0'
      call wrtr2d(iomet,z0,xbuf,mxnx,mxny,nx,ny,clabel,idum,idum,
     :            idum,idum)
c
c --- record #NCOM+12 - land use categories (NX * NY words)
      clabel='ILANDU'
      call wrti2d(iomet,ilandu,xbuf,mxnx,mxny,nx,ny,clabel,idum,idum,
     :            idum,idum)
c
c --- record #NCOM+13 - elevations (NX * NY words)
      clabel='ELEV'
      call wrtr2d(iomet,elev,xbuf,mxnx,mxny,nx,ny,clabel,idum,idum,
     :            idum,idum)
c
c --- record #NCOM+14 - leaf area index (NX * NY words)
      clabel='XLAI'
      call wrtr2d(iomet,xlai,xbuf,mxnx,mxny,nx,ny,clabel,idum,idum,
     :            idum,idum)
c
c --- record #NCOM+15 - nearest surface station no. to each
c                  grid point (NX * NY words)
c frr (09/01)- in noobs mode, no surface station      
      if(nssta.ge.1)then
         clabel='NEARS'
         call wrti2d(iomet,nears,xbuf,mxnx,mxny,nx,ny,clabel,idum,idum,
     :               idum,idum)
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine surfvar(u,v,tprog,temp2d,irh2d,ipcode2d,iall)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 071207            SURFVAR
c ---          F.Robe , Earth Tech
c
c --- PURPOSE:  Fill out 2D arrays of surface temperature,
c               relative humidity, and precipitation code,
c               using surface observations or prognostic data
c
c --- UPDATES:
c --- V6.223 Level 070702 to V6.31 Level 071207(F.Robe)
c           - Set RH to 100% overwater when there are no overwater 
c             stations (i.e. no SEA.DAT file) 
c           - Use default value for temp2d when iall=2 and itprog=2
c             because tprog not yet defined at that point
c --- v6.210 060408 to V6.223 Level 070702(F.Robe)
c           - Add option iall=2 to skip temperature averaging 
c
c ---  V5.6b Level 050412 to v6.210 060408 (F.Robe)
c           - change irhprog array name to irhpg
c           - fill in irh array with prognostic data based on value
c             of user-input parameter irhprog instead of noobs
c           - Separate RH and IPCODE array-filling statements
c 
c ---  V5.6 Level 050328 to V5.6b Level 050412 (F.Robe)
c           - Include 'ziparm.met'(to get hafang, mnmdav values)
c ---  V5.545 Level 030119 to V5.6 Level 050328  (F.Robe)
c           - Add flag to compute 2D temperature only or all variables
c           - Use original station temperature including missing data (otempk)
c             rather than temperature where missing values have been replaced
c             by nearest station value (tempk)
c           - Refine temperature extrapolation using IRAd, TRADKM, etc
c             rather than just taking nearest station value (surface 
c             interpolation moved here from (old)temp3d subroutine)
c                
c               
c --- INPUTS:
c            U(mxnx,mxny) - real array - surface wind U component
c            V(mxnx,mxny) - real array - surface wind V component
c
c   TPROG(mxnx,mxny,mxnz) - real array - prognostic temperature
c                                        on CALMET grid
c
c                    IALL - integer    - Flag to compute 
c                                       0: temperature only
c                                       1: all surf. variables (IALL=1)
c                                       2: all sf. var. but without 
c                                          temperature spatial averaging
c
c       Common block /GRID/
c          NX,NY,NZ,NEARS(mxnx,mxny)
c       Common block /MET1/
c          ITPROG,noobs,NPSTA
c       Common block /MET2/
c          OTEMPK(mxss), IRH(mxss), IPCODE(mxss)
c       Common /SURFPROG/(with rdmm5)
c          IRHPG(mxnx,mxny),IPCODEPG(mxnx,mxny)
c        Common block /TMP/
c           irad,numwb,tgdefb,tgdefa,jwat1,jwat2,trad,numts,iavet
c        Common block /GEO/
c           ilandu,iwat1,iwat2
c        Common block /OVRWAT/
c           tairow,nowsta
c        Common block /ZIPARM/
c           hafang,mnmdav
c
c --- OUTPUT:
c    TEMP2D(mxnx,mxny) - real array - surface temperature at all gridpoints
c     IRH2D(mxnx,mxny) - int array  - surface relative humidity       
c  IPCODE2D(mxnx,mxny) - int array  - surface precipitation code
c----------------------------------------------------------------------
c
      include 'params.met'
      include 'grid.met'
      include 'met1.met'
      include 'met2.met'
      include 'tmp.met'
      include 'geo.met'
      include 'ovrwat.met'
      include 'ziparm.met'

      common /surfprog/irhpg(mxnx,mxny),ipcodepg(mxnx,mxny)
      real u(mxnx,mxny),v(mxnx,mxny)
      real temp2d(mxnx,mxny),tprog(mxnx,mxny,mxnz)
      integer irh2d(mxnx,mxny),ipcode2d(mxnx,mxny),itmprh(mxtmp)
      real tmpwrk(mxtmp),tdist(mxtmp)
      integer stlist(mxtmp)

      data xmiss/9999./

c --- initialize (to 15C, 80%RH,no precip)
      do 1 j=1,ny
      do 1 i=1,nx
         temp2d(i,j)=288.
         irh2d(i,j) = 80
         ipcode2d(i,j) = 0
1     continue

      dgridi = 1.0 / dgrid
c
c --- Use Prognostic data for surface temperature if itprog=2
      if (itprog.eq.2) goto 49
         
c frr 050328 - Take code from old temp3d subroutine to interpolate T at surface

c --- Determine whether overwater vs. land interpolation to be used
c     (assume mxwb is hardwired to 1)
c --- Find maximum land use category
c
      maxcat = 0
      do lwi = 1,nlu
        if (ilucat(lwi) .gt. maxcat) maxcat = ilucat(lwi)
      end do
c
c --- If maximum land use category is < jwat1, use all sites
c     in the interpolation
c
      ldwat = 1
      if (maxcat .lt. jwat1(mxwb)) ldwat = 0
c
c --- Set LNDWAT = 0 so won't be undefined
c
      lndwat = 0
c
c --- Load surface temperature working array
c
      nstat = nssta + nowsta
      if ((nstat) .gt. mxtmp) then
        write(io6,*) ' too many combined surface stations!'
        write(io6,*) ' mxtmp = ',mxtmp,' nssta & nowsta = ',
     &                 nssta,nowsta
        stop
      end if
      do mstat = 1,nstat
        if (mstat .le. nssta) then
          tmpwrk(mstat) = otempk(mstat)
        else
          tmpwrk(mstat) = tairow(mstat - nssta)
        end if
      end do
c
c --- Reduce the missing value indicator by a small amount to allow
c     for machine roundoff
      xmissm=xmiss-0.01
c
49    continue

c --- Loop over grid cells
c
      do 50 i = 1,nx
c
c --- Note,(xssta,yssta) are relative to the SW corner of grid pt (1,1)
c
      xc = float(i) - 0.5
c
      do 50 j = 1,ny
        yc = float(j) - 0.5
c

c ---   Use prognostic temperature if itprog=2
c ---  (but not at first call to SURFVAR because tprog not defined yet)
        if ( itprog .eq. 2 ) then
c          temp2d(i,j) = tprog(i,j,1)
           if (iall.ne.2)temp2d(i,j) = tprog(i,j,1)
           goto 50
        endif

c --- Compute the weights for the surface met stations
c     and compute the average surface temperature
c     and average temperature gradients
c     (irad = 1 = 1/R; irad = 2 = 1/R**2)
c
c----------------------------------------------------------------
c...multiple water body capability commented out for now (9/94)
c
c --- If using land/water interpolation, determine in which water
c     body, if any, the grid cell is located
c
c.wb    jwb = 0
c.wb    if (numwb .gt. 0) then
c.wb      do iwb = 1,numwb
c.wb        if (ilandu(i,j) .ge. jwat1(iwb) .and.
c.wb &          ilandu(i,j) .le. jwat2(iwb)) then
c
c --- Grid cell land use places it in water body iwb
c
c.wb          jwb = iwb
c.wb          goto 27
c.wb        end if
c.wb      end do
c
c --- Grid cell not in any water body of interest, call it land
c     (jwb = 0)
c.wb
c.wb    end if
c27     continue
c--------------------------------------------------------------------
c  FRR (09/2001) May want an option for observed water temp rather than
c                prognostic temp in the future 

c --- If using land/water interpolation, determine whether water
c     or land (assume mxwb is hardwired to 1)
c
        if (ldwat .eq. 1) then
          lndwat = 0
          if (ilandu(i,j) .ge. jwat1(mxwb) .and.
     &        ilandu(i,j) .le. jwat2(mxwb)) lndwat = 1
        end if
c
c --- Find valid stations
c
        numsta = 0
        do 30 is = 1,nstat
c
c --- Skip this station if the temperature data is missing
c
          if (tmpwrk(is) .ge. xmissm) goto 30
c
c --- If not using L/W interpolation, skip this part and use all
c     stations
c
          if (ldwat .eq. 1) then
c
c --- Skip this station if using L/W interpolation, cell is water,
c     and station is land
c
            if (lndwat .eq. 1 .and. is .le. nssta) goto 30
c
c --- Skip this station if using L/W interpolation, cell is land,
c     and station is water
c
            if (lndwat .eq. 0 .and. is .gt. nssta) goto 30
          end if
c
c---------------------------------------------------------------------
c...multiple water body capability commented out for now (9/94)
c
c --- If number of water bodies to be interpolated = 0 then
c     include all nonmissing stations (numwb = 0).
c --- If using water/land interpolation (numwb > 0), discard
c     station if not located in interpolation area that corresponds
c     to land use range for that water body/land.
c
c.wb      if (numwb .gt. 0 .and. jwb .ne. jlandu(is)) goto 30
c----------------------------------------------------------------------
c
          numsta = numsta + 1
          if (is .le. nssta) then
            xxx = xssta(is)
            yyy = yssta(is)
          else
            xxx = xowsta(is - nssta)
            yyy = yowsta(is - nssta)
          end if
          r2 = (xxx * dgridi - xc)**2 +
     &         (yyy * dgridi - yc)**2
c
c --- Valid station, store distance and site number
c
          tdist(numsta) = sqrt(r2)
          stlist(numsta) = is
   30   continue
c
c --- Sort list of eligible stations
c
        if (numsta .gt. 1) then
          do ii = 1,numsta-1
          do jj = ii+1,numsta
            if (tdist(ii).gt.tdist(jj)) then
              tmpvar = tdist(ii)
              tdist(ii) = tdist(jj)
              tdist(jj) = tmpvar
              itmpvar = stlist(ii)
              stlist(ii) = stlist(jj)
              stlist(jj) = itmpvar
            end if
          end do
          end do
        end if
        if (numsta .eq. 0) then
c
c --- No valid sites, stop program
c
          write(io6,*) ' grid cell ',i,j,' has no valid sites for'
          write(io6,*) ' interpolation.  If it is a water body and'
          write(io6,*) ' you are using land/water interpolation,'
          write(io6,*) ' you must have at least 1 sea#.dat file!'
c
c------------------------------------------------------------------
c...commented out because no multiple water bodies and no JLANDU
c
c.wb      write(io6,*) ' you must assign it a real or pseudo'
c.wb      write(io6,*) ' station in input group 7!'
c-------------------------------------------------------------------
c
          stop
        end if
        sumwt = 0.0
        tsurf = 0.0
c
c --- Calculate average temperature

c ---   No stations within radius of influence, take nearest one  
        if (tdist(1) .gt. trad) then
           tsurf = tmpwrk(stlist(1))

        else
c --- Some stations within radius, use up to NUMTS of them
          do 888 is = 1,numsta
            if (tdist(is) .gt. trad) goto 889
            if (is .gt. numts) goto 889
            if (irad .eq. 2) tdist(is) = tdist(is) * tdist(is)
            if (tdist(is) .lt. 1.0) then
              wt = 1.0
            else
              wt = 1.0 / tdist(is)
            endif
            sumwt = sumwt + wt
            tsurf = tsurf + wt*tmpwrk(stlist(is))
 888      continue
 889      tsurf = tsurf / sumwt

        end if
c
c --- Always use the surface determined temperature for the lowest cell
c
        temp2d(i,j) = tsurf
   50 continue
c
51    continue

c --- Spatially average surface temperature
c --- (currently uses mixing height variables)
c
      if (iavet.eq.1.and.iall.ne.2) 
     &  call avetmp(nx,ny,mnmdav,hafang,dgrid,u,v,temp2d)
c

c --- Skip computation of other variables if not needed (050328-frr)
      if (iall.eq.0) return      
c

c --- RELATIVE HUMIDITY
c ----------------------
c --- Use prognostic data if irhprog=1 (will be automatcially the case if noobs=2)
      if (irhprog.eq.1) then
         do i=1,nx
            do j=1,ny
               irh2d(i,j)    = irhpg(i,j)
            end do
         end do
         goto 501
      endif         


c --- Load RH working array -
c
      do mstat = 1,nstat
        if (mstat .le. nssta) then
          itmprh(mstat) = irh(mstat)
        else
          itmprh(mstat) = int(rhow(mstat - nssta))
c ---      ASsume 100% RH overwater if overwater obs. missing
          if(itmprh(mstat).ge.xmissm) itmprh(mstat)=100
        end if
      end do
c
499   continue
c --- Loop over grid cells
c
      do 500 i = 1,nx
c --- Note,(xssta,yssta) are relative to the SW corner of grid pt (1,1)
      xc = float(i) - 0.5

      do 500 j = 1,ny
        yc = float(j) - 0.5
c
c --- Compute the weights for the surface met stations
c     and compute the average surface relative humidity
c     (irad = 1 = 1/R; irad = 2 = 1/R**2)

c --- If using land/water interpolation, determine whether water
c     or land (assume mxwb is hardwired to 1)
c
        if (ldwat .eq. 1) then
          lndwat = 0
          if (ilandu(i,j) .ge. jwat1(mxwb) .and.
     &        ilandu(i,j) .le. jwat2(mxwb)) lndwat = 1
        end if
c
c --- Find valid stations
c
        numsta = 0
        do 300 is = 1,nstat
c
c --- Skip this station if the RH data is missing
c
          if (itmprh(is) .ge. xmissm) goto 300
c
c --- If not using L/W interpolation, skip this part and use all
c     stations
c
          if (ldwat .eq. 1) then
c
c --- Skip this station if using L/W interpolation, cell is water,
c     and station is land
c
            if (lndwat .eq. 1 .and. is .le. nssta) goto 300
c
c --- Skip this station if using L/W interpolation, cell is land,
c     and station is water
c
            if (lndwat .eq. 0 .and. is .gt. nssta) goto 300
          end if

          numsta = numsta + 1
          if (is .le. nssta) then
            xxx = xssta(is)
            yyy = yssta(is)
          else
            xxx = xowsta(is - nssta)
            yyy = yowsta(is - nssta)
          end if
          r2 = (xxx * dgridi - xc)**2 +
     &         (yyy * dgridi - yc)**2
c
c --- Valid station, store distance and site number
c
          tdist(numsta) = sqrt(r2)
          stlist(numsta) = is
  300   continue
c
c --- Sort list of eligible stations
c
        if (numsta .gt. 1) then
          do ii = 1,numsta-1
          do jj = ii+1,numsta
            if (tdist(ii).gt.tdist(jj)) then
              tmpvar = tdist(ii)
              tdist(ii) = tdist(jj)
              tdist(jj) = tmpvar
              itmpvar = stlist(ii)
              stlist(ii) = stlist(jj)
              stlist(jj) = itmpvar
            end if
          end do
          end do
        end if
        sumwt = 0.0
        rhsurf = 0.

c --- if no valid site, assume 80% RH (overland only -Overwater:100%)
        if (numsta .eq. 0) then
           if(lndwat.eq.1) then 
c             numsta=0 can happen for overwater pts if there are 
c             no SEA.DAT 
              rhsurf=100.
           else
             rhsurf=80.
           endif
           goto 9000
        end if

c
c --- Calculate average RH

c ---   No stations within radius of influence, take nearest one  
        if (tdist(1) .gt. trad) then
           rhsurf = itmprh(stlist(1))

        else
c --- Some stations within radius, use up to NUMTS of them
          do 8888 is = 1,numsta
            if (tdist(is) .gt. trad) goto 8889
            if (is .gt. numts) goto 8889
            if (irad .eq. 2) tdist(is) = tdist(is) * tdist(is)
            if (tdist(is) .lt. 1.0) then
              wt = 1.0
            else
              wt = 1.0 / tdist(is)
            endif
            sumwt = sumwt + wt
            rhsurf = rhsurf + wt*itmprh(stlist(is))
8888      continue
8889      rhsurf = rhsurf / sumwt

        end if
c
9000    continue

c ---   2D surface relative humidity
        irh2d(i,j) = int (rhsurf)

500   continue

501   continue

c --- IPCODE  
c     ------    
c --- Skip if no precipitation (obs or progn)
      if (npsta.eq.0) goto 999

      if (noobs.eq.2 .or. npsta.eq.-1) then
c ---    Use prognostic data  
         do i=1,nx
            do j=1,ny
               ipcode2d(i,j) = ipcodepg(i,j)
            end do
         end do
      else
c ---    Take nearest station value if not missing- otherwise assume ipcode=0
         do 11 j=1,ny
         do 11 i=1,nx
            nsta=nears(i,j)
            if (ipcode(nsta).lt.xmissm) ipcode2d(i,j)=ipcode(nsta)
   11    continue
      endif

999   return
      end

c----------------------------------------------------------------------
      subroutine outhr(ndathrb,nsecb,ndathre,nsece,
     1                 nx,ny,nz,npsta,irtype,rho,qsw,
     1                 iomet,lcalgrd,temp2d,irh2d,ipcode2d)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060215              OUTHR
c ---          J. Scire, SRC
c              modified by F.Robe, Earth Tech
c
c --- PURPOSE:  Write hourly meteorological output fields
c
c       Run type = 0 (wind fields only)    -- write wind fields only
c       Run type = 1 (winds + met. fields) -- write wind fields + other
c                                             meteorological fields
c       (U, V components defined at grid points, W components
c        at grid cell faces starting at top of cell 1 -- i.e.,
c        "NZ" W fields written)
c       (Precipitation fields written only if no. precip.
c        stations (NPSTA) > 0)  or if MM5 precipitation data exist(NPSTA=-1)
c
c --- UPDATES:
c     Level 901130 to V6.2 (060215) (F. Robe)
c           - Replace hour ending times with explicit beginning/ending
c             times, including seconds (sub-hourly timesteps)

c --- INPUTS:
c       NDATHRB - integer     - Beginning Date and hour (YYYYJJJHH)
c                               in LST (explicit)
c         NSECB - integer     - Beginning seconds in LST (explicit)
c       NDATHRE - integer     - Ending Date and hour (YYYYJJJHH)
c                               in LST (explicit)
c         NSECE - integer     - Ending seconds in LST (explicit)
c        NX, NY - integers    - No.  X, Y grid cells
c            NZ - integer     - No. vertical layers
c         NSSTA - integer     - No. surface stations
c         NPSTA - integer     - No. precipitation stations
c        IRTYPE - integer     - Run type (0=only wind fields computed,
c                               1=winds + other met. fields computed)
c RHO(mxnx,mxny)- real array  - Air density (kg/m**3) at all gridpoints
c QSW(mxnx,mxny)- real array  - Short-wave radiation (W/m**2) at all
c                               gridpoints
c         IOMET - integer     - Fortran unit no. of output file
c       LCALGRD - logical     - Logical flag controlling output of
c                               special data fields needed by CALGRID
c                               (3-D fields of W and temperature)
c                               (LCALGRD=T to output these fields)
c   IRH2D(mxnx,mxny) - real array  - surface relative humidity
c   TEMP2D(mxnx,mxny)- real array  - surface temperature 
c IPCODE2D(mxnx,mxny)- real array  - precipitation code
c               
c       Common block /METGRD/
c          IPGT(mxnx,mxny), USTAR(mxnx,mxny), ZI(mxnx,mxny),
c          EL(mxnx,mxny), WSTAR(mxnx,mxny), RMM(mxnx,mxny)
c          ZTEMP(mxnx,mxny,mxnz)
c  frr (09/01) no need for common block MET2 as 2D values of T,RH,IPCODE
c       Common block /MET2/
c          TEMPK(mxss), IRH(mxss), IPCODE(mxss)
c       Common block /D1/
c          U(mxnx,mxny,mxnz), V(mxnx,mxny,mxnz), W(mxnx,mxny,mxnzp1)
c       Parameters: MXSS, MXUS, MXNX, MXNY, MXNZ, MXWND, MXNZP1
c
c --- OUTPUT:  none
c
c --- OUTHR called by:  COMP
c --- OUTHR calls:      WRTI2D, WRTR2D
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real rho(mxnx,mxny),qsw(mxnx,mxny),xbuf(mxnx,mxny)
      real temp2d(mxnx,mxny)
      integer irh2d(mxnx,mxny),ipcode2d(mxnx,mxny)

      character*8 clabel
      logical lcalgrd
c
      include 'metgrd.met'
      include 'd1.met'

c
c --- write the wind components
      do 10 i=1,nz
c
      clabel='U-LEV'
      write(clabel(6:8),'(i3)')i
      call wrtr2d(iomet,u(1,1,i),xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel(1:1)='V'
      call wrtr2d(iomet,v(1,1,i),xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      if(LCALGRD)then
c ---    W velocities at TOP cell face are written (NZ fields in all)
         clabel(1:5)='WFACE'
         call wrtr2d(iomet,w(1,1,i+1),xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
      endif
10    continue
c
c --- write the 3-D temperature field (LCALGRD run only)
      if(irtype.eq.0)return
      if(LCALGRD)then
         clabel='T-LEV'
         do 20 i=1,nz
         write(clabel(6:8),'(i3)')i
         call wrtr2d(iomet,ztemp(1,1,i),xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
20       continue
      endif
c
c --- write other 2-D meteorological fields -- PGT stability class,
c       Friction velocity (m/s), Mixing height (m), Monin-Obukhov
c       length (m), Convective velocity scale (m/s), Precip.
c       rate (mm/hr)
c     (if run type = 0, i.e., only winds computed, skip these writes)
      if(irtype.eq.0)return
      clabel='IPGT'
      call wrti2d(iomet,ipgt,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel='USTAR'
      call wrtr2d(iomet,ustar,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel='ZI'
      call wrtr2d(iomet,zi,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel='EL'
      call wrtr2d(iomet,el,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel='WSTAR'
      call wrtr2d(iomet,wstar,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel='RMM'
      if(npsta.ne.0 )
     : call wrtr2d(iomet,rmm,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)

c
c frr (09/01) SF TEMP, RHO, QSW, IRH, IPCODE: 2-D fields
c     Air density (kg/m**3), Short-wave solar radiation (W/m**2),
c     Relative humidity (percent), Precipitation code

      clabel='TEMPK'
      call wrtr2d(iomet,temp2d,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel='RHO'
      call wrtr2d(iomet,rho,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel='QSW'
      call wrtr2d(iomet,qsw,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel='IRH'
      call wrti2d(iomet,irh2d,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)
c
      clabel='IPCODE'
      if(npsta.ne.0)
     :  call wrti2d(iomet,ipcode2d,xbuf,mxnx,mxny,nx,ny,clabel,
     :            ndathrb,nsecb,ndathre,nsece)

      return
      end
c----------------------------------------------------------------------
      subroutine pack(nvals,xdata,nwords,xbuf)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130               PACK
c ---          J. Scire, SRC
c
c --- PURPOSE:  Pack a packed array of data by eliminating zeroes
c               (assumes all data values >= 0.0)
c
c --- INPUTS:
c       XDATA(NVALS) - real array - Array of unpacked data
c              NVALS - integer    - No. of unpacked values stored in
c                                   packed array
c
c --- OUTPUT:
c             NWORDS - integer    - Number of packed words
c       XBUF(NWORDS) - real array - Array of packed data
c
c --- PACK called by:  ******
c --- PACK calls:      none
c----------------------------------------------------------------------
      real xbuf(nvals),xdata(nvals)
c
c --- pack the data
      nzero=0
      nwords=0
      do 100 i=1,nvals
c
      if(xdata(i).eq.0.)then
         nzero=nzero+1
         go to 100
      endif
c
      if(nzero.gt.0)then
         nwords=nwords+1
         xbuf(nwords)=-nzero
         nzero=0
      endif
c
      nwords=nwords+1
      xbuf(nwords)=xdata(i)
100   continue
c
c --- account for case when last value in unpacked array is a zero
      if(nzero.gt.0)then
         nwords=nwords+1
         xbuf(nwords)=-nzero
      endif
c
c --- if all values are zero, set nwords = 0
      nzero=-xbuf(1)+0.001
      if(nzero.eq.nvals)nwords=0
c
      return
      end
c----------------------------------------------------------------------
      subroutine pgtstb(u10,v10,nears,icc,iceil,sinalp,ilandu,
ccec101006     1 iwat1,iwat2,nx,ny,icloud,ccgrid,iceilg,ipgt)
     1 iwat1,iwat2,nx,ny,mcloud,ccgrid,iceilg,ipgt)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 101006             PGTSTB
c ---          J. Scire, SRC  
c              Modified by F.Robe, Earth Tech Inc. (09/01)
c
c --- PURPOSE:  Calculate PGT stability class (1-6) at each non-water
c               grid point
c
c --- UPDATES
c --- V6.217 (061231) to V6.330 (101006)
c     - Change in ICLOUD into MCLOUD (and ICLDOUT)
c
c --- MOD5 (951021) to V6.217 (061231) (FRR)
c     - Allow icloud=4 option
c  
c --- INPUTS:
c       U10(mxnx,mxny) - real array    - Surface U component wind (m/s)
c                                        at height of 10 m
c       V10(mxnx,mxny) - real array    - Surface V component wind (m/s)
c                                        at height of 10 m
c     NEARS(mxnx,mxny) - integer array - Station number of surface
c                                        station closest to each grid pt
c            ICC(mxss) - integer array - Cloud cover (tenths)
c          ICEIL(mxss) - integer array - Ceiling height (hundreds of ft)
c    SINALP(mxnx,mxny) - real array    - Sine of the solar elevation
c                                        angle at all grid points
c    ILANDU(mxnx,mxny) - integer array - Land use category at each
c                                        grid point
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c         IWAT1, IWAT2 - integers      - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c               MCLOUD - integer       - Flag indicating if gridded
c                                        cloud data are available
c                                        (2 = yes, otherwise, no)
c    CCGRID(mxnx,mxny) - real array    - Gridded cloud fraction
c                                        (Used only if MCLOUD=2,3,4)
c    ICEILG(mxnx,mxny) - int array     - Gridded ceiling height
c                                        (Used only if MCLOUD=3 or 4)
c        Parameter: MXNX, MXNY, MXSS
c
c --- OUTPUT:
c      IPGT(mxnx,mxny) - integer array - PGT stability class (1-6) at
c                                        each grid point
c
c ---  PGTSTB called by:  COMP
c ---  PGTSTB calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real u10(mxnx,mxny),v10(mxnx,mxny)
      real ccgrid(mxnx,mxny)
c frr (09/01) sinalp at all grid points
c      real sinalp(mxss)
      real sinalp(mxnx,mxny)
      real scrit(3)
c frr (09/01) gridded ceiling height
      integer iceilg(mxnx,mxny)
c
      integer nears(mxnx,mxny),ilandu(mxnx,mxny),ipgt(mxnx,mxny)
      integer icc(mxss),iceil(mxss)
      integer jstab(12,7)
c
      data scrit/0.258819,0.5735764,0.8660254/
      data jstab/6,6,6,6,6,6,5,5,5,5,4,4,
     1           6,6,6,5,5,5,4,4,4,4,4,4,
     2           4,4,4,4,4,4,4,4,4,4,4,4,
     3           3,3,3,4,4,4,4,4,4,4,4,4,
     4           2,2,2,3,3,3,3,3,3,4,4,4,
     5           1,2,2,2,2,2,2,3,3,3,3,4,
     6           1,1,1,1,1,2,2,2,2,3,3,3/
c
c --- calculate PGT stability class
c
      do 200 i=1,nx
      do 200 j=1,ny
c
c --- check land use category -- water if ILANDU between IWAT1 & IWAT2
      if(ilandu(i,j).ge.iwat1.and.ilandu(i,j).le.iwat2)go to 200
c
c --- over land -- use Turner method
c
c --- NSTA is the station number of the nearest surface met. station to
c --- the current grid point (i,j)
      nsta=nears(i,j)
c
c frr (09/01) ceiling height
ccec101006      if (icloud.ge.3) then
      if (mcloud.ge.3) then
         jceil=iceilg(i,j)
      else
         jceil=iceil(nsta)
      endif

c --- calculate insolation category & pgt stability class
ccec101006      if( icloud.gt.1)then
      if( mcloud.gt.1)then
c ---    Use gridded cloud data - convert from fraction to tenths
         jcc=10.*ccgrid(i,j)+0.5
      else
c ---    Use NWS cloud data (in tenths)
         jcc=icc(nsta)
      endif
c      jceil=iceil(nsta)

c frr (09/01)
c      if(sinalp(nsta).le.0.0)then
      if(sinalp(i,j).le.0.0)then
c
c ---    nightime stability
c ---    for icc = 0-4, ic = -2
         ic=-2
         if(jcc.gt.4)then
c ---       for icc = 4-9 or 10 (with iceil ge 7,000 ft), icc = -1
            ic=-1
c ---       for icc = 10 and iceil lt 7,000 ft, icc = 0
c frr (09/01)jceil already computed
c            if(jcc.eq.10.and.iceil(nsta).lt.70)ic=0
            if(jcc.eq.10.and.jceil.lt.70)ic=0
         endif
      else
c
c ---    daytime stability
c ---    calculate radiation index, iri
c ---    sinalp array contains sine of the elevation angle
c ---    scrit(1)=sin(15. deg);scrit(2)=sin(35. deg);
c ---    scrit(3)=sin(60. deg)
c frr    sel=sinalp(nsta)
         sel=sinalp(i,j)
         do 55 n=1,3
         if(sel.le.scrit(n))then
            iri=n
            go to 56
         endif
55       continue
         iri=4
56       continue
c
c ---    determine daytime insolation class, ic
         ic=iri
         if(jcc.gt.5)then
c frr (09/01)jceil already computed
c           jceil=iceil(nsta)
            if(jcc.eq.10)then
c
c ---          icc = 10  --  ceiling ht. is in hundreds of ft.
               if(jceil.lt.70)then
c ---             icc=10; iceil lt 7,000 ft.
                  ic=0
               else if(jceil.lt.160)then
c
c ---             icc=10; 7,000 ft le iceil lt 16,000 ft
                  ic=iri-2
                  ic=max0(ic,1)
               else
c
c ---             icc=10; iceil ge 16,000 ft
                  ic=iri-1
                  ic=max0(ic,1)
               endif
            else
c
c ---          5 lt icc lt 10
               if(jceil.lt.70)then
c
c ---             5 lt icc lt 10; iceil lt 7,000 ft
                  ic=iri-2
                  ic=max0(ic,1)
               else if(jceil.lt.160)then
c
c ---             5 lt icc lt 10; 7,000 ft le iceil lt 16,000 ft
                  ic=iri-1
                  ic=max0(ic,1)
               else
c
c ---             5 lt icc lt 10; iceil ge 16,000 ft
                  ic=iri
               endif
            endif
         endif
      endif
c
c --- convert insolation class (-2 to +4) to array index (1 to 7)
      index=ic+3
c
c --- convert wind speed from m/s to nearest knot(1.9438 knots=1 m/s)
      iwsx=1.9438*sqrt(u10(i,j)**2+v10(i,j)**2)+0.5
      iwsx=max0(iwsx,1)
      iwsx=min0(iwsx,12)
c
      ipgt(i,j)=jstab(iwsx,index)
c
200   continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine prepdi(ws,wd,tempk,uaveaa,uavebb,vaveaa,vavebb,
     1 nhre,nyrze,njulze,nhrze,nsece,ziconv,gamma,
     2 um,vm,wt,us,vs,nowsta,wsow,wdow)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 090511             PREPDI
c ---          J. Scire, SRC
c ---          Sections adapted from code written by S. Douglas, SAI
c ---          Modified by M. Fernau
c
c --- PURPOSE:  Fill wind observational data arrays for the wind
c               field module
c                 - If input wind data are preprocessed into
c                   hourly U, V components, read directly from
c                   input file
c                 - If using twice-daily soundings and routinely
c                   available hourly surface data, perform time
c                   interpolation of upper air data and convert
c                   surface wind components to U, V components
c
c --- UPDATES:
c --- V6.32 Level 080205 to v6.327 Level 090511(FRR)
c     - Add more explicit information to 1089-1090 error write 
c       statements
c       
c --- V6.222 (070404) to V6.32 Level 080205(FRR)
c     - Use explicit end times instead of beginning times 
c
c --- V6.218 (070113)to V6.222 (070404) (F.Robe)
c     - Initialize um,vm
c
c --- V6.215 (061020) to V6.218 (070113) (F.Robe)
c     - Do not compute domain representative sf temp (Tinf) if
c       ISURFT=-1 (2D spatially varying sf temp) 
c     - Remove Beta2 from calling list (not computed anylonger
c       as never used)
c     - Replace former scalar lapse rate gamma by 2-D array based on all
c       upper air stations if IUPT=-1 and only one if IUPT>0 
c     - Include met1.met and remove nssta,nusta,noobs nz from calling list
c     - Include grid.met and remove nz from calling list
c
c --- V6.2 (060215) to V6.215 (061020) (DGS)
c     - Update arguments for CGAMMA (include seconds)
c
c --- V5.6 (050328) to V6.2 (060215) (F.Robe)
c     - Allow sub-hourly sounding frequency
c     - Replace hour-ending times with explicit beginning times with seconds
c
c --- V5.6 (050328-FRR): explicit common replace by include d4/d6.met
c
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c             WS(mxss) - real array - Surface land wind speed (m/s)
c             WD(mxss) - real array - Surface land wind direction (degrees)
c          WSOW(mxows) - real array - Over water wind speed (m/s)
c          WDOW(mxows) - real array - Over water wind direction (degrees)
c          TEMPK(mxss) - real array - Surface air temperature (deg. K)
c                                     note:no missing value in TEMPK (replaced
c                                     by nearest station value)
c    UAVEaa(mxnz,mxus) - real array - U component of wind for each grid
c                                     cell and upper air station at
c                                     aa GMT for NWS stations or
c                                     arbitrary time for other stations
c    UAVEbb(mxnz,mxus) - real array - U component of wind for each grid
c                                     cell and upper air station at
c                                     bb GMT for NWS stations or
c                                     arbitrary time for other stations
c    VAVEaa(mxnz,mxus) - real array - V component of wind for each grid
c                                     cell and upper air station at
c                                     aa GMT for NWS stations or
c                                     arbitrary time for other stations
c    VAVEbb(mxnz,mxus) - real array - V component of wind for each grid
c                                     cell and upper air station at
c                                     bb GMT for NWS stations or
c                                     arbitrary time for other stations
c                NOWSTA - integer    - Number of over water stations
c                 NHRE - integer    - Hour (LST) in "IBTZ" time zone
c                                     (explicit end time)
c                NYRZE - integer    - Year of current hour (GMT)
c                                     (explicit end time)
c               NJULZE - integer    - Day of current hour (GMT) 
c                                     (explicit end time)
c                NHRZE - integer    - Current Hour (GMT) 
c                                     (explicit end time)
c                NSECE - integer    - Current End Second
c    ZICONV(mxnx,mxny) - real array - Convective mixing heights (m)
c
c      Common block /WPARM/
c         idiopt(5), isurft, iupt, zupt, iupwnd, zupwnd1, zupwnd2,
c         iiupt, jjupt, iiupwn, jjupwn, iextrp
c      Parameters: MXNX, MXNY, MXNZ, MXSS, MXUS, MXBAR, MXLEV,
c                  MXWND, MXWK3, IO6, MXOWS
c      Common block /GRID/
c         nx,ny,nz,dgrid
c      common block /MET1/
c         xusta(mxus),yusta(mxus),noobs,IIUP(mxus),JJUP(mxus)
c
c --- OUTPUT:
c            **  GAMMA - real array - Temperature lapse
c                                     rate (deg. K/m)
c            **     UM - real       - Domain-scale U wind component
c                                     (m/s)
c            **     VM - real       - Domain-scale V wind component
c                                     (m/s)
c            WT(mxwnd) - real array - Weighting factor for observations
c       US(mxnz,mxwnd) - real array - U wind components (surface & upper
c                                     air stations) to be used in wind
c                                     field module
c       VS(mxnz,mxwnd) - real array - V wind components (surface & upper
c                                     air stations) to be used in wind
c                                     field module
c     common block /WPARM/
c     **tinf, htfac
c
c     ** => parameters used only if diagnostic wind field option
c           is selected
c
c --- PREPDI called by:  COMP
c --- PREPDI calls:      CGAMMA, VERTAV, XMIT, DELTT
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real ws(mxss),wd(mxss),tempk(mxss),wsow(mxows),wdow(mxows)
      real ziconv(mxnx,mxny)
      real uaveaa(mxnz,mxus),uavebb(mxnz,mxus),uave(mxnz,mxus)
      real vaveaa(mxnz,mxus),vavebb(mxnz,mxus),vave(mxnz,mxus)
      real wt(mxwnd),us(mxnz,mxwnd),vs(mxnz,mxwnd)
      real work2(3),work3(mxwk3)

      real gamma(mxnx,mxny),gamup(mxus),dis2(mxus)
c
      CHARACTER*4 namst,LAST,IBLANK,NAM
c
      include 'd4.met'
      include 'd6.met'
      include 'upmet.met'
      include 'wparm.met'
      include 'grid.met'
      include 'met1.met'
c
      DATA ZERO /0./, LAST /'LAST'/, IBLANK /'    '/
      
c
      htfac=1.0
      um=0.
      vm=0.

c --- Explicit end time (080205)
      nowtze= nyrze*100000+njulze*100+nhrze
c
c --- TINF, GAMMA, UM, VM are needed only if using diagnostic model
      if(iwfcod.ne.1)go to 8
c
c --- set surface temperature (deg. K) for use in wind field module
c --- unless 2D spatially varying surface temp is used (isurft=-1)(070113)

      if (isurft.ne.-1) then
         if(idiopt(1).eq.0)then
c
c ---       use temperature from surface station "isurft"
            tinf=tempk(isurft)
         else
c
c ---       read temp. (deg. K) from diagnostic data file
            READ(IRD,1010)TINF
1010        FORMAT(10X,F6.2)
         endif
      endif
c
c --- Computer temperature lapse rate 
      if (noobs .eq. 0 ) then
        if(idiopt(2).eq.0)then
c
c ---      use lapse rate from upper air station "iupt" or 2-D variable 
c ---      lapse rate based on all upper air stations (070113)
 
          if(iupt.gt.0) then 
c ---         use single upper air station IUPT
              call CGAMMA(nyrze,njulze,nhrze,nsece,iupt,zupt,
     &                ziconv(iiupt,jjupt),gamup(iupt))
c ---         Fill in 2D array (and convert to deg. K/m) (070113)
              do i=1,nx
              do j=1,ny
                 GAMMA(i,j) = GAMUP(iupt)
              end do
              end do
           else 
c ---         2-D varying lapse rate
c ---         First compute lapse rate at each upper air station
              do iu=1,nusta
c ---           compute lapse rate at all upper air stations
                call CGAMMA(nyrze,njulze,nhrze,nsece,iu,zupt,
     &                 ziconv(iiup(iu),jjup(iu)),gamup(iu))
             end do
c ---         Perform 1/R**2 INTERPOLATION  
              do 210 i=1,nx
                 xgm=(float(i)-0.5)*dgrid
                 do 205 j=1,ny
                   ygm=(float(j)-0.5)*dgrid
                   top=0.0
                   bot=0.0
c ---              Compute distance**2 of each upper air station to grid point (in meters)
                   call cmpd2(xgm,ygm,xusta,yusta,nusta,dis2)
c
c ---              Compute weighting functions for 1/R**2 method
                   do 203 k=1,nusta
c ---                 Minimum value of dist**2 to avoid numerical problems
                      dis2saf=amax1(dis2(k),0.01)
                      top=top+gamup(k)/dis2saf
                      bot=bot+1.0/dis2saf
203                continue
c ---              Weighted lapse rate at each gridpoint
                   gamma(i,j)=top/bot


205             continue
210           continue

 
           endif

        else
c
c ---      read lapse rate (deg. K/km) from diagnostic data file
           READ(IRD,1030)GAMDIA
1030       FORMAT(10X,8F5.1)
c
c ---      Fill in 2D array (and convert to deg. K/m) (070113)
           do i=1,nx
           do j=1,ny
              GAMMA(i,j) = GAMDIA/1000.
           end do
           end do

        endif
C

C --- STORE THE SIGN OF GAMMA IN BETA2 ARRAY
c --- Beta2 is never used - Do not compute (070113)
c      IF (GAMMA .LT. 0.) BETA2 = 1.
c      IF (GAMMA .EQ. 0.) BETA2 = 0.
c      IF (GAMMA .GT. 0.) BETA2 = -1.

      end if
c
c --- set domain-scale wind components
c *** JC modifications of 8/23/93 for non-uniform first-guess field. ***
c     Added additional criterion of iupwnd.gt.0
c
      if (noobs .eq. 0) then
        if(idiopt(3).eq.0)then
          if(iupwnd.gt.0)then
c
c ---       compute from upper air station "iupwnd"
c ---       first calculate vertically averaged winds through layer
c ---       from zupwnd(1) to zupwnd(2) at aa GMT and bb GMT
            call vertav(iupwnd,uaa,vaa,zlaa,nlaa(iupwnd),1,zupwnd,
     1      umaa,vmaa)
            call vertav(iupwnd,ubb,vbb,zlbb,nlbb(iupwnd),1,zupwnd,
     1      umbb,vmbb)
c
c ***    rjy additions of 1/26/90 for arbitrary soundings. ***********
            jorder = justa(iupwnd)
            jdelta = jusdt(iupwnd)
            ntzaas = ntzaa(iupwnd)
            call dedat(ntzaas,jaayr,jaaday,jaahr)
            ntzbbs = ntzbb(iupwnd)
            call dedat(ntzbbs,jbbyr,jbbday,jbbhr)

c ---       For sub-hourly soundings(060215) 
            iaasec = jaasec(iupwnd)
            ibbsec = jbbsec(iupwnd)


c**** Modified by EMI -- 4/26/94
           if(jorder.gt.0) then
c ---         Compute time difference in seconds (060215)
              call deltsec(nowtze ,nsece,ntzbbs,ibbsec,jtogo)
              call deltsec(ntzaas,iaasec,nowtze,nsece,jpast)
            else
              call deltsec(nowtze ,nsece,ntzaas,iaasec,jtogo)
              call deltsec(ntzbbs,ibbsec,nowtze,nsece,jpast)
            endif
c           check for negative values of jtogo or jpast 
            if(jtogo.LT.0 .OR. jpast.LT.0)then

c ---     Convert to Gregorian Day for output purposes
          call dedat(nowtze,ioutyz,ioutjz,iouthz) 
          call grday(io6,ioutyz,ioutjz,ioutmz,ioutdz) 
          call dedat(ntzaas,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)
          call dedat(ntzbbs,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)  

            write(io6,1089)iupwnd,
     :        ioutyz,ioutjz,ioutmz,ioutdz,iouthz,nsece,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,iaasec,
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,ibbsec

1089         format(//1x,'ERROR IN SUBR. PREPDI -- Upper air ',
     1      'soundings do not straddle current hour'/
     1      2x,'Station no.: ',i5/,
     2   38x,'Year  Julian Day  Month  Day  Hour  Seconds '/,
c             xxxx      xxx       xx    xx   xx    xxxx
     4   '  Current model date/time (UTC-GMT): ',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 1 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 2 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4)

              stop
            endif
c           double check for upper air data inconsistencies.
            if((jpast+jtogo).ne.jdelta) then    

c ---     Convert to Gregorian Day for output purposes
          call dedat(nowtze,ioutyz,ioutjz,iouthz) 
          call grday(io6,ioutyz,ioutjz,ioutmz,ioutdz) 
          call dedat(ntzaas,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)
          call dedat(ntzbbs,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)  

            write(io6,1090)iupwnd,
     :        ioutyz,ioutjz,ioutmz,ioutdz,iouthz,nsece,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,iaasec,
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,ibbsec

1090         format(//1x,'ERROR IN SUBR. PREPDI -- Inconsistent ',
     1      'upper air times for station ',i3/
     2   38x,'Year  Julian Day  Month  Day  Hour  Seconds '/,
c             xxxx      xxx       xx    xx   xx    xxxx
     4   '  Current model date/time (UTC-GMT): ',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 1 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 2 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4)

              stop
            endif
c**** End of EMI Modification -- 4/26/94
c ********************************************************************
c
c ***    rjy modifications of 1/26/90 for arbitrary soundings. *******
c ---    interpolate in time to current hour
            xfact = float(jtogo) / float(jdelta)
            if(jorder.lt.0) then
              um=umaa-(umaa-umbb)*xfact
              vm=vmaa-(vmaa-vmbb)*xfact
            else
              um=umbb-(umbb-umaa)*xfact
              vm=vmbb-(vmbb-vmaa)*xfact
            endif
          endif
c ********************************************************************
        else
c
c ---     read domain-scale wind components from diagnostic data file
          READ(IRD,1030)UM
          READ(IRD,1030)VM
        endif
      endif
c
c --- set-up arrays with missing value indicators
8     continue
      NUS=mxnz*mxwnd
      CALL XMIT(-NUS,EDIT,US)
      CALL XMIT(-NUS,EDIT,VS)
c
c --- convert surface observations of WS, WD into U, V components,
c --- insert results into output arrays
      if(idiopt(4).eq.1)go to 32
      nstat = nssta + nowsta
      do 10 j = 1,nstat
c
c --- weighting factor is 1.0
      wt(j)=1.0
c
      if (j .le. nssta) then
c
c --- check for missing data on land
c
        if (abs(wd(j)) .ge. edit) go to 10
        if (abs(ws(j)) .ge. edit) go to 10
c
        wdrad = 0.0174533 * wd(j)
        speed = ws(j)
        us(1,j) = -speed * sin(wdrad)
        vs(1,j) = -speed * cos(wdrad)
      else
c
c --- check for missing data over water
c
        if (abs(wdow(j - nssta)) .ge. edit) go to 10
        if (abs(wsow(j - nssta)) .ge. edit) go to 10
c
        wdrad = 0.0174533 * wdow(j - nssta)
        speed = wsow(j - nssta)
        us(1,j) = -speed * sin(wdrad)
        vs(1,j) = -speed * cos(wdrad)
      end if
10    continue
c
c --- compute time-interpolated winds
11    continue
c FRR (09/2001) additional option for noobs
c      if (noobs .eq. 1) goto 52
      if (noobs .ge. 1) goto 52
      if(idiopt(5).eq.1)go to 50
      do 20 j=1,nusta
c
c *** rjy additions of 1/26/90 for arbitrary soundings. ***********
      jorder = justa(j)
      jdelta = jusdt(j)
      ntzaas = ntzaa(j)
      call dedat(ntzaas,jaayr,jaaday,jaahr)
      ntzbbs = ntzbb(j)
      call dedat(ntzbbs,jbbyr,jbbday,jbbhr)

c --- For sub-hourly soundings(060215)
      iaasec = jaasec(j)
      ibbsec = jbbsec(j)

      if(jorder.gt.0) then
         call deltsec(nowtze ,nsece,ntzbbs,ibbsec,jtogo)
         call deltsec(ntzaas,iaasec,nowtze,nsece,jpast)
      else
         call deltsec(nowtze ,nsece,ntzaas,iaasec,jtogo)
         call deltsec(ntzbbs,ibbsec,nowtze,nsece,jpast)
      endif
c     check for negative values of jtogo or jpast 
      if(jtogo.LT.0 .OR. jpast.LT.0)then


c ---     Convert to Gregorian Day for output purposes
          call dedat(nowtze,ioutyz,ioutjz,iouthz) 
          call grday(io6,ioutyz,ioutjz,ioutmz,ioutdz) 
          call dedat(ntzaas,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)
          call dedat(ntzbbs,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)  

c ---   use station number j not iupwnd (=-1) for 1089 error message
            write(io6,1089)j,
     :        ioutyz,ioutjz,ioutmz,ioutdz,iouthz,nsece,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,iaasec,
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,ibbsec
        stop
      endif
c     double check for upper air data inconsistencies.
      if((jpast+jtogo).ne.jdelta) then

c ---     Convert to Gregorian Day for output purposes
          call dedat(nowtze,ioutyz,ioutjz,iouthz) 
          call grday(io6,ioutyz,ioutjz,ioutmz,ioutdz) 
          call dedat(ntzaas,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)
          call dedat(ntzbbs,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)  

            write(io6,1090)j,
     :        ioutyz,ioutjz,ioutmz,ioutdz,iouthz,nsece,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,iaasec,
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,ibbsec

          stop
         endif
c
c *** rjy modifications of 1/26/90 for arbitrary soundings. *******
c --- interpolate in time to current hour.  Note that xfact starts
c     out at 1.0 and works down to 0 as jtogo gets smaller.
      xfact = float(jtogo) / float(jdelta)
      do 15 i=1,nz
      if(jorder.lt.0) then
         uave(i,j)=uaveaa(i,j)-(uaveaa(i,j)-uavebb(i,j))*xfact
         vave(i,j)=vaveaa(i,j)-(vaveaa(i,j)-vavebb(i,j))*xfact
      else
         uave(i,j)=uavebb(i,j)-(uavebb(i,j)-uaveaa(i,j))*xfact
         vave(i,j)=vavebb(i,j)-(vavebb(i,j)-vaveaa(i,j))*xfact
      endif
15    continue
20    continue
c ********************************************************************
c
c --- insert upper air results into output arrays
      do 30 j = 1,nusta
        jj = nstat + j
c
c --- weighting factor is 1.0
        wt(jj) = 1.0
c
c --- if a surface station exists at the same point as an upper air
c --- station, do not use the upper air data in the lowest layer
        i1 = 1
        nam = namst(jj)
        do 28 kk = 1,nstat
          if (nam .eq. namst(kk)) i1 = 2
28      continue
c
c --- ignore upper air data in lowest layer if appropriate flag set
       if (iextrp .le. 0) i1 = 2
c
        do 30 i = i1,nz
          us(i,jj)=uave(i,j)
          vs(i,jj)=vave(i,j)
30    continue
      return
C
C     READ HOURLY INPUT DATA
C
32    continue
      time=nhre
      if(iwr.gt.0)then
         WRITE(IWR,2240) TIME, nhre
 2240    FORMAT(///,'   INPUT DATA AT TIME =  ',F6.0,' HOURS   ',4X,
     1   ' (SIMULATION HOUR NO.      ',I3,' )')
         WRITE(IWR,2241)
 2241    FORMAT(3X,64('-'))
      endif
C
C     READ SURFACE WIND DATA
C
   35 IF(NSURF.EQ.0) GO TO 48
      NUS=mxnz*mxwnd
      CALL XMIT(-NUS,EDIT,US)
      CALL XMIT(-NUS,EDIT,VS)
   41 READ(IRD,1043) NAM, (WORK2(J),J=1,3)
 1043 FORMAT(15X,A4,1X,3F5.1)
      IF(NAM.EQ.LAST)  GO TO 47
      IF(NAM.EQ.IBLANK)  GO TO 41
      DO 42 J=1,NSURF
        IF(NAM.EQ.NAMST(J))  GO TO 43
   42 CONTINUE
      if(iwr.gt.0)WRITE(IWR,2069) TIME,NAM
      WRITE(io6,2069) TIME,NAM
 2069 FORMAT(2X,'JOB ABORTED -- UNRECOGNIZED STATION NAME FOR SURFACE
     1       WIND DATA AT TIME = ',F6.0,1X,'NAME = ',A4)
      stop
   43 WT(J) = WORK2(1)
      US(1,J)=WORK2(2)
      VS(1,J)=WORK2(3)
   45 CONTINUE
      GO TO 41
   47 CONTINUE
C
C     PRINT INPUT SURFACE WIND DATA
C
      if(iwr.gt.0)then
         WRITE(IWR,2279)
 2279    FORMAT(//,12X,'SURFACE WIND DATA ',/,12X,17('-'))
         WRITE(IWR,2280)
 2280    FORMAT(/,' STATION   ','U-CMPT',5X,'V-CMPT',4X,'WEIGHTING',
     1   /,11X,'M/SEC',8X,'HM/SEC')
c
         DO 40 I=1,NSURF
         WRITE(IWR,2290) NAMST(I),US(1,I),VS(1,I),WT(I)
 2290    FORMAT(2X,A4,F9.1,3X,F9.1,4X,F8.2)
   40   CONTINUE
      endif
48    continue
      go to 11
C
C     INPUT UPPER AIR WIND DATA
C     (WINDS ARE INPUT FOR THE CELL CENTER ELEVATION)
C
   50 IF(NUPPER.EQ.0) GO TO 52
      N = NSURF + 1
      CALL XMIT(-mxus,ZERO,WT(N))
      NO = 2*NZ + 1
      N = MIN0(NO,11)
   51 READ(IRD,1041) NAM, (work3(I),I=1,N)
 1041 FORMAT(13X,A4,1X,31F5.1)
      N1 = N + 1
      IF(NO.GT.11) READ(IRD,1046) (work3(I),I=N1,NO)
 1046 FORMAT(20X,12F5.1)
      IF(NAM.EQ.LAST)  GO TO 56
      N1 = NSURF + 1
      DO 53 J=N1,NWIND
        IF(NAM.EQ.NAMST(J))  GO TO 54
   53 CONTINUE
      if(iwr.gt.0)WRITE(IWR,2390) TIME,NAM
      WRITE(io6,2390) TIME,NAM
 2390 FORMAT('  JOB ABORTED -- UNRECOGNIZED STATION NAME FOR UPPER AIR
     1 WIND DATA AT TIME = ',F6.0,'  NAME = ',A4)
      stop
   54 WT(J) = work3(1)
      I1=1
C
C     IF A SURFACE STATION ALSO EXISTS AT THIS POINT,
C     DO NOT USE UPPER AIR DATA IN LOWEST LAYER
C
      DO 57 I = 1,NSURF
        IF (NAM .EQ. NAMST(I)) I1 = 2
   57 CONTINUE
      IF (IEXTRP .LE. 0) I1=2
      DO 55 I=I1,NZ
        K = 2*(I-1) + 2
c
c ---   check for missing values
        if(work3(k).eq.edit.or.work3(k+1).eq.edit)go to 55
        US(I,J) = work3(K)
        VS(I,J) = work3(K+1)
   55 CONTINUE
      GO TO 51
   56 CONTINUE
C
C     PRINT INPUT UPPER AIR WIND DATA
C
      if(iwr.gt.0)then
         WRITE(IWR,2292) (I,I=1,NZ)
 2292    FORMAT(//,12X,'UPPER AIR WIND DATA  ',/,12X,19('-'),//,11X,
     1   5('--- LEVEL ',I3,' ---    '))
         WRITE(IWR,2293)
 2293    FORMAT(' STATION',3X,5('   U-CMPT   V-CMPT   '),/11X,
     1   5('    M/S      M/S     '))
c
         DO 58 L=1,NUPPER
         LST = NSURF + L
         WRITE(IWR,2294) NAMST(LST),(US(I,LST),VS(I,LST),I=1,NZ)
 2294    FORMAT(2X,A4,7X,5(F5.1,4X,F5.1,7X))
   58    CONTINUE
      endif
c
52    continue
      return
      end
c----------------------------------------------------------------------
      subroutine progrd(uprog,vprog,cellzc,utmxor,utmyor,time,nsece)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 061230             PROGRD
c              S.DOUGLAS, SAI
c ---          Modified by J. Scire 9/30/90
c
C
C --- PURPOSE :  THIS SUBROUTINE READS AND INTERPOLATES THE PROGNOSTIC 
C                MODEL OUTPUT TO THE DIAGNOSTIC MODEL GRID
c
c --- UPDATES:
c --- V6.2 Level 060215 to V6.216 Level 061230 (F.Robe)
c        - Make sure to skip reading new record when subhourly timestep
c        - Compare ending hour with prognostic hour to be consistent with MOD5
c
c --- V5.6 Level 050328 to V6.2 Level 060215  (F.Robe)
c        - Allow CALMET sub-hourly timesteps - only update with progn.model
c          output on hourly basis 
c        - Cosmetic changes to header (struture: purpose,updates, etc)
C     
c --- V5.6 (050328-FRR) explicit common replaced by include d4/d6.met 
c
C     INPUTS:   
C               UTMXOR (R)     - UTM_EASTING ORIGIN OF THE CALMET GRID
C               UTMYOR (R)     - UTM_NORTHING ORIGIN OF THE CALMET GRID
C               CELLZC(R ARRAY)- DIAGNOSTIC WIND MODEL CELL-CENTER HEIGHTS
C               TIME (R)       - CALMET SIMULATION TIME (hour)
c               NSECE (I)      - CALMET ending second of current timestep
C               
c        Parameters: MXNX, MXNY, MXNZ, MXNXP, MXNYP, MXNZP, IO6
C
C     OUTPUTS:  UPROG (R ARRAY)- INTERPOLATED U-COMPONENT OF THE PROGNOSTIC
C                                WIND FIELD on CALMET GRID
C               VPROG (R ARRAY)- INTERPOLATED V-COMPONENT OF THE PROGNOSTIC
C                                WIND FIELD on CALMET GRID
C
c 
c
c --- PROGRD called by: DIAGNO 
c --- PROGRD calls:     XMIT 
c
c ---------------------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'grid.met'
      include 'd4.met'
      include 'd6.met'

c     Record access to progrd (060215)
      COMMON /PROGSTEP/ ifirstpg,nfm3d

      DIMENSION UPROG(mxnx,mxny,*), VPROG(mxnx,mxny,*),
     1          UP(mxnxp,mxnyp,mxnzp), VP(mxnxp,mxnyp,mxnzp),
     2          CELLZC(*), Z(mxnzp), UTMP(mxnxp,mxnyp,mxnz),
     3          VTMP(mxnxp,mxnyp,mxnz), IP(4), JP(4), RS(4)

c --- storage arrays (as uprog,vprog reset to 0 before every call 
      DIMENSION UPROGS(mxnx,mxny,mxnz), VPROGS(mxnx,mxny,mxnz)
c
c --- Minimum distance (km) in 1/r**2 interpolation
      data rmin/0.001/


c --- Do not read new data if sub-hourly timestep (only update on hourly
c --- basis (051128)
      if (nsece.ne.0 .and. nsece.ne.3600 .and. ifirstpg.ne.0) then
         do j=1,mxny
         do i=1,mxnx
            do k=1,mxnz
               uprog(i,j,k)=uprogs(i,j,k)
               vprog(i,j,k)=vprogs(i,j,k)
            end do
         end do
         end do
c ---    make sure to skip reading new record: 061230
         return
      endif

      if (ifirstpg.eq.0) ifirstpg=1

C     READ PROGNOSTIC MODEL OUTPUT

   30 READ(IRDP) TIMEH
c *     write(io6,*)
c *     write(io6,*)'TIMEH = ',timeh
      ITIME = TIMEH * 100
      READ(IRDP) NXP,NYP,NZP
c *     write(io6,*)'NXP, NYP, NZP = ',nxp,nyp,nzp
c
c --- Check that array dimensions are not exceeded
      if(nxp.gt.mxnxp.or.nyp.gt.mxnyp.or.nzp.gt.mxnzp)then
         write(io6,*)'ERROR in subr. PROGRD -- Array dimensions ',
     1   'are too small for data being read'
         write(io6,*)'Grid being read  (NXP,   NYP,   NZP  ) = ',
     1    nxp,nyp,nzp
         write(io6,*)'Array dimensions (MXNXP, MXNYP, MXNZP) = ',
     1    mxnxp,mxnyp,mxnzp
         stop
      endif
c
      READ(IRDP) UTMXOP,UTMYOP,DXKP
c *     write(io6,*)'UTMXOP = ',utmxop,' UTMYOP = ',utmyop,' DXKP = ',
c *    1 dxkp
      DYKP = DXKP
      READ(IRDP) (Z(I),I=1,NZP)
c *     write(io6,*)'Z = ',(z(i),i=1,nzp)
      DO 10 K = 1,NZP
      DO 10 J = 1,NYP
        READ(IRDP) (UP(I,J,K),I=1,NXP)
   10 CONTINUE
      DO 20 K = 1,NZP
      DO 20 J = 1,NYP
        READ(IRDP) (VP(I,J,K),I=1,NXP)
   20 CONTINUE
c *      write(io6,*)'UP(1,1,1) = ',up(1,1,1)
c *      write(io6,*)'VP(1,1,1) = ',vp(1,1,1)
c *      write(io6,*)'CELLZC = ',(cellzc(n),n=1,nz)
c *      write(io6,*)'UTMXOR = ',utmxor
c *      write(io6,*)'UTMYOR = ',utmyor
c *      write(io6,*)'TIME   = ',time
c *      write(io6,*)'DX     = ',dx
c *      write(io6,*)'DY     = ',dy
C
C     CHECK TIME
C
c --- TIME= beginning hour in CALMET (hourly) timestep (x 100)
c --- to be consistent with MOD5, ending time should be used (i.e. beg. time +1)
c --- with ending time between 0-23 (i.e. 0<=TIME<=2300) (061230)
c     IT = TIME 
      IT = TIME +100
      if (IT.EQ.2400) IT=0

      IF (ITIME .LT. IT) GO TO 30
      IF (ITIME .GT. IT) THEN
        if(iwr.gt.0)WRITE(IWR,2010) TIME
        WRITE(io6,2010) TIME
        STOP
      ENDIF
C
C     INTERPOLATE PROGNOSTIC SOUNDINGS VERTICALLY TO DIAGNOSTIC MODEL
C     LEVELS
C
      DO 40 K = 1,NZ
        DO 55 KP = 2,NZP
          KPM1 = KP - 1
          IF (Z(KPM1) .LE. CELLZC(K) .AND. Z(KP) .GT. CELLZC(K)) THEN
            DELZ1 = CELLZC(K) - Z(KPM1)
            DELZ2 = Z(KP) - Z(KPM1)
            DO 50 J = 1,NYP
            DO 50 I = 1,NXP
              UTMP(I,J,K) = UP(I,J,KPM1) + (UP(I,J,KP) - UP(I,J,KPM1))
     1                       * DELZ1/DELZ2
              VTMP(I,J,K) = VP(I,J,KPM1) + (VP(I,J,KP) - VP(I,J,KPM1))
     2                       * DELZ1/DELZ2
   50       CONTINUE
          ENDIF
   55   CONTINUE
        IF (CELLZC(K) .LT. Z(1)) THEN
          DO 60 J = 1,NYP
          DO 60 I = 1,NXP
            UTMP(I,J,K) = UP(I,J,1)
            VTMP(I,J,K) = VP(I,J,1)
   60     CONTINUE
        ENDIF
        IF (CELLZC(K) .GE. Z(NZP)) THEN
          DO 70 J = 1,NYP
          DO 70 I = 1,NXP
            UTMP(I,J,K) = UP(I,J,NZP)
            VTMP(I,J,K) = VP(I,J,NZP)
   70     CONTINUE
        ENDIF
   40 CONTINUE
c ***
c *** write layer #1
c *      ldate=.true.
c *      messag='UTMP -- Layer 1 -- After 40 Loop'
c *      call out(utmp(1,1,1),idum,1,5,ldate,messag,nx,ny)
c *      messag='VTMP -- Layer 1 -- After 40 Loop'
c *      call out(vtmp(1,1,1),idum,1,5,ldate,messag,nx,ny)
c ***
C
C     INTERPOLATE PROGNOSTIC SOUNDINGS HORIZONTALLY TO DIAGNOSTIC MODEL
C     GRID
C
      DXK = DX * 0.001
      DYK = DY * 0.001
C
      DO 80 J = 1,NY
      DO 80 I = 1,NX
        X = (I - 1) * DXK
        Y = (J - 1) * DYK
C
C     CONVERT FROM LOCAL COORDINATES ON DIAGNOSTIC GRID TO LOCAL
C     COORDINATES ON PROGNOSTIC GRID
C
        X = X + UTMXOR - UTMXOP
        Y = Y + UTMYOR - UTMYOP
        IP(1) = X/DXKP + 1
        IP(2) = X/DXKP + 2
        IP(3) = IP(2)
        IP(4) = IP(1)
        JP(1) = Y/DYKP + 1
        JP(2) = JP(1)
        JP(3) = Y/DYKP + 2
        JP(4) = JP(3)
C
C     CALCULATE DISTANCE FROM PROGNOSTIC GRID POINTS TO DIAGNOSTIC GRID
C     POINTS
C
        NPTS = 4
        CALL XMIT(-NPTS,EDIT,RS)
        DO 90 N = 1,NPTS
          IF (IP(N) .LT. 1 .OR. JP(N) .LT. 1) GO TO 90
          IF (IP(N) .GT. NXP .OR. JP(N) .GT. NYP) GO TO 90
          RSX = X - (IP(N) - 1) * DXKP
          RSY = Y - (JP(N) - 1) * DYKP
          RS(N) = RSX**2 + RSY**2
          RS(N) = SQRT(RS(N))
          rs(n)=amax1(rs(n),rmin)
   90   CONTINUE
C
C     PERFORM 1/R**2 INTERPOLATION
C
        DO 100 K = 1,NZ
          UNUM = 0.
          VNUM = 0.
          DENOM = 0.
          NSUM = 0.
          DO 110 N = 1,NPTS
            IF (RS(N) .GT. EDITL) GO TO 110
            WT = 1./RS(N)**2
            UNUM = UNUM + UTMP(IP(N),JP(N),K) * WT
            VNUM = VNUM + VTMP(IP(N),JP(N),K) * WT
            DENOM = DENOM + WT
            NSUM = NSUM + 1
  110     CONTINUE
          IF (NSUM .EQ. 0) THEN
            if(iwr.gt.0)WRITE(IWR,2020) I,J,K
            WRITE(io6,2020) I,J,K
            STOP
          ENDIF
          UPROG(I,J,K) = UNUM/DENOM
          VPROG(I,J,K) = VNUM/DENOM
  100   CONTINUE
   80 CONTINUE
c ***
c *** write layer #1
c *      ldate=.true.
c *      messag='UPROG -- Layer 1 -- After 80 Loop'
c *      call out(uprog(1,1,1),idum,1,5,ldate,messag,nx,ny)
c *      messag='VPROG -- Layer 1 -- After 80 Loop'
c *      call out(vprog(1,1,1),idum,1,5,ldate,messag,nx,ny)
c ***
C
C     CONVERT TO M/S
C
      DO 120 K = 1,NZ
      DO 120 J = 1,NY
      DO 120 I = 1,NX
        UPROG(I,J,K) = UPROG(I,J,K) * 0.01
        VPROG(I,J,K) = VPROG(I,J,K) * 0.01
c ---   store variables for sub-hourly timestep access (060215)
        uprogs(i,j,k)=uprog(i,j,k)
        vprogs(i,j,k)=vprog(i,j,k)
  120 CONTINUE

c ***
c *** write layer #1
c *      ldate=.true.
c *      messag='UPROG -- Layer 1 -- After 120 Loop'
c *      call out(uprog(1,1,1),idum,1,5,ldate,messag,nx,ny)
c *      messag='VPROG -- Layer 1 -- After 120 Loop'
c *      call out(vprog(1,1,1),idum,1,5,ldate,messag,nx,ny)
c ***
c *** write layer #2
c *      ldate=.true.
c *      messag='UPROG -- Layer 2 -- After 120 Loop'
c *      call out(uprog(1,1,2),idum,1,5,ldate,messag,nx,ny)
c *      messag='VPROG -- Layer 2 -- After 120 Loop'
c *      call out(vprog(1,1,2),idum,1,5,ldate,messag,nx,ny)
c *     STOP
c ***
C
 2010 FORMAT('NO PROGNOSTIC OUTPUT AVAILABLE FOR TIME = ',F6.0)
 2020 FORMAT('NO PROGNOSTIC INTERPOLATION POSSIBLE FOR I = ',I2,' J = ',
     1I2,' K = ',I2)
      RETURN
      END
c----------------------------------------------------------------------
      subroutine qcksrt3(n,arr,arr2,arr3,arr4,arr5,arr6,arr7)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 061231            QCKSRT3
c ---          J. Scire, Earth Tech, Inc.
c
c --- PURPOSE:  Sorts an aray ARR of length N into ascending numerical 
c       order using Quicksort algorithm.  N is input; ARR is replaced on 
c       output by its sorted rearrangement.
c
c --- UPDATES:
c --- Level 941101 to V6.217 Level 061231 (F.Robe)
c     Modified to sort 7 arrays 
c
c --- Modified to sort 5 arrays   MEF 11/01/94
c --- Modified to sort 3 arrays   EMI  9/11/92
c
c --- QCKSRT3 called by: RDMM4
c --- QCKSRT3 calls: none
c
c -------------------------------------------------------------------
      PARAMETER (M=7,NSTACK=50,FM=7875.,FA=211.,FC=1663.
     *    ,FMI=1.2698413E-4)
c
c       Here M is the size of subarrays sorted by straight insertion,
c       NSTACK is the required auxiliary storage, and the remaining constants
c       are used by the random number generating statements.
c
      DIMENSION ARR(N),ISTACK(NSTACK),arr2(n),arr3(n),arr4(n),arr5(n)
      DIMENSION ARR6(N),ARR7(N)

      JSTACK=0
      L=1
      IR=N
      FX=0.
10    IF(IR-L.LT.M)THEN
        DO 13 J=L+1,IR
          A=ARR(J)
          b=arr2(J)
          c=arr3(J)
          d=arr4(J)
          e=arr5(J)
          f=arr6(J)
          g=arr7(J)

          DO 11 I=J-1,1,-1
            IF(ARR(I).LE.A)GO TO 12
            ARR(I+1)=ARR(I)
            arr2(I+1)=arr2(I)
            arr3(I+1)=arr3(I)
            arr4(I+1)=arr4(I)
            arr5(I+1)=arr5(I)
            arr6(I+1)=arr6(I)
            arr7(I+1)=arr7(I)
11        CONTINUE
          I=0
12        ARR(I+1)=A
          arr2(I+1)=b
          arr3(I+1)=c
          arr4(I+1)=d
          arr5(I+1)=e
          arr6(I+1)=f
          arr7(I+1)=g
13      CONTINUE
        IF(JSTACK.EQ.0)RETURN
        IR=ISTACK(JSTACK)
        L=ISTACK(JSTACK-1)
        JSTACK=JSTACK-2
      ELSE
        I=L
        J=IR
        FX=MOD(FX*FA+FC,FM)
        IQ=L+(IR-L+1)*(FX*FMI)
        A=ARR(IQ)
        b=arr2(IQ)
        c=arr3(IQ)
        d=arr4(IQ)
        e=arr5(IQ)
        f=arr6(IQ)
        g=arr7(IQ)
        ARR(IQ)=ARR(L)
        arr2(IQ)=arr2(L)
        arr3(IQ)=arr3(L)
        arr4(IQ)=arr4(L)
        arr5(IQ)=arr5(L)
        arr6(IQ)=arr6(L)
        arr7(IQ)=arr7(L)
20      CONTINUE
21        IF(J.GT.0)THEN
            IF(A.LT.ARR(J))THEN
              J=J-1
              GO TO 21
            ENDIF
          ENDIF
          IF(J.LE.I)THEN
            ARR(I)=A
            arr2(I)=b
            arr3(I)=c
            arr4(I)=d
            arr5(I)=e
            arr6(I)=f
            arr7(I)=g
            GO TO 30
          ENDIF
          ARR(I)=ARR(J)
          arr2(I)=arr2(J)
          arr3(I)=arr3(J)
          arr4(I)=arr4(J)
          arr5(I)=arr5(J)
          arr6(I)=arr6(J)
          arr7(I)=arr7(J)
          I=I+1
22        IF(I.LE.N)THEN
            IF(A.GT.ARR(I))THEN
              I=I+1
              GO TO 22
            ENDIF
          ENDIF
          IF(J.LE.I)THEN
            ARR(J)=A
            arr2(J)=b
            arr3(J)=c
            arr4(J)=d
            arr5(J)=e
            arr6(J)=f
            arr7(J)=g
            I=J
            GO TO 30
          ENDIF
          ARR(J)=ARR(I)
          arr2(J)=arr2(I)
          arr3(J)=arr3(I)
          arr4(J)=arr4(I)
          arr5(J)=arr5(I)
          arr6(J)=arr6(I)
          arr7(J)=arr7(I)
          J=J-1
        GO TO 20
30      JSTACK=JSTACK+2
        IF(JSTACK.GT.NSTACK)PAUSE 'NSTACK must be made larger.'
        IF(IR-I.GE.I-L)THEN
          ISTACK(JSTACK)=IR
          ISTACK(JSTACK-1)=I+1
          IR=I-1
        ELSE
          ISTACK(JSTACK)=I-1
          ISTACK(JSTACK-1)=L
          L=I+1
        ENDIF
      ENDIF
      GO TO 10
      END
c----------------------------------------------------------------------
      subroutine rdhd(iform,io,ibyrn,ibjuln,ibhrn,ibsecn,
     1                ieyrn,iejuln,iehrn,iesecn,
     1                ibtz,nsta,ipack,dataver,idsta,anem,cname,
     2                rnlat,relon,maxs,clat,clon,datum,lstnloc)
c----------------------------------------------------------------------

c --- CALMET   Version: 6.4.0     Level: 121203               RDHD
c ---          J. Scire, Earth Tech, Inc.
c
c --- PURPOSE:  Read the header records from a surface
c               met. data file or a precipitation data file
c
c --- UPDATES:
c
c --- V6.321 (080325) to v6.4.0 Level 121203 (F.Robe)
c              - Fix missing read statement for axtz in dataset v2.1
c                with full location information
c
c --- V6.223 (070702)to V6.321 (080325)(F.Robe)
c              -  Correct typo that stops a run with a SURF.DAT or   
c                 PRECIP.DAT stating in its header that the surf./precip. records end on
c                 PRECIP.DAT the last day of the year at hour 24. 
c
c --- V6.2 (060215) to V6.223 (070702)(F.Robe)
c               - read axtz as formatted a8 when formatted surf.dat
c
c --- V5.543 (031215) to V6.2 (060215) (F.Robe)
c               - Use explicit beginning/ending times with seconds
c               - Read in SURF.DAT data version and pass the information   
c                 back via calling list
c               - New SURF.DAT/PRECIP.DAT (2.1) header: additional line for
c                 UTC time zone and beginning/ending seconds
c
c --- V5.542 (031126) to V5.543 (031215)  (DGS)
c               - Left-justify station name
c --- V5.541 (031017) to V5.542 (031126)  (J. Scire)
c               - Add CLAT and CLON to argument list to avoid
c                 local array dimensioning with a variable
c --- V5.5 (030402) to V5.54 (031017)  (DGS)
c               - Add station location flag and datum to arg list
c               - Convert character lat/lon to reals
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c               - Add list-file unit to YR4 call
c               - New header format
c               - Transfer file headers to scratch file
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c             IFORM - integer    - Data format flag (0=data not used,
c                                  1=unformatted, 2=formatted)
c                IO - integer    - Fortran unit no. of input file
c              MAXS - integer    - Maximum number of stations
c
c       Common block /QA/ variables:
c         NCOMMOUT
c
c        Parameters: IO6, IOX
c
c --- OUTPUT:
c              IBYRN - integer    - Beginning year of data (explicit)
c             IBJULN - integer    - Beginning Julian day number(explicit)
c              IBHRN - integer    - Beginning hour(explicit)
c             IBSECN - integer    - Beginning second (explicit)
c              IEYRN - integer    - Ending year of data (4 digits)(explicit)
c             IEJULN - integer    - Ending Julian day number(explicit)
c              IEHRN - integer    - Ending hour(explicit)
c             IESECN - integer    - Ending second (explicit)
c              IBTZ - integer    - Base time zone (8 = PST, 7 = MST,
c                                  6 = CST, 5 = EST)
c              NSTA - integer    - Number of stations
c             IPACK - integer    - Data packing code (0=unpacked,
c                                  1=packed)
c          DATAVER  - char*16    - Dataset version number
c       IDSTA(MAXS) - int. array - Array of station identification
c                                  codes
c        ANEM(MAXS) - real array - Array of station anemometer hts
c       CNAME(MAXS) - char array - Array of station names
c       RNLAT(MAXS) - real array - Array of station N.latitudes
c       RELON(MAXS) - real array - Array of station E.longitudes
c        CLAT(MAXS) - char*16    - Array holding station latitudes
c        CLON(MAXS) - char*16    - Array holding station longitudes
c             DATUM - character  - DATUM code for location
c           LSTNLOC - logical    - T: station location data found
c
c       Common block /QA/ variables:
c         NCOMMOUT
c
c --- RDHD called by:  READHD
c --- RDHD calls:      DEDAT, YR4, XTRACTLL
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'

      include 'qa.met'

      real anem(maxs),rnlat(maxs),relon(maxs)
      integer idsta(maxs)
      character*4 cname(maxs),cnam,ctemp
      character*16 clat(maxs),clon(maxs)

      character*4 xyunit
      character*8 datum, pmap, axtz
      character*12 daten
      character*16 dataset,dataver
      character*64 datamod
      character*80 comment1
      character*33 blank33,break33
      character*132 blank,break

      logical lstnloc

      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 --- Set location data flag to false
      lstnloc=.FALSE.

      write(io6,*)
      write(io6,*)
      write(io6,*)
      write(io6,'(a30,50x)')'Surface Met File Header ------'
      write(io6,*)

      if(iform.eq.0)then
c ---    data not used
         nsta=0

      else if(iform.eq.1)then
c ---    File unformatted
         read(io) dataset,dataver,datamod
         write(io6,'(2a16,a64)') dataset,dataver,datamod
c ---    Check for valid dataset name
         if(dataset.NE.'SURF.DAT'.AND.dataset.NE.'PRECIP.DAT') then
            write(io6,*)
            write(io6,*) 'RDHD:  Invalid dataset found'
            write(io6,*) 'Dataset name found = ',dataset
            write(io6,*) '  Dataset expected = SURF.DAT'
            write(io6,*) '                or = PRECIP.DAT'
            write(*,987)
            stop 'Halted in RDHD'
         endif
c ---    To scratch file
         write(iox,'(a132)') blank
         write(iox,'(a132)') break
         write(iox,'(a132)') blank
         write(iox,'(2a16,a64)') dataset,dataver,datamod
         ncommout=ncommout+4
         read(io) ncomment
         do i=1,ncomment
            read(io) comment1
            write(io6,'(a80)') comment1
c ---       To scratch file
            write(iox,'(a80)') comment1
            ncommout=ncommout+1
         enddo
         read(io) pmap
         write(io6,'(a8)') pmap
c ---    To scratch file
         write(iox,'(a8)') pmap
         ncommout=ncommout+1
         if(pmap.EQ.'NONE    ') then
            if (dataver.eq.'2.1') then
c ---          UTC time zone - Convert to CALMET IBTZ time zone
               ncommout=ncommout+1
               read(io) axtz
               call utcbasr(axtz,xbtz)
               ibtz=int(xbtz)
               write(io6,'(a8)') axtz
c ---          To scratch file
               write(iox,'(a8)') axtz
c ---          explicit time with seconds 
               read(io) ibegn,ibsecn,iendn,iesecn,nsta,ipack
               write(io6,*)ibegn,ibsecn,iendn,iesecn,ibtz,nsta,ipack
               write(iox,'(2(i12,i5),i12,i4)')ibegn,ibsecn,iendn,
     :              iesecn,nsta,ipack
            else
c ---          hour-ending time convention (pre 2.1 dataset) 
               read(io) ibeg,iend,ibtz,nsta,ipack
               write(io6,*)ibeg,iend,ibtz,nsta,ipack
               write(iox,'(2i12,i4,i12,i4)')ibeg,iend,ibtz,nsta,ipack
            endif   
            read(io) (idsta(n),n=1,nsta)
            write(io6,*)(idsta(n),n=1,nsta)
c ---       To scratch file
            write(iox,'(2i12,i4,i12,i4)')ibeg,iend,ibtz,nsta,ipack
            do k=1,nsta
               write(iox,'(i8)') idsta(k)
            enddo
            ncommout=ncommout+nsta+1
         elseif(pmap.EQ.'LL      ') then
            lstnloc=.TRUE.
            read(io) datum,daten
            read(io) ibeg,iend,ibtz,nsta,ipack
            write(io6,'(a8,a10)') datum,daten
            write(io6,'(a4)') xyunit
c ---       To scratch file
            write(iox,'(a8,a10)') datum,daten
            write(iox,'(a4)') xyunit
            if (dataver.eq.'2.1') then
c ---          UTC time zone - Convert to CALMET IBTZ time zone
               ncommout=ncommout+1
               read(io) axtz
               call utcbasr(axtz,xbtz)
               ibtz=int(xbtz)
               write(io6,'(a8)') axtz
c ---          To scratch file
               write(iox,'(a8)') axtz
c ---          explicit time with seconds  
               read(io) ibegn,ibsecn,iendn,iesecn,nsta,ipack
               write(io6,*)ibegn,ibsecn,iendn,iesecn,nsta,ipack
               write(iox,'(2(i12,i5),i12,i4)')ibegn,ibsecn,iendn,
     :              iesecn,ibtz,nsta,ipack
             else
c ---          hour-ending time convention (pre 2.1 dataset) 041123
               read(io) ibeg,iend,ibtz,nsta,ipack
               write(io6,'(2i12,i4,i12,i4)')ibeg,iend,ibtz,nsta,ipack
               write(iox,'(2i12,i4,i12,i4)')ibeg,iend,ibtz,nsta,ipack
           endif   

           ncommout=ncommout+3
            read(io) (idsta(n),n=1,nsta)
            read(io) (cname(n),n=1,nsta)
            read(io) (clat(n),n=1,nsta)
            read(io) (clon(n),n=1,nsta)
c ---       Remove leading blanks from CNAME
            do n=1,nsta
               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
            enddo
            if(dataset.EQ.'SURF.DAT') then
               read(io) (anem(n),n=1,nsta)
               do n=1,nsta
                 write(io6,*)idsta(n),cname(n),clat(n),clon(n),anem(n)
c ---            To scratch file
                 write(iox,*)idsta(n),cname(n),clat(n),clon(n),anem(n)
                 ncommout=ncommout+1
               enddo
            endif
            if(dataset.EQ.'PRECIP.DAT') then
               do n=1,nsta
                 write(io6,*)idsta(n),cname(n),clat(n),clon(n)
c ---            To scratch file
                 write(iox,*)idsta(n),cname(n),clat(n),clon(n)
                 ncommout=ncommout+1
               enddo
            endif
         else
            write(io6,*)
            write(io6,*) 'RDHD:  Invalid projection found'
            write(io6,*) 'Projection found    = ',pmap
            write(io6,*) 'Projection expected = NONE or LL'
            write(*,987)
            stop 'Halted in RDHD'
         endif

c ---    decode start and end times
         if (dataver.eq.'2.1') then
c ---       decode explicit starting and ending dates
            call dedat(ibegn,ibyrn,ibjuln,ibhrn)
            call dedat(iendn,ieyrn,iejuln,iehrn)
         else
c ---       decode h0ur-ending starting and ending dates
            call dedat(ibeg,ibyr,ibjul,ibhr)
            call dedat(iend,ieyr,iejul,iehr)
         endif   

c
      else if(iform.eq.2)then
c ---    File formatted
         ipack=0
         read(io,'(2a16,a64)') dataset,dataver,datamod
         write(io6,'(2a16,a64)') dataset,dataver,datamod
         if(dataset.NE.'SURF.DAT'.AND.dataset.NE.'PRECIP.DAT') then
            write(io6,*)
            write(io6,*) 'RDHD:  Invalid dataset found'
            write(io6,*) 'Dataset name found = ',dataset
            write(io6,*) '  Dataset expected = SURF.DAT'
            write(io6,*) '                or = PRECIP.DAT'
            write(*,987)
            stop 'Halted in RDHD'
         endif
c ---    To scratch file
         write(iox,'(a132)') blank
         write(iox,'(a132)') break
         write(iox,'(a132)') blank
         write(iox,'(2a16,a64)') dataset,dataver,datamod
         ncommout=ncommout+4
         read(io,*) ncomment
         write(io6,*) ncomment
         do i=1,ncomment
            read(io,'(a80)') comment1
            write(io6,'(a80)') comment1
c ---       To scratch file
            write(iox,'(a80)') comment1
            ncommout=ncommout+1
         enddo
         read(io,'(a8)') pmap
         write(io6,'(a8)') pmap
c ---    To scratch file
         write(iox,'(a8)') pmap
         ncommout=ncommout+1
         if(pmap.EQ.'NONE    ') then
         if (dataver.eq.'2.1') then
c ---          Explicit time convention -
c ---          UTC time zone - Convert to CALMET IBTZ time zone
               read(io,'(a8)') axtz
               call utcbasr(axtz,xbtz)
               ibtz=int(xbtz)
               write(io6,'(a8)') axtz
c ---          To scratch file
               ncommout=ncommout+1
               write(iox,'(a8)') axtz

               read(io,*)ibyrn,ibjuln,ibhrn,ibsecn,ieyrn,iejuln,iehrn,
     :                   iesecn,nsta
               write(io6,*)ibyrn,ibjuln,ibhrn,ibsecn,ieyrn,iejuln,iehrn,
     :                   iesecn,nsta
               write(iox,'(8i5,i12)')ibyrn,ibjuln,ibhrn,ibsecn,ieyrn,
     :                   iejuln,iehrn,iesecn,nsta
            else
c ---          hour-ending dataset 
               read(io,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,ibtz,nsta
               write(io6,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,ibtz,nsta
c ---          To scratch file
               write(iox,'(7i5,i12)')ibyr,ibjul,ibhr,ieyr,iejul,iehr,
     &                            ibtz,nsta
            endif
            read(io,*)(idsta(n),n=1,nsta)
            write(io6,*)(idsta(n),n=1,nsta)
            do n=1,nsta
               write(iox,'(i8)') idsta(n)
            enddo
            ncommout=ncommout+nsta+1
         elseif(pmap.EQ.'LL      ') then
            lstnloc=.TRUE.
            read(io,'(a8,a10)') datum,daten
            read(io,'(a4)') xyunit
            write(io6,'(a8,a10)') datum,daten
            write(io6,'(a4)') xyunit
c ---       To scratch file
            write(iox,'(a8,a10)') datum,daten
            write(iox,'(a4)') xyunit
            if (dataver.eq.'2.1') then
c ---          explicit time with seconds
c ---          UTC time zone - Convert to CALMET IBTZ time zone
c              read(io) axtz  - must be formatted (070702)
c --- v6.4.0, Level 121203
               read(io,'(a8)') axtz
               call utcbasr(axtz,xbtz)
               ibtz=int(xbtz)
               write(io6,'(a8)') axtz
c ---          To scratch file
               ncommout=ncommout+1
               write(iox,'(a8)') axtz
               read(io,*)ibyrn,ibjuln,ibhrn,ibsecn,ieyrn,iejuln,iehrn,
     :                   iesecn,nsta
               write(io6,*)ibyrn,ibjuln,ibhrn,ibsecn,ieyrn,iejuln,iehrn,
     :                   iesecn,nsta
               write(iox,'(8i5,i12)')ibyrn,ibjuln,ibhrn,ibsecn,ieyrn,
     :                   iejuln,iehrn,iesecn,nsta
            else
c ---          hour-ending dataset 
               read(io,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,ibtz,nsta
               write(io6,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,ibtz,nsta
               write(iox,'(7i5,i12)')ibyr,ibjul,ibhr,ieyr,iejul,iehr,
     &                            ibtz,nsta
            endif

            ncommout=ncommout+3
            if(dataset.EQ.'SURF.DAT') then
               do n=1,nsta
                 read(io,*)idsta(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(io6,*)idsta(n),cname(n),clat(n),clon(n),anem(n)
c ---            To scratch file
                 write(iox,*)idsta(n),cname(n),clat(n),clon(n),anem(n)
                 ncommout=ncommout+1
               enddo
            else
               do n=1,nsta
                 read(io,*)idsta(n),cname(n),clat(n),clon(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(io6,*)idsta(n),cname(n),clat(n),clon(n)
c ---            To scratch file
                 write(iox,*)idsta(n),cname(n),clat(n),clon(n)
                 ncommout=ncommout+1
               enddo
            endif
         else
            write(io6,*)
            write(io6,*) 'RDHD:  Invalid projection found'
            write(io6,*) 'Projection found    = ',pmap
            write(io6,*) 'Projection expected = NONE or LL'
            write(*,987)
            stop 'Halted in RDHD'
         endif
c
      else
         write(io6,12)iform
12       format(//2x,'ERROR IN SUBR. RDHD -- invalid value of IFORM'/
     1   5x,'IFORM = ',i10)
         write(*,987)
         stop 'Halted in RDHD'
      endif


c --- Convert from hour-ending times to explicit times  

      if (dataver.eq.'2.1') then
c ---    explicit time with seconds- only check format and boundaries
c ---    Make sure years are YYYY (Y2K)  
         call YR4(io6,ibyrn,ierrb)
         call YR4(io6,ieyrn,ierre)
         if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in RDHD - Y2K'

c ---    Hours from 0 to 23
         if (ibhrn.ge.24) then
             nhinc=ibhrn-23
             ibhrn=23
c --- 080325-call incr(io6,ibyn,ibjuln,ibhrn,nhinc)
             call incr(io6,ibyrn,ibjuln,ibhrn,nhinc)
         endif
         if (iehrn.ge.24) then
             nhinc=iehrn-23
             iehrn=23
c --- 080325-call incr(io6,ieyn,iejuln,iehrn,nhinc)
             call incr(io6,ieyrn,iejuln,iehrn,nhinc)
          endif
c ---    Convert seconds to hours
         if(ibsecn.GE.3600) then
            nhrinc=ibsecn/3600
            ibsecn=ibsecn-nhrinc*3600
            call INCR(io6,ibyrn,ibjuln,ibhrn,nhrinc)
         endif
         if(iesecn.GE.3600) then
            nhrinc=iesecn/3600
            iesecn=iesecn-nhrinc*3600
            call INCR(io6,ieyrn,iejuln,iehrn,nhrinc)
         endif

      else
c ---    hour-ending dataset => compute explicit times
c ---    Make sure years are YYYY (Y2K)  
         call YR4(io6,ibyr,ierrb)
         call YR4(io6,ieyr,ierre)
         if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in RDHD - Y2K'

c ---    hourly records only
         ibsecn=0
         iesecn=0   

c ---    ending time is already explicit
         iehrn=iehr
         iejuln=iejul
         ieyrn=ieyr

c ---    Shift back beginning hour-ending time by one hour
         ibhrn=ibhr
         ibjuln=ibjul
         ibyrn=ibyr
         
         call INCR(io6,ibyrn,ibjuln,ibhrn,-1)
      endif

c --- Convert the character lat/lon to reals
      if(lstnloc) then
         do n=1,nsta
            call XTRACTLL(io6,'LAT ',clat(n),rnlat(n))
            call XTRACTLL(io6,'LON ',clon(n),relon(n))
         enddo
      endif

      return
987   format(1x,'ERROR in CALMET run - see CALMET.LST file')
      end
c----------------------------------------------------------------------
      subroutine rdhdu(io,iolst,iox,ibyrun,ibjulun,ibhrun,ibsecun,
     1                 ieyrun,iejulun,iehrun,iesecun,ptop,jdat,
     2                 dataver,ifmt,lht,ltemp,lwd,lws,idstn,cname,
     3                 rnlat,relon,elevm,datum,lstnloc)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 090511              RDHDU
c ---          J. Scire, SRC
c
c --- PURPOSE:  Read a set of upper air header records
c
c --- UPDATES:
c --- V6.32 (080801) to v6.327 (090511)(F.Robe)
c        - Store dataset beginning time as specified in UP.DAT 
c          header V2.0and do not shift it by 1 hour 
c --- v6.223 (070702) to V6.32 (080801)(F.Robe)
c               - Allow new version of UP.DAT (version 2.2.)
c --- V6.221 (070327) to v6.223 (070702)(F.Robe)
c               - Use proper year variable name  for format2.0 in Y2K test
c
c --- V6.2 (060215) to V6.221 (070327) (F.Robe)
c               - Use proper year variable names for format2.1 in Y2K test
c
c --- V5.543 (031215) to V6.2 (060215)  (F.Robe)
c               - Replace hour-ending by explicit beginning-ending times
c                 with seconds (passed to READHD via calling list)
c               - New header format with UTC time zone
c                 for data version 2.1 (must be UTC+0000)
c               - Pass dataset version number through calling list
c --- V5.54 (031017) to V5.543 (031215)  (DGS)
c               - Add station ID and name to arg list
c               - Left-justify station name
c --- V5.5 (030402) to V5.54 (031017)  (DGS)
c               - Add station location data to arg list
c               - Convert character lat/lon to reals
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c               - Add list-file unit to YR4 call
c               - New header format
c               - Transfer file headers to scratch file
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c --- Modified (2/98) by J. Scire to allow comma-delimited data format
c
c --- INPUTS:
c                   IO - integer    - Fortran unit number of upper
c                                     air data file to read
c                IOLST - integer    - Fortran unit number of list file
c                  IOX - integer    - Fortran unit number of scratch
c
c
c       Common block /QA/ variables:
c         NCOMMOUT
c
c --- OUTPUT:
c               IBYRUN - integer    - Beginning year of data (GMT) (explicit)
c              IBJULUN - integer    - Beginning Julian day of data (GMT)(explicit)
c               IBHRUN - integer    - Beginning hour of data (GMT)(explicit)
c              IBSECUN - integer    - Beginning hour of data (GMT) (explicit)
c               IEYRUN - integer    - Ending year of data (GMT)(explicit)
c              IEJULUN - integer    - Ending Julian day of data (GMT)(explicit)
c               IEHRUN - integer    - Ending hour of data (GMT)(explicit)
c              IESECUN - integer    - BEginning hour of data (GMT) (explicit)
cc                 PTOP - real       - Top pressure level extracted
c                                     from original sounding
c                 JDAT - integer    - Data source: 1=TD6201 data,
c                                     2=NCDC CD-ROM data, 3=other
c                                     or unknown)
c              DATAVER - char*16    - Dataset version number
c                 IFMT - integer    - File format (1=slash-delimited
c                                     (/) format (original format), 
c                                     2=comma-delimited data records)
c                  LHT - logical    - Flag indicating if level was
c                                     eliminated if height missing
c                LTEMP - logical    - Flag indicating if level was
c                                     eliminated if temperature missing
c                  LWD - logical    - Flag indicating if level was
c                                     eliminated if wind dir. missing
c                  LWS - logical    - Flag indicating if level was
c                                     eliminated if wind speed missing
c                IDSTN - integer    - Station ID
c                 CNAM - char*4     - Station name
c                RNLAT - real       - Station N.latitude
c                RELON - real       - Station E.longitude
c                ELEVM - real       - station elevation (m MSL)
c                DATUM - character  - DATUM code for location
c              LSTNLOC - logical    - T: station location data found
c
c       Common block /QA/ variables:
c         NCOMMOUT
c
c --- RDHDU called by:  READHD
c --- RDHDU calls:      YR4, XTRACTLL
c----------------------------------------------------------------------
      include 'qa.met'

      logical lht,ltemp,lwd,lws
      logical lstnloc

      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
      character*80 comment1
      character*33 blank33,break33
      character*132 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 --- Set location data flag to false
      lstnloc=.FALSE.

      write(iolst,*)
      write(iolst,*)
      write(iolst,*)
      write(iolst,'(a30,50x)')'UP.DAT File Header -----------'
      write(iolst,*)

      read(io,'(2a16,a64)') dataset,dataver,datamod
      write(iolst,'(2a16,a64)') dataset,dataver,datamod
c --- Check first field of record 1
      if(dataset.EQ.'UP.DAT') then
c ---    To scratch file
         write(iox,'(a132)') blank
         write(iox,'(a132)') break
         write(iox,'(a132)') blank
         write(iox,'(2a16,a64)') dataset,dataver,datamod
         ncommout=ncommout+4
         read(io,*) ncomment
         write(iolst,*) ncomment
         do i=1,ncomment
            read(io,'(a80)') comment1
            write(iolst,'(a80)') comment1
c ---       To scratch file
            write(iox,'(a80)') comment1
            ncommout=ncommout+1
         enddo
         read(io,'(a8)') pmap
         write(iolst,'(a8)') pmap
c ---    To scratch file
         write(iox,'(a8)') pmap
         ncommout=ncommout+1
        if(pmap.EQ.'NONE    ') then
c ---       Original 2 header records follow + UTC time header line if versin 2.1
            if (dataver.eq.'2.1'.or.dataver.eq.'2.2') then
c ---          additional header line with UTC time zone
               ncommout=ncommout+1
               read(io,'(a8)')axtz
               write(iolst,'(a8)')axtz
c ---          To scratch file
               write(iox,'(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(io,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,iejulun,
     &                  iehrun,iesecun,ptop,jdat,ifmt
               write(iolst,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,
     &                  iejulun,iehrun,iesecun,ptop,jdat,ifmt
c ---          To scratch file
               write(iox,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,
     &                  iejulun,iehrun,iesecun,ptop,jdat,ifmt
            else
               read(io,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
               write(iolst,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
c ---          To scratch file
               write(iox,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                    ptop,jdat,ifmt
            endif
            read(io,124)lht,ltemp,lwd,lws
            write(iolst,124)lht,ltemp,lwd,lws
            write(iox,124)lht,ltemp,lwd,lws

            ncommout=ncommout+2

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

c ---          additional header line with UTC time zone
               ncommout=ncommout+1
               read(io,'(a8)')axtz
               write(iolst,'(a8)')axtz
c ---          To scratch file
               write(iox,'(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(io,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,iejulun,
     &                  iehrun,iesecun,ptop,jdat,ifmt
               write(iolst,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,
     &                  iejulun,iehrun,iesecun,ptop,jdat,ifmt
c ---          To scratch file
               write(iox,123)ibyrun,ibjulun,ibhrun,ibsecun,ieyrun,
     &                  iejulun,iehrun,iesecun,ptop,jdat,ifmt
            else
               read(io,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
               write(iolst,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
c ---          To scratch file
               write(iox,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                    ptop,jdat,ifmt
            endif

            read(io,124)lht,ltemp,lwd,lws
            read(io,*) idstn,cname,clat,clon,ielevm
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
            write(iolst,124)lht,ltemp,lwd,lws
            write(iolst,*) idstn,cname,clat,clon,ielevm
c

c ---       To scratch file
            write(iox,124)lht,ltemp,lwd,lws
            write(iox,*) idstn,cname,clat,clon,ielevm
            ncommout=ncommout+5
         else
            write(iolst,*)
            write(iolst,*) 'RDHDU:  Invalid projection found'
            write(iolst,*) 'Projection found    = ',pmap
            write(iolst,*) 'Projection expected = NONE or LL'
            write(*,987)
            stop 'Halted in RDHDU'
         endif

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



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

c ---    Convert seconds to hours
         if(ibsecun.GE.3600) then
            nhrinc=ibsecun/3600
            ibsecun=ibsecun-nhrinc*3600
            call INCR(io6,ibyrun,ibjulun,ibhrun,nhrinc)
         endif
         if(iesecun.GE.3600) then
            nhrinc=iesecun/3600
            iesecun=iesecun-nhrinc*3600
            call INCR(io6,ieyrun,iejulun,iehrun,nhrinc)
         endif
c ---    Convert hours to days
         if (ibhrun.ge.24) then
             nhinc=ibhrun-23
             ibhrun=23
             call incr(io6,ibyrun,ibjulun,ibhrun,nhinc)
          endif
          if (iehrun.ge.24) then
             nhinc=iehrun-23
             iehrun=23
             call incr(io6,ieyrun,iejulun,iehrun,nhinc)
          endif
 
      else
c ---    hour-ending times - convert to explicit times
c ---    Check year format
c         call YR4(iolst,ibyrun,ierrb) - 070702
         call YR4(iolst,ibyru,ierrb)
         call YR4(iolst,ieyru,ierre)
         if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in RDHDU - 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 
c ---    Instantaneous soundings so no need to back up one hour (090511) 
c        call INCR(io6,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 --- Convert the character lat/lon and integer elevation to reals
      if(lstnloc) then
         call XTRACTLL(iolst,'LAT ',clat,rnlat)
         call XTRACTLL(iolst,'LON ',clon,relon)
         elevm=FLOAT(ielevm)
      endif

c --- Formats

122   format(1x,6i5,f5.0,2i5)
123   format(1x,8i5,f5.0,2i5)
124   format(1x,4(4x,l1))
987   format(1x,'ERROR in CALMET run - see CALMET.LST file')

      return
      end
c----------------------------------------------------------------------
      subroutine rdhdow(iw,ibtz)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060218             RDHDOW
c ---          D. Strimaitis, Earth Tech, Inc.
c
c --- PURPOSE:  Read a set of overwater header records
c
c --- UPDATES:
c --- v5.614 (051228) to v6.201 (060218)
c       (1) Check for different datums in SEA.DAT and CALMET grid
c
c --- V5.613 (051227) to v5.614 (051228)(F.Robe)
c       (1) Initialize twave and hwave with 9999 instead of -999.
c
c --- V5.61 (051111) to V5.613 (051227) (F.Robe)
c       (1) Read new header (SEA.DAT version 2.11) with time zone,
c           start date and end date (also new format (a132) for Station 
c           Name in OVRWAT.MET )
c       (2) Check that SEA.DAT time zone matches CALMET base time zone
c           (SEA.DAT versions 2.11+) 
c       (3) Add ibtz to calling list
c       (4) Initialize the Tair Sensor height (ZTAIR) and SST sensor
c           depth (ZSST) arrays with missing values
c
c --- V5.6 (050328) to V5.61 (051111):
c       (1)  Store sea.dat version number for each file
c --- V5.545 (030402) to V5.6 (050328):
c       (1)  Check sea.dat version number against icoare value
c            make sure twave, hwave exist if their values must be used
c       (2)  Initialize new variables TWAVE and HWAVE
c 
c
c --- INPUTS:
c                   IW - integer    - Index for overwater data file
c                 IBTZ - integer    - CALMET base time zone
c
c       Common block /QA/ variables:
c         NCOMMOUT
c       Common block /MAP/ variables:
c         iutmzn,feast,fnorth,
c         rnlat0,relon0,xlat1,xlat2,
c         pmap,utmhem,datum,daten
c
c        Parameters: IO6, IOX
c
c --- OUTPUT:
c
c       Common block /QA/ variables:
c         NCOMMOUT
c       Common block /OVRWAT/ variables:
c         IDOWSTA(mxows), CHOWSTA(mxows)
c         lremap,rverow(mxows),
c         iutmznow,feastow,fnorthow,
c         rnlat0ow,relon0ow,xlat1ow,xlat2ow,
c         pmapow,utmhemow,datumow,datenow,
c         cactionow,vectiow,vectoow
c
c --- RDHDOW called by:  READHD
c --- RDHDOW calls:      ALLCAP, LRSAME, XTRACTLL, GLOBE1
c----------------------------------------------------------------------
      include 'params.met'

      include 'ovrwat.met'
      include 'map.met'
      include 'qa.met'

      character*64 datamod
      character*80 comment1

c --- time zone
      character*8 awxtz

c --- Local Variables
      character*4 xyunitin,utmhemin
      character*8 pmapin,datumin
      character*12 datenin
      character*16 dataset,dataver,blank16
      character*16 clat0in,clon0in,clat1in,clat2in
      character*33 blank33,break33
      character*132 blank,break

      logical lutmin,llccin,lpsin,lemin,llazain,lttmin
      logical LRSAME
      logical lerror

c --- For coordinate transformations
      character*8 cmapi,cmapo

      data nlim/1/
      data blank16/'                '/

      data blank33/'                                 '/
      data break33/'.................................'/

      lerror=.FALSE.

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 --- Initialize inputs
      pmapin='        '

      lutmin =.FALSE.
      llccin =.FALSE.
      lpsin  =.FALSE.
      lemin  =.FALSE.
      llazain=.FALSE.
      lttmin =.FALSE.

      iutmznin=0
      utmhemin='    '

      rlat0in=-999.
      rlon0in=-999.
      xlat1in=-999.
      xlat2in=-999.
      clat0in=blank16
      clon0in=blank16
      clat1in=blank16
      clat2in=blank16

      feastin=0.0
      fnorthin=0.0
      xyunitin='    '

      datumin='        '
      datenin='            '

      dataset=blank16
      dataver=blank16


      write(io6,*)
      write(io6,'(a30,50x)')'SEA.DAT File Header ----------'
      write(io6,*)

c --- Set file unit number
      io=ioow(iw)

      read(io,'(2a16,a64)') dataset,dataver,datamod
      write(io6,'(2a16,a64)') dataset,dataver,datamod
c --- Convert Dataset to upper case
      do i=1,16
         call ALLCAP(dataset(i:i),nlim)
      enddo

c --- Check Dataset
      if(dataset.NE.'SEA.DAT') then
c ---    Incorrect file type
         write(io6,12)dataset
12       format(//2x,'ERROR IN SUBR. RDHDOW -- invalid file dataset'/
     1   5x,'DATASET = ',a16/
     2   5x,'EXPECTED SEA.DAT')
         lerror=.TRUE.
         goto 999
      endif


c --- Check Dataver against ICOARE value
      read(dataver(1:4),'(f4.2)')rverow(iw)
      if((rverow(iw).LT.2.1).and.(icoare.lt.0) ) then
c ---    Observed wave characteristics are required but not available
         write(io6,13)icoare,dataver
13       format(//2x,'ERROR IN SUBR. RDHDOW -- invalid SEA.DAT format'/
     1   5x,'EXPECTED SEA.DAT VERSION > 2.0 for ICOARE < 0'/
     2   5x,'ICOARE = ',i4,' SEA.DAT version: ',a16/ )
         lerror=.TRUE.
         goto 999
      endif
c
c --- Check Dataver to stop if sub-hourly records (for MOD6)
      if(rverow(iw).GE.2.2) then
c ---    dataset with sub-hourly records
         write(io6,14)dataver
14       format(//2x,'ERROR IN SUBR. RDHDOW -- invalid SEA.DAT format'/
     1   5x,'EXPECTED SEA.DAT VERSION < 2.2 for MOD5 CALMET'/
     2   ' SEA.DAT version: ',a16/ )
         lerror=.TRUE.
         goto 999

       endif 
c
c --- To scratch file
      write(iox,'(a132)') blank
      write(iox,'(a132)') break
      write(iox,'(a132)') blank
      write(iox,'(2a16,a64)') dataset,dataver,datamod
      ncommout=ncommout+4
      read(io,*) ncomment
      write(io6,*) ncomment
      do i=1,ncomment
         read(io,'(a80)') comment1
         write(io6,'(a80)') comment1
c ---    To scratch file
         write(iox,'(a80)') comment1
         ncommout=ncommout+1
      enddo

c --- Map projection
      read(io,'(a8)') pmapin
      write(io6,'(a8)') pmapin
      do i=1,8
         call ALLCAP(pmapin(i:i),nlim)
      enddo
      if(pmapin.EQ.'UTM     ')  lutmin =.TRUE.
      if(pmapin.EQ.'LCC     ')  llccin =.TRUE.
      if(pmapin.EQ.'PS      ')  lpsin  =.TRUE.
      if(pmapin.EQ.'EM      ')  lemin  =.TRUE.
      if(pmapin.EQ.'LAZA    ')  llazain=.TRUE.
      if(pmapin.EQ.'TTM     ')  lttmin =.TRUE.

c --- Test for valid PMAPIN
      if(lutmin.OR.llccin.OR.lpsin.OR.lemin.OR.
     &   llazain.OR.lttmin) then
c ---    To scratch file
         write(iox,'(a8)') pmapin
         ncommout=ncommout+1
      else
         write(io6,*)
         write(io6,*) 'RDHDOW: Invalid PMAP      = ',pmapin
         write(io6,*) 'PMAP must be UTM,LCC,PS,EM,LAZA, or TTM'
         lerror=.TRUE.
         goto 999
      endif

c --- Map projection parameters
      if(LUTMIN) then
         read(io,'(i4,a4)') iutmznin,utmhemin
         write(io6,'(i4,a4)') iutmznin,utmhemin
c ---    To scratch file
         write(iox,'(i4,a4)') iutmznin,utmhemin
         ncommout=ncommout+1
      elseif(LLCCIN) then
         read(io,'(4a16)') clat0in,clon0in,clat1in,clat2in
         read(io,*) feastin,fnorthin
         write(io6,'(4a16)') clat0in,clon0in,clat1in,clat2in
         write(io6,*) feastin,fnorthin
c ---    To scratch file
         write(iox,'(4a16)') clat0in,clon0in,clat1in,clat2in
         write(iox,*) feastin,fnorthin
         ncommout=ncommout+2
      elseif(LPSIN) then
         read(io,'(3a16)') clat0in,clon0in,clat1in
         write(io6,'(3a16)') clat0in,clon0in,clat1in
c ---    To scratch file
         write(iox,'(3a16)') clat0in,clon0in,clat1in
         ncommout=ncommout+1
      elseif(LEMIN) then
         read(io,'(2a16)') clat0in,clon0in
         write(io6,'(2a16)') clat0in,clon0in
c ---    To scratch file
         write(iox,'(2a16)') clat0in,clon0in
         ncommout=ncommout+1
      elseif(LLAZAIN.or.LTTMIN) then
         read(io,'(2a16)') clat0in,clon0in
         read(io,*) feastin,fnorthin
         write(io6,'(2a16)') clat0in,clon0in
         write(io6,*) feastin,fnorthin
c ---    To scratch file
         write(iox,'(2a16)') clat0in,clon0in
         write(iox,*) feastin,fnorthin
         ncommout=ncommout+2
      endif
      if(clat0in(1:1).NE.' ') call XTRACTLL(io6,'LAT ',clat0in,rlat0in)
      if(clon0in(1:1).NE.' ') call XTRACTLL(io6,'LON ',clon0in,rlon0in)
      if(clat1in(1:1).NE.' ') call XTRACTLL(io6,'LAT ',clat1in,xlat1in)
      if(clat2in(1:1).NE.' ') call XTRACTLL(io6,'LAT ',clat2in,xlat2in)

c --- Map DATUM and DATE
      read(io,'(a8,a10)') datumin,datenin
      write(io6,'(a8,a10)') datumin,datenin
      do i=1,8
         call ALLCAP(datumin(i:i),nlim)
      enddo
c --- To scratch file
      write(iox,'(a8,a10)') datumin,datenin
      ncommout=ncommout+1

c --- XYUNIT
      read(io,'(a4)') xyunitin
      write(io6,'(a4)') xyunitin
      do i=1,4
         call ALLCAP(xyunitin(i:i),nlim)
      enddo
c --- To scratch file
      write(iox,'(a4)') xyunitin
      ncommout=ncommout+1

c --- Record 10: Time Zone and start/end dates
c --- (for Versions>=2.11) (051227)
      if(rverow(iw).GE.2.10999) then
c ---    time zone
         read(io,'(a8)')awxtz
         write(io6,'(a8)') awxtz

c ---    start and end dates
         read(io,'(6i6)')iwbyr,iwbjdy,iwbhr,
     &              iweyr,iwejdy,iwehr
         write(io6,'(6i6)')iwbyr,iwbjdy,iwbhr,
     &              iweyr,iwejdy,iwehr
c ---    To scratch file
         write(iox,'(a8)') awxtz
         write(iox,'(6i6)')iwbyr,iwbjdy,iwbhr,
     &              iweyr,iwejdy,iwehr
         ncommout=ncommout+2
       endif
     
c --- Station identification
c --- Note: idowsta is i9 and chowsta is a132 for Versions 2.11+
      read(io,*) idowsta(iw),chowsta(iw)
      write(io6,*) idowsta(iw),chowsta(iw)
c --- To scratch file
      write(iox,*) idowsta(iw),chowsta(iw)
      ncommout=ncommout+1

c --- QA header information
c -------------------------

c --- Test for valid time zone (versions 2.11+)

      if(rverow(iw).GE.2.10999) then
         read(awxtz(4:6),'(i3)')iwhr
         read(awxtz(7:8),'(i2)')iwmin
         if(iwhr.lt.0)iwmin=-iwmin
         xwbtz=iwhr+iwmin/60.
c ---    Flip sign as base time convention is opposite UTC/GMT
         xwbtz=-xwbtz
         iwbtz=int(xwbtz)
         if (iwbtz.ne.ibtz) then
c ---       SEA.DAT time zone does not match base time zone - stop
            write(io6,*)
            write(io6,*) 'RDHDOW: Time zones mistmatch - STOP -'
            write(io6,*) 'SEA.DAT time zone must match CALMET base',
     :                   ' time zone'
            write(io6,*) 'SEA.DAT time zone:', iwbtz,'  (',awxtz,')'
            write(io6,*) 'CALMET base time zone:', ibtz
            lerror=.TRUE.
            goto 999 
         endif

      endif

c --- Test for valid IUTMZN
      if((iutmznin.LT.1 .OR. iutmznin.GT.60) .AND. LUTMIN) then
         write(io6,*)
         write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
         write(io6,*)'        IUTMZN should be 1 to 60'
         write(io6,*)'        SEA.DAT file: ',iutmznin
         lerror=.TRUE.
      endif
c --- Test for valid UTMHEM
      if((utmhemin.NE.'N   '.AND.utmhemin.NE.'S   ') .AND. LUTMIN) then
         write(io6,*)
         write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
         write(io6,*)'        UTMHEM should be N or S'
         write(io6,*)'        SEA.DAT file: ',utmhemin
         lerror=.TRUE.
      endif
c --- Test for valid Units
      if(xyunitin.NE.'KM  ') then
         write(io6,*)
         write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
         write(io6,*)'        XY units must be KM'
         write(io6,*)'        SEA.DAT file: ',xyunitin
         lerror=.TRUE.
      endif


      

c --- Store info or compare with stored info
c ------------------------------------------
      if(iw.EQ.1) then
c ---   Pass header data into /OVRWAT/ if this is the first station
        pmapow=pmapin
        iutmznow=iutmznin
        utmhemow=utmhemin
        rnlat0ow=rlat0in
        relon0ow=rlon0in
        xlat1ow=xlat1in
        xlat2ow=xlat2in
        datumow=datumin
        datenow=datenin
        feastow=feastin
        fnorthow=fnorthin

c ---   Is a coordinate transformation needed for CALMET?
c ---   Set translation vectors going from SEA.DAT (x,y)
c ---   to CALMET projection (x,y)
c ---   Scale factor for Tangential TM projection
        tmsone=1.00000
c ---   SEA.DAT
        iutmi=iutmznin
        if(utmhemin.EQ.'S   ' .AND. iutmznin.LT.900) iutmi=-iutmi
        cmapi=pmapin
        if(cmapi.EQ.'TTM     ') cmapi='TM      '
c ---   CALMET
        iutmo=iutmzn
        if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
        cmapo=pmap
        if(cmapo.EQ.'TTM     ') cmapo='TM      '
        call GLOBE1(cmapi,iutmi,tmsone,xlat1in,xlat2in,
     &              rlat0in,rlon0in,feastin,fnorthin,
     &              cmapo,iutmo,tmsone,xlat1,xlat2,
     &              rnlat0,relon0,feast,fnorth,
     &              cactionow,vectiow,vectoow)
c ---   Compare projections, transformation vectors and datums
        lremap=.FALSE.
        if(pmapin.NE.pmap) lremap=.TRUE.
        if(datumin.NE.datum) lremap=.TRUE.
        do i=1,9
           if(vectiow(i).NE.vectoow(i)) lremap=.TRUE.
        enddo

      else
c ---   Compare header data with previous overwater file
c ---   Projection checks
        if(pmapin.NE.pmapow) then
          write(io6,*)
          write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
          write(io6,*)'        Map projection PMAP does not match'
          write(io6,*)'        SEA.DAT file  : ',pmapin
          write(io6,*)'        Previous file : ',pmapow
          lerror=.TRUE.
        endif
        if(iutmznin.NE.iutmznow)then
          write(io6,*)
          write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
          write(io6,*)'        UTM zone does not match'
          write(io6,*)'        SEA.DAT file  : ',iutmznin
          write(io6,*)'        Previous file : ',iutmznow
          lerror=.TRUE.
        endif
        if(utmhemin.NE.utmhemow)then
          write(io6,*)
          write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
          write(io6,*)'        UTM Hemisphere does not match'
          write(io6,*)'        SEA.DAT file  : ',utmhemin
          write(io6,*)'        Previous file : ',utmhemow
          lerror=.TRUE.
        endif
c ---   Check lat/lon variables
        if(clat0in(1:1).NE.' ') then
          if(.not.LRSAME(0.0001,rlat0in,rnlat0ow))then
            write(io6,*)
            write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
            write(io6,*)'        RNLAT0 does not match'
            write(io6,*)'        SEA.DAT file  : ',rlat0in
            write(io6,*)'        Previous file : ',rnlat0ow
            lerror=.TRUE.
          endif
        endif
        if(clon0in(1:1).NE.' ') then
          if(.not.LRSAME(0.0001,rlon0in,relon0ow))then
            write(io6,*)
            write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
            write(io6,*)'        RELON0 does not match'
            write(io6,*)'        SEA.DAT file  : ',rlon0in
            write(io6,*)'        Previous file : ',relon0ow
            lerror=.TRUE.
          endif
        endif
        if(clat1in(1:1).NE.' ') then
          if(.not.LRSAME(0.0001,xlat1in,xlat1ow))then
            write(io6,*)
            write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
            write(io6,*)'        XLAT1 does not match'
            write(io6,*)'        SEA.DAT file  : ',xlat1in
            write(io6,*)'        Previous file : ',xlat1ow
            lerror=.TRUE.
          endif
        endif
        if(clat2in(1:1).NE.' ') then
          if(.not.LRSAME(0.0001,xlat2in,xlat2ow))then
            write(io6,*)
            write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
            write(io6,*)'        XLAT2 does not match'
            write(io6,*)'        SEA.DAT file  : ',xlat2in
            write(io6,*)'        Previous file : ',xlat2ow
            lerror=.TRUE.
          endif
        endif
c ---   DATUM and DATE
        if(datumin.NE.datumow .OR. datenin.NE.datenow)then
           write(io6,*)
           write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
           write(io6,*)'        DATUM or DATE does not match'
           write(io6,*)'        SEA.DAT file  : ',datumin,datenin
           write(io6,*)'        Previous file : ',datumow,datenow
          lerror=.TRUE.
        endif
c ---   False Easting, Northing
        if(feastin.NE.feastow .OR. fnorthin.NE.fnorthow)then
           write(io6,*)
           write(io6,*)'RDHDOW: Problem for station: ',chowsta(iw)
           write(io6,*)'        False Easting/Northing does not match'
           write(io6,*)'        SEA.DAT file  : ',feastin,fnorthin
           write(io6,*)'        Previous file : ',feastow,fnorthow
          lerror=.TRUE.
        endif

      endif

c --- STOP now if error exists in the input file
999   if(LERROR) then
         write(*,987)
         stop 'Halted in RDHDOW'
      endif

c --- Formats
987   format(1x,'ERROR in CALMET run - see CALMET.LST file')


c --- Initialize the wave characteristics (HWAVE and TWAVE)
c     dominant wave period 
      twave(iw)=9999.
c     Significant wave height
      hwave(iw)=9999.

c --- Initialize Tair Sensor height and SST sensor depth (051227)
      ZTAIR(iw)=9999.
      ZSST(iw) =9999.

      return
      end
c----------------------------------------------------------------------
      subroutine rdhd4 (dxmm5)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 110421              RDHD4
c ---          J. Scire, Earth Tech, Inc.
c ---          Modified by M. Fernau
c              Modified by F. Robe to allow UTM projection in MM4.DAT
c
c --- PURPOSE:  Read the IWAQM-formatted header records from a MM4 file
c
c --- UPDATES              
c --- v6.327(090511)to v6.334(110421)(F.Robe)
c        - Compute MM4 gridsize and pass it via calling list
c
c --- V6.2 (060215) to v6.327(090511)(F.Robe)
c        - Check that CALMET grid is within the prognostic sub-domain 
c        - Print out QA3D.DAT file sooner in the code (so it is available
c          for QA-ing should the code stop because the CALMET grid is 
c          outside of the MM4 prognostic domain)
c
c --- V5.547 (041010) to V6.2 (060215)(F.Robe)
c        - Compute array of nearest CALMET neighbors to each MM4
c          gridpoint - INEARG,JNEARG (mxnxp,mxyp) stored in MM4HDO.MET
c           
c --- V5.546 (040924)to V5.547 (041010) (F. Robe)
c                - Add variable nfm3d to common PROGSTEP (for multiple MM4 files)
c --- V5.542 (031126) to V5.546 (040924) (F. Robe)
c                - Compute the positions of MM4 gridpoints relative to CALMET
c                  domain origin
c --- V5.541 (030515) to V5.542 (031126) (J. Scire)
c               - Write MM4.DAT grid pts (X,Y,long,lat) to QA3D.DAT
c                 file
c --- V5.5 (030402) to V5.51 (030515)  (DGS)
c               - Add grid points to list file
c               - MM4 DATUM is DATUM3D in /MM4HDO/
c --- V5.4 (030119) to V5.5 (030402)  (DGS)
c               - Add list-file unit to JULDAY, INCR, YR4 calls
c               - Add new COORDS (GLOBE1, GLOBE)
c               - Change documentation:  coordinates may be other than
c                 UTM or LLC
c --- V5.1-V5.3     030119  (FRR):initialization for NOOBS mode
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c
c        Parameters:
c            MXNXP, MXNYP, MXNZP, IO6, IO20, MXNX, MXNY, IO4,MXB3D
c        Common block /MAP/:
c            IUTMZN, UTMHEM, XLAT1, XLAT2, RELON0, RNLAT0,
c            FEAST, FNORTH, DATUM
c        Common block /GRID/:
c            NX,NY,DGRID,XORIGR,YORIGR,
c        Common block /MM4HDO/ variables:
c            DATUM3D
c
c --- OUTPUT:
c
c        Common block /MM4HDO/ variables:
c            IBYRM, IBJULM, IBHRM, IEYRM, IEJULM, IEHRM,
c            NXMM4, NYMM4, NZP, PTOPMM4, I1, J1, NXP, NYP,
c            SIGMA(mxnzp), XLAT4(mxnxp,mxnyp), XLONG4(mxnxp,mxnyp),
c            IELEV4(mxnxp,mxnyp),ILU4(mxnxp,mxnyp),XLCMM4(mxnxp,mxnyp),
c            YLCMM4(mxnxp,mxnyp),IGRAB(mxnx,mxny,4),JGRAB(mxnx,mxny,4),
c            IOUTMM5,DATUM3D
c            INEARG(mxnxp,mxnyp), JNEARG((mxnxp,mxnyp)
c
c        Common PROGSTEP variables (to RDMM4)
c            ifirstpg,nfm3d
c
c --- RDHD4 called by:  READHD
c --- RDHD4 calls:      JULDAY, INCR, YR4, GLOBE1, GLOBE, INOUT
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      character*36 ctext
      logical lprt
c
c --- Common blocks
      include 'map.met'
      include 'grid.met'
      include 'mm4hdo.met'
      include 'd6.met'

c     Initialisation for NOOBS option (common with RDMM4,READHD)
      COMMON /PROGSTEP/ ifirstpg,nfm3d

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

c --- CALMET corner points (090511)
      real*8 xc(4),yc(4)

c --- MM4 corner points (defining MM4 boundary)(090511)
      real*8 xb(mxb3d),yb(mxb3d)

      dimension neari(4),nearj(4),dnear(4)
      data lprt/.true./


c --- Scale factor for Tangential TM projection
      tmsone=1.00000
c --- Set translation vectors going from N.lat/E.lon
c --- to projection(x,y)km
      iutmo=iutmzn
      if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
      cmapo=pmap
      if(cmapo.EQ.'TTM     ') cmapo='TM      '
      cmapi='LL      '
      idum=0
      rdum=0.0
      call GLOBE1(cmapi,idum,rdum,rdum,rdum,rdum,rdum,
     &            rdum,rdum,
     &            cmapo,iutmo,tmsone,xlat1,xlat2,rnlat0,relon0,
     &            feast,fnorth,
     &            caction,vecti,vecto)

c
c ------------------------------------------------------------------
c --- Read header record #1 (text date/time stamp for file creation)
c ------------------------------------------------------------------
      read(io20,10)ctext
10    format(a36)
c
c ----------------------------------------------------------
c --- Read header record #2 (MM4 grid data) (revised format)
c ----------------------------------------------------------
c *** read(io20,20)ibyrm,ibmom,ibdym,ibhrm,ieyrm,iemom,iedym,iehrm,
c ***1             nxmm4,nymm4,nzp,ptopmm4
c *20 format(4i2,1x,4i2,3i4,f6.1)
      read(io20,20)ibyrm,ibmom,ibdym,ibhrm,nhrsmm4,
     1             nxmm4,nymm4,nzp,ptopmm4
 20   format(4i2,4i4,f6.1)
      call YR4(io6,ibyrm,ierrb)
      if(ierrb.NE.0) stop 'Halted in RDHD4'
c
c --- Calculate Julian day
      call julday(io6,ibyrm,ibmom,ibdym,ibjulm)
c --- Uncomment if using other format
c *** call julday(io6,ieyrm,iemom,iedym,iejulm)
c
c --- Compute ending date/time (comment out if using other format)
      ieyrm=ibyrm
      iejulm=ibjulm
      iehrm=ibhrm
      call incr(io6,ieyrm,iejulm,iehrm,nhrsmm4)
c

c -----------------------------------------------------
c --- Read header record #3 (extraction subdomain data)
c -----------------------------------------------------
      read(io20,30)i1,j1,nxp,nyp
30    format(4i4)
c
c --- Note that MM4 data includes 8 mandatory levels (surface, 1000,
c --- 925, 850, 700, 500, 400, and 300 mb) plus NZP model levels
      nzpp8 = nzp + 8
c --- Check that array dimensions are not exceeded
      if(nxp.gt.mxnxp.or.nyp.gt.mxnyp.or.nzpp8.gt.mxnzp)then
         write(io6,*)'ERROR in subr. RDHD4 -- Array dimensions ',
     1   'are too small for data being read'
         write(io6,*)'Grid being read  (NXP, NYP, NZP, NZPP8) = ',
     1    nxp,nyp,nzp,nzpp8
         write(io6,*)'Array dimensions (MXNXP, MXNYP, MXNZP) = ',
     1    mxnxp,mxnyp,mxnzp
         stop
      endif
c
c ----------------------------------------
c --- Next NZP records -- MM4 sigma levels
c ----------------------------------------
      do 40 n=1,nzp
         read(io20,38)sigma(n)
38       format(f6.4)
40    continue
c
c -----------------------------------------------------
c --- Print the MM4 header information to the list file
c --- (except for the gridded fields)
c -----------------------------------------------------
      if(lprt)then
         write(io6,102)ctext
102      format(//1x,'Information read from MM4 data file'/
     1   5x,'LABEL (CTEXT): ',a36)
c
         write(io6,104)ibyrm,ibmom,ibdym,ibhrm,nhrsmm4,
     1                 nxmm4,nymm4,nzp,ptopmm4
104      format(/5x,'Date/time (YYYYMMDDHH) of MM4 data: '/
     1           5x,'                  Start = ',i4,3i2,' (GMT)'/
     2           5x,'              No. hours = ',i4,/
     3           5x,'Full MM4 model grid characteristics: '/
     4           5x,'            No. X cells = ',i4/
     5           5x,'            No. Y cells = ',i4/
     6           5x,'            No. layers  = ',i4/
     7           5x,'     Top pressure level = ',f6.1,' (mb)')
c
         ixlast=i1+nxp-1
         jylast=j1+nyp-1
         write(io6,106)i1,j1,ixlast,jylast
106      format(/5x,'Extraction subdomain in MM4.DAT file: '/
     1           5x,'            Beginning X = ',i4/
     2           5x,'            Beginning Y = ',i4/
     3           5x,'               Ending X = ',i4/
     4           5x,'               Ending Y = ',i4)
c
         write(io6,108)
108      format(/5x,'MM4 sigma levels'/5x,'Level',5x,'Sigma'/)
         do 110 i=1,nzp
            write(io6,109)i,sigma(i)
109         format(4x,i4,6x,f6.4)
110      continue
      endif
c
c --------------------------------------------------------------
c --- Next NXP * NYP records -- lat., long., elevation, land use
c --------------------------------------------------------------

      do 50 j=1,nyp
      do 50 i=1,nxp
        read(io20,48)iindex,jindex,xlat4(i,j),xlong4(i,j),
     &    ielev4(i,j),ilu4(i,j)
48      format(2i3,f7.3,f8.3,i5,i3)

c ---   Compute grid point locations from N.Lat and E.Lon
        call GLOBE(io6,caction,datum3d,vecti,datum,vecto,
     &             xlong4(i,j),xlat4(i,j),xlcmm4(i,j),ylcmm4(i,j),
     &             idum,c4hem)
c
c ---   QA check that I,J read match expected values
c
        icheck=iindex-i1+1
        jcheck=jindex-j1+1
        if(icheck.ne.i.or.jcheck.ne.j)then
          write(io6,*)'ERROR in subr. RDHD4 -- I,J do not match ',
     1      'values read on header record'
          write(io6,*)'I, J = ',i,j
          write(io6,*)'ICHECK, JCHECK = ',icheck,jcheck
          stop
        endif

50    continue
c
c --- 110421- Compute MM5 gridsize in km 
      dxmm5= sqrt ( (xlcmm4(1,1)-xlcmm4(2,1))**2 + 
     :              (ylcmm4(1,1)-ylcmm4(2,1))**2 )
c
c -----------------------------------------------------
c --- Print the MM4 grid points to the QA file
c -----------------------------------------------------
      if(lprt)then
         open(io4,file='QA3D.DAT',status='unknown')
c        
         write(io4,*)'            MM4.DAT Grid Points'
         write(io4,*)'     X           Y        Longitude    Latitude'
         write(io4,*)'   (km)        (km)        (deg E)     (deg N)'
         do j=1,nyp
         do i=1,nxp
            write(io4,'(4f12.3)') xlcmm4(i,j),ylcmm4(i,j),
     1                            xlong4(i,j),xlat4(i,j)
         enddo
         enddo
c
         close(io4)
      endif

c -----------------------------------------------------------------------
c --- Ensure that the CALMET domain is within the MM4 sub-domain (090511)
c -----------------------------------------------------------------------
c --- MM4 boundary points 
c --- Must include all boundary points and not just corner points
c --- because of possible curvature of MM4 domain in CALMET coord. system

      do nc=1,nyp
        xb(nc)=xlcmm4(1,nc)
        yb(nc)=ylcmm4(1,nc)
      end do
      do i=1,nxp-1
        nc=nyp+i
        xb(nc)=xlcmm4(1+i,nyp)
        yb(nc)=ylcmm4(1+i,nyp)
      end do
      do i=1,nyp-1
         nc=nyp+nxp-1+i
        xb(nc)=xlcmm4(nxp,nyp-i)
        yb(nc)=ylcmm4(nxp,nyp-i)
      end do
      do i=1,nxp-1
        nc=nyp+nxp+nyp-2+i
        xb(nc)=xlcmm4(nxp-i,1)
        yb(nc)=ylcmm4(nxp-i,1)
      end do

c --- total number of boundary points
      nptbound=nyp+nxp+nyp+nxp-3

c --- CALMET corner points 
      delg= dgrid * .001
      xc(1) = xmap0  + (0.5 * delg)
      yc(1) = ymap0  + (0.5 * delg)
      xc(2) = xc(1)
      yc(2) = yc(1) + (ny-1) * delg
      xc(3) = xc(1) + (nx-1) * delg
      yc(3) = yc(1)
      xc(4) = xc(3)
      yc(4) = yc(2)

c
      do nc=1,4

        call inout(xc(nc),yc(nc),iflag,xb,yb,nptbound)

        if (iflag.eq.0) then
c ---      calmet gridpoint is outside of MM4 subdomain ->stop
           write(io6,*)'STOP - Subroutine RDHD4 -'
           write(io6,*)'CALMET grid outside of prognostic grid'
           write(6,*)'STOP - CALMET grid outside of prognostic grid'                                         
           write(io6,*)'Check plot files QAMETG.BNA and QA3D.DAT'
           STOP
        end if

      end do

c -----------------------------------------------------------------
c --- Find the 4 closest MM4 grid points to each CALMET grid point
c     (assume CALMET domain is inside MM4 grid section)
c
c     delg = dgrid * .001  ! already defined (090511)
c *** xcal = xorigr * .001 + (0.5 * delg)
c *** ycal = yorigr * .001 + (0.5 * delg)
c --- Compute CALMET grid coordinates in real space coordinates
      xcal = xmap0  + (0.5 * delg)
      ycal = ymap0  + (0.5 * delg)

      do i = 1,nx
c
c --- Find x/y for CALMET center points
c
        xx = xcal + (i - 1) * delg
        do j = 1,ny
          yy = ycal + (j - 1) * delg
          do k = 1,4
            neari(k) = 0
            nearj(k) = 0
            dnear(k) = 9.9E19
          enddo

          
          do ii = 1,nxp
          do jj = 1,nyp

            pdist = sqrt ((xlcmm4(ii,jj) - xx) ** 2 +
     &                    (ylcmm4(ii,jj) - yy) **2)


            do k = 1,4
              if (pdist .lt. dnear(k)) then
                if (k .lt. 4) then
                  dnear(4) = dnear(3)
                  nearj(4) = nearj(3)
                  neari(4) = neari(3)
                endif
                if (k .lt. 3) then
                  dnear(3) = dnear(2)
                  nearj(3) = nearj(2)
                  neari(3) = neari(2)
                endif
                if (k .lt. 2) then
                  dnear(2) = dnear(1)
                  nearj(2) = nearj(1)
                  neari(2) = neari(1)
                endif
                dnear(k) = pdist
                nearj(k) = jj
                neari(k) = ii
                goto 66
              endif
            enddo
 66         continue

          enddo
          enddo

          do k = 1,4
            igrab(i,j,k) = neari(k)
            jgrab(i,j,k) = nearj(k)
          enddo

        enddo
      enddo

c-------------------------------------------------------------------
c --- Find the closest CALMET grid point to each MM4
c     grid point (060213)v (stored in MM4HDO.MET)
c ------------------------------------------------------------------
      do i = 1,nxp
      do j = 1,nyp
          nearii = 1
          nearjj = 1
          dnearg=9.9E19

          do ii = 1,nx 
          do jj = 1,ny 

             xx = xcal + (ii - 1) * delg
             yy = ycal + (jj - 1) * delg
   
            pdist = sqrt ((xlcmm4(i,j) - xx) ** 2 +
     &                    (ylcmm4(i,j) - yy) **2)

            if (pdist .lt. dnearg) then
                dnearg  = pdist
                nearii = ii
                nearjj = jj
             endif

          enddo
          enddo
          
          inearg(i,j) = nearii
          jnearg(i,j) = nearjj


      enddo
      enddo 

c ---------------------------------------------------------------------

c --- 040924 (frr) Compute the MM5 gridpoints locations (in m) relative
c --- the CALMET domain origin - Done here rather than at each timestep
c --- in subrtoutine interpqr (also use units of meters not km)
      np=0
      do 300 ip=1,nxp
      do 300 jp=1,nyp
         np=np+1
         x04(np)=(xlcmm4(ip,jp)-xmap0)*1000.
         y04(np)=(ylcmm4(ip,jp)-ymap0)*1000.
 300  continue



c     Record first access to MM4 record (And first MM4.DAT file)
      ifirstpg=0
      nfm3d=1

      return
      end
c----------------------------------------------------------------------
      subroutine rdhd5(mcloud,itwprog,npsta,dxmm5)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 110421              RDHD5
c              F.Robe
c
c --- PURPOSE: Read the header records from a MM5.DAT or 3D.DAT file
c
c --- UPDATES:
c --- v6.330 (101006) to v6.334 (110421) (FRR)
c       - compute MM5 gridsize 
c
c --- v6.328 (090615) to v6.330 (101006) (CEC)
c       - Change ICLOUD into MCLOUD (and ICLDOUT)
c
c --- v6.327(090511) to V6.328 (090615)
c       - Move printing of first/last gridpoint lat/lon/elev to
c         RDHD51, RDHD52 and RDHD53 so the info is printed out
c         after each multiple file header is read in
c
c --- V6.32 (080205) to v6.327(090511)(F.Robe)
c       - Check that CALMET grid is within the prognostic sub-domain 
c
c ---    v6.219 (070123)to V6.32 (080205)(F.Robe)
c        - Allow 3D.DAT version 3.0 
c        - Add npsta to rdhd5 and rdhd53 calling lists
c
c ---  v6.217 (061231)to v6.219 (070123)(F.Robe)
c        - Compute 4 closest ocean 3D.Dat gridpoint to ALL CALMET
c          gridpoints (not just offshore gridpoints)
c
c ---  V6.2 (060215) to v6.217 (061231)(F.Robe)
c        - Allow icloud=4 option
c
c --- v5.56h (051113) to V6.2 (060215)(F.Robe)
c        - Compute array of nearest CALMET neighbors to each MM5
c          gridpoint - INEARG,JNEARG (mxnxp,mxyp) stored in MM4HDO.MET
c
c --- V5.6f (050428)to v5.56h (051113)(F.Robe)
c        - Check compatibility between dataset version and itwprog option
c          (if itwprog=2, make sure deltaT is available in 3D.DAT file)
c        - Get itwprog value from calling list and pass to rdhd53
c        - compute 4 closest ocean 3D.DAT gridpoints to each offshore
c          CALMET gridpoints (igrabw,jgrabw) and store in MM4HDO
c        - include GEO.MET
c
c --- V5.6 (050328) to V5.6f (050428)(F.Robe)
c        - Remove npsta from calling list (no longer needed)
c
c --- V5.547 (041010) to V5.6 (050328)(F.Robe)
c        - Remove ioutmm5 restriction on NPSTA=-1 as surface precipitation is
c          is always part of the M3D record even if rainfall profiles (qr)
c          are not
c --- V5.546 (040924) to V5.547 (041010) (F.Robe)
c        - add variable file number (nfm3d) and change call
c          to rdhd51/rdhd52/rdhd53 (necessary for multiple MM5.DAT)
c        - explicit common replaced by include d6.met                
c --- V5.542 (031126) to V5.546 (040924) (F. Robe)
c        - Compute the positions of MM5 gridpoints relative to CALMET
c          domain origin               
c --- V5.541 (030402) to V5.542 (031126) (J. Scire)
c               - Changes to allow new 3D.DAT file structure (Version 2.0) 
c                 to be read while maintinaing backward compatibility with
c                 older MM5.DAT and 3D.DAT/M3D.DAT/MM53D.DAT files
c --- V5.4 (000602d) to V5.5 (030402)  (DGS)
c               - Change documentation:  coordinates may be other than
c                 UTM or LLC
c --- V5.0-V5.1   991104  (DGS): YYYY format for year
c --- V5.0-V5.1   991104  (DGS): Allow either new or old header format
c
c --- INPUTS:
C              MCLOUD  INT     - CLOUD FLAG - IF MCLOUD=3 or 4, compute cloud cover
C                                based on prognostic variables
C
c             ITWPROG  INT     - Flag to use SEA.DAT or prognostic offshore 
c                                temperatures (deltaT)
c                                0 : use SEA.DAT air/sea temperatures and lapse rates
c                                1 : use SEa.DAT temp and prognostic lapse rates
c                                2 : use prognostic air/sea temperatures 
c                                    and lapse rates
c            NPSTA   integer     Precipitation flag
c                                -1: use prognostic precipitation fields
c                                 0: no precipitation
c                               n>0: number of precipitation stations
c
c        Parameters:
c            MXNXP, MXNYP, MXNZP, IO6, IO20, MXNX, MXNY, MXB3D
c        Common block /GRID/:
c            NX,NY,DGRID,XORIGR,YORIGR
c        Common block /FILNAM/: M3DDAT(mxm3d)
c        Common block /MM4HDO/: NM3D,itwprog
c        Common block /GEO/: ilandu,iwat1,iwat2
c
c
c --- OUTPUT:
c
c        Common block /MM4HDO/ variables:
c            IBYRM, IBJULM, IBHRM, IEYRM, IEJULM, IEHRM,
c            NXMM4, NYMM4, NZP, PTOPMM4, I1, J1, NXP, NYP,
c            SIGMA(mxnzp), XLAT4(mxnxp,mxnyp), XLONG4(mxnxp,mxnyp),
c            IELEV4(mxnxp,mxnyp),ILU4(mxnxp,mxnyp),XLCMM4(mxnxp,mxnyp),
c            YLCMM4(mxnxp,mxnyp),X04(mxnxp*mxnyp),Y04(mxnxp*mxnyp),
c            IGRAB(mxnx,mxny,4),JGRAB(mxnx,mxny,4),IOUTMM5
c            IGRABW(mxnx,mxny),JGRABW(mxnx,mxny)
c            INEARG(mxnxp,mxnyp), JNEARG(mxnxp)
c
c
c --- RDHD5 called by:  READHD
c --- RDHD5 calls:      RDHD51, RDHD52, RDHD53, INOUT
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      character*80 buff1,buff2
      character*12 cset3d
      logical lprt
c
c --- Common blocks
      include 'grid.met'
      include 'mm4hdo.met'
      include 'filnam.met'
      include 'd6.met'
      include 'geo.met'

c     COMMON /D6/ IRD,IWR,IFILE,IRDP
c
      COMMON /PROGSTEP/ ifirstpg,nfm3d
c
      dimension neari(4),nearj(4),dnear(4)
      data lprt/.true./

c --- CALMET corner points (090511)
      real*8 xc(4),yc(4)

c --- MM5 corner points (defining MM5 boundary)(090511)
      real*8 xb(mxb3d),yb(mxb3d)

c --- FRR (09/2001) - non hourly mm5 data
c --- Flag for initialization in rdmm5 subroutine
      ifirstpg = 0

c --- MM5.DAT file number
      nfm3d=1

c --- Read first two records to determine  file format 
c ---   iMM53d = 0 for MM5.DAT file structure
c ---   iMM53d = 1 for 3D.DAT file structure prior to Version 2.0
c ---   iMM53d = 2 for 3D.DAT file structure, Version 2.x
c ---   imm53d = 3 for 3D.DAT file structure, version 3.0 or later
      read(io20,'(a)')buff1
      read(io20,'(a)')buff2

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
         imm53d=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
            imm53d=2
c ---       Version 3.x (explicit beg/end times with seconds)
            if(buff1(17:17).eq.'3')imm53d=3
         else
c
c ---       Structure does not fit 3D.DAT conventions -- assume
c ---       file is in MM5.DAT format
            imm53d=0
         endif
      endif

      close(io20)

c --- Check compatibility with ITWPROG (051113)
      if (itwprog.eq.2 .and. imm53d.lt.2) then
         write(io6,*) 'STOP in RDHD5 '
         write(io6,*) 'Error in Input Group 6 of CALMET.INP '
         write(io6,*) 'ITWPROG=2 incompatible with 3D.DAT dataset'
         write(io6,*) '3D.DAT version # must be 2.0 or higher'
         stop
       endif         


c frr 041010 - Multiple MM5.DAT
c     open(io20,file=mm4dat,status='old')
      open(io20,file=m3ddat(1),status='old')      

c -----------------------
c --- Read header records
c -----------------------

c --- frr 050328 - keep track of multiple MM5.DAT files to open them

      if(imm53d.eq.0) then
c ---    Data is in original MM5 format (No data set name)  
c ---    Record 1 includes a comment line
         call rdhd51(nfm3d)
c
      else if(imm53d.eq.1)then
c
c ---    Data is in old 3D.DAT format prior to version 2.0 
c ---    (Record 1 is title, Record 2 is dataset name, 
c ---    code version # and level #)
         call rdhd52(nfm3d)

      else if(imm53d.eq.2.or.imm53d.eq.3)then
c
c ---    Data is in new 3D.DAT format (dataset version 2.0 or
c ---    3.0)
         call rdhd53(nfm3d,itwprog,npsta)

      else
c
c ---   Unexpected value of imm53d -- write error message
        write(io6,*)'Error in Subr. RDHD5 -- Unexpected value ',
     1  'of IMM53D -- IMM53D = ',imm53d
        stop
      endif
c


c --- 110421- Compute MM5 gridsize in km  
      dxmm5= sqrt ( (xlcmm4(1,1)-xlcmm4(2,1))**2 + 
     :              (ylcmm4(1,1)-ylcmm4(2,1))**2 )


c --- Print out after each new file is read in (elevations can change)
c --- 090615
c --------------------------------------------------------
c --- Print first and last lat/lon values to the list file
c --------------------------------------------------------
c      if(lprt)then
c         write(io6,121)xlat4(1,1),xlong4(1,1),ielev4(1,1),
c     &                 xlat4(nxp,nyp),xlong4(nxp,nyp),ielev4(nxp,nyp)
c121      format(/5x,' Lat./Lon./Elev. of First Cell: ',f9.4,f10.4,i6/
c     :           5x,' Lat./Lon./Elev. of Last  Cell: ',f9.4,f10.4,i6)
c      endif
c


c ----------------------------------------------------------------------
c --- Ensure that the CALMET domain is within the M3D sub-domain (090511)
c ----------------------------------------------------------------------
c --- M3D boundary points:
c --- Must include all boundary points and not just corner points
c --- because of possible curvature of M3D domain in CALMET coord. system

      do nc=1,nyp
        xb(nc)=xlcmm4(1,nc)
        yb(nc)=ylcmm4(1,nc)
      end do
      do i=1,nxp-1
        nc=nyp+i
        xb(nc)=xlcmm4(1+i,nyp)
        yb(nc)=ylcmm4(1+i,nyp)
      end do
      do i=1,nyp-1
         nc=nyp+nxp-1+i
        xb(nc)=xlcmm4(nxp,nyp-i)
        yb(nc)=ylcmm4(nxp,nyp-i)
      end do
      do i=1,nxp-1
        nc=nyp+nxp+nyp-2+i
        xb(nc)=xlcmm4(nxp-i,1)
        yb(nc)=ylcmm4(nxp-i,1)
      end do

c --- total number of boundary points
      nptbound=nyp+nxp+nyp+nxp-3

c --- CALMET corner points 
      delg= dgrid * .001
      xc(1) = xmap0  + (0.5 * delg)
      yc(1) = ymap0  + (0.5 * delg)
      xc(2) = xc(1)
      yc(2) = yc(1) + (ny-1) * delg
      xc(3) = xc(1) + (nx-1) * delg
      yc(3) = yc(1)
      xc(4) = xc(3)
      yc(4) = yc(2)

c
      do nc=1,4
        call inout(xc(nc),yc(nc),iflag,xb,yb,nptbound)
        if (iflag.eq.0) then
c ---      calmet gridpoint is outside of M3D subdomain ->stop
           write(io6,*)'STOP - Subroutine RDHD5 -'
           write(io6,*)'CALMET grid outside of prognostic grid'
           write(6,*)'STOP - CALMET grid outside of prognostic grid'                                         
           write(io6,*)'Check plot files QAMETG.BNA and QA3D.DAT'
           STOP
        end if
      end do

c----------------------------------------------------------------
c --- Find the 4 closest MM5 grid points to each CALMET grid point
c     (assume CALMET domain is inside MM5 grid section)
c ---------------------------------------------------------------
c      delg = dgrid * .001   ! Already defined (090511)
      
c --- Compute CALMET grid coordinates in real space coordinates
      xcal = xmap0  + (0.5 * delg)
      ycal = ymap0  + (0.5 * delg)
c
      do i = 1,nx
c
c --- Find x/y for CALMET center points
c
        xx = xcal + (i - 1) * delg
        do j = 1,ny
          yy = ycal + (j - 1) * delg
          do k = 1,4
            neari(k) = 0
            nearj(k) = 0
            dnear(k) = 9.9E19
          enddo
          do ii = 1,nxp
          do jj = 1,nyp
            pdist = sqrt ((xlcmm4(ii,jj) - xx) ** 2 +
     &                    (ylcmm4(ii,jj) - yy) **2)
            do k = 1,4
              if (pdist .lt. dnear(k)) then
                if (k .lt. 4) then
                  dnear(4) = dnear(3)
                  nearj(4) = nearj(3)
                  neari(4) = neari(3)
                endif
                if (k .lt. 3) then
                  dnear(3) = dnear(2)
                  nearj(3) = nearj(2)
                  neari(3) = neari(2)
                endif
                if (k .lt. 2) then
                  dnear(2) = dnear(1)
                  nearj(2) = nearj(1)
                  neari(2) = neari(1)
                endif
                dnear(k) = pdist
                nearj(k) = jj
                neari(k) = ii
                goto 66
              endif
            enddo
66         continue

          enddo
          enddo

c
          do k = 1,4
            igrab(i,j,k) = neari(k)
            jgrab(i,j,k) = nearj(k)
          enddo
        enddo
      enddo
c

c-------------------------------------------------------------------
c --- Find the 4 closest MM5 ocean grid points to each offshore 
c     CALMET grid point - only if itwprog=2 (051031-frr)
c     (assume CALMET domain is inside MM5 grid section)
c ------------------------------------------------------------------
      if (itwprog.eq.2) then 

         do 55 i = 1,nx
c
c ---      Find x/y for CALMET center points
           xx = xcal + (i - 1) * delg

           do 56 j = 1,ny

c ---        Process ALL CALMET points (070123)
c            if (ilandu(i,j).lt.iwat1.or.ilandu(i,j).gt.iwat2) go to 56

             yy = ycal + (j - 1) * delg

             nearii = 0
             nearjj = 0
             dnearr = 9.9E19

             do 57 ii = 1,nxp
             do 58 jj = 1,nyp

c ---          only process ocean 3D.DAT points
               if (ilu4(ii,jj).ne.iluoc3d) go to 58

               pdist = sqrt ((xlcmm4(ii,jj) - xx) ** 2 +
     &                    (ylcmm4(ii,jj) - yy) **2)
               if (pdist .lt. dnearr) then
                  dnearr = pdist
                  nearjj = jj
                  nearii = ii
               endif

58           continue
57           continue

             igrabw(i,j) = nearii
             jgrabw(i,j) = nearjj

56         continue
55       continue
 
      endif



c-------------------------------------------------------------------
c --- Find the closest CALMET grid point to each MM5
c     grid point (060213)v (stored in MM4HDO.MET)
c ------------------------------------------------------------------
      do i = 1,nxp
      do j = 1,nyp
          nearii = 0
          nearjj = 0
          dnearg=9.9E19

          do ii = 1,nx 
          do jj = 1,ny 

             xx = xcal + (ii - 1) * delg
             yy = ycal + (jj - 1) * delg
   
            pdist = sqrt ((xlcmm4(i,j) - xx) ** 2 +
     &                    (ylcmm4(i,j) - yy) **2)

            if (pdist .lt. dnearg) then
                dnearg  = pdist
                nearii = ii
                nearjj = jj
             endif

          enddo
          enddo

          inearg(i,j) = nearii
          jnearg(i,j) = nearjj
      enddo
      enddo 
      
c -------------------------------------------------------

c frr (09/01) check if prognostic precip data are available
c NPSTA>0 : use observations (precip data)
c NPSTA=0 : no precipitation data (neither obs nor MM5)
c NPSTA=-1: use MM5 data
c 
c --- 050328: surface rainfall always available even if qr vertical
c --- profiles are not
c     if (npsta.lt.0 )then
c         if (ioutmm5.eq.81 .or. ioutmm5.eq.82 .or.
c     :       ioutmm5.eq.91 .or. ioutmm5.eq.92 )then
c              write(io6,*)'WARNING - Subroutine RDHD5 -'
c              write(io6,*)'MM5 precipitation data is not available'
c              write(io6,*)'NPSTA must be reset - NPSTA =',NPSTA
c              stop
c         endif
c      endif

c --- 040924 (frr) Compute the MM5 gridpoints locations (in m) relative
c --- the CALMET domain origin - Done here rather than at each timestep
c --- in subrtoutine interpqr (also use units of meters not km)
      np=0
      do 300 ip=1,nxp
      do 300 jp=1,nyp
         np=np+1
         x04(np)=(xlcmm4(ip,jp)-xmap0)*1000.
         y04(np)=(ylcmm4(ip,jp)-ymap0)*1000.
 300  continue


c
c --- frr (09/01)
c --- test if cloud data can be computed from MM5 record 
c --- Check that prognostic relative humidy is available 

      icloud3 = 0
      if ( (ioutmm5.ge.82 .and. ioutmm5.le.85 ) .or.
     :     (ioutmm5.ge.92 .and. ioutmm5.le.95 ) )   icloud3=1

ccec101006      if ( icloud.ge.3 .and. icloud3.eq.0 ) then
      if ( mcloud.ge.3 .and. icloud3.eq.0 ) then
        write(io6,*)'Cloud cover cannot be computed from MM5 data'
        write(io6,*)'No prognostic relative humidity available'
        write(io6,*)'MCLOUD  = ',mcloud
        write(io6,*)'ioutmm5 = ',ioutmm5
        stop
      endif
c 
      return
      end
c----------------------------------------------------------------------
      subroutine rdhd51(nfm3d)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 090615             RDHD51
c              F.Robe
c              Modified by J. Scire (1/99), Zhong Wu (11/00), F.Robe (04)
c
c --- PURPOSE: Read MM5.DAT header records in original format. 
c              Record 1 includes title, program (not dataset)
c              version and level
c              Note that year is not Y2K format(i2)
c
c --- UPDATES
c --- V6.223 (070702) to v6.328 (090615)
c      - Read header records on 2nd, 3rd, ... MM5.DAT files rather
c        than skipping these records.  This will allow header record
c        data such as ground elevations to change within a CALMET 
c        run (needed for 2005 RUC processing).
c      - Print out location and elevations of first/last MM5 gridpoints
c        in list file
c
c --- V5.547 (041010) to V6.223 (070702)(F.Robe)
c        - Read in the actual LU from MM5.DAT since it is available 
c          rather than inferring it from zero elevation
c
c --- V5.542(031126) to V5.547 (041010) (F.Robe)
c               - For multiple MM5.DAT files, skip headers
c                 (except for 1st file)
c               - Explicit common replaced by include d6.met              
c --- V5.541 (030515) to V5.542 (031126) (J. Scire)
c        - Revise comments to reflect MM5.DAT format
c        - Fix a write statement to refer to RDHD51
c        - Write MM5.DAT grid pts (X,Y,long,lat) to QA3D.DAT
c          filec --- V5.5 (030402) to V5.51 (030515)  (DGS)
c        - Add grid points to list file
c        - MM5 DATUM is DATUM3D in /MM4HDO/
c --- V5.4 (000602d) to V5.5 (030402)  (DGS)
c               - Add list-file unit to JULDAY, INCR, YR4 calls
c               - Add new COORDS (GLOBE1, GLOBE)
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c --- V5.0-V5.1     991104  (DGS): Allow either new or old header format
c
c --- INPUTS:
c                N -  INTEGER  - number of the current MM5 file .
c
c        Parameters:
c            MXNXP, MXNYP, MXNZP, IO6, IO20, MXNX, MXNY,IO4
c        Common block /MAP/:
c            IUTMZN, UTMHEM, XLAT1, XLAT2, RELON0, RNLAT0,
c            FEAST, FNORTH, DATUM
c        Common block /GRID/:
c            NX,NY,DGRID,XORIGR,YORIGR
c        Common block /MM4HDO/ variables:
c            DATUM3D, NM3D
c        Common block /FILNAM/ variables:
c            M3DDAT(MXM3D)
c
c --- OUTPUT:
c
c        Common block /MM4HDO/ variables:
c            IBYRM, IBJULM, IBHRM, IEYRM, IEJULM, IEHRM,
c            NXMM4, NYMM4, NZP, PTOPMM4, I1, J1, NXP, NYP,
c            SIGMA(mxnzp), XLAT4(mxnxp,mxnyp), XLONG4(mxnxp,mxnyp),
c            IELEV4(mxnxp,mxnyp),ILU4(mxnxp,mxnyp),XLCMM4(mxnxp,mxnyp),
c            YLCMM4(mxnxp,mxnyp),X04(mxnxp*mxnyp),Y04(mxnxp*mxnyp),
c            IGRAB(mxnx,mxny,4),JGRAB(mxnx,mxny,4),IOUTMM5,DATUM3D
c
c --- RDHD51 called by:  RDHD5 ,MM5
c --- RDHD51 calls:      JULDAY, INCR, YR4, GLOBE1, GLOBE
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      character*80 ctext
      character*12 cver5,clab5
c --- Increase line variable to 32 to include landuse
c      character*26 cline
      character*32 cline
      logical lprt
c
c --- Common blocks
      include 'map.met'
      include 'grid.met'
      include 'mm4hdo.met'
      include 'filnam.met'

      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,IRDP

c --- For coordinate transformations
      character*8 cmapi,cmapo
      character*12 caction
      character*4 c4hem
      real*8 vecti(9),vecto(9)
c
c --- Prognostic land use
      integer ilu4p(mxnxp,mxnyp)

      data lprt/.true./


c ------------------------------------------------------------------
c --- Close current MM5.DAT and open next MM5.DAT-
c --- Skip header (Assumption: all MM5.DAT files have similar size/params)
c ------------------------------------------------------------------    

      if(nfm3d.gt.1) then
         close(io20)
         open(io20,file=m3ddat(nfm3d),status='old')
c ---    V6.328 change - do NOT skip header records
         write(io6,8)nfm3d,m3ddat(nfm3d)
8        format(/1x,'Reading MM5.DAT file number: ',i3/1x,
     1    'File name: ',a132)
c ---    skip first 6 +nzp+ nxp*nyp headers
c ***    do k=1,6+nzp+nxp*nyp
c ***      read(io20,*)
c ***    end do
c ***    return
      endif


c --- Scale factor for Tangential TM projection
      tmsone=1.00000
c --- Set translation vectors going from N.lat/E.lon
c --- to projection(x,y)km
      iutmo=iutmzn
      if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
      cmapo=pmap
      if(cmapo.EQ.'TTM     ') cmapo='TM      '
      cmapi='LL      '
      idum=0
      rdum=0.0
      call GLOBE1(cmapi,idum,rdum,rdum,rdum,rdum,rdum,
     &            rdum,rdum,
     &            cmapo,iutmo,tmsone,xlat1,xlat2,rnlat0,relon0,
     &            feast,fnorth,
     &            caction,vecti,vecto)
c
c
c ------------------------------------------------------------------
c --- Read header record #1 (text date/time stamp for file creation)
c ------------------------------------------------------------------
      read(io20,10)ctext,cver5,clab5
10    format(a80,2a12)
c
c ------------------------------------------------
c --- Read header record #2 (CALMM5 output options)
c ------------------------------------------------
      read(io20,43)ioutw,ioutq,ioutc,iouti,ioutg 
      ioutmm5=81+10*ioutw+ioutq+ioutc+iouti+ioutg
43    format(5(i3))
c ----------------------------------------------
c --- Skip header record #3 (MM5 Map projection)
c ----------------------------------------------
      read(io20,*)
c ------------------------------------------------
c --- Read header record #4 (CALMM5 output options)
c ------------------------------------------------
      read(io20,44) inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     :               ifddaan,ifddaob
44    format(8(i3))
c --------------------------------------------
c --- Read header record #5 (CALMM5 grid data)
c --------------------------------------------
      read(io20,20)ibyrm,ibmom,ibdym,ibhrm,nhrsmm5,
     1             nxp,nyp,nzp
 20   format(4i2,i5,3i4)
      call YR4(io6,ibyrm,ierrb)
      if(ierrb.NE.0) stop 'Halted in RDHD51'
c
c --- Calculate Julian day
      call julday(io6,ibyrm,ibmom,ibdym,ibjulm)

c
c --- Compute ending date/time (comment out if using other format)
      ieyrm=ibyrm
      iejulm=ibjulm
      iehrm=ibhrm
      call incr(io6,ieyrm,iejulm,iehrm,nhrsmm5)
c
c -----------------------------------------------------
c --- Read header record #6 (extraction subdomain data)
c -----------------------------------------------------
      read(io20,30)nx1,ny1,nx2,ny2,rxmin,rxmax,rymin,rymax
      i1=nx1
      j1=ny1
30    format(4i4,4(f8.2))
c
c --- Check that array dimensions are not exceeded
      if(nxp.gt.mxnxp.or.nyp.gt.mxnyp.or.nzp.gt.mxnzp)then
         write(io6,*)'ERROR in subr. RDHD51 -- Array dimensions ',
     1   'are too small for data being read'
         write(io6,*)'Grid being read  (NXP, NYP, NZP) = ',
     1    nxp,nyp,nzp
         write(io6,*)'Array dimensions (MXNXP, MXNYP, MXNZP) = ',
     1    mxnxp,mxnyp,mxnzp
         stop
      endif
c
c ---------------------------------------------
c --- Next NZP records -- MM5 half-sigma levels
c ---------------------------------------------
      do 40 n=1,nzp
         read(io20,38)sigma(n)
38       format(f6.3)
40    continue
c
c -----------------------------------------------------
c --- Print the MM5 header information to the list file
c --- (except for the gridded fields)
c -----------------------------------------------------
      if(lprt)then
         write(io6,101)ctext,cver5,clab5
101      format(//1x,'Information read from MM5.DAT data file'/
     1   5x,'Dataset Title (CTEXT): ',a80/
     2   5x,'Program Version:       ',a12/
     3   5x,'Program Label:         ',a12)
c
         write(io6,102) inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     :               ifddaan,ifddaob
102      format(/5x,'MM5 physics options: '/
     1           5x,'    Hydrostatic:           ',i2/
     1           5x,'    Moisture scheme:       ',i2/
     1           5x,'    Convection scheme:     ',i2/
     1           5x,'    Boundary layer scheme: ',i2/
     1           5x,'    Radiation scheme       ',i2/
     1           5x,'    Soil scheme:           ',i2/
     1           5x,'    Analysis FDDA:         ',i2/
     1           5x,'    Observation FDDA:      ',i2)
c
         write(io6,103)1,ioutw,ioutq,ioutc,iouti,ioutg
103      format(/5x,'CALMM5 output fields (1 = YES; 0 = NO): '/
     1           5x,' Pressure, height,T,Wind speed and direction: ',i2/
     1           5x,'                           Vertical velocity: ',i2/
     1           5x,'                   RH and vapor mixing ratio: ',i2/
     1           5x,'                Cloud and rain mixing ratios: ',i2/
     1           5x,'                  Ice and Snow mixing ratios: ',i2/
     1           5x,'                                     Graupel: ',i2)

c
         write(io6,104)ibyrm,ibmom,ibdym,ibhrm,nhrsmm5,
     1                 nxp,nyp,nzp
104      format(/5x,'Date/time (YYYYMMDDHH) of MM5 data: '/
     1           5x,'                  Start = ',i4,3i2,' (GMT)'/
     2           5x,'              No. hours = ',i4,/
     3           5x,'Extraction Subdomain in MM5 file: '/
     4           5x,'            No. X cells = ',i4/
     5           5x,'            No. Y cells = ',i4/
     6           5x,'            No. layers  = ',i4 )
c
         write(io6,106)nx1,ny1,nx2,ny2
106      format(/5x,'            Beginning X = ',i4/
     2           5x,'            Beginning Y = ',i4/
     3           5x,'               Ending X = ',i4/
     4           5x,'               Ending Y = ',i4)
c
         write(io6,107)rymin,rymax,rxmin,rxmax
107      format(/5x,' Latitude range : ',f7.2,'  -  ',f7.2/
     :           5x,' Longitude range: ',f8.2, ' - ' ,f8.2)

         write(io6,108)
108      format(/5x,'MM5 half-sigma levels'/5x,'Level',5x,'Sigma'/)
         do 110 i=1,nzp
            write(io6,109)i,sigma(i)
110      continue
109      format(4x,i4,6x,f6.4)
      endif
c
c ----------------------------------------------------
c --- Next NXP * NYP records -- lat., long., elevation, land use
c ----------------------------------------------------
      do 50 j=1,nyp
      do 50 i=1,nxp
        read(io20,'(a32)') cline
        if(cline(13:13).EQ.' ') then
c ---      Early MM5.DAT format for these records
           read(cline,47)iindex,jindex,xlat4(i,j),xlong4(i,j),
     &                   ielev4(i,j), ilu4p(i,j)
        else
c ---      Revised MM5.DAT format for these records
           read(cline,48)iindex,jindex,xlat4(i,j),xlong4(i,j),
     &                   ielev4(i,j), ilu4p(i,j)
        endif
47      format(2i3,f6.2,f8.2,i5,i3)
48      format(2i3,f7.3,f8.3,i5,i3)

          
c ---   Fill in ILU4 array stored in MM4HDO.MET 
        ilu4(i,j)=ilu4p(i,j)

c ---   Compute grid point locations from N.Lat and E.Lon
        call GLOBE(io6,caction,datum3d,vecti,datum,vecto,
     &             xlong4(i,j),xlat4(i,j),xlcmm4(i,j),ylcmm4(i,j),
     &             idum,c4hem)
c
c ---   QA check that I,J read match expected values
c
        icheck=iindex-i1+1
        jcheck=jindex-j1+1
        if(icheck.ne.i.or.jcheck.ne.j)then
          write(io6,*)'ERROR in subr. RDHD5 -- I,J do not match ',
     1      'values read on header record'
          write(io6,*)'I, J = ',i,j
          write(io6,*)'ICHECK, JCHECK = ',icheck,jcheck
          stop
        endif
50    continue

c ---------------------------------------------
c --- Print the MM5 grid points to the QA file
c ---------------------------------------------
      if(lprt)then
         open(io4,file='QA3D.DAT',status='unknown')
c        
         write(io4,*)'            MM5.DAT Grid Points'
         write(io4,*)'     X           Y        Longitude    Latitude'
         write(io4,*)'   (km)        (km)        (deg E)     (deg N)'
         do j=1,nyp
         do i=1,nxp
            write(io4,'(4f12.3)') xlcmm4(i,j),ylcmm4(i,j),
     1                            xlong4(i,j),xlat4(i,j)
         enddo
         enddo
c
         close(io4)
      endif
c
c --------------------------------------------------------
c --- Print first and last lat/lon values to the list file (090615)
c --------------------------------------------------------
      if(lprt)then
         write(io6,121)xlat4(1,1),xlong4(1,1),ielev4(1,1),
     &                 xlat4(nxp,nyp),xlong4(nxp,nyp),ielev4(nxp,nyp)
121      format(/5x,' Lat./Lon./Elev. of First Cell: ',f9.4,f10.4,i6/
     :           5x,' Lat./Lon./Elev. of Last  Cell: ',f9.4,f10.4,i6)
      endif
c

      return
      end

c----------------------------------------------------------------------
      subroutine rdhd52(nfm3d)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070702             RDHD52
c              Zhong-Xiang Wu
c
c --- PURPOSE: Read a 3D.DAT file in old format (prior to Version 2.0).
c              Record 1 is title, Record 2 includes data set name, 
c              program (not dataset) version and level numbers.
c              Note that year is Y2K format (i4).
c
c --- UPDATES:
c --- V6.223 (070702) to v6.328 (090615)
c      - Read header records on 2nd, 3rd, ... MM5.DAT files rather
c        than skipping these records.  This will allow header record
c        data such as ground elevations to change within a CALMET 
c        run (needed for 2005 RUC processing).
c      - Print out location and elevations of first/last MM5 gridpoints
c        in list file
c
c --- V6.206 (060322) to V5.731 (070702) (F. Robe)
c        - Read in the actual LU from MM5.DAT since it is available 
c          rather than inferring it from zero elevation
c
c --- V5.6 (041010) to V6.206 (060322)(F.Robe)
c               - Assign ocean LU to zero elevation gridpoints (no land use
c                 is read from MM5 records in this format so substitute)
c
c --- V5.542 (031126) to V5.6 (041010) (F.Robe)
c               - For multiple MM5.DAT files, skip headers
c                 (except for 1st file)
c               - Explicit common replaced by include d6.met 
c --- V5.541 (030515) to V5.542 (031126) (J. Scire)
c               - Revise comments to reflect 3D.DAT format (prior
c                 to dataset Version 2.0)
c               - Fix a write statement to refer to RDHD52
c               - Write 3D.DAT grid pts (X,Y,long,lat) to QA3D.DAT
c                 file
c --- V5.5 (030402) to V5.51 (030515)  (DGS)
c               - Add grid points to list file
c               - MM4 DATUM is DATUM3D in /MM4HDO/
c --- V5.4 (000602d) to V5.5 (030402)  (DGS)
c               - Add list-file unit to JULDAY, INCR, YR4 calls
c               - Add new COORDS (GLOBE1, GLOBE)
c
c --- INPUTS:
c
c                nfm3d -  INTEGER  - number of the current MM5 file 
c
c        Parameters:
c            MXNXP, MXNYP, MXNZP, IO6, IO20, MXNX, MXNY,IO4
c        Common block /MAP/:
c            IUTMZN, UTMHEM, XLAT1, XLAT2, RELON0, RNLAT0,
c            FEAST, FNORTH, DATUM
c        Common block /GRID/:
c            NX,NY,DGRID,XORIGR,YORIGR
c        Common block /MM4HDO/ variables:
c            DATUM3D
c        Common block /FILNAM/ variables:
c            m3ddat(mxm3d)
c
c --- OUTPUT:
c
c        Common block /MM4HDO/ variables:
c            IBYRM, IBJULM, IBHRM, IEYRM, IEJULM, IEHRM,
c            NXMM4, NYMM4, NZP, PTOPMM4, I1, J1, NXP, NYP,
c            SIGMA(mxnzp), XLAT4(mxnxp,mxnyp), XLONG4(mxnxp,mxnyp),
c            IELEV4(mxnxp,mxnyp),ILU4(mxnxp,mxnyp),XLCMM4(mxnxp,mxnyp),
c            YLCMM4(mxnxp,mxnyp),IGRAB(mxnx,mxny,4),JGRAB(mxnx,mxny,4),
c            IOUTMM5,DATUM3D
c
c --- RDHD52 called by:  RDHD5 , MM5
c --- RDHD52 calls:      JULDAY, INCR, YR4, GLOBE1, GLOBE
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      character*80 ctext
      character*12 cver5,clab5,cset3d
      logical lprt
c
c --- Common blocks
      include 'map.met'
      include 'grid.met'
      include 'mm4hdo.met'
      include 'filnam.met'

      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,IRDP

c --- For coordinate transformations
      character*8 cmapi,cmapo
      character*12 caction
      character*4 c4hem
      real*8 vecti(9),vecto(9)
c
c --- Prognostic land use
      integer ilu4p(mxnxp,mxnyp)

      data lprt/.true./

c ------------------------------------------------------------------
c --- Close current MM5.DAT and open next MM5.DAT-
c --- Skip header (Assumption: all MM5.DAT files have similar size/params)
c ------------------------------------------------------------------    
      if(nfm3d.gt.1) then
         close(io20)
         open(io20,file=m3ddat(nfm3d),status='old')
c ---    V6.328 change  - do NOT skip header records
c
         write(io6,8)nfm3d,m3ddat(nfm3d)
8        format(/1x,'Reading 3D.DAT file number: ',i3/1x,
     1    'File name: ',a132)
c ---    skip first 7 +nzp+ nxp*nyp headers
c ***    do k=1,7+nzp+nxp*nyp
c ***       read(io20,*)
c ***    end do
c ***    return
      endif


c --- Scale factor for Tangential TM projection
      tmsone=1.00000
c --- Set translation vectors going from N.lat/E.lon
c --- to projection(x,y)km
      iutmo=iutmzn
      if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
      cmapo=pmap
      if(cmapo.EQ.'TTM     ') cmapo='TM      '
      cmapi='LL      '
      idum=0
      rdum=0.0
      call GLOBE1(cmapi,idum,rdum,rdum,rdum,rdum,rdum,
     &            rdum,rdum,
     &            cmapo,iutmo,tmsone,xlat1,xlat2,rnlat0,relon0,
     &            feast,fnorth,
     &            caction,vecti,vecto)
c
c ------------------------------------------------------------------
c --- Read header record #1 (title)
c ------------------------------------------------------------------
      read(io20,10)ctext
10    format(a80)

c ------------------------------------------------------------------
c --- Read header record #2 (Data set nema, version and level)
c ------------------------------------------------------------------
      read(io20,11)cset3d,cver5,clab5
11    format(3a12)
c
c ------------------------------------------------
c --- Read header record #3 (CALMM5 output options)
c ------------------------------------------------
      read(io20,43)ioutw,ioutq,ioutc,iouti,ioutg 
      ioutmm5=81+10*ioutw+ioutq+ioutc+iouti+ioutg
43    format(5(i3))

c ------------------------------------------------
c --- Skip header record #4 (MM5 Map projection)
c ------------------------------------------------
      read(io20,*)

c ------------------------------------------------
c --- Read header record #5 (CALMM5 output options)
c     (Add 13 output options for surface variables)
c ------------------------------------------------
      read(io20,44) inhyd,imphys,icupa,ibltyp,ifrad,isoil
     :         ,ifddaan,ifddaob
     :         ,igrdt,ipbl,ishf,ilhf,iustr,iswdn
     :         ,ilwdn,ist1,ist2,ist3,ist4,ist5,ist6
44    format(30(i3))
c --------------------------------------------
c --- Read header record #6 (CALMM5 grid data)
c --------------------------------------------
      read(io20,20)ibyrm,ibmom,ibdym,ibhrm,nhrsmm5,
     1             nxp,nyp,nzp
 20   format(i4,3i2,i5,3i4)
      call YR4(io6,ibyrm,ierrb)
      if(ierrb.NE.0) stop 'Halted in RDHD52'
c
c --- Calculate Julian day
      call julday(io6,ibyrm,ibmom,ibdym,ibjulm)
c
c --- Compute ending date/time (comment out if using other format)
      ieyrm=ibyrm
      iejulm=ibjulm
      iehrm=ibhrm
      call incr(io6,ieyrm,iejulm,iehrm,nhrsmm5)
c
c -----------------------------------------------------
c --- Read header record #7 (extraction subdomain data)
c -----------------------------------------------------
      read(io20,30)nx1,ny1,nx2,ny2,nz1,nz2,
     &             rxmin,rxmax,rymin,rymax
      i1=nx1
      j1=ny1
30    format(6i4,2f10.4,2f9.4)
c

c --- Check that array dimensions are not exceeded
      if(nxp.gt.mxnxp.or.nyp.gt.mxnyp.or.nzp.gt.mxnzp)then
         write(io6,*)'ERROR in subr. RDHD52 -- Array dimensions ',
     1   'are too small for data being read'
         write(io6,*)'Grid being read  (NXP, NYP, NZP) = ',
     1    nxp,nyp,nzp
         write(io6,*)'Array dimensions (MXNXP, MXNYP, MXNZP) = ',
     1    mxnxp,mxnyp,mxnzp
         stop
      endif
c --- Check consistency between nz1,nz2, and nzp
      if(nzp.ne.nz2-nz1+1) then
        write(io6,*)'Error in RDHD52: NZ1,NZ2 and NZP not consistent'
        write(io6,*)'nz1,nz2,nzp:',nz1,nz2,nzp
        stop
      endif
c
c ----------------------------------------
c --- Next NZP records -- MM5 half-sigma levels
c ----------------------------------------
      do 40 n=1,nzp
         read(io20,38)sigma(n)
38       format(f6.3)
40    continue
c
c -----------------------------------------------------
c --- Print the MM5 header information to the list file
c --- (except for the gridded fields)
c -----------------------------------------------------
      if(lprt)then
         write(io6,101)ctext,cset3d,cver5,clab5
101      format(//1x,'Information read from 3D.DAT file'/
     1   5x,'Dataset Title (CTEXT): ',a80/ 
     2   5x,'Dataset Name:          ',a12/
     3   5x,'Program Version:       ',a12/
     4   5x,'Program Level:         ',a12)
c
         write(io6,102) inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     :               ifddaan,ifddaob
102      format(/5x,'MM5 physics options: '/
     1           5x,'    Hydrostatic:           ',i2/
     1           5x,'    Moisture scheme:       ',i2/
     1           5x,'    Convection scheme:     ',i2/
     1           5x,'    Boundary layer scheme: ',i2/
     1           5x,'    Radiation scheme       ',i2/
     1           5x,'    Soil scheme:           ',i2/
     1           5x,'    Analysis FDDA:         ',i2/
     1           5x,'    Observation FDDA:      ',i2)


         write(io6,1021)igrdt,ipbl,ishf,ilhf,iustr,iswdn
     :         ,ilwdn,ist1,ist2,ist3,ist4,ist5,ist6
1021      format(/5x,'MM5 surface variable options: '/
     1           5x,'    Ground temperature:    ',i2/
     1           5x,'    PBL:                   ',i2/
     1           5x,'    Sensible heat flux:    ',i2/
     1           5x,'    Latent heat flux:      ',i2/
     1           5x,'    Frictional velocity:   ',i2/
     1           5x,'    Downward SW radiation: ',i2/
     1           5x,'    Downward LW radiation: ',i2/
     1           5x,'    Soil temp at layer 1:  ',i2/
     1           5x,'    Soil temp at layer 2:  ',i2/
     1           5x,'    Soil temp at layer 3:  ',i2/
     1           5x,'    Soil temp at layer 4:  ',i2/
     1           5x,'    Soil temp at layer 5:  ',i2/
     1           5x,'    Soil temp at layer 6:  ',i2)

         write(io6,103)1,ioutw,ioutq,ioutc,iouti,ioutg
103      format(/5x,'CALMM5 output fields (1 = YES; 0 = NO): '/
     1           5x,' Pressure, height,T,Wind speed and direction: ',i2/
     1           5x,'                           Vertical velocity: ',i2/
     1           5x,'                   RH and vapor mixing ratio: ',i2/
     1           5x,'                Cloud and rain mixing ratios: ',i2/
     1           5x,'                  Ice and Snow mixing ratios: ',i2/
     1           5x,'                                     Graupel: ',i2)

         write(io6,104)ibyrm,ibmom,ibdym,ibhrm,nhrsmm5,
     1                 nxp,nyp,nzp
104      format(/5x,'Date/time (YYYYMMDDHH) of MM5 data: '/
     1           5x,'                  Start = ',i4,3i2,' (GMT)'/
     2           5x,'              No. hours = ',i4,/
     3           5x,'Extraction Subdomain in MM5 file: '/
     4           5x,'            No. X cells = ',i4/
     5           5x,'            No. Y cells = ',i4/
     6           5x,'            No. layers  = ',i4 )
c
         write(io6,106)nx1,ny1,nz1,nx2,ny2,nz2
106      format(/5x,'            Beginning X = ',i4/
     2           5x,'            Beginning Y = ',i4/
     3           5x,'            Beginning Z = ',i4/
     4           5x,'               Ending X = ',i4/
     5           5x,'               Ending Y = ',i4/
     6           5x,'               Ending Z = ',i4)
c
         write(io6,107)rymin,rymax,rxmin,rxmax
107      format(/5x,' Latitude range : ',f9.4,'  -  ',f9.4/
     :           5x,' Longitude range: ',f10.4, ' - ' ,f10.4)

         write(io6,108)
108      format(/5x,'MM5 half-sigma levels'/5x,'Level',5x,'Sigma'/)
         do 110 i=1,nzp
            write(io6,109)i,sigma(i)
110      continue
109      format(4x,i4,6x,f6.4)
      endif
c
c ----------------------------------------------------
c --- Next NXP * NYP records -- lat., long., elevation
c ----------------------------------------------------
      do 50 j=1,nyp
      do 50 i=1,nxp
c ---    read lu as available (070702)
         read(io20,99)iindex,jindex,xlat4(i,j),xlong4(i,j),
     &                ielev4(i,j),ilu4p(i,j)
 99      format(2i4,f9.4,f10.4,i5,i3)
c ---   LU is actually available in records
c ---   assign ocean LU to zero elevation points (060322)
c        if (ielev4(i,j).eq.0) then
c           ilu4(i,j)=iluoc3d
c        else
c ---       make sure that not all points are flagged as ocean
c ---       if by chance user input iluoc3d=0
c            ilu4(i,j)=iluoc3d+1
c        endif
c ---   Fill in ILU4 array stored in MM4HDO.MET 
        ilu4(i,j)=ilu4p(i,j)

c ---   Compute grid point locations from N.Lat and E.Lon
        call GLOBE(io6,caction,datum3d,vecti,datum,vecto,
     &             xlong4(i,j),xlat4(i,j),xlcmm4(i,j),ylcmm4(i,j),
     &             idum,c4hem)
c
c ---   QA check that I,J read match expected values
c
        icheck=iindex-i1+1
        jcheck=jindex-j1+1
        if(icheck.ne.i.or.jcheck.ne.j)then
          write(io6,*)'ERROR in subr. RDHD52 -- I,J do not match ',
     1      'values read on header record'
          write(io6,*)'I, J = ',i,j
          write(io6,*)'ICHECK, JCHECK = ',icheck,jcheck
          stop
        endif
50    continue

c ---------------------------------------------
c --- Print the MM5 grid points to the QA file
c ---------------------------------------------
      if(lprt)then
         open(io4,file='QA3D.DAT',status='unknown')
c        
         write(io4,*)'             3D.DAT Grid Points'
         write(io4,*)'     X           Y        Longitude    Latitude'
         write(io4,*)'   (km)        (km)        (deg E)     (deg N)'
         do j=1,nyp
         do i=1,nxp
            write(io4,'(4f12.3)') xlcmm4(i,j),ylcmm4(i,j),
     1                            xlong4(i,j),xlat4(i,j)
         enddo
         enddo
c
         close(io4)
      endif
c
c
c --------------------------------------------------------
c --- Print first and last lat/lon values to the list file (090615)
c --------------------------------------------------------
      if(lprt)then
         write(io6,121)xlat4(1,1),xlong4(1,1),ielev4(1,1),
     &                 xlat4(nxp,nyp),xlong4(nxp,nyp),ielev4(nxp,nyp)
121      format(/5x,' Lat./Lon./Elev. of First Cell: ',f9.4,f10.4,i6/
     :           5x,' Lat./Lon./Elev. of Last  Cell: ',f9.4,f10.4,i6)
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine rdhd53(nfm3d,itwprog,npsta)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203             RDHD53
c              J. Scire, Earth Tech
c              Adapted from RDHD52
c
c --- PURPOSE: Read the header records from a file in 3D.DAT format 
c              (dataset Version 2.x or 3.x)
c
c --- UPDATES:
c
c --- v6.328 (090615) to v6.4.0 (121203)
c      - Add checks for recognized dataset versions
c        2.0, 2.1, 2.11, 2.12, 2.13
c        3.0, 3.1
c      - Halt with error message if 3D.DAT is generated by processor
c        version with known errors.
c
c --- v6.327 (090511) to v6.328 (090615)
c      - Read header records on 2nd, 3rd, ... MM5.DAT files rather
c        than skipping these records.  This will allow header record
c        data such as ground elevations to change within a CALMET 
c        run (needed for 2005 RUC processing).
c      - Print out location and elevations of first/last MM5 gridpoints
c        in list file
c --- v6.32 (080205) to v6.327 (090511)(F.Robe)
c      - Initialize MM5 seconds
c
c --- V6.206 (060322)to v6.32 (080205)(F.Robe)
c      - Read in 3D.DAT version 3.x with explicit beg/end times with 
c        seconds (the header is the same as Version 2.x otherwise)
c      - Check availability of precipitation and SST data if user
c        wants to use them (could be blank if not available or not good
c        in original prognostic datasets e.g. for RUC data)        
c      - Add npsta to calling list
c
c --- V5.611 (051113) to V6.206 (060322)(F.Robe)
c      - fill in values for ILU4 for all values of ITWPROG
c
c --- V5.6 (041010) to V5.611 (051113) (F.Robe)
c      - Read in 3D.DAT land use type and store in ILU4 array
c        (in MM4HD0.MET) with minus sign for ocean gridpoints
c        not surrounded by other ocean gridpoints
c      - Change read format 11 to free read
c 
c --- V5.542 (031126) to V5.6 (041010) (F.Robe)
c      - For multiple MM5.DAT files, skip headers (except for 1st file)
c      - Explicit common replaced by include d6.met 
c
c --- INPUTS:
c
c         NFM3D   Integer   - number of the current 3D.DAT file 
c
c       ITWPROG   Integer   - Offshore temperature option
c                             0 : deltaT and OW lapse rates from SEA.DAT   
c                             1 : deltaT from SEA.DAT and OW lapse rates from
c                                 3D.DAT  
c                             2 : prognostic deltaT and lapse rates(from 3D.DAT)
c         NPSTA   integer     Precipitation flag
c                             -1: use prognostic precipitation fields
c                              0: no precipitation
c                            n>0: number of precipitation stations
c
c        Parameters:
c            MXNXP, MXNYP, MXNZP, IO6, IO20, MXNX, MXNY
c        Common block /MAP/:
c            IUTMZN, UTMHEM, XLAT1, XLAT2, RELON0, RNLAT0,
c            FEAST, FNORTH, DATUM
c        Common block /GRID/:
c            NX,NY,DGRID,XORIGR,YORIGR
c        Common block /MM4HDO/ variables:
c            DATUM3D
c        Common block /FILNAM/ variables:
c            m3ddat(mxm3d)
c
c --- OUTPUT:
c
c        Common block /MM4HDO/ variables:
c            IBYRM, IBJULM, IBHRM, IEYRM, IEJULM, IEHRM,
c            NXMM4, NYMM4, NZP, PTOPMM4, I1, J1, NXP, NYP,
c            SIGMA(mxnzp), XLAT4(mxnxp,mxnyp), XLONG4(mxnxp,mxnyp),
c            IELEV4(mxnxp,mxnyp),ILU4(mxnxp,mxnyp),XLCMM4(mxnxp,mxnyp),
c            YLCMM4(mxnxp,mxnyp),IGRAB(mxnx,mxny,4),JGRAB(mxnx,mxny,4),
c            IOUTMM5,NCOMM3D, CNAME3D, CVER3D, CTITLE3D, COMM3D, 
c            DATUM3D
c
c --- RDHD53 called by:  RDHD5
c --- RDHD53 calls:      JULDAY, INCR, YR4, GLOBE1, GLOBE
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      character*128 ctemp3d
      character*5 crain
      character*8 csst
      logical lprt
c
c --- Common blocks
      include 'map.met'
      include 'grid.met'
      include 'mm4hdo.met'
      include 'filnam.met'

      COMMON /D6/ IRD,IWR,IFILE,IRDP

c --- For coordinate transformations
      character*8 cmapi,cmapo
      character*12 caction
      character*4 c4hem
      real*8 vecti(9),vecto(9)
c
c --- Prognostic land use
      integer ilu4p(mxnxp,mxnyp)

      data lprt/.true./

c --- Initialize seconds (090511)
      nscmm5=0

c --- check that precipitation and/or SST are available (if required)(080205)
      if(npsta.eq.-1.or.itwprog.eq.2) then
         if(nfm3d.gt.1) then
c ---       close previous file and open new one
            close(io20)
            open(io20,file=m3ddat(nfm3d),status='old')
         endif

c ---    skip first 2+ncomm3d+3+nzp+nxp*nyp headers
         read(io20,*)
         read(io20,*)ncomm3d
         do k=1,ncomm3d+3
            read(io20,*)
         end do
c ---    Read in nxp,nyp,nzp
c ---    Versions 2.x: hours only - Version 3.x: with seconds (080205)
         if (imm53d.eq.2) then
            read(io20,20)ibyrm,ibmom,ibdym,ibhrm,nhrsmm5,
     1             nxp,nyp,nzp
         else if (imm53d.eq.3) then
            read(io20,21)ibyrm,ibmom,ibdym,ibhrm,ibsecm,nhrsmm5,
     1             nscmm5,nxp,nyp,nzp
         endif 
c ---    skip remaining headers
         do k=1,1+nzp+nxp*nyp
            read(io20,*)
         end do
c ---    Check first record to see if precipitation field is blank
         if (imm53d.eq.2) then
c ---       (3D.DAT version 2.x)
            read(io20,62) myr,mmo,mday,mhr,ix,jx,
     &         pmsl,crain,isnow,rads,radl,t2,qq2,wd10,ws10,csst
62          format(i4,3i2,2i3,f7.1,a5,i2,3f8.1,f8.2,2f8.1,a8)
         else if (imm53d.eq.3) then
c ---       (3D.DAT version 3.x and above(080205)
            read(io20,63) myrb,mmob,mdayb,mhrb,msecb,
     &                    myr,mmo,mday,mhr,msec,ix,jx,
     &        pmsl,crain,isnow,rads,radl,t2,qq2,wd10,ws10,csst
63     format(i4,3i2,i4,i5,3i2,i4,i4,i3,f7.1,a5,i2,3f8.1,f8.2,2f8.1,a8)
         endif


         if(crain(1:5).eq.'       ' .and.npsta.eq.-1) then
c ---       precip fields left blank: warn user and stop
            write(6,*)' STOP in RDHD53 - Check list file'
            write(6,*)' No prognostic precipitation data'
            write(io6,*)'STOP in RDHD53'
            write(io6,*)'No prognostic precipitation data'
            write(io6,*)'Use NPSTA>=0'
            stop 
         else if (csst(1:8).eq.'        '.and.itwprog.eq.2) then
c ---       SSTs fields left blank: warn user and stop
            write(6,*)' STOP in RDHD53 - Check list file'
            write(6,*)' No prognostic SST data'
            write(io6,*)'STOP in RDHD53'
            write(io6,*)'No prognostic SST data'
            write(io6,*)'Select ITWPROG < 2'
            stop 
         else
c ---       Precipitation and SST available if needed - Proceed
c ---       rewind and proceed if first file 
c ---       for next files, close and rewind below
            if(nfm3d.eq.1) then
               close(io20)
               open(io20,file=m3ddat(nfm3d),status='old')
            endif
         endif
      endif     

c --- 041010 - Multiple 3D.DAT files  (Frr)-
c ------------------------------------------------------------------------
c --- Close current 3D.DAT and open next 3D.DAT-
c --- v6.328 change - do NOT skip header records
c ------------------------------------------------------------------------   
      if(nfm3d.gt.1) then
         close(io20)
         open(io20,file=m3ddat(nfm3d),status='old')
         write(io6,8)nfm3d,m3ddat(nfm3d)
8        format(/1x,'Reading 3D.DAT file number: ',i3/1x,
     1    'File name: ',a132)
c ---    skip first 2+ncomm3d+5+nzp+ nxp*nyp headers
c ***    read(io20,*)
c         read(io20,11)ncomm3d
c ***    read(io20,*)ncomm3d
c ***    do k=1,ncomm3d+5+nzp+nxp*nyp
c ***       read(io20,*)
c ***    end do
c ***    return
      endif

c --- Scale factor for Tangential TM projection
      tmsone=1.00000
c --- Set translation vectors going from N.lat/E.lon
c --- to projection(x,y)km
      iutmo=iutmzn
      if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
      cmapo=pmap
      if(cmapo.EQ.'TTM     ') cmapo='TM      '
      cmapi='LL      '
      idum=0
      rdum=0.0
      call GLOBE1(cmapi,idum,rdum,rdum,rdum,rdum,rdum,
     &            rdum,rdum,
     &            cmapo,iutmo,tmsone,xlat1,xlat2,rnlat0,relon0,
     &            feast,fnorth,
     &            caction,vecti,vecto)
c
c ------------------------------------------------------------------
c --- Read header record #1 (Dataset name, version and title
c ------------------------------------------------------------------
      read(io20,10)cname3d,cver3d,ctitle3d
10    format(2a16,a64)

c --- v6.4.0, Level 121203
c --- Check for known dataset versions
c --- This will require code update for new 3D.DAT datasets
      igood3d=0
      if(cver3d.EQ.'2.0') then
         igood3d=1
      elseif(cver3d.EQ.'2.1') then
         igood3d=1
      elseif(cver3d.EQ.'2.11') then
         igood3d=1
      elseif(cver3d.EQ.'2.12') then
         igood3d=1
      elseif(cver3d.EQ.'2.13') then
         igood3d=1
      elseif(cver3d.EQ.'3.0') then
         igood3d=1
      elseif(cver3d.EQ.'3.1') then
         igood3d=1
      endif
      if(igood3d.EQ.0) then
         write(io6,*)
         write(io6,*)'ERROR in subr. RDHD53 -- dataset version'
         write(io6,*)'Expected 2.0, 2.1, 2.11, 2.12, 2.13, '//
     &               'or 3.0, 3.1'
         write(io6,*)'Found 3D.DAT Dataset Version ',cver3d
         stop 'Halted in RDHD53 -- See list file'
      endif

c ------------------------------------------------------------------
c --- Read header record #2 (Number of comment lines)
c ------------------------------------------------------------------
c      read(io20,11)ncomm3d
      read(io20,*)ncomm3d
c11    format(i4)

c ------------------------------------------------------------------
c --- Next "NCOMM3d" lines (comment lines)
c ------------------------------------------------------------------
      if(ncomm3d.gt.0)then
         do i=1,ncomm3d
            read(io20,12)ctemp3d
12          format(a132)
c ---       Save first line of text for later printing
            if(i.eq.1)comm3d=ctemp3d
         enddo
      endif

c -------------------------------------------
c --- Next header record (MM5 output options)
c -------------------------------------------
      read(io20,43)ioutw,ioutq,ioutc,iouti,ioutg 
      ioutmm5=81+10*ioutw+ioutq+ioutc+iouti+ioutg
43    format(5(i3))

c --------------------------------------------
c --- Skip next header record (map projection)
c --------------------------------------------
      read(io20,*)

c ------------------------------------------------
c --- Next header record (MM5 output options)
c     (Add 13 output options for surface variables)
c ------------------------------------------------
      read(io20,44) inhyd,imphys,icupa,ibltyp,ifrad,isoil
     :         ,ifddaan,ifddaob
     :         ,igrdt,ipbl,ishf,ilhf,iustr,iswdn
     :         ,ilwdn,ist1,ist2,ist3,ist4,ist5,ist6
44    format(30(i3))
c --------------------------------------
c --- Next header record (MM5 grid data)
c --------------------------------------
c --- Versions 2.x: hours only - Version 3.x: with seconds (080205)
      if (imm53d.eq.2) then
         read(io20,20)ibyrm,ibmom,ibdym,ibhrm,nhrsmm5,
     1             nxp,nyp,nzp
 20      format(i4,3i2,i5,3i4)
      else if (imm53d.eq.3) then
         read(io20,21)ibyrm,ibmom,ibdym,ibhrm,ibsecm,nhrsmm5,
     1             nscmm5,nxp,nyp,nzp
 21      format(i4,3i2,i4,i5,i5,3i4)
      endif 
      call YR4(io6,ibyrm,ierrb)
      if(ierrb.NE.0)then
         write(io6,*)'Error encountered in Subr. YR4 '
         write(io6,*)'Execution stopping in Subr. RDHD53 ',
     1   '-- IERRB = ',ierrb
         stop
      endif
c
c --- Calculate Julian day
      call julday(io6,ibyrm,ibmom,ibdym,ibjulm)
c
c --- Compute ending date/time (comment out if using other format)
      ieyrm=ibyrm
      iejulm=ibjulm
      iehrm=ibhrm
c     Use seconds (080205)
c     call incr(io6,ieyrm,iejulm,iehrm,nhrsmm5)
      nsecmm5=nscmm5+nhrsmm5*3600
      call incrs(io6,ieyrm,iejulm,iehrm,iesecm,nsecmm5)
c
c --------------------------------------------------
c --- Next header record (extraction subdomain data)
c --------------------------------------------------
      read(io20,30)nx1,ny1,nx2,ny2,nz1,nz2,
     &             rxmin,rxmax,rymin,rymax
      i1=nx1
      j1=ny1
30    format(6i4,2f10.4,2f9.4)
c

c --- Check that array dimensions are not exceeded
      if(nxp.gt.mxnxp.or.nyp.gt.mxnyp.or.nzp.gt.mxnzp)then
         write(io6,*)'ERROR in subr. RDHD53 -- Array dimensions ',
     1   'are too small for data being read'
         write(io6,*)'Grid being read  (NXP, NYP, NZP) = ',
     1    nxp,nyp,nzp
         write(io6,*)'Array dimensions (MXNXP, MXNYP, MXNZP) = ',
     1    mxnxp,mxnyp,mxnzp
         stop
      endif
c --- Check consistency between nz1,nz2, and nzp
      if(nzp.ne.nz2-nz1+1) then
        write(io6,*)'Error in RDHD53: NZ1,NZ2 and NZP not consistent'
        write(io6,*)'nz1,nz2,nzp:',nz1,nz2,nzp
        stop
      endif
c
c ---------------------------------------------
c --- Next NZP records -- MM5 half-sigma levels
c ---------------------------------------------
      do 40 n=1,nzp
         read(io20,38)sigma(n)
38       format(f6.3)
40    continue
c
c --------------------------------------------------------
c --- Print the 3D.DAT header information to the list file
c --- (except for the gridded fields)
c --------------------------------------------------------
      if(lprt)then
         write(io6,101)cname3d,cver3d,ctitle3d,comm3d
101      format(//1x,'Information read from 3D.DAT file'/
     1   5x,'Dataset Name:    ',a12/
     2   5x,'Dataset Version: ',a12/
     3   5x,'Dataset Title:   ',a64/
     4   5x,'First line of comments: ',
     5   8x,a132)
c
         write(io6,102) inhyd,imphys,icupa,ibltyp,ifrad,isoil,
     :               ifddaan,ifddaob
102      format(/5x,'MM5 physics options: '/
     1           5x,'    Hydrostatic:           ',i2/
     1           5x,'    Moisture scheme:       ',i2/
     1           5x,'    Convection scheme:     ',i2/
     1           5x,'    Boundary layer scheme: ',i2/
     1           5x,'    Radiation scheme       ',i2/
     1           5x,'    Soil scheme:           ',i2/
     1           5x,'    Analysis FDDA:         ',i2/
     1           5x,'    Observation FDDA:      ',i2)


         write(io6,1021)igrdt,ipbl,ishf,ilhf,iustr,iswdn
     :         ,ilwdn,ist1,ist2,ist3,ist4,ist5,ist6
1021      format(/5x,'MM5 surface variable options: '/
     1           5x,'    Ground temperature:    ',i2/
     1           5x,'    PBL:                   ',i2/
     1           5x,'    Sensible heat flux:    ',i2/
     1           5x,'    Latent heat flux:      ',i2/
     1           5x,'    Frictional velocity:   ',i2/
     1           5x,'    Downward SW radiation: ',i2/
     1           5x,'    Downward LW radiation: ',i2/
     1           5x,'    Soil temp at layer 1:  ',i2/
     1           5x,'    Soil temp at layer 2:  ',i2/
     1           5x,'    Soil temp at layer 3:  ',i2/
     1           5x,'    Soil temp at layer 4:  ',i2/
     1           5x,'    Soil temp at layer 5:  ',i2/
     1           5x,'    Soil temp at layer 6:  ',i2)

         write(io6,103)1,ioutw,ioutq,ioutc,iouti,ioutg
103      format(/5x,'MM5 output fields (1 = YES; 0 = NO): '/
     1           5x,' Pressure, height,T,Wind speed and direction: ',i2/
     1           5x,'                           Vertical velocity: ',i2/
     1           5x,'                   RH and vapor mixing ratio: ',i2/
     1           5x,'                Cloud and rain mixing ratios: ',i2/
     1           5x,'                  Ice and Snow mixing ratios: ',i2/
     1           5x,'                                     Graupel: ',i2)
        if(imm53d.eq.3) then
c ---      Include seconds (V3.0 - 080205)
           write(io6,104)ibyrm,ibmom,ibdym,ibhrm,ibsecm,nhrsmm5,
     1                  nscmm5,nxp,nyp,nzp
        else 
           write(io6,104)ibyrm,ibmom,ibdym,ibhrm,nhrsmm5,
     1                  nxp,nyp,nzp
        endif

104     format(/5x,'Date/time (YYYYMMDDHH) of MM5 data: '/
     1           5x,'                  Start = ',i4,3i2,' (GMT)'/
     2           5x,'              No. hours = ',i4,/
     3           5x,'Extraction Subdomain in MM5 file: '/
     4           5x,'            No. X cells = ',i4/
     5           5x,'            No. Y cells = ',i4/
     6           5x,'            No. layers  = ',i4 )
c
105      format(/5x,'Date/time (YYYYMMDDHH) of MM5 data: '/
     1           5x,'                  Start = ',i4,3i2,' (GMT)'/
     1           5x,'                    and = ',i4,' seconds'/
     2           5x,'  No. hours and seconds = ',i4,' and ',i4/
     3           5x,'Extraction Subdomain in MM5 file: '/
     4           5x,'            No. X cells = ',i4/
     5           5x,'            No. Y cells = ',i4/
     6           5x,'            No. layers  = ',i4 )
c

         write(io6,106)nx1,ny1,nz1,nx2,ny2,nz2
106      format(/5x,'            Beginning X = ',i4/
     2           5x,'            Beginning Y = ',i4/
     3           5x,'            Beginning Z = ',i4/
     4           5x,'               Ending X = ',i4/
     5           5x,'               Ending Y = ',i4/
     6           5x,'               Ending Z = ',i4)
c
         write(io6,107)rymin,rymax,rxmin,rxmax
107      format(/5x,' Latitude range : ',f9.4,'  -  ',f9.4/
     :           5x,' Longitude range: ',f10.4, ' - ' ,f10.4)

         write(io6,108)
108      format(/5x,'MM5 half-sigma levels'/5x,'Level',5x,'Sigma'/)
         do 110 i=1,nzp
            write(io6,109)i,sigma(i)
110      continue
109      format(4x,i4,6x,f6.4)
      endif
c
c ---------------------------------------------------------
c --- Next NXP * NYP records -- lat., long., elevation, LU
c --------------------------------------------------------
      do 50 j=1,nyp
      do 50 i=1,nxp
         read(io20,99)iindex,jindex,xlat4(i,j),xlong4(i,j),
     &                ielev4(i,j),ilu4p(i,j)
 99      format(2i4,f9.4,f10.4,i5,i3)

c ---   Fill in ILU4 array stored in MM4HDO.MET 
        ilu4(i,j)=ilu4p(i,j)

c ---   Compute grid point locations from N.Lat and E.Lon
        call GLOBE(io6,caction,datum3d,vecti,datum,vecto,
     &             xlong4(i,j),xlat4(i,j),xlcmm4(i,j),ylcmm4(i,j),
     &             idum,c4hem)
c
c ---   QA check that I,J read match expected values
c
        icheck=iindex-i1+1
        jcheck=jindex-j1+1
        if(icheck.ne.i.or.jcheck.ne.j)then
          write(io6,*)'ERROR in subr. RDHD53 -- I,J do not match ',
     1      'values read on header record'
          write(io6,*)'I, J = ',i,j
          write(io6,*)'ICHECK, JCHECK = ',icheck,jcheck
          stop
        endif
50    continue

c --- 051113 - Flag "true" ocean 3D.DAT gridpoints to be used
c --- for pronostic deltaT calculation if itwprog=2
c --- "True" ocean (dot) gridpoints are defined as gridpoints surrounded
c --- by 4 ocean cross-gridpoints. This is necessary because all 3D.DAT
c --- scalar variables have been interpolated to MM5 dot points 
c --- except for land use which is set at crosspoints
c --- Dot cross-point (i,j) is surrounded by dot-points
c --- (i,j),(i-1,j),(i,j-1) and (i-1,j-1)
c --- For border points (i=1 or j=1): average was done on 2 points only
c --- To get a meaningful offshore deltaT, the gridpoint has to be
c --- a "true" ocean gridpoint.

      if (itwprog.eq.2) then
         noff=0
c ---    ocean LU category :iluoc3d (user-input stored in mm4hdo.met)
         do 51 j=2,nyp 
         do 51 i=2,nxp 
c           ilu4(i,j)=ilu4p(i,j) 
            if (ilu4p(i,j) .eq. iluoc3d)then
c ---          check if surrounding points are also ocean
               if( (ilu4p(i-1,j).eq.iluoc3d)  .and.
     :             (ilu4p(i,j-1).eq.iluoc3d)  .and.
     :             (ilu4p(i-1,j-1).eq.iluoc3d) ) then
c ---             "true" ocean
                   noff=noff+1
                else
c ---              deltaT corrupted by land value 
c ---              reset land use to non ocean value
                   ilu4(i,j)=-ilu4p(i,j)
                endif
            endif                            
51       continue

         do j=2,nyp
c            ilu4(1,j)=ilu4p(1,j) 
            if (ilu4p(1,j) .eq. iluoc3d)then
c ---          check if surrounding points are also ocean
               if(ilu4p(1,j-1).eq.iluoc3d) then
c ---             "true" ocean
                   noff=noff+1
                else
c ---              deltaT corrupted by land value 
c ---              reset land use to non ocean value
                   ilu4(1,j)=-ilu4p(1,j) 
                endif
            endif                            
         enddo

         do i=2,nxp
c            ilu4(i,1)=ilu4p(i,1) 
            if (ilu4p(i,1) .eq. iluoc3d)then
c ---          check if surrounding points are also ocean
               if(ilu4p(i-1,1).eq.iluoc3d) then
c ---             "true" ocean
                   noff=noff+1
                else
c ---              deltaT corrupted by land value 
c ---              reset land use to non ocean value
                   ilu4(i,1)=-ilu4p(i,1) 
                endif
            endif                            
         enddo
c         ilu4(1,1)=ilu4p(1,1) 
         if (ilu4p(1,1).eq.iluoc3d) noff=noff+1
 

c ---    There must be at least one ocean point for the option itwprog=2
c ---    to be meaningful (051031)- Otherwise stop -
         if (noff.eq.0) then
            write(io6,*)'STOP in RDHD53'
            write(io6,*)'There are no true offshore 3D.DAT gridpoints'
            write(io6,*)'Option ITWPROG=2 is not possible'
         endif

      endif

c -----------------------------------------------
c --- Print the 3D.DAT grid points to the QA file
c -----------------------------------------------
      if(lprt)then
         open(io4,file='QA3D.DAT',status='unknown')
c        
         write(io4,*)'             3D.DAT Grid Points'
         write(io4,*)'     X           Y        Longitude    Latitude'
         write(io4,*)'   (km)        (km)        (deg E)     (deg N)'
         do j=1,nyp
         do i=1,nxp
            write(io4,'(4f12.3)') xlcmm4(i,j),ylcmm4(i,j),
     1                            xlong4(i,j),xlat4(i,j)
         enddo
         enddo
c
         close(io4)
      endif
c
c
c --------------------------------------------------------
c --- Print first and last lat/lon values to the list file (090615)
c --------------------------------------------------------
      if(lprt)then
         write(io6,121)xlat4(1,1),xlong4(1,1),ielev4(1,1),
     &                 xlat4(nxp,nyp),xlong4(nxp,nyp),ielev4(nxp,nyp)
121      format(/5x,' Lat./Lon./Elev. of First Cell: ',f9.4,f10.4,i6/
     :           5x,' Lat./Lon./Elev. of Last  Cell: ',f9.4,f10.4,i6)
      endif

c --- v6.4.0, Level 121203
c --------------------------------------------------------
c --- Final QA Assessment
c --------------------------------------------------------
c --- QA known problems for specific processor versions identified in
c --- the first comment record
c --- Problem #1:  CALWRF versions through CALWRF 1.4, Level: 100322
      if(INDEX(comm3d,'CALWRF').NE.0) then
         n1=INDEX(comm3d,'Level: ')+7
         n2=n1+5
         read(comm3d(n1:n2),'(i6)') ilev
         if(ilev.LE.100322) then
            write(io6,*) 
            write(io6,*)'HALTING:  3D.DAT file precipitation rate '//
     &                  'may not be correct.'
            write(io6,*) TRIM(comm3d)
            write(io6,*)'The CALWRF processor through Version 1.4 '//
     &                  'included precipitation totals accumulated '
            write(io6,*)'during the spin-up period when reporting '//
     &                  'hourly precipitation rates for the first 2 '
            write(io6,*)'hours after each spin-up (WRF restart) in '//
     &                  'the 3D.DAT file.'
            stop 'Halted in RDHD53 -- See list file'
         endif
      endif

      return
      end
c ----------------------------------------------------------------------
      subroutine rdhdmet
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203             RDHDMET
c              F.Robe
c
c --- PURPOSE: Read the header records from an IGF-CALMET.DAT file 
c              Set up the map projection/datum transfo parameters 
c              and compute the wind direction adjustments if LCC
c
c --- UPDATES:
c
c --- v6.324 (080421) to v6.4.0 (121203)
c        - Add wind dir. rotation for Polar Stereographic projection
c        - Version string is a12
c
c --- v6.323(080411) to v6.324 (080421)(F. Robe)
c        - Accept different datum/map projections and set up the
c          correponding transformation parameters (stored in IGF.MET)
c          Compute the IGF-CALMET gridpoint coordinates in the current
c          CALMET map/datum as well as the wind direction adjustments
c          if the IGF and or current CALMET map projections are Lambert
c          conformal
c        - Compute current CALMET x,y coordinates and stored them in 
c          GRID.MET for use in RDCALMET
c        - Correct typo (clabxp instead of clabxi) - Does not affect 
c          results
c --- V6.302 (070929) to v6.323(080411) (FRR)
c        - Only print out ending times in LST file if IGF-CALMET version 2.1 
c          (undefined ending times otherwise which might stop compilation)
c --- V6.301 (070927) to V6.302 (070929) (JSS)
c          - Update documentation on routines calling subr. & called by
c          - Modify calls to RDR2D, RDR1D, RDI2D to include IO6
c --- V6.220 (070127) to V6.301 (070927) (FRR)
c          - Extend IGF option to read in coarse MOD6 CALMET fields
c          - Check lcalgridi value sooner
c
c --- v6.211 (060414) to V6.220 (070127) (FRR) 
c          - Define lcalgrdi as logical and perform tests on False/true
c           rather than 0/1 
c
c --- V5.711 (060106) to v6.211 (060414) (DGS)
c          - DATENI was not declared
c          - I2DMET was not assigned (remained at 0)
c
c
c        Parameters:
c            MXNXi, MXNYi, MXNZi, IO6, IO18, MXNX, MXNY
c        Common block /FILNAM/: igfDAT(mxigf)
c        common block /IGF/nfigf,Nigf
c        common block /MAP/datum,pmap
c        Common block /GRID/:NX,NY, xabskm(mxnx),yabskm(mxny)
c
c --- OUTPUT:
c
c        common block /IGF/nfigf,Nigf, mtver,CELLZCi(mxnzi),
c                     IBYRi, IBJULi, IBHRi, ibsec,IEYRi, IEJULi, IEHRi,
c                     NEARSi(mxnxi,mxnyi),NSSTAi,NPSTAi,JBTZi,
c                     ieseci,xigf(mxnxi,mxnyi),yigf(mxnxi,mxnyi)
c                     xigf0(mxnxi,mxnyi),yigf0(mxnxi,mxnyi),z0i(mxnxi,mxnyi),
c                     igrabi(mxnx,mxny,4), jgrabi(mxnx,nxny4)
c                     kdathrei,nsecei,
c                     lremapigf,LCCIGF,DWDI(mxnxi,mxnyi)
c                     LPSIGF
c
c
c --- RDHDMET called by:  READHD, RDMET2
c --- RDHDMET calls: UTCBASR, JULDAY, INCR, RDR1D, RDR2D, RDI2D, 
c                    GLOBE1, GLOBE1
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
c --- Local Parameters
c --------------------

      real xbuf(mxnxi,mxnyi)
      real elevi(mxnxi,mxnyi)
      real xsstai(mxss),ysstai(mxss), xustai(mxus),yustai(mxus)
      real xpstai(mxps),ypstai(mxps),xlaii(mxnxi,mxnyi)
      real zfacei(mxnzi+1)
      integer ilui(mxnxi,mxnyi),neari(4),nearj(4)
      real dnear(4)
c
      character*80 title(3)
      character*8 vermeti,levmeti,pmapi
      character*8 clabel,clabxs,clabys,clabxu,clabyu,clabxp,clabyp
      character*8 clabz0,clablu,clabte,clablai,clabnss
c
c --- For coordinate transformations
      character*8 cmapi,cmapo,datumi
      character*12 cactioni,dateni,cactionlli
      character*4 cigfhem, c4hem
      real*8 vectii(9),vectoi(9)
      real*8 vectilli(9),vectolli(9)

      real xlonigf(mxnxi,mxnyi), xlatigf(mxnxi,mxnyi)

      character*16 dataset,dataver
      character*33 blank33
      character*64 datamod
      character*80 doc1
      character*132 comment1,blank

      character*8 axtzi

      logical lprt,llconfi,lcalgrdi

c --- Common blocks
      include 'grid.met'
      include 'filnam.met'
      include 'map.met'
      include 'igf.met'

      data lprt/.true./

      data blank33/'                                 '/

c --- Set blank (132 characters)
      blank(1:33)=blank33
      blank(34:66)=blank33
      blank(67:99)=blank33
      blank(100:132)=blank33


c --- Initialize begin/end time flag
c ---    0: end-time (no seconds) (MOD5)
c ---    1: begin-time / end-time  (MOD6)
      mtver=1

c --- Initialize IGF time stamp
      kdathrei=0
      nsecei=0


      if (nfigf.gt.1 .and. nfigf.le.nigf) then
c ---    Close previous file
         close(io18)
      else if (nfigf.gt.nigf) then
c ---    no more files - STop
         write(io6,*) ' STOP in RDHDMET'
         write(io6,*) ' Unexpected End of IGF-CALMET records'
         stop 'RDHDMET: Unexpected End of IGF-CALMET records'
      endif

c --- Read and test first record to determine header format
c --- Record #1 - File Declaration -- 24 words
      open(io18,file=igfdat(nfigf),status='old',form='unformatted')      

      read(io18) dataset,dataver,datamod
      ifilver=0
      if(dataset.EQ.'CALMET.DAT') ifilver=1
      REWIND(io18)


      if(ifilver.EQ.1) then
c ---   Assign 2D flag (2D vars are in this file version)
        i2dmet=1
c
c ---   Record #1 - File Declaration -- 24 words
        read(io18) dataset,dataver,datamod
c
c ---   Record #2 - Number of comment lines -- 1 word
        read(io18) ncom
c ---   Loop over comment records
        if(Lprt) then
          write(io6,*)
          write(io6,*)'IGF-CALMET Control file information:'
          write(io6,*)
        endif
        do i=1,ncom
          comment1=blank
          read(io18) 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
            title(i-1)=comment1(1:80)
          endif
          if(lprt) write(io6,*) comment1
        enddo
c
c ---   record #NCOM+3 - run control parameters -- 37 words
        if (dataver.eq.'2.1') then
c ---      CALMET.DAT with explicit beg./ending times, seconds, and
c ---      UTC timezone as string
           read(io18) ibyri,ibmoi,ibdyi,ibhri,ibseci,ieyri,iemoi,
     1     iedyi,iehri,ieseci,axtzi,irlgi,irtypei,
     1      nxi, nyi, nzi, dgridi, xorigri, yorigri, iwfcodi, nsstai,
     2      nustai, npstai, nowstai, nlui, iwat1i, iwat2i, lcalgrdi,
     3      pmapi,datumi,dateni,feasti,fnorthi,cigfhem,
     4      iutmzni,rnlat0i,relon0i,xlat1i,xlat2i

c ---       Convert UTC time zone to IBTZ time zone
            call utcbasr(axtzi,xbtzi)
            jbtzi=int(xbtzi)


            call julday(io6,ibyri,ibmoi,ibdyi,ibjuli)
            call julday(io6,ieyri,iemoi,iedyi,iejuli)
 
        else
c ---      CALMET with hour-ending times (1-hour timestep)
           mtver=0
            read(io18) ibyri,ibmoi,ibdyi,ibhri,jbtzi,irlgi,irtypei,
     1      nxi, nyi, nzi, dgridi, xorigri, yorigri, iwfcodi, nsstai,
     2      nustai, npstai, nowstai, nlui, iwat1i, iwat2i, lcalgrdi,
     3      pmapi,datumi,dateni,feasti,fnorthi,cigfhem,
     4      iutmzni,rnlat0i,relon0i,xlat1i,xlat2i
        endif


      endif
c
      if(ifilver.EQ.0) then
c ---   Read older CALMET header records
c
c ---   CALMET with hour-ending times
        mtver=0
c
c ---   Assign 2D flag (2D vars are NOT in this file version)
        i2dmet=0
c
c ---   record #1 - run title -- 60 words
        read(io18)title
c
c ---   record #2 - run control parameters -- 26 words
c ---   (vermeti, levmeti are both 8 bytes)
        read(io18)vermeti,levmeti,ibyri,ibmoi,ibdyi,ibhri,jbtzi,irlgi,
     1   irtypei,nxi, nyi, nzi, dgridi, xorigri, yorigri, iutmzni, 
     2   iwfcodi, nsstai,nustai, npstai, nowstai, nlui, iwat1i, iwat2i,
     3   lcalgrdi
c ---    older CALMET: assume datum=NWS-84
        datumi='NWS-84  '


c --- All fields must be available for nested options:
      if (lcalgrdi) then
c        ok
      else
         write(io6,*)'STOP in RDHDMET'
         write(io6,*)'Not all required fields are available in ',
     :               'initial CALMET.DAT for IGFMEt option'
         write(io6,*)'AS LCALGRD in IGF-CALMET is set to FALSE '
         write(io6,*)' STOP in RDHDMET'
         STOP 'STOP IN RDHDMET - Check list file'
      endif

c ---   New record -- #3 - additional run control data -- 8 words
c ---   This record was introduced in CALMET Version 5.0 (980304)
        read(levmeti(1:6),'(i6)') ilevmet
        read(vermeti(1:6),'(f6.0)') rvermet
        if(ilevmet.GE.980304 .OR. rvermet.GT.5.1) then
c ---      New header record format
           read(io18)xlat0i,xlon0i,llconfi,coneci,xlat1i,xlat2i,
     &              rlat0i,rlon0i
        endif
c
c ---   Recast map projection information
        if(LLCONFi) then
           pmapi='LCC     '
        else
           pmapi='UTM     '
        endif
        
c ---   Convert to new format variables (North lat and EAST long)
        rnlat0i=xlat0i
        relon0i=-xlon0i

      endif

c --- Check that datum and map projection match those in current calmet:
c --- This is now allowed (080314)
c          if ( (pmapi.ne.pmap) .or. (datumi.ne.datum)) then
c              write(io6,*)' STOP in RDHDMET '
c              write(io6,*)' IGF Datum and map projection do not match'
c              write(io6,*)' Current datum:',datum,
c     :                    ' and map projection:',pmap
c              write(io6,*)' IGF datum:    ',datumi,
c     :                    ' and map projection:',pmapi
c 
c             STOP' STOP in RDHDMET - Datum/map projection do not match '
c          endif


c --- Convert hour-ending times to beginning and ending julian dates
      if (mtver.eq.0) then 
         call julday(io6,ibyri,ibmoi,ibdyi,ibjuli)
         call incr(io6,ibyri,ibjuli,ibhri,-1)
         ibseci=0

         ieyri=ibyri
         iejuli=ibjuli
         iehri=ibhri
         ieseci=0
         call incr(io6,ieyri,iejuli,iehri,irlgi)
       endif

c --- Check that array dimensions have been sized properly
      if(nxi.gt.mxnxi.or.nyi.gt.mxnyi.or.nzi.gt.mxnzi)then
      write(io6,2354)nxi,mxnxi,nyi,mxnyi,nzi,mxnzi
2354     format(/1x,'ERROR -- Array dimensions are too small for ',
     1   'the data in the IGF-CALMET.DAT file'/
     2   5x,'nxi    = ',i5,4x,'MXnxi = ',i5/
     3   5x,'nyi    = ',i5,4x,'MXnyi = ',i5/
     4   5x,'nzi    = ',i5,4x,'MXnzi = ',i5/)
      stop
      endif
c
c --- record #4 - cell face heights (NZ + 1 words)
      nzi1=nzi+1
      call rdr1d(io18,mtver,io6,zfacei,nzi1,clabel,idum,idum,idum,idum)

c --- IGF-CALMET levels
      do ki=1,nzi
         cellzci(ki)= (zfacei(ki)+zfacei(ki+1))/2.
      end do    
c
c
c --- records #5 & 6 - x, y coordinates of surface stations
c --- (NSSTAi words each record)
      if(nsstai.gt.0)then
        call rdr1d(io18,mtver,io6,xsstai,nsstai,clabxs,idum,idum,idum,
     1   idum)
        call rdr1d(io18,mtver,io6,ysstai,nsstai,clabys,idum,idum,idum,
     1   idum)
      endif
c
c --- records #7 & 8 - x, y coordinates of upper air stations
c --- (NUSTA words each record)
      if(nustai.gt.0)then
        call rdr1d(io18,mtver,io6,xustai,nustai,clabxu,idum,idum,idum,
     1   idum)
        call rdr1d(io18,mtver,io6,yustai,nustai,clabyu,idum,idum,idum,
     1   idum)
      endif
c 
c --- records #9 & 10 - x, y coordinates of precipitation stations
c --- (NPSTA words each record)
      if(npstai.gt.0)then
        call rdr1d(io18,mtver,io6,xpstai,npstai,clabxp,idum,idum,idum,
     1   idum)
        call rdr1d(io18,mtver,io6,ypstai,npstai,clabyp,idum,idum,idum,
     1   idum)
      endif
c
c --- record #11 - surface roughness lengths (NX * NY words)
      call rdr2d(io18,mtver,io6,z0i,xbuf,mxnxi,mxnyi,nxi,nyi,
     1           clabz0,idum,idum,idum,idum,ieof)
c
c --- record #12 - land use categories (NX * NY words)
      call rdi2d(io18,mtver,io6,ilui,xbuf,mxnxi,mxnyi,nxi,nyi,
     1           clablu,idum,idum,idum,idum)
c
c --- record #13 - elevations (NX * NY words)
      call rdr2d(io18,mtver,io6,elevi,xbuf,mxnxi,mxnyi,nxi,nyi,
     :           clabte,idum,idum,idum,idum,ieof)

c --- record #14 - leaf area index (NX * NY words)
      call rdr2d(io18,mtver,io6,xlaii,xbuf,mxnxi,mxnyi,nxi,nyi,
     1           clablai,idum,idum,idum,idum,ieof)

c --- record #15 - nearest surface station to each grid point
c                  (NX * NY words)
      if(nsstai.ge.1)then
         call rdi2d(io18,mtver,io6,nearsi,xbuf,mxnxi,mxnyi,nxi,nyi,
     1              clabnss,idum,idum,idum,idum)
      endif


      if (lprt) then

c ---   Write run parameters from CALMET header records
        write(io6,*)'Data read from header records of IGF-CALMET file: '
        write(io6,'(1x,a132)')igfdat(nfigf) 
        write(io6,*)
        if(ifilver.EQ.1) then
           write(io6,'(2a16,a64)')dataset,dataver,datamod
           write(io6,*)
        endif
        write(io6,102)title
102        format(3(1x,a80/))
        if(ifilver.EQ.0) then
           write(io6,104)vermeti,levmeti

c --- v6.4.0, Level 121203
104        format(1x,'CALMET Version: ',a12,3x,'Level: ',a8)

        else
           write(io6,'(a80)') doc1
        endif
        if (mtver.eq.1) then
         write(io6,*)' MOD6 version with explicit times and seconds'
        else
         write(io6,*)' MOD5 version with hour-ending times'
        endif
        write(io6,*)
        write(io6,*)' Input Group #0 parameters ---'
        write(io6,*)' NUSTA   = ',nustai
        write(io6,*)' NOWSTA  = ',nowstai
        write(io6,*)
        write(io6,*)' Input Group #1 parameters ---'
        write(io6,*)' IBYR    = ',ibyri
        write(io6,*)' IBMO    = ',ibmoi
        write(io6,*)' IBDY    = ',ibdyi
        write(io6,*)' IBHR    = ',ibhri
        write(io6,*)' IBSEC   = ',ibseci
        if (dataver.eq.'2.1') then
        write(io6,*)' IEYR    = ',ieyri
        write(io6,*)' IEMO    = ',iemoi
        write(io6,*)' IEDY    = ',iedyi
        write(io6,*)' IEHR    = ',iehri
        write(io6,*)' IESEC   = ',ieseci
        endif
        write(io6,*)' IBTZ    = ',jbtzi
        write(io6,*)' IRLG    = ',irlgi
        write(io6,*)' IRTYPE  = ',irtypei
        write(io6,*)' LCALGRD = ',lcalgrdi
        write(io6,*)
        write(io6,*)' Input Group #2 parameters ---'
        write(io6,*)' PMAP    = ',pmapi
        write(io6,*)' DATUM   = ',datumi
        write(io6,*)' NIMADATE= ',dateni
        write(io6,*)' FEAST   = ',feasti
        write(io6,*)' FNORTH  = ',fnorthi
        if(PMAPi.EQ.'UTM     ') then
           write(io6,*)' IUTMZN  = ',iutmzni
           write(io6,*)' UTMHEM  = ',cigfhem
        else
           write(io6,*)' XLAT1   = ',xlat1i
           write(io6,*)' XLAT2   = ',xlat2i
           write(io6,*)' RNLAT0  = ',rnlat0i
           write(io6,*)' RELON0  = ',relon0i
        endif
        write(io6,*)' NX      = ',nxi
        write(io6,*)' NY      = ',nyi
        write(io6,*)' DGRID   = ',dgridi
        write(io6,*)' XORIGR  = ',xorigri
        write(io6,*)' YORIGR  = ',yorigri
        write(io6,*)' NZ      = ',nzi
        write(io6,203)(zfacei(n),n=1,nzi1)
203     format(1x,'ZFACE  = ',10(f9.3,', '))
        write(io6,*)
        write(io6,*)' Land Use parameters from GEO.DAT ---'
        write(io6,*)' NLU     = ',nlui
        write(io6,*)' IWAT1   = ',iwat1i
        write(io6,*)' IWAT2   = ',iwat2i
        write(io6,*)
        write(io6,*)' Input Group #4 parameters ---'
        write(io6,*)' NSSTA   = ',nsstai
        write(io6,*)' NPSTA   = ',npstai
        write(io6,*)
        write(io6,*)' Input Group #5 parameters ---'
        write(io6,*)' IWFCOD  = ',iwfcodi

       endif
c

c ---------------------------------------------------------------
c ---   Is a coordinate transformation needed for CALMET? (080314)
c ----------------------------------------------------------------
c ---   Set translation vectors going from IGF-CALMET (x,y)
c ---   to current CALMET projection (x,y)
c ---   Scale factor for Tangential TM projection
        tmsone=1.00000
c ---   IGF-CALMET
        iutmi=iutmzni
        if(cigfhem.EQ.'S   ' .AND. iutmzni.LT.900) iutmi=-iutmi
        cmapi=pmapi
        if(cmapi.EQ.'TTM     ') cmapi='TM      '
c ---   CALMET
        iutmo=iutmzn
        if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
        cmapo=pmap
        if(cmapo.EQ.'TTM     ') cmapo='TM      '
        call GLOBE1(cmapi,iutmi,tmsone,xlat1i,xlat2i,
     &              rnlat0i,relon0i,feasti,fnorthi,
     &              cmapo,iutmo,tmsone,xlat1,xlat2,
     &              rnlat0,relon0,feast,fnorth,
     &              cactioni,vectii,vectoi)
c ---   Compare projections, transformation vectors and datums
        lremapigf=.FALSE.
        if(pmapi.NE.pmap) lremapigf=.TRUE.
        if(datumi.NE.datum) lremapigf=.TRUE.
        do i=1,9
           if(vectii(i).NE.vectoi(i)) lremapigf=.TRUE.
        enddo


c -----------------------------------------------------------------
c --- Compute IGF-CALMET (x,y) in current CALMET coordinate system
c ----------------------------------------------------------------
c --- Remap if necessary (080314)
 
      do 50 j=1,nyi
      do 50 i=1,nxi
c ---   (x,Y) in IGF-coordinate system in km
        xigf0(i,j) = (xorigri + (i-0.5)*dgridi)*0.001
        yigf0(i,j) = (yorigri + (j-0.5)*dgridi)*0.001
c ---   remap to current coordinate system if different
        if(LREMAPIGF) then
           call GLOBE(io6,cactioni,datumi,vectii,datum,
     &                vectoi,xigf0(i,j),yigf0(i,j),
     &                 xigf(i,j),yigf(i,j),idum,c4hem)
         else
            xigf(i,j) = xigf0(i,j)
            yigf(i,j) = yigf0(i,j)
         endif 
50    continue


c ---------------------------------------------------------------
c --- Compute the wind direction adjustement if LCC and/or LCCIGF
c --- or if PS and/or LPSIGF
c ---------------------------------------------------------------

c --- v6.4.0, Level 121203
c --- Initialize IGF logicals for LCC and PS 
      LCCIGF=.FALSE.
      LPSIGF=.FALSE.
c --- Set Polar Stereographic
      if(pmapi.EQ.'PS      ') lpsigf=.TRUE.
c --- Set Lambert CC

      if(pmapi.EQ.'LCC     ')  lccigf =.TRUE.

c --- Initialize wind direction shift
      do 54 j=1,nyi
      do 54 i=1,nxi
          dwdi(i,j) = 0
54    continue

c --- Skip if same map projection/datums
      if (.not.lremapigf) goto 555


c --- First from LCC-IGF to true North
      IF (LCCIGF)then

c ---    Calculate cone constant for LCC (used to adjust winds)
         coneci=0.0
         d2r = 0.0174533
c ---    Use absolute value of latitudes, then adjust y coordinate
c ---    later if in Southern Hemisphere
         coneci = log(cos(abs(xlat1i)*d2r) / cos(abs(xlat2i)*d2r))
         coneci = coneci/(log(tan(d2r*(45.-abs(xlat1i)/2.)) /
     &                     tan(d2r * (45. - abs(xlat2i) / 2.))))
        
c --- v6.4.0, Level 121203
c --- Add logic for Polar Stereographic cone = 1.0
      elseif(LPSIGF) then
         coneci=1.0
      else
         coneci=0.0
      endif
c --- Apply conversion
      if(LCCIGF .OR. LPSIGF) then        

c ---    Compute conversion parameters to latitude-longitude
c ---    In IGF system

         iutmi=iutmzni
         if(cigfhem.EQ.'S   ' .AND. iutmzni.LT.900) iutmi=-iutmi
         cmapi=pmapi
         if(cmapi.EQ.'TTM     ') cmapi='TM      '
         cmapo='LL      '
         idum=0
         rdum=0.0
         call GLOBE1(cmapi,iutmi,tmsone,xlat1i,xlat2i,
     &            rnlat0i,relon0i,feasti,fnorthi,
     &            cmapo,idum,rdum,rdum,rdum,rdum,rdum,
     &            rdum,rdum,
     &            cactionlli,vectilli,vectolli)

         do 51 j=1,nyi
         do 51 i=1,nxi
c ---       Compute lat, longitude in IGF-CALMET coord system
            call GLOBE(io6,cactionlli,datumi,vectilli,datumi,
     &              vectolli,xigf0(i,j),yigf0(i,j),
     &              xlonigf(i,j),xlatigf(i,j),izone,c4hem)

c ---      assumes xlonigf  and relon0i ae positive in Eastern Hem.
           dloni = -relon0i + xlonigf(i,j)

c ---      Code to handle 180 degree longitude straddle
           if (dloni.gt. 180.) dloni = dloni - 360.
           if (dloni.lt. -180.) dloni = dloni + 360.
c ---      compute wind direction adjustment (to be added to wd IGF)
           if (xlat1i .lt. 0.) then
c ---        Southern Hemisphere
             dwdi(i,j)=-(coneci * dloni)
           else
c ---        Northern Hemisphere
             dwdi(i,j) = +(coneci * dloni)
           end if

51       continue

      endif

c --- v6.4.0, Level 121203
c --- Then from true North to LCC-Current 
c --- or to Polar Stereographic - Current
      if(LLCC .OR. LPS) then

c ---    Compute conversion parameters to latitude-longitude
c ---    At this point, the conversion parameters to lat, long
c ---    have not been computed yet (they will be in microi)
c ---    so have to compute them first and called them differently
c ---    to prevent any risk of contamination
         iutmi=iutmzn
         if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmi=-iutmi
         cmapi=pmap
         if(cmapi.EQ.'TTM     ') cmapi='TM      '
         cmapo='LL      '
         idum=0
         rdum=0.0
         call GLOBE1(cmapi,iutmi,tmsone,xlat1,xlat2,rnlat0,relon0,
     &            feast,fnorth,
     &            cmapo,idum,rdum,rdum,rdum,rdum,rdum,
     &            rdum,rdum,
     &            cactionlli,vectilli,vectolli)

         do 52 j=1,nyi
         do 52 i=1,nxi
c ---       Compute lat, longitude in current CALMET coord system
            call GLOBE(io6,cactionlli,datum,vectilli,datum,vectolli,
     &              xigf(i,j),yigf(i,j),xlonigf(i,j),xlatigf(i,j),
     &              izone,c4hem)


c ---      assumes xlonigf is positive in Eastern Hem.(rlon0 is not)
           dlon = rlon0 + xlonigf(i,j)
c ---      Code to handle 180 degree longitude straddle
           if (dlon .gt. 180.) dlon = dlon - 360.
           if (dlon.lt. -180.) dlon = dlon + 360.

c ---      compute wind direction adjustment (to be added to wd IGF)
c ---      and combine with IGF-LCC shift if any
           if (xlat1 .lt. 0.) then
c ---        Southern Hemisphere
             dwdi(i,j)=dwdi(i,j)+(conec * dlon)
           else
c ---        Northern Hemisphere
             dwdi(i,j)=dwdi(i,j)-(conec * dlon)
           end if
            
52       continue
      endif

555   continue

c -----------------------------------------------
c --- Print the IGF-CALMET.DAT grid points to the QA file
c -----------------------------------------------
      if(lprt)then
         open(io4,file='QAIGF.DAT',status='unknown')
c        
         write(io4,*)'  IGF-CALMET.DAT Grid Points'
         write(io4,*)'     X           Y       '
         write(io4,*)'   (km)        (km)      '
         do j=1,nyi
         do i=1,nxi
            write(io4,'(2f12.3)') xigf(i,j),yigf(i,j)
         enddo
         enddo
c
         close(io4)
      endif
c

c----------------------------------------------------------------
c --- Find the 4 closest coarse IGF-CALMET grid points to each current  
c     CALMET grid point(assume CALMET domain is inside coarse CALMET 
c     grid section)
c ---------------------------------------------------------------
      delg = dgrid * .001

c --- Compute CALMET grid coordinates in real space coordinates
      xcal = xmap0  + (0.5 * delg)
      ycal = ymap0  + (0.5 * delg)
c
      do i = 1,nx
c
c --- Find x/y for CALMET center points
c
c ---   Compute and store current CALMET (x,y) in GRID.MET (080421)
        xabskm(i) = xcal + (i - 1) * delg
        do j = 1,ny
          yabskm(j) = ycal + (j - 1) * delg
          do k = 1,4
            neari(k) = 0
            nearj(k) = 0
            dnear(k) = 9.9E19
          enddo
          do ii = 1,nxi
          do jj = 1,nyi
            pdist = sqrt ((xigf(ii,jj) - xabskm(i)) ** 2 +
     &                    (yigf(ii,jj) - yabskm(j)) **2)
            do k = 1,4
              if (pdist .lt. dnear(k)) then
                if (k .lt. 4) then
                  dnear(4) = dnear(3)
                  nearj(4) = nearj(3)
                  neari(4) = neari(3)
                endif
                if (k .lt. 3) then
                  dnear(3) = dnear(2)
                  nearj(3) = nearj(2)
                  neari(3) = neari(2)
                endif
                if (k .lt. 2) then
                  dnear(2) = dnear(1)
                  nearj(2) = nearj(1)
                  neari(2) = neari(1)
                endif
                dnear(k) = pdist
                nearj(k) = jj
                neari(k) = ii
                goto 66
              endif
            enddo
 66         continue
          enddo
          enddo
          do k = 1,4
            igrabi(i,j,k) = neari(k)
            jgrabi(i,j,k) = nearj(k)
          enddo
        enddo
      enddo
      return
      end
c ---------------------------------------------------------------------
      subroutine RDCALMET(cellzc,uigf,vigf) 
c ---------------------------------------------------------------------
C
c --- CALMET   Version: 6.4.0     Level: 121203           RDCALMET
c              F.Robe

c --- PURPOSE : READ AND INTERPOLATE EXISTING CALMET WIND FIELDS ONTO 
c               THE CURRENT CALMET GRID (for effective nested grid
c               option). 
c
c --- UPDATES:
c
c --- v6.324 (080421) to v6.4.0 (121203)
c         - Add wind dir. rotation for Polar Stereographic projection
c
c --- V6.301 Level 070927 to v6.324 Level 080421(FRR)
c         - Perform wind direction rotation if IGF and current coord. 
c           systems are not identical and at least one of them is LCC.
c           (Part of allowing different datums/projection in IGF and
c           current CALMET)
c         - Use x,y stored in GRID.MET rather than computing them again
c           at every timestep
c
c --- V6. level 060106 to V6.301 Level 070927 (FRR)
c         - Change calling list to RDMET2 to allow for MOD6 IGF CALMET
c         - Add check whether need to read a new IGF record
c
C --- INPUTS:  CELLZC R-ARRAY  - CURRENT CALMET CELL-CENTER HEIGHTS
c
c ---     Common /IGF/:z0i (mxnxi,mxnyi),cellzci(mxnzi),
c                      igrabi(mxnx,mxny,4),jgrabi(mxnx,mxny,4)
C                      IGFMOD,LCCIGF,DWDI(mxnxi,mxnyi)
c                      lremapigf
c                      LPSIGF
c ---     common/GEN/: ndathrb,nsecb,ndathre,nsece,ibtz
c ---     common/GRID/: xabskm(mxnx),yabskm(mxny)
C
C     OUTPUTS:  
C               UIGF R-ARRAY  - U-COMPONENT OF THE IGF-CALMET WIND FIELD
C                               INTERPOLATED TO CALMET GRID
C               VIGF R-ARRAY  - V-COMPONENT OF THE IGF-CALMET WIND FIELD
C                               INTERPOLATED TO CALMET GRID
c
C     OTHER VARIABLES:
C               NXi     INT   - NO. OF PROGNOSTIC MODEL GRID POINTS IN THE
C                               X-DIRECTION
C               NYi     INT   - NO. OF PROGNOSTIC MODEL GRID POINTS IN THE
C                               Y-DIRECTION
C               NZi     INT   - NO. OF PROGNOSTIC MODEL LEVELS
c
c        Parameters: MXNX, MXNY, MXNZ, MXNXi, MXNYi, MXNZi, IO6
c
c --- RDCALMET called by:  DIAGNO
c --- RDCALMET calls:      JULDAY, INDECR,  R2INTERP, ESAT, YR4
c                          R2INTERP2, RDMET2, GLOBE
c----------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'gen.met'
      include 'map.met'
      include 'grid.met'
      include 'metgrd.met'

      include 'd4.met'
      include 'd6.met'
      include 'igf.met'

      DIMENSION Uigf(mxnx,mxny,mxnz),  Vigf(mxnx,mxny,mxnz),
     1          UP(mxnxi,mxnyi,mxnzi), VP(mxnxi,mxnyi,mxnzi),
     1          UDAT(mxnxi,mxnyi,mxnz),VDAT(mxnxi,mxnyi,mxnz),
     2          CELLZC(mxnz)



c --- Express current timestep in IGF-CALMET base time zone (jbtzi)
      jdathrb=ndathrb
      call dedat(jdathrb,jyrb,jjulb,jhrb)
      idtz=ibtz-jbtzi
      call incr(io6,jyrb,jjulb,jhrb,idtz)
      jdathrb=jyrb*100000+jjulb*100+jhrb

      jdathre=ndathre
      call dedat(jdathre,jyre,jjule,jhre)
      idtz=ibtz-jbtzi
      call incr(io6,jyre,jjule,jhre,idtz)
      jdathre=jyre*100000+jjule*100+jhre

c --- Check if last read IGF record is still valid for the current timestep
c --- if so, do not read any new records

      call deltsec(jdathre,nsece,kdathrei,nsecei,ndelsec)
      if(kdathrei.ne.0.and.ndelsec.ge.0) return


c ---  Read in IGF-CALMET data
       call rdmet2(jdathre,nsece,up,vp)

c ---  Correct wind direction if coordinates systems are different
c ---  and either one is Lambert Conformal

c --- v6.4.0, Level 121203
c ---  or Polar Stereographic
       if((LREMAPIGF). AND.
     &    (LLCC .OR. LCCIGF .OR. LPS .OR. LPSIGF)) then

          do 4 k=1,nzi
          do 4 j=1,nyi
          do 4 i=1,nxi

c ---        compute wind speed and direction in IGF map system
             ws=sqrt(up(i,j,k)**2+vp(i,j,k)**2)
             if(ws.gt.1.e-9)then
                wd=270.-57.295778*atan2(vp(i,j,k),up(i,j,k))
                wd=amod(wd,360.)
c ---           Add wind direction correction
                wd=wd+dwdi(i,j)
c ---           Revert to u,v in current map system
                dir=0.0174533*wd
                up(i,j,k)=-ws*sin(dir)
                vp(i,j,k)=-ws*cos(dir)
             endif

4         continue

       endif


c ---  Loop over coarse IGF-CALMET gridpoints:
       do 5 j=1,nyi
       do 5 i=1,nxi

C ---      INTERPOLATE PROGNOSTIC SOUNDINGS VERTICALLY TO DIAGNOSTIC
C ---      MODEL LEVELS
           DO 75 K = 1,NZ
c         
c ---        Persist data below bottom level
             IF(CELLZC(K).LT.cellzci(1))then
                UDAT(I,J,K)=UP(I,J,1)
                VDAT(I,J,K)=VP(I,J,1)
          
c ---        Persist data above top CALMET level
             else if(CELLZC(K).GE.cellzci(nzi))then
                UDAT(I,J,K)=UP(I,J,nzi)
                VDAT(I,J,K)=VP(I,J,nzi)
          
c ---        Interpolate to CALMET level from surrounding IGF-CALMET levels
             else
                DO KP = 2,nzi
                   KPM1 = KP - 1
                   IF(cellzci(KPM1).LE.CELLZC(K).AND.
     1                cellzci(KP).GT.CELLZC(K))THEN
                      ratio1=(CELLZC(K)-cellzci(KPM1))/
     1                       (cellzci(KP)-cellzci(KPM1))
                     UDAT(I,J,K)=UP(I,J,KPM1)+(UP(I,J,KP)-UP(I,J,KPM1))
     1                            *ratio1
                     VDAT(I,J,K)=VP(I,J,KPM1)+(VP(I,J,KP)-VP(I,J,KPM1))
     1                            *ratio1

                      go to 77
                   endif
                enddo
77              continue
             endif
c           
c ---        Replace winds below first IGF-CALMET level with 
c ---        extrapolated logarithmic profile winds. This is unlikely to
c ---        happen as usually CALMET first level is at 10m but cannot
c ---        be ruled out
c          
c ---        Use a logarithmic profile to extrapolate winds down toward
c ---        the surface
             if(cellzc(k).lt.cellzci(1))then
                xlnzo=alog(z0i(i,j))
c ---           cellzci(1) is the lowest true MM5 half-sigma level
                xlnz2=alog(cellzci(1))
c ---           CELLZC(k) is the CALMET grid point height
                xlnz1=alog(cellzc(k))
c ---           Logarithmic  profile scaling factor
                ratio2=(xlnz1-xlnzo)/(xlnz2-xlnzo)

                UDAT(I,J,K)=ratio2*UP(I,J,1)
                VDAT(I,J,K)=ratio2*VP(I,J,1)
             endif

75         CONTINUE


c ---  end of loop on nxi,nyi (IGF-CALMET gridpoints)
5      continue


 997   continue
C
C      INTERPOLATE PROGNOSTIC SOUNDINGS HORIZONTALLY TO DIAGNOSTIC MODEL
C      GRID
C ---  Use stored values of current grid coordinates (080421)
c ---  Convert diagnostic grid spacing from m to km
c       dxk = dx * 0.001
c       dyk = dy * 0.001
c
c ---  Compute cell center x,y of diagnostic grid cell (1,1)
c ***  xorigcc = utmxor + (0.5*dxk)
c ***  yorigcc = utmyor + (0.5*dyk)
c ---  Compute diagnostic grid coordinates in real space
c       xorigcc = xmap0 + (0.5 * dxk)
c       yorigcc = ymap0 + (0.5 * dyk)
c
c ---  Loop over diagnostic grid
       do 125 j = 1,ny
c ---  Compute Y of cell center
c       y = yorigcc + (j - 1) * dyk
       do 125 i = 1,nx
c ---    Compute X of cell center
c         x = xorigcc + (i - 1) * dxk       

         do 121 k = 1,nz
 
c ---    Interpolate horizontally from igf-calmet grid to diagnostic
c ---    grid x,y using inverse distance squared at four nearest points.
c      
          call r2interpi(i,j,xabskm(i),yabskm(j),udat,k,uigf(i,j,k))
          call r2interpi(i,j,xabskm(i),yabskm(j),vdat,k,vigf(i,j,k))

 121     continue
       


 125   continue
c ---  end of loop on calmet grid

 
      return
      end
c----------------------------------------------------------------------
      subroutine rdmet2(jdathre,jsece,umet,vmet)
c----------------------------------------------------------------------
c
c --- CALMET    Version: 6.4.0     Level: 070929            RDMET2
c               F.Robe, Earth Tech
c               
c
c --- PURPOSE:  Read CALMET meteorological data for one hour
c               If old CALMET format, interpolates 1-D arrays
c               of ipcode, rho and rh to fill 2-D arrays
c
c --- Updates:
c     V6.301 Level 070927 to V6.302 Level 070929 (JSS)
c        - Modify calls to RDR1D, RDI1D, RDR2D, RDI2D to include IO6
c     060601 to V6.301 Level 070927 (FRR)
c        - Read MOD5 and MOD6 records
c
c --- INPUTS:
c        jDATHRE - integer      - Ending Date & hour of required data
c                                 (YYYYJJJHH) in IGF CALMET 
c                                 timezone
c        jSECE   - integer      - Ending.second of required data in IGF
c                                 CALMET timezone
c
c
c    Common block /IGFMET/ variables:
c         NXi, NYi, NZi, NEARSi, NSSTAi, NPSTAi, I2DMET,JBTZi,MTVER,
c         KDATHREI,NSECEI
c
c    Parameters:
c         MXNZMP1, IO6, IO18
c
c --- OUTPUT:
c
c   UMET(mxni,mxnyi,mxnzi) - real   - U component of the wind (m/s)
c                                     at each IGF-CALMET grid point
c   VMET(mxni,mxnyi,mxnzi) - real   - V-component of the wind (m/s)
c                                     at each IGF-CALMET grid point
c
c --- RDMET2 called by:  RDCALMET
c --- RDMET2 calls:      RDHDMET, RDR1D, RDR2D, RDI1D, RDI2D, YR4,DELTSEC
c----------------------------------------------------------------------
c
c --- Include parameter statements
      include 'params.met'
      include 'igf.met'
c
      real umet(mxnxi,mxnyi,mxnzi),vmet(mxnxi,mxnyi,mxnzi)
      real tmet(mxnxi,mxnyi,mxnzi)
      real rmm(mxnxi,mxnyi)
c     real wrk1(nwork)
      real wrk1(mxnxi*mxnyi)
      real tempss(mxss),rhoss(mxss),qswss(mxss)
      real wdiv(mxnxi,mxnyi,mxnzi)
      real temp2d(mxnxi,mxnyi),rho2d(mxnxi,mxnyi),qsw2d(mxnxi,mxnyi)
      integer irh2d (mxnxi,mxnyi),ipcode2d(mxnxi,mxnyi)

c --- Micromet variables:
      real ustari(mxnxi,mxnyi),ZIi(mxnxi,mxnyi),ELi(mxnxi,mxnyi)
      real WSTARi(mxnxi,mxnyi)
      integer IPGTi(mxnxi,mxnyi)

      integer irhss(mxss),ipcode(mxss)
c
      character*8 clabel
      character*8 clabexp
c


c --- Begin reading data records for one time period
1     continue
c

c --- Track date-hr of end of this period to check for problems in file
c --- (end-times are available in new and old formats)
      kdathre=0
      ksece=0
c
c --- read the U, V wind components
      do 10 iz=1,nzi
      call rdr2d(io18,mtver,io6,umet(1,1,iz),wrk1,mxnxi,mxnyi,nxi,nyi,
     1           clabel,ndathrb1,nsecb1,ndathre1,nsece1,ieof)
      if(ieof.EQ.1) then
c ---    Reached end of CALMET.DAT file; check for another file
         nfigf=nfigf+1
         call RDHDMET
c ---    read again (in new file)
         call rdr2d(io18,mtver,io6,umet(1,1,iz),wrk1,mxnxi,mxnyi,nxi,
     1         nyi,clabel,ndathrb1,nsecb1,ndathre1,nsece1,ieof)
      endif
c

c --- Compute IGF timestep (done only once)
      if(kdathrei.eq.0)then
         if (mtver.eq.0) then
            istepi=3600
         else
            call deltsec(ndathrb1,nsecb1,ndathre1,nsece1,istepi)
         endif
      endif

c --- Check that record label matches expected label
      clabexp='U-LEV'
      write(clabexp(6:8),'(i3)')iz
      if(clabel.ne.clabexp)go to 999
c

      call rdr2d(io18,mtver,io6,vmet(1,1,iz),wrk1,mxnxi,mxnyi,nxi,
     1           nyi,clabel,ndathrb2,nsecb2,ndathre2,nsece2,ieof)
      if(ieof.EQ.1) then
         write(*,*)
         stop 'RDMET2: Unexpected EOF in CALMET records'
      endif
      clabexp(1:1)='V'
      if(clabel.ne.clabexp)go to 999
c

c --- Use the W wind component (conditional) for w-divergence
c --- Values of lcalgrdp=off have been screend out in RDHDMET
c      if(lcalgrdp)then
         call rdr2d(io18,mtver,io6,wdiv(1,1,iz),wrk1,mxnxi,mxnyi,nxi,
     1              nyi,clabel,ndathrb3,nsecb3,ndathre3,nsece3,ieof)
         if(ieof.EQ.1) then
            write(*,*)
            stop 'RDMET2: Unexpected EOF in CALMET records'
         endif
         clabexp(1:5)='WFACE'
         if(clabel.ne.clabexp)go to 999
         if(ndathre2.ne.ndathre3 .OR. nsece2.ne.nsece3) goto 2999
c      endif
c

      if(ndathre1.ne.ndathre2 .OR. nsece1.ne.nsece2) goto 2999
      if(kdathre.eq.0)then
c ---    first vertical level
         kdathre=ndathre1
         ksece=nsece1

      else if(ndathre1.ne.kdathre .OR. nsece1.ne.ksece)then
c ---    date/time does not match value for previous layer
         ndathre=ndathre1
         nsece=nsece1
         go to 3999
      endif
10    continue
c
c --- Read the 3-D temperature field
c --- Values of lcalgrdp=off have been screend out in RDHDMET
c      if(lcalgrdp)then
         clabexp='T-LEV'
         do 12 iz=1,nzi
         call rdr2d(io18,mtver,io6,tmet(1,1,iz),wrk1,mxnxi,mxnyi,nxi,
     1              nyi,clabel,ndathrb,nsecb,ndathre,nsece,ieof)
         
         if(ieof.EQ.1) then
            write(*,*)
            stop 'RDMET2: Unexpected EOF in CALMET records'
         endif
c
         write(clabexp(6:8),'(i3)')iz
         if(clabel.ne.clabexp)go to 999
         if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
12       continue
c      endif
c

c --- read other 2-D meteorological fields
c
c --- PGT stability class
      call rdi2d(io18,mtver,io6,ipgti,wrk1,mxnxi,mxnyi,nxi,nyi,
     1           clabel,ndathrb,nsecb,ndathre,nsece)
      clabexp='IPGT'
      if(clabel.ne.clabexp)go to 999
      if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999

c --- FRICTION VELOCITY
      call rdr2d(io18,mtver,io6,ustari,wrk1,mxnxi,mxnyi,nxi,nyi,
     1           clabel,ndathrb,nsecb,ndathre,nsece,ieof)
      if(ieof.EQ.1) then
         write(*,*)
         stop 'RDMET2: Unexpected EOF in CALMET records'
      endif
      clabexp='USTAR'
      if(clabel.ne.clabexp)go to 999
      if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
c --- MIXING HEIGHT
      call rdr2d(io18,mtver,io6,zii,wrk1,mxnxi,mxnyi,nxi,nyi,
     1           clabel,ndathrb,nsecb,ndathre,nsece,ieof)
      if(ieof.EQ.1) then
         write(*,*)
         stop 'RDMET2: Unexpected EOF in CALMET records'
      endif
      clabexp='ZI'
      if(clabel.ne.clabexp)go to 999
      if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
c --- MONIN-OBUKHOV LENGTH
      call rdr2d(io18,mtver,io6,eli,wrk1,mxnxi,mxnyi,nxi,nyi,
     1           clabel,ndathrb,nsecb,ndathre,nsece,ieof)
      if(ieof.EQ.1) then
         write(*,*)
         stop 'RDMET2: Unexpected EOF in CALMET records'
      endif
      clabexp='EL'
      if(clabel.ne.clabexp)go to 999
      if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
c --- CONVECTIVE VELOCITY SCALE
      call rdr2d(io18,mtver,io6,wstari,wrk1,mxnxi,mxnyi,nxi,nyi,
     1           clabel,ndathrb,nsecb,ndathre,nsece,ieof)
      if(ieof.EQ.1) then
         write(*,*)
         stop 'RDMET2: Unexpected EOF in CALMET records'
      endif
      clabexp='WSTAR'
      if(clabel.ne.clabexp)go to 999
      if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
c --- PRECIPITATION DATA
      if(npstai.ne.0)then
         call rdr2d(io18,mtver,io6,rmm,wrk1,mxnxi,mxnyi,nxi,nyi,
     1              clabel,ndathrb,nsecb,ndathre,nsece,ieof)
         if(ieof.EQ.1) then
            write(*,*)
            stop 'RDMET2: Unexpected EOF in CALMET records'
         endif
      endif

c
c frr (09/01)
c --- NOOBS CALMET: full 2-D fields of the following variables instead
c --- of 1-D fields (values at the surface stations only)
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

      if(i2dmet.EQ.1) then

c ---   New CALMET output format - 2D arrays -

        call rdr2d(io18,mtver,io6,temp2d,wrk1,mxnxi,mxnyi,nxi,nyi,
     1             clabel,ndathrb,nsecb,ndathre,nsece,ieof)
        if(ieof.EQ.1) then
           write(*,*)
           stop 'RDMET2: Unexpected EOF in CALMET records'
        endif
        clabexp='TEMPK'
        if(clabel.ne.clabexp)go to 999
      if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
        call rdr2d(io18,mtver,io6,rho2d,wrk1,mxnxi,mxnyi,nxi,nyi,
     1             clabel,ndathrb,nsecb,ndathre,nsece,ieof)
       if(ieof.EQ.1) then
           write(*,*)
           stop 'RDMET2: Unexpected EOF in CALMET records'
        endif
        clabexp='RHO'
        if(clabel.ne.clabexp)go to 999
      if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
        call rdr2d(io18,mtver,io6,qsw2d,wrk1,mxnxi,mxnyi,nxi,nyi,
     1             clabel,ndathrb,nsecb,ndathre,nsece,ieof)
        if(ieof.EQ.1) then
           write(*,*)
           stop 'RDMET2: Unexpected EOF in CALMET records'
        endif
        clabexp='QSW'
        if(clabel.ne.clabexp)go to 999
      if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
        call rdi2d(io18,mtver,io6,irh2d,wrk1,mxnxi,mxnyi,nxi,nyi,
     1             clabel,ndathrb,nsecb,ndathre,nsece)
        clabexp='IRH'
        if(ieof.EQ.1) then
           write(*,*)
           stop 'RDMET2: Unexpected EOF in CALMET records'
        endif
        if(clabel.ne.clabexp)go to 999
      if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
c ---   Precipitation code at surface stations

        if(npstai.ne.0)then
          call rdi2d(io18,mtver,io6,ipcode2d,wrk1,mxnxi,mxnyi,
     1               nxi,nyi,clabel,ndathrb,nsecb,ndathre,nsece)
          clabexp='IPCODE'
          if(clabel.ne.clabexp)go to 999
          if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
       endif


      elseif(i2dmet.EQ.0) then
c ---    read 1-D meteorological fields:
c           Air temp. (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(io18,mtver,io6,tempss,nsstai,clabel,ndathrb,nsecb,
     :              ndathre,nsece)
         clabexp='TEMPK'
         if(clabel.ne.clabexp)go to 999
         if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
         call rdr1d(io18,mtver,io6,rhoss,nsstai,clabel,ndathrb,nsecb,
     :              ndathre,nsece)
         clabexp='RHO'
         if(clabel.ne.clabexp)go to 999
         if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
         call rdr1d(io18,mtver,io6,qswss,nsstai,clabel,ndathrb,
     :              nsecb,ndathre,nsece)
         clabexp='QSW'
         if(clabel.ne.clabexp)go to 999
         if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
         call rdi1d(io18,mtver,io6,irhss,nsstai,clabel,ndathrb,nsecb,
     :              ndathre,nsece)
         clabexp='IRH'
         if(clabel.ne.clabexp)go to 999
         if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
c
c ---    Precipitation code at surface stations
         if(npstai.gt.0)then
            call rdi1d(io18,mtver,io6,ipcode,nsstai,clabel,ndathrb,
     1                 nsecb,ndathre,nsece)
            clabexp='IPCODE'
            if(clabel.ne.clabexp)go to 999
            if(ndathre.ne.kdathre .OR. nsece.ne.ksece)go to 3999
         endif

      else
         write(*,*)'Subr. RDMET2:  Invalid I2DMET = ',i2dmet
         stop
      endif

c --- Enforce YYYY format 
      kyr=kdathre/100000
      kdyhr=kdathre-kyr*100000
      call YR4(io6,kyr,ierr)
      if(ierr.NE.0) then
         write(*,*)
         stop 'Halted in RDMET2 - not YYYY format in IGF-CALMET'
      endif
      kdathre=kyr*100000+kdyhr

c --- Save CALMEt-IGF ending time in the IGF.MET common file
      kdathrei=kdathre
      nsecei=ksece

c --- Check to see if required date-time has been read
      call deltsec(jdathre,jsece,kdathre,ksece,ndelsec)

      if(ndelsec.lt.0)then
c ---    Obtain next time period in MET file
         go to 1
      elseif(ndelsec.ge.istepi)then
         write(io6,*)'ERROR in subr. RDMET2 -- current hour not found ',
     1  'in the IGF-MET data file (MOD5)'
         write(io6,*)' -- Current ending date/hour/sec = ',jdathre,jsece
         write(io6,*)' -- Last date/hour read = ',kdathre,ksece
         write(*,*)
         stop 'Halted in RDMET2 -- see list file.'
      endif
c

      return
c
c --- Write error messages -- incorrect record label read
999   continue
      write(io6,1001)clabel,clabexp
1001  format(/1x,'ERROR in subr. RDMET2 -- incorrect record label ',
     1 'read from MET data file'//1x,'Label read     = ',a8/
     2                               1x,'Label expected = ',a8)
      write(*,*)
      stop 'Halted in RDMET2 -- see list file.'
c
c --- date/time variables do not match
2999  continue
      write(io6,*)'ERROR in subr. RDMET2 -- date/time variables ',
     1 'do not match -- ndathre1 = ',ndathre1,' ndathre2 = ',ndathre2,
     2 ' ndathre3 = ',ndathre3
      write(*,*)
      stop 'Halted in RDMET2 -- see list file.'
3999  continue
      write(io6,*)'ERROR in subr. RDMET2 -- date/time variables ',
     1 'do not match -- ndathre = ',ndathre,' KDATHR = ',kdathre
      write(*,*)
      stop 'Halted in RDMET2 -- see list file.'
      end
c----------------------------------------------------------------------
      subroutine rdmm4(cellzc,udat,vdat,uprog,vprog,
ccec101006     1 tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta)
     1 tprog,vptprog,mcloud,ccgrid,iceilg,rho,npsta)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203              RDMM4
c              E. Insley, Earth Tech, Inc.
c ---          Modified by M. Fernau, J. Scire, F. Robe
c              Modified by F. Robe, TRC
c
c --- UPDATES:
c
c --- v6.330 (101006) to v6.4.0 (121203)
c      - Add wind dir. rotation for Polar Stereographic projection
c
c --- V6.32 (080205) to V6.330 (101006) (CEC)
c      - Change ICLOUD into MCLOUD (and ICLDOUT)
c
c --- v6.31 (071207) to v6.32 (080205)(F. Robe)
c      - Remove prog LST times from calling list (never used)
c
c --- V6.223 (070702) to v5.81 (071207)(F. Robe)
c      - At the first timestep, use the current hour MM4 soundings  
c        to initialize TZo,ZL0 used in MIXDT2 to compute the convective 
c        mixing height growth (in the unlikely event, the first timestep
c        is convective)
c
c --- V6.222 (070404) to V6.223 (070702) to (F. Robe)
c        - Replace calls to r2interp by calls to r2interp2 to interpolate
c          rhop, rh850, rh, and ccp as r2interp2 is designed for 2D arrays 
c          while r2interp is for a slice of a 3D array 
c        - Use modified cinterp calling list

c
c --- V6.220 (070206) to V6.222 (070404) (F. Robe)
c      - Initialize nlevag1,TZ,ZL at fist call to subroutine 
c        (does not affect results but can stop execution with some
c         compilers)
c
c --- v6.218 (070113) to V6.220 (070206) (F. Robe)
c               - Compute ceiling height based on high/middle/low cloud
c                 covers (ICLOUD=4 option only) if qc not available
c
c --- V6.217 (061231) to v6.218 (070113)
c               - Bug fix: correct date comparison s.t. ok at midnight
c
c --- V6.216 (061230) to v6.217 (061231)
c               - Implement icloud=4 option (cloud cover based on
c                 RH using MM5toGrads algorithm)
c               - Sort out RH and Press arrays by ascending heights
c                 (call to updated qcksrt3 subroutine)
c               - Use rhprog as scalar not as array (save space)
c
c --- v6.210 (060408)to V6.216 (061230)(F.Robe)
c               - Bug fix:correct record dates comparison so that
c                 the MM4 fields used in CALMET are updated on an 
c                 hourly basis. In particular make sure to take
c                 nsece into account (can be =3600sec i.e. 1 hour)
c
c --- v6.206 (060322)to v6.210 (060408) (F.Robe)
c               - Change array name irhprog(mxnx,mxny) to irhpg (mxnx,mxny)
c     
c --- V6.2 (060215) to v6.206 (060322) (F.Robe)
c               - Do not use Stull night cooling overwater but extrapolate
c                 down from lowest 2 MM4 levels
c
c --- V6.0 (051128) to V6.2 (060215)(F.Robe)
c               - Change sinalp argument to take into account new sinalp 
c                 array index range
c               - Replace real argument deltas by integer ndeltas in 
c                 call to deltsec 
c               - Bug fix: Use solar angle at nearest CALMET gridpoint to 
c                 determine sunrise/sunset on MM5 grid rather than solar angle  
c                 on CALMET grid (indices and possibly array dimension mismatch
c                 if NXP> MXNX and/or NYP>MXNY)  
c           
c --- V5.611 Level 051113 to V6.0 (051128)(F.Robe)
c               - Use explicit beginning current times
c               - Store UDAT,VDAT,UPROG,VPROG in UDATS,VDATS,UPROGS,VPROGS
c                 when new data is read so they can be used when data is not
c                 read in (sub-hourly CALMET timesteps) (necessary because
c                 UDAT,VDAT,UPROG,VPROG are reset to zero before every call
c                 to RDMM4               
c
c --- V5.6 Level 050328 to v5.611 Level 051113  (F.Robe)
c               - Use index1 instead index+1 in call to STULL (F.Robe)
c
c --- Version V5.548b Level 050113 to V5.6 Level 050328
c               - use previous hour soundings to compute lapse rates above 
c                 previous  hour mixing height  instead of current hour 
c                 lapse rates to avoid unrealistic overgrowth of mixing height
c                 (used in MIXDT2 - itprog>0 mode)
c
c --- V5.547 (041016) to V5.548b (050113)  (F.Robe)
c               - Make sure no duplicate z levels are used in subroutines
c                 STULL0,STULL
c
c --- V5.546 (040924) to V5.547 (041016) (F.Robe)
c               - Add ability to read multiple (consecutive or overlapping)
c                 MM4.DAT files
c               - explicit common replaced by include d4/d6.met 
c
c --- V5.53 (030709) to V5.546 (040924)  (DGS)
c               - Reset pressure check from 8500 to 850 (millibars)
c                 The code had been written for pressure in tenths of
c                 millibars, but the pressure has been converted to
c                 millibars, so level 1 of the RH profile was selected
c                 instead.
c --- V5.52 (030515) to V5.53 (030709)  (F.Robe)
c               - Remove spurious statement (bug fix)
c --- V5.5 (030402) to V5.5 (030402)  (J. Scire)
c               - Add checks to MM4.DAT read statements to confirm
c                 MM4 I,J indexes read match expected values
c --- V5.4 (030119) to V5.5 (030402)  (DGS)
c               - Add list-file unit to JULDAY, INDECR, YR4 calls
c               - LLCONF replaced with LLCC
c               - /MAP/ replaces /LON/
c               - Change documentation:  coordinates may be other than
c                 UTM or LLC
c     V5.3 - frr 030119: NOOBS version for MM4 data as well (hourly
c            MM4 records only)
c 
c
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
C     THIS SUBROUTINE READS AND INTERPOLATES THE MM4 PROGNOSTIC MODEL
C     OUTPUT TO THE DIAGNOSTIC MODEL GRID
C
C     INPUTS:  CELLZC R-ARRAY  - DIAGNOSTIC WIND MODEL CELL-CENTER HEIGHTS
C
C     OUTPUTS:  UDAT  R-ARRAY  - U-COMPONENT OF THE WIND PROGNOSTIC HORIZONTAL
C                                GRID INTERPOLATED TO CALMET LEVELS
C               VDAT  R-ARRAY  - V-COMPONENT OF THE WIND PROGNOSTIC HORIZONTAL
C                                GRID INTERPOLATED TO CALMET LEVELS
C               UPROG R-ARRAY  - U-COMPONENT OF THE PROGNOSTIC WIND FIELD
C                                INTERPOLATED TO CALMET GRID
C               VPROG R-ARRAY  - V-COMPONENT OF THE PROGNOSTIC WIND FIELD
C                                INTERPOLATED TO CALMET GRID
C               TPROG R-ARRAY  - PROGNOSTIC TEMPERATURE FIELD
C                                INTERPOLATED TO CALMET GRID
C             VPTPROG R-ARRAY  - PROGNOSTIC VIRTUAL POTENTIAL TEMPERATURE
c                                FIELD INTERPOLATED TO CALMET GRID
c             CCGRID  R-ARRAY  - Gridded cloud cover computed with MM4
c                                Relative humidity (if mcloud=3 or 4)
c             ICEILG  I-ARRAY  - ceiling height 
c               RHO   R-ARRAY  - 2-D surface air density on CALMET grid
c       
c              NPSTA  INT      - Precipitation flag:use MM5 if NPSTA=-1
C
c     OUTPUT VIA COMMON MM5TEMP
c                 ZL  R-ARRAY  - ELEVATION ABOVE GROUND OF MM5 LEVELS AT
C                                MM5 GRIDPOINT CLOSEST TO GIVEN CALMET
C                                GRIDPOINT. Artificial zl=0 level added
c                 TZ  R-ARRAY  - VERTICAL PROGNOSTIC TEMPERATURE PROFILE
C                                AT GIVEN CALMET GRIDPOINT BASED ON CLOSEST
C                                MM5 GRIDPOINT. Surface temperature is
c                                copied from first MM5 level .
c                                Not interpolated in time: past (or present)
c                                time (NOT future) is passed to MIXHT2/MIXDT2
c                                This is consistent with using most recent past
c                                upper air sounding in MIXHT/MIXDT
c                             
c 
c
c     OUTPUT VIA COMMON SURFPROF
c             iRHPG I-ARRAY  - SURFACE RELATIVE HUMIDITY INTERPOLATED
C                                TO CALMET GRID (IN PERCENT)
c            IPCODEPG I-ARRAY  - SURFACE PRECIPITATION CODE INTERPOLATED
C                                TO CALMET GRID (0: NO PRECIP - 10: LIQUID
C                                20: FROZEN - 9999: MISSING)
c     OUTPUT VIA COMMON METGRD
c               RMM   R-ARRAY  - PRECIPITATION RATE (mm/hr) on calmet grid
C
C     OTHER VARIABLES:
C               NXP      INT   - NO. OF PROGNOSTIC MODEL GRID POINTS IN THE
C                                X-DIRECTION
C               NYP      INT   - NO. OF PROGNOSTIC MODEL GRID POINTS IN THE
C                                Y-DIRECTION
C               NZP      INT   - NO. OF PROGNOSTIC MODEL LEVELS
C               NLEVAG   INT   - NO. OF PROGNOSTIC MODEL LEVELS ABOVE GROUND
C               XMAP0   REAL   - LOCATION OF ORIGIN (X IN KM) IN REAL SPACE
C                                COORDINATES
C               YMAP0   REAL   - LOCATION OF ORIGIN (Y IN KM) IN REAL SPACE
C                                COORDINATES
C
c        Parameters: MXNX, MXNY, MXNZ, MXNXP, MXNYP, MXNZP, IO6
c
c --- RDMM4 called by:  DIAGNO
c --- RDMM4 calls:      JULDAY, INDECR, QCKSRT3, R2INTERP, ESAT, YR4
c----------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'gen.met'
      include 'map.met'
      include 'grid.met'
c frr 030119 set the precipitation rate rmm
      include 'metgrd.met'


      include 'd4.met'
      include 'd6.met'
      include 'mm4hdo.met'

      common/mm4dum/ix,jx,zdum,wddum,wsdum,pdum,itdum,idddum

c --- Multiple MM4.DAT filenames
      include 'filnam.met'

c frr 030119 - 050328 (use previous,not current, hour)
c     common with mixdt2 (computation of mixing height in noobs mode)
      common/mm5temp/nlevag0,zl0(mxnx,mxny,mxnzp+1),
     :                       tz0(mxnx,mxny,mxnzp+1)

c     common with surfvar: 2D surface prognostic data
      common /surfprog/irhpg(mxnx,mxny),ipcodepg(mxnx,mxny)

c 
c     Initialisation in RDHD4 
c --- number of current mm5 file (nfm3d)
      COMMON /PROGSTEP/ ifirstpg,nfm3d

      DIMENSION UPROG(mxnx,mxny,*), VPROG(mxnx,mxny,*),
     1          UP(mxnxp,mxnyp,mxnzp), VP(mxnxp,mxnyp,mxnzp),
     1          UDAT(mxnxp,mxnyp,mxnz), VDAT(mxnxp,mxnyp,mxnz),
     2          CELLZC(*),z(mxnzp),ws(mxnzp),wd(mxnzp),
     &          zp(mxnxp,mxnyp,mxnzp),
     &          t(mxnzp),tp(mxnxp,mxnyp,mxnzp),
     &          tmm4(mxnxp,mxnyp,mxnz),tprog(mxnx,mxny,*),
     &          vpt1(mxnzp),vptp(mxnxp,mxnyp,mxnzp),
     &          vptdat(mxnxp,mxnyp,mxnz),vptprog(mxnx,mxny,*),
c frr 030119
     &          rh850pg(mxnx,mxny),rh850(mxnxp,mxnyp),
     &          rh(mxnxp,mxnyp),
     &          ccgrid(mxnx,mxny),iceilg(mxnx,mxny),
     &          rhop(mxnxp,mxnyp),rho(mxnx,mxny),
     &          rain(mxnxp,mxnyp),indx(mxnxp,mxnyp),
     &          pt20(mxnxp,mxnyp), pt30(mxnxp,mxnyp),
     &          tsurf(mxnxp,mxnyp),
     &          zl(mxnx,mxny,mxnzp+1),tz(mxnx,mxny,mxnzp+1), 
c frr 061230 -070206
     &          rhp1(mxnzp),rhp(mxnxp,mxnyp,mxnzp),
     &          press(mxnzp),pp(mxnxp,mxnyp,mxnzp),
     &          ccp(mxnxp,mxnyp),ceilp(mxnxp,mxnyp)

c --- Storage arrays for sub-hourly CALMET timesteps
      DIMENSION UPROGS(mxnx,mxny,mxnz), VPROGS(mxnx,mxny,mxnz),
     1          UDATS(mxnxp,mxnyp,mxnz), VDATS(mxnxp,mxnyp,mxnz)

      save uprogs,vprogs,udats,vdats

c --- Only update on an hourly basis, Not at every CALMET timestep (060215)
c     if (nsece.ne.0 .and. ifirstpg.ne.0) then
c --- bug fix (061230)
      if (nsecb.ne.0 .and. ifirstpg.ne.0) then

c ---    Fill in with stored variables  
         do k=1,mxnz
            do j=1,mxny
            do i=1,mxnx
                uprog(i,j,k)=uprogs(i,j,k)
                vprog(i,j,k)=vprogs(i,j,k)
            end do
            end do
            do j=1,mxnyp
            do i=1,mxnxp
                udat(i,j,k)=udats(i,j,k)
                vdat(i,j,k)=vdats(i,j,k)
            end do
            end do
         end do

        return

      endif

c --- BUG FIX: ifirstpg should not be updated here (it is later) otherwise
c --- pt20,pt30 are not initialized and surface temp. are zeroes (i.e. crash
c --- when itprog=2 and computes lapse rates incorrectly when itprog=1
c --- frr 061230
c     if (ifirstpg.eq.0) ifirstpg=1

c --- Initialize variables (070404)
      if (ifirstpg.eq.0) then
         nlevag1=0
         do k=1,mxnzp+1
         do j=1,mxny
         do i=1,mxnx
            tz(i,j,k)=0.
            zl(i,j,k)=0.
         end do
         end do
         end do
      endif         
         
*****
c
c --- Initialize constants
      deg2rad=0.0174533
C
c --- Set number of levels to read; sfc and mandatory (1st 8 levels)
c --- plus nzp significant levels
      nlev = 8+nzp
c --- Loop over each grid cell in extraction subdomain
 1    continue
      do 5 j=1,nyp
      do 5 i=1,nxp
c ---   Read date record of data portion
c frr 030119 : read all variables of first record in MM4.DAT
c        read(io20,60,end=999) myr,mmo,mday,mhr,ix,jx
        read(io20,60,end=999)myr,mmo,mday,mhr,ix,jx,
     :       pmsl,rain(i,j),isnow
60      format(4i2,2i3,f7.1,f5.2,i2)
c60      format(4i2,2i3)

c ---   Check that MM4 grid point I,J read match expected values
        ixexpect=i+i1-1
        jxexpect=j+j1-1
        if(ix.ne.ixexpect.or.jx.ne.jxexpect)then
           write(io6,960)myr,mmo,mday,mhr,ix,jx,ixexpect,jxexpect
960        format(1x,'Error in Subr. RDMM4 -- Error in MM4.DAT file'/
     1     1x,'MM4 grid point I,J do not match expected values'/
     2     1x,'MM4 date/time:  Yr: ',i4,1x,'Mo: ',i2,1x,'Day: ',i2,
     3     1x,'Hr: ',i2,' (GMT)'/
     4     1x,     'MM4 I,J: ',2i4/
     5     1x,'Expected I,J: ',2i4)
c
           print *,'Error in Subr. RDMM4 -- Error in MM4.DAT file'
           print *,'MM4 grid point I,J do not match expected values'
           stop
        endif
c
        call YR4(io6,myr,ierr)
        if(ierr.NE.0) stop 'Halted in RDMM4'
c ---   Convert date/time from GMT to LST
        call julday(io6,myr,mmo,mday,mjul)
        idtz = 0 - ibtz
        call indecr(io6,myr,mjul,mhr,idtz,0,23)
c
c ---   Check whether data are beyond current time step
c ---   (this should not happen because checked in READHD)
        mdathr=myr*100000+mjul*100+mhr
c       if (mdathr .gt. ndathr) then
c ---   explicit times (060215)
c ---   take into account seconds (can be 3600sec =1hr) 061230 and midnight (070113)
c       if (mdathr .gt. ndathre) then
c       if (mdathr .gt. (ndathrb+1)) then
        call deltsec(ndathre,nsece,mdathr,0,ndeltas)
        if (ndeltas.gt.0) then
          write(io6,*) ' MM4 data record is beyond CALMET time step: '
c         write(io6,*) myr,mjul,mhr,nyr,njul,nhr,i,j,ix,jx
          write(io6,*) myr,mjul,mhr,nyrb,njulb,nhrb,i,j,ix,jx
          print *,'MM4 data record is beyond CALMET time step - STOP -'
          stop
        endif
c
c ---   Check whether need to skip a record
        iskip = 0

c        if (mdathr .lt. ndathr) iskip = 1
c        if (mdathr .lt. ndathre) iskip = 1
c ---   bug fix (061230) - ndathre does not properly reflect the end of an hour because
c ---   it does not take into account nsece which is 3600sec at the end of the hour
        if (mdathr .lt. (ndathrb+1)) iskip = 1

c
c ---   Read data levels
        if(iskip.EQ.0) then
c ---     Want to use these data levels

c030119   initialize RH array
          rh850(i,j)=0.

c030119   convert rainfall rate from cm/hr to mm/hr
          rain(i,j)= rain(i,j)*10.

          do 35 n=1,nlev
c ---       Read sfc and mandatory (1st 8 levels) + nzp significant levels
            read(io20,70) press(n),z(n),itmp,idd,wd(n),ws(n)

70          format(f5.1,f6.0,i4,i2,f4.0,f2.0)
c ---       Adjust temperature to correct value and sign
c           (0.1 degrees; odd number = negative)
            xneg = 1.
            if (mod(itmp,2) .ne. 0) xneg = -1.
            t(n) = xneg * float(itmp) / 10.
c ---       Adjust dew point depression (< 56 = 0.1 degrees C; >= 56
c           = whole degrees C - 50.)
c ---       RH1 is work variable: 1st = dew point depression, then
c           dew point, then relative humidity
            if (idd .lt. 56) then
              rh1 = float(idd) / 10.
            else
              rh1 = float(idd) - 50.
            end if
c ---       Convert dew point depression to dew point
            rh1 = t(n) - rh1
c ---       Calculate relative humidity using empirical formula from
c           Bosen (Monthly Weather Review, vol 86, pg 486 [1958])
            ztmp = 1.8 * t(n) + 32.
            zdp  = 1.8 * rh1 + 32.
            xnum = 173. - 0.1 * ztmp + zdp
            xdenom = 173. + 0.9 * ztmp
            rh1 = (xnum / xdenom) ** 8.0
            rh1 = rh1 * 100.
            if (rh1 .gt. 100.) rh1 = 100.
c 061230 (frr)
            rhp1(n)=rh1

c 030119 (frr)
c 040924 (dgs)
c ---       Store RH at (near) 850 mb for cloud cover computation
c           Allow for surface pressure < 850mb (happens e.g. SW Wyoming)
            if (n.eq.1 .or. press(n).gt.850.)rh850(i,j)=rh1

c ---       Convert Celsius temperature to Kelvins
            tairc = t(n)
            t(n) = t(n) + 273.15

c ---       Calculate potential temperature
            pt1 = t(n) * ((1000./press(n)) ** 0.286)
c
c --- compute saturation and actual water vapor pressure (mb)
c --- (NOTE: ESAT function uses temperature in deg. C)
c --- (constant 0.01 converts rh from percent to fraction)
            es = esat(tairc)
            e = 0.01 * rh1 * es
c
c --- compute actual mixing ratio (g h20/g dry air)
            w = 0.622 * e / (press(n) - e)
c --- compute specific humidity
            q = w / (1 + w)
c --- compute virtual potential temperature
            vpt1(n) = pt1 * (1. + 0.61 * q)
c ---       Adjust heights from msl to ht above local ground
            z(n) = z(n) - float(ielev4(i,j))
            
c frr 030119 Surface RH and rho
            if (n.eq.1) then
              rh(i,j)=rh1
              rhop(i,j)= 0.3484321*press(1)/t(1)
            endif
35        continue
c
c ***     Replace above sfc 1000mb calm winds with sfc winds
c ***     (fix needed for initial IWAQM data)
c ***     if(z(2).GE.z(1))then
c ***       if(wd(2).LT. 0.001 .AND. ws(2).LT.0.001)then
c ***         wd(2) = wd(1)
c ***         ws(2) = ws(1)
c ***       endif
c ***     endif

c ---     Sort arrays by ascending height
          call qcksrt3(nlev,z,wd,ws,t,vpt1,rhp1,press)
    
c frr 030119 Several pressure levels can be recorded at the same height
c         (owing to round-off errors). Only keep one level per height
c         => delete one level
          nlevok=nlev
          do k=1,nlev-1
             if (z(k).eq.z(k+1))then
                 do kk=k+1,nlevok-1
                    z(kk)=z(kk+1)
                    wd(kk)=wd(kk+1)
                    ws(kk)=ws(kk+1)
                    t(kk)=t(kk+1)
                    vpt1(kk)=vpt1(kk+1)
                    rhp1(kk)=rhp1(kk+1)
                    press(kk)=press(kk+1)
                 end do
                 nlevok=nlevok-1
             endif
          end do

c ---     Convert wd,ws to u,v components and store in grid arrays
c ---     Store temperature in grid array
c ---     Store RH in grid array
          nlevag=0
c         do 45 k=1,nlev
          do 45 k=1,nlevok
            if(z(k).GE.-0.0001)then
c ---         Use only above ground level
              nlevag = nlevag + 1

c --- v6.4.0, Level 121203
              if(LLCC .OR. LPS) then

c ---           Convert wd from true north (south) to Lambert Conformal
c ---           map north (south)
c ---           MM4 west longitudes are negative but RLON0 is positive
                dlong =  rlon0 + xlong4(i,j)
c --- Code to handle 180 degree longitude straddle
                if (dlong .gt. 180.) dlong = dlong - 360.
                if (dlong .lt. -180.) dlong = dlong + 360.
                if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
                  wdmap = wd(k) + (conec*dlong)
                else
c --- Northern Hemisphere
                  wdmap = wd(k) - (conec*dlong)
                end if
                if(wdmap.LT.0.) wdmap = wdmap + 360.
                if(wdmap.GT.360.) wdmap = wdmap - 360.
                wd(k) = wdmap
              endif
c ---         Convert ws from knots to m/s,
              ws(k) = ws(k) * 0.51444
              wdrad = deg2rad*wd(k)
              up(i,j,nlevag) = -ws(k) * sin(wdrad)
              vp(i,j,nlevag) = -ws(k) * cos(wdrad)
              tp(i,j,nlevag) = t(k)
              vptp(i,j,nlevag) =vpt1(k)
              zp(i,j,nlevag) = z(k)
              rhp(i,j,nlevag)= rhp1(k)
              pp(i,j,nlevag)=press(k)
            endif
45        continue


c ---     INDEX is the height of the lowest true half-sigma MM4 level
          if(zp(i,j,1).lt.1.0)then
c ---        MM4 level at the ground surface is not a half-sigma level
             index=2
          else
c ---        Lowest MM4 level is above the surface
             index=1
          endif
          indx(i,j)=index

c frr 030119 - Determine whether day or night for temp. extrapolation
c          if (mhr.eq.0)then
c             sina=sinalp(i,j,24)
c          else
c             sina=sinalp(i,j,mhr)
c          endif
c
c --- Use nearest CALMET gridpoint (i,j loops over MM4 grid at this point
c --- and sinalp is defined on CALMET grid) 
c --- Only hourly MM4 records and explicit MM4 time is interpreted as 
c --- hour-ending time. Therefore use sinalp at (mhr-1/2) i.e. sinalp(i,j,mhr+1)
c --- because in MOD6, sinalp has 26 values ranging from 23:30 previous day
c --- to 0:30 on next day 
          sina=sinalp(inearg(i,j),jnearg(i,j),mhr+1)

c frr 030106
c         initialize pot.temp history for temp extrapolation 
          if (ifirstpg.eq.0) then
c ---        Make sure not to pass duplicate levels to subroutine (050113-frr)
             if (zp(i,j,index).ne.zp(i,j,index+1))then
                 index1=index+1
             else
                 index1=index+2
             endif
             call stull0(vptp(i,j,index)  ,zp(i,j,index),
     :                   vptp(i,j,index1),zp(i,j,index1),
     :                   pt20(i,j),pt30(i,j))
          endif

c         Record pot.temp before sunset for extrapolation at night
c         record even if cellzc(k) not below lowest MM4 level at that
c         time because this may change during the night (MM4 levels
c         are usually not fixed in Z (but in sigma or p)
c         assume virt pot. temp ~ pot. temp.
          if (sina.gt.0)then
             pt20(i,j) = vptp(i,j,index)
             pt30(i,j) = vptp(i,j,index+1)
          endif


C ---     INTERPOLATE PROGNOSTIC SOUNDINGS VERTICALLY TO DIAGNOSTIC
C ---     MODEL LEVELS
          DO 75 K = 1,NZ
c
c ---       Persist data below bottom level
            IF(CELLZC(K).LT.zp(i,j,1))then
               UDAT(I,J,K)=UP(I,J,1)
               VDAT(I,J,K)=VP(I,J,1)
               TMM4(I,J,K)=TP(I,J,1)
               VPTDAT(I,J,K)=VPTP(I,J,1)
c
c ---       Persist data above top MM4 level
            else if(CELLZC(K).GE.zp(i,j,nlevag))then
               UDAT(I,J,K)=UP(I,J,nlevag)
               VDAT(I,J,K)=VP(I,J,nlevag)
               TMM4(I,J,K)=TP(I,J,nlevag)
               VPTDAT(I,J,K)=VPTP(I,J,nlevag)
c
c
c ---       Interpolate to CALMET level from surrounding MM4 levels
            else
               DO KP = 2,nlevag
                  KPM1 = KP - 1
                  IF(zp(i,j,KPM1).LE.CELLZC(K).AND.
     1               zp(i,j,KP).GT.CELLZC(K))THEN
                     ratio1=(CELLZC(K)-zp(i,j,KPM1))/
     1                      (zp(i,j,KP)-zp(i,j,KPM1))
                     UDAT(I,J,K)=UP(I,J,KPM1)+(UP(I,J,KP)-UP(I,J,KPM1))
     1                           *ratio1
                     VDAT(I,J,K)=VP(I,J,KPM1)+(VP(I,J,KP)-VP(I,J,KPM1))
     1                           *ratio1
                     TMM4(I,J,K)=TP(I,J,KPM1)+(TP(I,J,KP)-TP(I,J,KPM1))
     1                           *ratio1
                     VPTDAT(I,J,K)=VPTP(I,J,KPM1)+(VPTP(I,J,KP)-
     1                           VPTP(I,J,KPM1))*ratio1
                     go to 77
                  endif
               enddo
77             continue
            endif
c
c ---       Replace winds below first MM4 half-sigma level with 
c ---       extrapolated logarithmic profile winds. Ignore MM4 surface
c ---       (Z=0) winds, 
c
c ---       Use a logarithmic profile to extrapolate winds down toward
c ---       the surface
            if(cellzc(k).lt.zp(i,j,index))then
c ---          Assume a typical roughness length for extrapolation 
c ---          purposes
               zoave=0.5
               xlnzo=alog(zoave)
c ---          ZP(i,j,index) is the lowest true MM4 half-sigma level
               xlnz2=alog(zp(i,j,index))
c ---          CELLZC(k) is the CALMET grid point height
               xlnz1=alog(cellzc(k))
c ---          Logarithmic profile scaling factor
               ratio2=(xlnz1-xlnzo)/(xlnz2-xlnzo)
               UDAT(I,J,K)=ratio2*UP(I,J,index)
               VDAT(I,J,K)=ratio2*VP(I,J,index)

c
c frr 030119  Extrapolate temperature downwards assuming dry adiabatic
c             during the day and Stull cooling profile at night
              if (sina .le. 0.) then
c               nighttime
c ---           Make sure not to pass duplicate levels to subroutine (050113-frr)
                if (zp(i,j,index).ne.zp(i,j,index+1))then
                    index1=index+1
                else
                    index1=index+2
                endif
c ---           Differentiate between land/water (no sharp cooling as parameterized by
c ---           Stull over ocean) (060322)
                if (ilu4(i,j).eq.iluoc3d) then
c ---              ocean
                   zx=(cellzc(k)-zp(i,j,index))/
     :                (zp(i,j,index1)-zp(i,j,index))
                   vptdat(i,j,k)=vptp(i,j,index)
     :                 +zx*(vptp(i,j,index1)-vptp(i,j,index))
                else
c ---              land

                   call stull(zp(i,j,index) ,vptp(i,j,index),pt20(i,j),
     :                  zp(i,j,index1),vptp(i,j,index1),
     :                  pt30(i,j),cellzc(k),vptdat(i,j,k))
                endif

c               compute T from theta and z
c               note that pressure is not sorted by qcksrt3 so
c               initial pressure levels do not correspond to  initial z
c               => use t=theta *exp(AZ)*B , and 2 levels to determine A and B
                A=log( (tp(i,j,index)*vptp(i,j,index+1))/
     :              (tp(i,j,index+1)*vptp(i,j,index)) )/
     :              (zp(i,j,index)-zp(i,j,index+1))
                B=exp(-A*zp(i,j,index))*tp(i,j,index)/vptp(i,j,index)

                tmm4(i,j,k)= vptdat(i,j,k)*exp(a*cellzc(k))*B
              else
c             daytime: assume "dry" adiab and constant theta virt)
                vptdat(i,j,k)=vptdat(i,j,1)
                TMM4(I,J,K)= tp(i,j,index)+
     :                         0.0098*(zp(i,j,index)-cellzc(k))
              endif


            endif

75        CONTINUE


c frr 030119 Extrapolate temperature down to the surface
          
            if (sina .le. 0.) then
c              nighttime
c ---          Make sure not to pass duplicate levels to subroutine (050113-frr)
               if (zp(i,j,index).ne.zp(i,j,index+1))then
                  index1=index+1
               else
                  index1=index+2
               endif
               if (ilu4(i,j).eq.iluoc3d) then
c ---              ocean
                   zx=-zp(i,j,index)/
     :                (zp(i,j,index1)-zp(i,j,index))
                   ptsurf=vptp(i,j,index)
     :                   +zx*(vptp(i,j,index1)-vptp(i,j,index))
               else
c ---             land
                  call stull(zp(i,j,index) ,vptp(i,j,index),pt20(i,j),
     :                       zp(i,j,index1),vptp(i,j,index1),
     :                       pt30(i,j),0.,ptsurf)
               endif

c              compute T from theta and z
c              note that pressure is not sorted by qcksrt3 so
c              initial pressure levels do not correspond to  initial z
c              => use t=theta *exp(AZ)*B , and 2 levels to determine A and B
               A=log( (tp(i,j,index)*vptp(i,j,index+1))/
     :                   (tp(i,j,index+1)*vptp(i,j,index)) )/
     :                   (zp(i,j,index)-zp(i,j,index+1))
               B=exp(-A*zp(i,j,index))*tp(i,j,index)/vptp(i,j,index)
               tsurf(i,j)= ptsurf*B

            else
c              daytime: assume "dry" adiab and constant theta virt)
c frr 030709: bug  vptdat(i,j,k)=vptdat(i,j,index)
               Tsurf(I,J)= tp(i,j,index)+0.0098*zp(i,j,index)
            endif

          if (ifirstpg.eq.0 .and. i.eq.nxp .and. j.eq.nyp) ifirstpg=1

        else
          do 65 n=1,nlev
c ---       "Read" (skip) data
            read(io20,70) pdum,zdum,itdum,idddum,wddum,wsdum
65        continue
        endif
5     continue
c


c --- Do another iteration through the i,j loop if current time not yet reached
      if (iskip .eq. 1) goto 1
c

c --- Compute cloud cover on MM4 grid if icloud=4
c --- Method 4 (MM5toGrads): cloud cover from prognostic relative humidity
c --- at all levels - Ceiling height 
ccec101006      if (icloud.eq.4) call cloud4(nxp,nyp,nlev,rhp,pp,zp,ccp,ceilp)
      if (mcloud.eq.4) call cloud4(nxp,nyp,nlev,rhp,pp,zp,ccp,ceilp)

      goto 997
c
c --- ran out of data
c
 999  if (iskip .eq. 1) then
        write(io6,*) ' ran out of MM4 data before start!'
        stop
c --- open next MM4.DAT file if available and skip header
       else if (nfm3d.lt.nm3d) then
           nfm3d=nfm3d+1
           close(io20)
           open(io20,file=m3ddat(nfm3d),status='old')
           do nn=1,3+nzp+nxp*nyp
              read(io20,*)
           end do
           goto 1
      else
        write(io6,*) ' ran out of MM4 data during run...'
        stop
      end if
 997  continue
C
C     INTERPOLATE PROGNOSTIC SOUNDINGS HORIZONTALLY TO DIAGNOSTIC MODEL
C     GRID
C
c --- Convert diagnostic grid spacing from m to km
      dxk = dx * 0.001
      dyk = dy * 0.001
c
c --- Compute cell center x,y of diagnostic grid cell (1,1)
c *** xorigcc = utmxor + (0.5*dxk)
c *** yorigcc = utmyor + (0.5*dyk)
c --- Compute diagnostic grid coordinates in real space
      xorigcc = xmap0 + (0.5 * dxk)
      yorigcc = ymap0 + (0.5 * dyk)
c

c 030119 interpolate rainfall 
      if (npsta.eq.-1) then
         call interpqr(rain,rmm)
      endif

c --- Loop over diagnostic grid
      do 125 j = 1,ny
c --- Compute Y of cell center
      y = yorigcc + (j - 1) * dyk
         do 125 i = 1,nx
c ---      Compute X of cell center
           x = xorigcc + (i - 1) * dxk

c ---      Interpolate horizontally from prognostic grid to diagnostic
c ---      grid x,y using inverse distance squared at four nearest points.
c
           do 126 k = 1,nz
             call r2interp(i,j,x,y,udat,k,uprog(i,j,k))
             call r2interp(i,j,x,y,vdat,k,vprog(i,j,k))
             call r2interp(i,j,x,y,tmm4,k,tprog(i,j,k))
             call r2interp(i,j,x,y,vptdat,k,vptprog(i,j,k))
126        continue


c frr (030119) - Interpolate horizontally surface variables onto CALMET grid
c          Surface density
c ---      070702: use r2interp2 for 2D array rather than r2interp
c          call r2interp(i,j,x,y,rhop,1,rho(i,j))
           call r2interp2(i,j,x,y,rhop,rho(i,j))

c          Surface RH
c ---      070702: use r2interp2 for 2D array rather than r2interp
c          call r2interp(i,j,x,y,rh,1,rhprog)
           call r2interp2(i,j,x,y,rh,rhprog)
           irhpg(i,j) = int(rhprog)
         
c          RH at 850 mb
c ---      070702: use r2interp2 for 2D array rather than r2interp
c          call r2interp(i,j,x,y,rh850,1,rh850pg(i,j))
           call r2interp2(i,j,x,y,rh850,rh850pg(i,j))


c          precip code (10 for liquid (isnow=0), 20 for frozen (isnow=1))  
           if (npsta.eq.-1 .and. rmm(i,j).gt.0. ) then
               if (tprog(i,j,1).lt.273.15) then
                  ipcodepg(i,j)=20
               else
                  ipcodepg(i,j)=10
               endif
           else
              ipcodepg(i,j)=0
           endif

c ---      cloud cover and ceiling height if icloud=4
ccec101006           if (icloud.eq.4)then
           if (mcloud.eq.4)then
c ---      070702: use r2interp2 for 2D array rather than r2interp
c             call r2interp(i,j,x,y,ccp,1,ccgrid(i,j))
              call r2interp2(i,j,x,y,ccp,ccgrid(i,j))
c ---      070702: modified cinterp to deal with 2D arrays
c             call cinterp(i,j,x,y,ceilp,1,ceilg)
              call cinterp(i,j,x,y,ceilp,ceilg)
              iceilg(i,j)=int(ceilg/30.48)
           endif

c 030119   Vertical profiles of temperatures (for mixing heights in MIXDT2)
c          Use above surface MM4 levels ( index -> top)- add one for surface
c 050328   first save previous hour value
           nlevag0=nlevag1
           nlevag1=nlevag+1

c 050328   Save previous hour soundings to compute previous hour lapse rate in MIXDT          
           do 622 k = 1,nlevag0
             tz0(i,j,k)=tz(i,j,k) 
             zl0(i,j,k)=zl(i,j,k) 
 622       continue

c ---      Update progn.temperature soundings with current hour values

           index=indx(igrab(i,j,1),jgrab(i,j,1))
           do 722 k = 2,nlevag1+1-index
             tz(i,j,k) = tp(igrab(i,j,1),jgrab(i,j,1),index+k-2)
             zl(i,j,k) = zp(igrab(i,j,1),jgrab(i,j,1),index+k-2)
 722       continue
           do 723 k=nlevag1+2-index,nlevag1
             tz(i,j,k) = tz(i,j,k-1)
             zl(i,j,k) = zl(i,j,k-1)+1.
 723       continue
             zl(i,j,1) = 0.
             tz(i,j,1)=tsurf(igrab(i,j,1),jgrab(i,j,1))

c ---      Fill in temp soundings with current value for the first valid timestep
c ---      to avoid all zeroes in MIXDT2 if first timestep is convective (071207)
           if (ifirstpg.eq.1) then
               nlevag0=nlevag1
               if(i.eq.nx.and.j.eq.ny) ifirstpg=2
               do 6622 k = 1,nlevag0
                 tz0(i,j,k)=tz(i,j,k) 
                 zl0(i,j,k)=zl(i,j,k) 
 6622          continue
           endif    


125      continue


c frr(030119)  compute cloud cover  if icloud=3
ccec101006      if (icloud.eq.3) then
      if (mcloud.eq.3) then
c ---   Method 3 (Teixera): cloud cover from prognostic relative humidity at 850 mb
        call cloud3(nx,ny,rh850pg,ccgrid)
      endif

c --- set constant ceiling height at 8000ft (for icloud=3)
ccec101006      if (icloud.eq.3) then
      if (mcloud.eq.3) then
        do 138 j=1,ny
        do 138 i=1,nx          
           iceilg(i,j) = 80
138     continue

      endif
 

c --- Store variables for sub-hourly timesteps (060215)
         do k=1,mxnz
            do j=1,mxny
            do i=1,mxnx
                uprogs(i,j,k)=uprog(i,j,k)
                vprogs(i,j,k)=vprog(i,j,k)
            end do
            end do
            do j=1,mxnyp
            do i=1,mxnxp
                udats(i,j,k)=udat(i,j,k)
                vdats(i,j,k)=vdat(i,j,k)
            end do
            end do
         end do


      return
      end
c----------------------------------------------------------------------
      subroutine rdmm5(cellzc,udat,vdat,uprog,vprog,tprog,vptprog,
ccec101006     1                 icloud,ccgrid,iceilg,rho,npsta,itwprog)
     1                 mcloud,ccgrid,iceilg,rho,npsta,itwprog)
c----------------------------------------------------------------------
C
c --- CALMET   Version: 6.4.0     Level: 121203              RDMM5
c              F.Robe
c ---          Modified by M. Fernau, F.Robe ,J. Scire (Earth Tech Inc.)
c ---          Modified by F. Robe, TRC
c
c --- UPDATES:
c
c --- v6.330 (101006) to v6.4.0 (121203)
c        - Add wind dir. rotation for Polar Stereographic projection
c        - Add liquid water processing for AUX file
c        - Revise test on CVER3D for change in water variables format
c          so that older format is used only for version 2.0 (logic
c          was not correct for versions greater than 2.1)
c
c --- v6.327 (090511) to v6.330 (101006) (CEC)
c     (1) Change ICLOUD into MCLOUD (and ICLDOUT)
c
c --- v6.326 (080709) to v6.327(090511) (F.RobE)
c     (1) Initialize qc and qr that may not be read from MM5
c
c --- V6.325 (080512) to v6.326 (080709)
c     (1) Modify timecheck in RDMM5 for the case of multiple overlapping
c         MM5 input data files to avoid the simulation to stop one hour
c         short. Results not affected by this fix
c     (2) Fixed typo in error message
c     (3) Only call cloud4 if new valid data (icloud=4 option)
c         Note: if compiling with linux 64bits, the -Msave compilation
c         flag must be on otherwise some variables can take random
c         values (e.g. msec, nlevag1 and probably others)
c
c --- v6.323 (080411) to V6.325 (080512) (F.Robe)
c      - Bug fix: Update values of gridpoint location in the call to  
c        cinterp and r2interp2 (flagged by Bruno Santos)
c        Affects computation of prognostic ceiling height.
c      - Apply temperature interpolation overwater at CALMEt levels
c        below lowest M3D level to actual temperature array
c        when ITWPROG=2 (flagged by Bruno Santos)
c
c --- v6.321 (080325)to v6.323 (080411) 
c      - Bug fix: check values of ceiling heights at both t1 and t2 
c        before performing a time interpolation (suggested by Bruno Santos)
c --- V6.32 (080205) to v6.321 (080325) (FRR)
cc     - Save isec1, isec2 to make sure their values are saved from one
c        timestep to the next. Otherwise can assume wrong values and 
c        cause crash with some compilers.
c --- V6.31 (071207) to V6.32 (080205)
c      - Allow sub-hourly prognostic timesteps (equal or larger than
c        CALMET timesteps) but still only instantaneous records
c        Note: 3D.DAT version 3.0 has explicit beginning and end times
c        with seconds. For instantaneous records: beginning time=end time
c      - Remove Progn LST times from calling list (never used)
c      - Add npsta to rdhd53 calling list
c
c --- V6.3 (070717)to V6.31 (071207) (FRR)
c      - Keep searching for first valid MM5 record through subsequent
c        MM5 files (and do not give up after first one)
c      - Enforce bounds on dtinc value (0<=dtinc<=1)
c      - Make sure that the current and future timesteps are always 
c        in memory (it1,it2) and never the previous and current timesteps 
c        (except for the last simulation timestep) for consistency with MOD5, 
c        propercomputing of previous hour temperature sounding, proper
c        initialization of Stull surface temperature cooling, and to avoid
c        the potential of not having the proper records to compute the last
c        timesteps correctly
c      - Removed previous (commented) bug lines (cleaning up)
c
c --- V6.223 (070702) to V6.3 (070717)(F. Robe)
c        - Store the previous hour prognostic lapse rate rather than the 
c          current hour lapse rate to compute mixing height growth 
c          (TZ0,ZL0)
c        - Make sure the 2 MM5 records read in are the current time and the
c          following time, in all cases.
c        
c --- V6.222 (070404) to V6.223 (070702) to (F. Robe)
c        - Replace calls to r2interp by calls to r2interp2 to interpolate
c          rh850, ccp, and qctot as r2interp2 is designed for 2D arrays 
c          while r2interp is for a slice of a 3D array 
c        - Use modified cinterp calling list
c        - Interpolate ceiling height from cloud=4 option with cinterp
c          rather than r2interp (using modified cinterp for 2D arrays)
c        - spatially interpolate ccp only for icloud=4 
c        - Only fill in indx array when valid records (not when skipping)
c          (useless and besides, index not definied when skipping records)
c
c --- V6.221 (070327) to V6.222 (070404)(F. Robe)
c        - Initialize nlevag1,TZ1,ZL1 at first call (does not
c          affect results but will stop some compilers)
c
c --- V6.220 (070206) to V6.221 (070327)(F. Robe)
c --- Modifications suggested by B. Brashers)
c        - Modify computation of RHOP  such that it is 
c          properly initialized at each timestep/gridpoint and is 
c          computed at the surface. The non-initialization of RHOP 
c          could produce wrong values with some compilers (e.g. PGI 
c          in Linux) 
c
c -- V6.217 (061231) to V6.220 (070206) (F. Robe)
c                -  Compute ceiling height based on high/middle/low cloud
c                   covers (ICLOUD=4 option only) if qc not available
c 
c --- V6.213 (060525)to V6.217 (061231) (F. Robe)
c                - implement new option to compute cloud cover from 
c                  prognostic relative humidity (icloud=4; MM5toGrads 
c                  algorithm)
c
c --- V6.210 (060408)to V6.213 (060525)(D. Strimaitis)
c                - Change nsec1 (not initialized) to isec1 (initialized
c                  to 0) in call to DELTSEC
c 
c --- V6.206 (060322)to V6.210 (060408)(F.Robe)
c                - Change array name irhprog(mxnx,mxny) to irhpg (mxnx,mxny)
c 
c --- V6.205 (060309) to V6.206 (060322)(F.Robe)
c                - Store previous hour prognostic temperature profile in TZO  
c                  instead of '2-hour-ago' progn. temp.(important for mixing height
c                  growth when prognostic lapse rates are used itprog=1,2; itwprog=1)
c                  No need for TZ2,ZL2 arrays anylonger
c                - Extrapolate progn. temp. down to surface overwater using
c                  prognostic SSTs or adiabatic profile (formely used Stull
c                  cooling is not appropriate overwater, only land)         
c
c --- V6.2 Level 060215 to V6.205 (060309)(F.Robe)
c               -  Change argument type from real to integer in call to delsec
c
c --- V5.611 Level 051113 to V6.2 Level 060215 (F.Robe)
c               - Implement time interpolation to sub-hourly CALMET timesteps
c               - Use explicit explicit current times: note that current time
c                 is defined here by the ending time of the CALMET timestep
c                 whereas MM5 timestamp is an instantaneous time, which in MOD5
c                 we matched with the CALMET time (i.e. ending time of the
c                 CALMET timestep)
c               - Save local variables from one timestep to the next
c               - Replace real argument deltas by integer ndeltas in 
c                 call to deltsec 
c               - Bug fix: Use solar angle at nearest CALMET gridpoint to 
c                 determine sunrise/sunset on MM5 grid rather than solar angle  
c                 on CALMET grid (indices and possibly array dimension mismatch
c                 if NXP> MXNX and/or NYP>MXNY)  
c               - Move sina computation outside of k loop and take new sinalp 
c                 array index range into account
c               
c 
c --- V5.61 Level 051111 to V5.611 Level 051113
c --- Modified by F.Robe
c               - itwprog in calling list
c               - Read in extended surface variables for imm53d=2 
c                 (3D.DAT version 2.0 and higher)
c               - Store surface temp, rh/temp/height at first 
c                 half-sigma level in M3DMET.MET for use in 
c                 WATERP/WATER2P subroutines 
c               - Use index1 instead of index+1 in call to STULL
c                 only affects datsets with redundant lowest levels
c                 (fix was only partially implemented before)
c
c --- V5.6g Level 051109 to V5.61 Level 051111
c        - Fix errant test on IFIRSTPG from EQ to LE (problem with
c          skipping first hours
c
c --- V5.6 Level 050328 to V5.6g Level 051109
c --- Modified by F.Robe
c        - Read new moisture variable format (CVER3D=2.1)
c        - Bug fix for last timestep at end of leap year 
c
c --- Version V5.548c Level 050125 to V5.6 Level 050328
c --- Modified by F.Robe
c        - use previous hour soundings to compute lapse rates above 
c          previous  hour mixing height  instead of current hour 
c          lapse rates to avoid unrealistic overgrowth of mixing height
c          (used in MIXDT2 - itprog>0 mode)
c
c --- Version V5.548b Level 050113 to V5.548c Level 050125
c --- Modified by F.Robe
c               - Save it1,it2 as some compilers do not automatically save 
c                 local variables from one timestep to the next
c
c --- V5.547 (041016) to V5.548b (050113)(F.Robe)
c               - Add check to avoid duplicate prognostic levels in vertical
c                 temperature extrapolation (STULL0,STULL)
c
c --- V5.541(030528) to V5.547 (041016) (F.Robe)
c               - Add ability to read multiple (consecutive or overlapping)
c                 MM5.DAT files
c               - Explicit common replaced by include d4/d6.met
c
c --- V5.51 (030515) to V5.52 (030528) (F. Robe)
c               - correction to ensure a smooth transition from 
c                 Dec 31 to Jan 1 (if period straddles these dates)
c
c --- V5.5 (030402) to V5.51 (030515) (J. Scire)
c               - correction to ensure IGF is defined when conducting 
c                 1-hour run
c               - add check to ensure MM5/3D.DAT grid point I,J read
c                 match expected values
c
c --- V5.4 (030214) to V5.5 (030402)  (DGS)
c               - Add list-file unit to JULDAY, INDECR, YR4 calls
c               - LLCONF replaced with LLCC
c               - /MAP/ replaces /LON/
c               - Change documentation:  coordinates may be other than
c                 UTM or LLC
c
c --- V5.3 (030119) to V5.4 (030214)  (CEC)
c               - Initialise precipitation with current hour
c
c --- V5.3          Allow non hourly data (F.Robe)
c                   Compute cloud cover from MM5 relative humidity
c                   Interpolate 3D temperature field + precip on CALMET grid
c
c --- V5.2          000602d  (Zhong WU)
c                   Modify code to read 3D.DAT format
c                   IMM53D flag was added to mm4hdo.met
c
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
C     THIS SUBROUTINE READS AND INTERPOLATES THE MM5 PROGNOSTIC MODEL
C     OUTPUT (formatted by CALMM5) TO THE DIAGNOSTIC MODEL GRID
c frr (09/01)
C     It also linearly interpolates the MM5 data in time for non-hourly
C     MM5 timesteps (dry adiabatic lapse rate in convective B-L
c     is imposed in TEMP3D not here)
C     
C
C     INPUTS:  CELLZC R-ARRAY  - DIAGNOSTIC WIND MODEL CELL-CENTER HEIGHTS
C
C              MCLOUD  INT     - CLOUD FLAG 
c                              - IF MCLOUD=3, compute cloud cover from MM5 relative
C                                 humidity at 850 mb(Teixeira, 2001)
c                              - IF MCLOUD=4, compute cloud cover from MM5 relative
C                                 humidity at all levels (MM5toGrads algorithm)
c
c           ITWPROG   Int      - Offshore temperature option
c                                0 : deltaT and OW lapse rates from SEA.DAT   
c                                1 : deltaT from SEA.DAT and OW lapse rates from
c                                    3D.DAT  
c                                2 : prognostic deltaT and lapse rates(from 3D.DAT)
C
C     INPUT VIA COMMON GEN.MET:
c              NDATHRE INT     - eXPLICIT ENDING TIME OF CURRENT CALMET TIMESTEP
c                NSECE INT     - ENDING SECOND OF CURRENT CALMET TIMESTEP
C
C     OUTPUTS:  UDAT  R-ARRAY  - U-COMPONENT OF THE WIND PROGNOSTIC HORIZONTAL
C                                GRID INTERPOLATED TO CALMET LEVELS
C               VDAT  R-ARRAY  - V-COMPONENT OF THE WIND PROGNOSTIC HORIZONTAL
C                                GRID INTERPOLATED TO CALMET LEVELS
C               UPROG R-ARRAY  - U-COMPONENT OF THE PROGNOSTIC WIND FIELD
C                                INTERPOLATED TO CALMET GRID
C               VPROG R-ARRAY  - V-COMPONENT OF THE PROGNOSTIC WIND FIELD
C                                INTERPOLATED TO CALMET GRID
C               TPROG R-ARRAY  - PROGNOSTIC TEMPERATURE FIELD
C                                INTERPOLATED TO CALMET GRID
C             VPTPROG R-ARRAY  - PROGNOSTIC VIRTUAL POTENTIAL TEMPERATURE
c                                FIELD INTERPOLATED TO CALMET GRID
c             CCGRID  R-ARRAY  - Gridded cloud cover computed with MM5
c                                Relative humidity (if mcloud=3 or 4)
c              ICEIL  I-ARRAY  - ceiling height (lowest MM5 level)
c                                with non zero qc (for ioutmm5>82 and mcloud=3,4)
c               RHO   R-ARRAY  - 2-D surface air density on CALMET grid
c              NPSTA  INT      - PRecipitation flag:use MM5 if NPSTA=-1
c          
C
c     OUTPUT VIA COMMON MM5TEMP
c                 ZL0 R-ARRAY  - ELEVATION ABOVE GROUND OF MM5 LEVELS AT
C                                MM5 GRIDPOINT CLOSEST TO GIVEN CALMET
C                                GRIDPOINT. Artificial zl=0 level added
c                 TZ0 R-ARRAY  - VERTICAL PROGNOSTIC TEMPERATURE PROFILE
C                                AT GIVEN CALMET GRIDPOINT BASED ON CLOSEST
C                                MM5 GRIDPOINT. Surface temperature is
c                                copied from first MM5 level .
c                                Not interpolated in time: past (or present)
c                                time (NOT future) is passed to MIXHT2/MIXDT2
c                                This is consistent with using most recent past
c                                upper air sounding in MIXHT/MIXDT
c                             
c
c     OUTPUT VIA COMMON SURFPROF
c             iRHPG I-ARRAY  - SURFACE RELATIVE HUMIDITY INTERPOLATED
C                                TO CALMET GRID (IN PERCENT)
c            IPCODEPG I-ARRAY  - SURFACE PRECIPITATION CODE INTERPOLATED
C                                TO CALMET GRID (0: NO PRECIP - 10: LIQUID
C                                20: FROZEN - 9999: MISSING)
c     OUTPUT VIA COMMON METGRD
c               RMM   R-ARRAY  - PRECIPITATION RATE (mm/hr) on calmet grid
c
c     OUTPUT VIA COMMON M3DMET
c        TAIRP(mxnxp*mxnyp) R-ARRAY - air temperature at first half-sigma
c                                     level at each 3D.DAT gridpoint
c                                     (in degrees kelvin)
c         SSTP(mxnxp*mxnyp) R-ARRAY - surface temperature at each 3D.DAT 
c                                     gridpoint (in degrees kelvin)
c          RHP(mxnxp*mxnyp) R-ARRAY - relative humidity at first half-sigma 
c                                     level at each 3D.DAT gridpoint (in %)                                                    
c                            
c          Z1P(mxnxp*mxnyp) R-ARRAY - height above ground of first half-sigma
c                                     level at each 3D.DAT gridpoint(in m)
c  
C
C     OTHER VARIABLES:
C               NXP      INT   - NO. OF PROGNOSTIC MODEL GRID POINTS IN THE
C                                X-DIRECTION
C               NYP      INT   - NO. OF PROGNOSTIC MODEL GRID POINTS IN THE
C                                Y-DIRECTION
C               NZP      INT   - NO. OF PROGNOSTIC MODEL LEVELS
C               NLEVAG   INT   - NO. OF PROGNOSTIC MODEL LEVELS ABOVE GROUND
C               XMAP0   REAL   - LOCATION OF ORIGIN (X IN KM) IN REAL SPACE
C                                COORDINATES
C               YMAP0   REAL   - LOCATION OF ORIGIN (Y IN KM) IN REAL SPACE
C                                COORDINATES
C
c        Parameters: MXNX, MXNY, MXNZ, MXNXP, MXNYP, MXNZP, IO6
c
c --- RDMM5 called by:  DIAGNO
c --- RDMM5 calls:      JULDAY, INDECR, QCKSRT3, R2INTERP, ESAT, YR4
c                       R2INTERP2, RDHD51,RDHD52
c----------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'gen.met'
      include 'map.met'
      include 'grid.met'
      include 'metgrd.met'

      include 'd4.met'
      include 'd6.met'
c     COMMON /D4/ EDIT,EDITL,IEDIT,IEDITL
c      COMMON /D6/ IRD,IWR,IFILE,IRDP
      include 'mm4hdo.met'
c --- 051113 
      include 'm3dmet.met'

      common/mm4dum/ix,jx,zdum,wddum,wsdum,pdum,itdum,idddum

      COMMON /PROGSTEP/ ifirstpg,nfm3d

c --- v6.4.0, Level 121203
      include 'auxdat.met'

c     common with mixdt2 (computation on mixing height in noobs mode)
c     share last hour temperature profile to compute T jump above MH
      common/mm5temp/nlevag0,zl0(mxnx,mxny,mxnzp+1),
     :                       tz0(mxnx,mxny,mxnzp+1)

c     common with surfvar: 2D surface prognostic data
      common /surfprog/irhpg(mxnx,mxny),ipcodepg(mxnx,mxny)

c    
c ---  FRR for zl,tz take prognostic point closest to
c      calmet i,j point igrab(i,j,1) -

      Character*80 buff
      DIMENSION UPROG(mxnx,mxny,*), VPROG(mxnx,mxny,*),
     1          UP(mxnxp,mxnyp,mxnzp), VP(mxnxp,mxnyp,mxnzp),
     1          UDAT(mxnxp,mxnyp,mxnz), VDAT(mxnxp,mxnyp,mxnz),
     2          CELLZC(*),z(mxnzp),ws(mxnzp),wd(mxnzp),
     2          zp(mxnxp,mxnyp,mxnzp),
     &          t(mxnzp),tp(mxnxp,mxnyp,mxnzp),
     &          tmm4(mxnxp,mxnyp,mxnz),tprog(mxnx,mxny,*),
     &          vpt1(mxnzp),vptp(mxnxp,mxnyp,mxnzp),
     &          vptdat(mxnxp,mxnyp,mxnz),vptprog(mxnx,mxny,*),
c frr (09/01) previous and next time step values (for time interpolation)
     &          uprog1(mxnx,mxny,mxnz), vprog1(mxnx,mxny,mxnz),
     &          uprog2(mxnx,mxny,mxnz), vprog2(mxnx,mxny,mxnz),
     &          tprog1(mxnx,mxny,mxnz), vptprog1(mxnx,mxny,mxnz),
     &          tprog2(mxnx,mxny,mxnz), vptprog2(mxnx,mxny,mxnz),
     &          UDAT1(mxnxp,mxnyp,mxnz), VDAT1(mxnxp,mxnyp,mxnz),
     &          UDAT2(mxnxp,mxnyp,mxnz), VDAT2(mxnxp,mxnyp,mxnz),
c frr (09/01) additional variables for noobs case
     &          rhop(mxnxp,mxnyp),rho(mxnx,mxny),
     &        ccgrid(mxnx,mxny),iceilg(mxnx,mxny),qcprog(mxnx,mxny),
     &        ceil(mxnxp,mxnyp),qctot(mxnxp,mxnyp),
     &          rh(mxnxp,mxnyp,mxnzp),rhprog(mxnx,mxny),
     &          rain(mxnxp,mxnyp),
c frr (09/01) new variables for combined noobs and nonhourly
     &         rmm1(mxnx,mxny),rmm2(mxnx,mxny),
     &         rho1(mxnx,mxny),rho2(mxnx,mxny),
     &         irhprog1(mxnx,mxny),irhprog2(mxnx,mxny),
     &         iceilg1(mxnx,mxny),iceilg2(mxnx,mxny),
     &         qcprog1(mxnx,mxny),qcprog2(mxnx,mxny),
c frr  040225
     &         zl1(mxnx,mxny,mxnzp+1),tz1(mxnx,mxny,mxnzp+1),
c frr (070717)
     &         zl2(mxnx,mxny,mxnzp+1),tz2(mxnx,mxny,mxnzp+1),
c frr 021105: RH at 850mb for cloud subroutine
     &        rh850pg1(mxnx,mxny),rh850pg2(mxnx,mxny),
     &        rh850pg(mxnx,mxny),rh850(mxnxp,mxnyp),
c frr 030106
     &        pt20(mxnxp,mxnyp),pt30(mxnxp,mxnyp),pt(mxnzp),ip(mxnzp),
     &        indx(mxnxp,mxnyp),tsurf(mxnxp,mxnyp),
c frr 051113
     &        sstp1(mxnxp,mxnyp),sstp2(mxnxp,mxnyp),rhp1(mxnxp,mxnyp),
     &        rhp2(mxnxp,mxnyp),tairp1(mxnxp,mxnyp),tairp2(mxnxp,mxnyp),
     &        z1p1(mxnxp,mxnyp),z1p2(mxnxp,mxnyp),
c frr 061231-070206
     &     pp(mxnxp,mxnyp,mxnzp),ccp (mxnxp,mxnyp),
     &     ceil4(mxnxp,mxnyp),ccgrid1(mxnx,mxny),ccgrid2(mxnx,mxny)

c --- v6.4.0, Level 121203
c --- 3D.DAT cloud liquid water content (LWC) profile for current cell
      real qcpzp(mxnzp), qcpz(mxnz)
c --- 3D.DAT interface heights (mAGL) for current cell
      real zfacep(mxnzp+1)
c --- LWC profile for CALMET layers (stored on M3D grid)
      real qcijpz(mxnxp,mxnyp,mxnz)
c --- Cloud LWC properties above CALMET top (stored on M3D grid)
      real zupbotp(mxnxp,mxnyp), zuptopp(mxnxp,mxnyp)
      real qcavgp(mxnxp,mxnyp)
c --- Cloud LWC properties stored on CALMET grid (current and future)
      real qcup1(mxnx,mxny),qcup2(mxnx,mxny)
      real zuptop1(mxnx,mxny),zuptop2(mxnx,mxny)
      real zupbot1(mxnx,mxny),zupbot2(mxnx,mxny)
      real qc3d1(mxnx,mxny,mxnz),qc3d2(mxnx,mxny,mxnz)
c --- Print debug
      logical ldbaux

c --- Explicit beginning-end times with seconds (080205)
c --- No sub-hourly frequency for 3D.DAT records at this point (060215)
c      data isec1/0/,isec2/0/

c --- Make sure to keep it1,it2,isec1,isec2 in memory for next time step
c --- (050125-080325) 
      save it1,it2,isec1,isec2

c --- Initialise variables at first access to MM5 data records
c ---     (flag initialized in rdhd5)
      if (ifirstpg.eq.0) then
         it1=0
         it2=0
         isec1=0
         isec2=0
         msec=0
         nlevag1=0


c ---    051113 - Variables for M3DMET.MET
         do 556 j = 1,mxnyp
         do 556 i = 1,mxnxp
           sstp1(i,j) = 0.
           sstp2(i,j) = 0.
           rhp1(i,j) = 0.
           rhp2(i,j) = 0.
           tairp1(i,j) = 0.
           tairp2(i,j) = 0.
           z1p1(i,j) = 0.
           z1p2(i,j) = 0.
556      continue    
    
         do 55 k = 1,mxnz
           do 56 j = 1,mxnyp
           do 56 i = 1,mxnxp
              udat1(i,j,k) = 0.
              vdat1(i,j,k) = 0.
              udat2(i,j,k) = 0.
              vdat2(i,j,k) = 0.
56         continue        
           do 57 j = 1,mxny
           do 57 i = 1,mxnx
              uprog1(i,j,k) = 0.
              vprog1(i,j,k) = 0.
              tprog1(i,j,k) = 0.
              vptprog1(i,j,k) = 0.                   
              uprog2(i,j,k) = 0.
              vprog2(i,j,k) = 0.
              tprog2(i,j,k) = 0.
              vptprog2(i,j,k) = 0.
              
57         continue        
55       continue


         do 58 j = 1,mxny
         do 58 i = 1,mxnx
              qcprog1(i,j)=0.
              iceilg1(i,j)=0
              irhprog1(i,j)=0
              rho1(i,j) = 0.
              rmm1(i,j) = 0.
              rh850pg1(i,j)=0.
              ccgrid1(i,j)=0.
              qcprog2(i,j)=0.
              iceilg2(i,j)=0
              irhprog2(i,j)=0
              rho2(i,j) = 0.
              rmm2(i,j) = 0.
              rh850pg2(i,j)=0.
              ccgrid2(i,j)=0.
58       continue

         do 59 k = 1,mxnzp+1
         do 59 j = 1,mxny
         do 59 i = 1,mxnx
              tz1(i,j,k)=0.
              zl1(i,j,k)=0.
              tz2(i,j,k)=0.
              zl2(i,j,k)=0.
59       continue
 
c --- v6.4.0, Level 121203
         do k=1,mxnz
           do j=1,mxny
             do i=1,mxnx
               qc3d1(i,j,k)=0.
               qc3d2(i,j,k)=0.
             enddo
           enddo
         enddo
         do j=1,mxny
           do i=1,mxnx
             qcup1(i,j)=0.
             zuptop1(i,j)=0.
             zupbot1(i,j)=0.
             qcup2(i,j)=0.
             zuptop2(i,j)=0.
             zupbot2(i,j)=0.
           enddo
         enddo

      endif

c
c last hour temperature profile for use in MIXDT2 (Mix.H. growth)(070717)
      nlevag0= nlevag1
      do 1221 i = 1,nx
      do 1221 j = 1,ny
         do 1222 k = 1,mxnzp+1
            tz0(i,j,k) = tz1(i,j,k)
            zl0(i,j,k) = zl1(i,j,k)
1222     continue
1221  continue

c --- Check if last step in calmet run -
c --- (But only if run length > 1 hour (JSS, 4/2003))
c --- If so, do no read next mm5 record 

      if ( nendhr.eq.1 .and. ifirstpg.ne.0) then
c ---    skip reading
         goto 555
      endif


c --- Read new data every isteppg hours.
c --- In between, linearly interpolate in time -

      call deltsec(it1,isec1,ndathre,nsece,ndelta1)
      call deltsec(ndathre,nsece,it2,isec2,ndelta2)

      if(ndelta1.ge.0 .and. ndelta2.gt.0 ) then

c ---    linearly interpolate in time - do not read any new mm5 data
         goto 555

      else

c ---  Read new data

c ---  Initialize constants
       deg2rad=0.0174533

C
c ---  Initialize data that may not be read from CALMM5
       irh=0
       q=0.
c ---  Additionally (090511)
       qc=0.
       qr=0.       

c ---  Number of vertical levels
       nlev = nzp

c ---  Loop over each grid cell in extraction subdomain
1      continue
       do 5 j=1,nyp
       do 5 i=1,nxp


         i850=0

c ---    initialize integrated cloud water content and ceiling height
         qctot(i,j) = 0
         ceil(i,j) = 0
         ceil4(i,j) = 0
       
c ---    Read date record of data portion (with seconds if any -080205)
         if(imm53d.eq.0) then
            read(io20,60,end=999) myr,mmo,mday,mhr,ix,jx
     &           ,pmsl,rain(i,j),isnow
c frr  (09/01)- rain array
60          format(4i2,2i3,f7.1,f5.2,i2)
         else if (imm53d.eq.1) then
            read(io20,61,end=999) myr,mmo,mday,mhr,ix,jx
     &           ,pmsl,rain(i,j),isnow,rads,radl
61          format(i4,3i2,2i3,f7.1,f5.2,i2,2f8.1)
         else if (imm53d.eq.2) then
c ---       Read extended list of surface variables (051113)
c ---       (3D.DAT version 2.0 and above)
            read(io20,62,end=999) myr,mmo,mday,mhr,ix,jx,
     &        pmsl,rain(i,j),isnow,rads,radl,t2,qq2,wd10,ws10,sstp2(i,j)
62          format(i4,3i2,2i3,f7.1,f5.2,i2,3f8.1,f8.2,3f8.1)
         else if (imm53d.eq.3) then
c ---       Read extended list of surface variables with explicit 
c ---       beginning/end times with seconds 
c ---       (3D.DAT version 3.0 and above(080205)
            read(io20,63,end=999) myrb,mmob,mdayb,mhrb,msecb,
     &                            myr,mmo,mday,mhr,msec,ix,jx,
     &        pmsl,rain(i,j),isnow,rads,radl,t2,qq2,wd10,ws10,sstp2(i,j)
c ---       So far only accept instantaneous records (080205)
            call julday(io6,myrb,mmob,mdayb,nbjul)
            call julday(io6,myr,mmo,mday,nejul)
            nbdathr=myrb*100000+nbjul*100+mhrb
            nedathr=myr *100000+nejul*100+mhr 
            call deltsec(nbdathr,msecb,nedathr,msec,idt)
            if(idt.ne.0) then
               write(6,*)'STOP in RDMM5 - See list file'
               write(io6,*)'STOP in RDMM5'
               write(io6,*)'Prognostic records must be instantaneous'
               write(io6,*)'Beginning GMT time:',nbdathr,'- ',msecb
               write(io6,*)'End       GMT time:',nedathr,'- ',msec
               stop
            endif
63          format(i4,3i2,i4,i5,3i2,i4,i4,i3,f7.1,f5.2,i2,
     :             3f8.1,f8.2,3f8.1)
         endif
c
c ---   Check if surface temperature data (sstp) are in 3D.DAT  
c       when itwprog=2 (051113)
c ---   Missing SST are flagged by CALRUC with 0. for RUC data, 
c       and by CALETA with -999  for ETA model, while missing 
c ---   data are often flagged with 999 or 9999. 
c ---   SST are in kelvins in MM5 => check if 150< sst< 350

        if ( (itwprog.eq.2).and.
     :       ((sstp2(i,j).lt.150).or.(sstp2(i,j).gt.350)) )then
          write(6,*)'STOP in RDMM5 - Check list file'
          write(io6,*)'STOP in RDMM5'
          write(io6,*)'ITWPROG =2 requires SST in 3D.DAT file '
          write(io6,*)'But there is no valid surface temp. in 3D.DAT'
          write(io6,*)'STOP'
          stop
        endif    

c ---   Check that MM5/3D.DAT grid point I,J read match expected values
        ixexpect=i+i1-1
        jxexpect=j+j1-1
        if(ix.ne.ixexpect.or.jx.ne.jxexpect)then
           write(io6,960)myr,mmo,mday,mhr,ix,jx,ixexpect,jxexpect
960        format(1x,'Error in Subr. RDMM5 -- Error in MM5.DAT/',
     1     '3D.DAT file'/     
     2     1x,'MM5/3D grid point I,J do not match expected values'/
     3     1x,'MM5/3D date/time:  Yr: ',i4,1x,'Mo: ',i2,1x,'Day: ',i2,
     4     1x,'Hr: ',i2,' (GMT)'/
     5     1x,'  MM5/3D I,J: ',2i4/
     6     1x,'Expected I,J: ',2i4)
c
           print *,'Error in Subr. RDMM5 -- Error in MM5/3D.DAT file'
           print *,'MM5/3D grid point I,J do not match expected ',
     1             'values'
           stop
        endif
c ---   convert rain in cm accumulated over the hour into mm/hr
        rain(i,j)=rain(i,j)*10.
       
         call YR4(io6,myr,ierr)
         if(ierr.NE.0) stop 'Halted in RDMM5'
c ---    Convert date/time from GMT to LST
         call julday(io6,myr,mmo,mday,mjul)
         idtz = 0 - ibtz
         call indecr(io6,myr,mjul,mhr,idtz,0,23)
c
c --- Check if no gap in MM5 records
c        MM5 Time (LST)  
         mdathr=myr*100000+mjul*100+mhr

c        Compute current time+ MM5 timestep in yyyyjulhr format
c        Use explicit ending time (60202)
         nsyr=nyrb
         nsjul=njulb
         nshr=nhrb
         nssec=nsece
         call incrs(io6,nsyr,nsjul,nshr,nssec,isteppgs)
         nsdathr=nsyr*100000+nsjul*100+nshr
c ---    MM5 times with seconds (080205)
c        call deltsec(nsdathr,nssec,mdathr,0,ndeltas)
         call deltsec(nsdathr,nssec,mdathr,msec,ndeltas)

c        if (mdathr .gt. nsdathr ) then
         if (ndeltas.gt.0) then
           write(io6,*)
           write(io6,*) ' ERROR - in Subroutine RDMM5 - STOP'
           write(io6,*) ' Gap in MM5 record'
           write(io6,*) ' Current ending LST TIME (yyyyjulhr-sec): ',
     :                    ndathre,' - ',nsece
           write(io6,*) ' Current LST MM5 TIME (yyyyjulhr - sec): ',
     :                    it2,' - ',isec2
           write(io6,*) ' Next LST MM5 TIME (yyyyjulhr - sec): ',
     :                    mdathr,' - ',msec
           write(io6,*) ' MM5 Timestep:', isteppgs
           stop   'STOP in RDMM5 - GAP in records- Check list file'      
         endif
c      

c ---    initialize surface density (070327 -BAB)
         rhop(i,j)=0.
         irho=0

c ---    Check whether need to skip a record
         iskip = 0

c ---    Always read in the next MM5 record, except for first valid record
c ---    Check include seconds (060215)- With non z
c ---    Sub-hourly timesteps- Explicit times (051128) with seconds(080205)
c        call deltsec(mdathr,0,ndathre,nsece,ndeltskip)
         call deltsec(mdathr,msec,ndathre,nsece,ndeltskip)

         if (ndeltskip.ge.isteppgs) iskip=1

c ---    Always have current and future timesteps in memory,even at the
c ---    start (otherwise can trigger keeping past and current during
c ---    the whole simulation (not good for previous hour soundings and Stull)
c        if (ndeltskip.eq.isteppgs .and.ifirstpg.le.1) iskip=0  (070717)
c        if (ndeltskip.eq.isteppgs .and.ifirstpg.lt.1) iskip=0  (071207)

c ---    Make sure that if reading next M3D file, the future timestep
c ---    is read in  and not the  current timestep. This could happen
c ---    when successive M3D files were overlapping and caused dtinc=1 
c ---    throughout the rest of the simulation and dtinc=2 at the end (080709)
         if(ndeltskip.eq.0.and.nfm3d.gt.1) then
           iskip=1
           if(i.eq.1.and.j.eq.1)then
             write(io6,*)'WARNING: M3D files overlap in time'
       write(io6,*)'CALMET used duplicate times from the earlier file'
       write(io6,*)'and skipped those same times in the later file'
           endif
         endif

c ---    Read data levels
         if(iskip.EQ.0) then

c frr (09/01)
c  ---    fill in previous time step for time interpolation
           do 6 k=1,nz
            udat1(i,j,k) = udat2(i,j,k)
            vdat1(i,j,k) = vdat2(i,j,k)
6          continue

c ---      M3DMEt.MEt variables (051113)
           sstp1(i,j) = sstp2(i,j)
           tairp1(i,j) = tairp2(i,j)
           rhp1(i,j)=rhp2(i,j)
           z1p1(i,j)=z1p2(i,j)

           index=1
           indpx=1

c ---      Want to use these data levels
           do 35 n=1,nlev
c ---        read in CALMM5 fields (depends on parameter ioutmm5)
             if (ioutmm5.eq.81) then
                read(io20,81) ipress,iz,t(n),iwd,ws(n)
81              format (i4,i6,f6.1,i4,f5.1)
             else if (ioutmm5.eq.82) then
                read(io20,82) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q
82              format (i4,i6,f6.1,i4,f5.1,i3,f5.2)
             else if (ioutmm5.eq.83) then
c --- v6.4.0, Level 121203
                if(cver3d.EQ.'2.1'  .OR.
     &             cver3d.EQ.'2.11' .OR.
     &             cver3d.EQ.'2.12' .OR.
     &             cver3d.EQ.'2.13' .OR.
     &             cver3d.EQ.'3.1' ) then
                   read(io20,830) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr
                elseif(cver3d.EQ.'2.0' .OR. cver3d.EQ.'3.0') then
                   read(io20,83) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr
                else
c ---              Unknown dataset version
                   write(io6,*)'RDMM5: Unknown 3D.DAT dataset: ',cver3d
                   stop 'HALTED in RDMM5 --- see list file'
                endif

830             format (i4,i6,f6.1,i4,f5.1,i3,f5.2,2(f6.3))
83              format (i4,i6,f6.1,i4,f5.1,i3,3(f5.2))
             else if (ioutmm5.eq.84) then
c --- v6.4.0, Level 121203
                if(cver3d.EQ.'2.1'  .OR.
     &             cver3d.EQ.'2.11' .OR.
     &             cver3d.EQ.'2.12' .OR.
     &             cver3d.EQ.'2.13' .OR.
     &             cver3d.EQ.'3.1' ) then
                   read(io20,840) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr,qi,qs
                elseif(cver3d.EQ.'2.0' .OR. cver3d.EQ.'3.0') then
                   read(io20,84) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr,qi,qs
                else
c ---              Unknown dataset version
                   write(io6,*)'RDMM5: Unknown 3D.DAT dataset: ',cver3d
                   stop 'HALTED in RDMM5 --- see list file'
                endif
840             format (i4,i6,f6.1,i4,f5.1,i3,f5.2,4(f6.3))
84              format (i4,i6,f6.1,i4,f5.1,i3,5(f5.2))
             else if (ioutmm5.eq.85) then
c --- v6.4.0, Level 121203
                if(cver3d.EQ.'2.1'  .OR.
     &             cver3d.EQ.'2.11' .OR.
     &             cver3d.EQ.'2.12' .OR.
     &             cver3d.EQ.'2.13' .OR.
     &             cver3d.EQ.'3.1' ) then
                   read(io20,850) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr,qi,qs,qg
                elseif(cver3d.EQ.'2.0' .OR. cver3d.EQ.'3.0') then
                   read(io20,85) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr,qi,qs,qg
                else
c ---              Unknown dataset version
                   write(io6,*)'RDMM5: Unknown 3D.DAT dataset: ',cver3d
                   stop 'HALTED in RDMM5 --- see list file'
                endif
850             format (i4,i6,f6.1,i4,f5.1,i3,f5.2,5(f6.3))
85              format (i4,i6,f6.1,i4,f5.1,i3,6(f5.2))
             else if (ioutmm5.eq.91) then
                read(io20,91) ipress,iz,t(n),iwd,ws(n),w
91              format (i4,i6,f6.1,i4,f5.1,f6.2)
             else if (ioutmm5.eq.92) then
                read(io20,92) ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q
92              format (i4,i6,f6.1,i4,f5.1,f6.2,i3,f5.2)
c            Compressed output
             else if (ioutmm5.ge.93) then
                read(io20,'(a)')buff
c               Read common parts and compression flag 
c --- v6.4.0, Level 121203
                if(cver3d.EQ.'2.1'  .OR.
     &             cver3d.EQ.'2.11' .OR.
     &             cver3d.EQ.'2.12' .OR.
     &             cver3d.EQ.'2.13' .OR.
     &             cver3d.EQ.'3.1' ) then
                   read(buff,930) ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,fcomp
                elseif(cver3d.EQ.'2.0' .OR. cver3d.EQ.'3.0') then
                   read(buff,93) ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,fcomp
                else
c ---              Unknown dataset version
                   write(io6,*)'RDMM5: Unknown 3D.DAT dataset: ',cver3d
                   stop 'HALTED in RDMM5 --- see list file'
                endif
93              format (i4,i6,f6.1,i4,f5.1,f6.2,i3,3(f5.2))
930              format (i4,i6,f6.1,i4,f5.1,f6.2,i3,f5.2,2(f6.3))
         
c               Un-compression from
                if(fcomp.gt.-0.0001) then
                   if(ioutmm5.eq.93) then
c --- v6.4.0, Level 121203
                      if(cver3d.EQ.'2.1'  .OR.
     &                   cver3d.EQ.'2.11' .OR.
     &                   cver3d.EQ.'2.12' .OR.
     &                   cver3d.EQ.'2.13' .OR.
     &                   cver3d.EQ.'3.1' ) then
                         read(buff,930)ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr
                      elseif(cver3d.EQ.'2.0' .OR.
     &                       cver3d.EQ.'3.0') then
                         read(buff,93)ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr
                      else
c ---                    Unknown dataset version
                         write(io6,*)'RDMM5: Unknown 3D.DAT dataset: ',
     &                                cver3d
                         stop 'HALTED in RDMM5 --- see list file'
                      endif
                   else if (ioutmm5.eq.94) then
c --- v6.4.0, Level 121203
                      if(cver3d.EQ.'2.1'  .OR.
     &                   cver3d.EQ.'2.11' .OR.
     &                   cver3d.EQ.'2.12' .OR.
     &                   cver3d.EQ.'2.13' .OR.
     &                   cver3d.EQ.'3.1' ) then
                         read(buff,940)ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr,qi,qs
                      elseif(cver3d.EQ.'2.0' .OR.
     &                       cver3d.EQ.'3.0') then
                         read(buff,94)ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr,qi,qs
                      else
c ---                    Unknown dataset version
                         write(io6,*)'RDMM5: Unknown 3D.DAT dataset: ',
     &                                cver3d
                         stop 'HALTED in RDMM5 --- see list file'
                      endif
940                   format (i4,i6,f6.1,i4,f5.1,f6.2,i3,f5.2,4(f6.3))
94                    format (i4,i6,f6.1,i4,f5.1,f6.2,i3,5(f5.2))
                   else if (ioutmm5.eq.95) then
c --- v6.4.0, Level 121203
                      if(cver3d.EQ.'2.1'  .OR.
     &                   cver3d.EQ.'2.11' .OR.
     &                   cver3d.EQ.'2.12' .OR.
     &                   cver3d.EQ.'2.13' .OR.
     &                   cver3d.EQ.'3.1' ) then
c ---                    new moisture format (6.3 instead of 5.2)(050504)
                         read(buff,950) ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr,qi,qs,qg
                      elseif(cver3d.EQ.'2.0' .OR.
     &                       cver3d.EQ.'3.0') then
                         read(buff,95) ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr,qi,qs,qg
                      else
c ---                    Unknown dataset version
                         write(io6,*)'RDMM5: Unknown 3D.DAT dataset: ',
     &                                cver3d
                         stop 'HALTED in RDMM5 --- see list file'
                      endif
95                    format (i4,i6,f6.1,i4,f5.1,f6.2,i3,6(f5.2))
950                   format (i4,i6,f6.1,i4,f5.1,f6.2,i3,f5.2,5(f6.3))
                   endif
c               Compressed form
                else
                   if(ioutmm5.eq.93) then
                      qc=0.
                      qr=0.
                   else if (ioutmm5.eq.94) then
                      qc=0.
                      qr=0.
                      qi=0.
                      qs=0.
                   else if (ioutmm5.eq.95) then
                      qc=0.
                      qr=0.
                      qi=0.
                      qs=0.
                      qq=0.
                   endif
                endif
         
             endif


c ---        Convert to real variables:
             wd(n)=iwd
         
c ---        Convert mixing ratio from g/kg to g/g
             q=q/1000.
         
c ---        Calculate potential temperature
c             pt1 = t(n) * ((1000./ipress) ** 0.286)
c frr 030106
             pt(n) = t(n) * ((1000./ipress) ** 0.286)
             ip(n) = ipress
         
c ---        compute specific humidity
             qw = q / (1 + q)
         
c ---        compute virtual potential temperature
             vpt1(n) = pt(n) * (1. + 0.61 * qw)
         
c ---        Adjust heights from msl to ht above local ground
             z(n) = iz - ielev4(i,j)


c ---        find cloud ceiling (in meters)
             if ( ceil(i,j).eq.0. .and. qc.gt.1.e-09 ) 
     :            ceil(i,j)=z(n)

          
c frr (09 /01)
c ---        integrate cloud water content over vertical (in g/kg)
             qctot (i,j)= qctot(i,j) + qc
          
          
c --- v6.4.0, Level 121203
c ---        Store cloud LWC profile
             qcpzp(n)=qc
          
          
c ---        Compute air density at lowest level above ground
c ---        constant 0.3484321 = 100 kg / (m * sec**2) per mb divided by
c ---        (287 m**2 / (deg K * sec**2))
c
c frr 030106 make sure to use lowest level above ground (not necessarily
c            the case if M3D data  (e.g. from synoptic model not MM5)
c ---        Take surface density (not necessarily the highest - 070327)
             if ( z(n).ge.0. .and. irho.eq.0) then        
                rhop(i,j)= 0.3484321*ipress/t(n)
                irho=1
             endif
          
c frr (09/01)
c ---        3D array of relative humidity
             rh(i,j,n)= float(irh)
c ---        3D array of pressure
             pp(i,j,n)=float(ipress)
          
c frr (021105)
c            find  RH at (near) 850mb level for Cloud subroutine
             if (ipress.lt.850 .and. i850.eq.0) then
                 if (n.ne.1) then
                   k850=n-1
                 else
                   k850=1
                 endif
                 i850=1
                 rh850(i,j)=rh(i,j,k850)
             endif

c ---      Fill in arrays needed for prognostic offshore delta Method
c ---      Values at first level above ground
           if(z(n).lt.0) indpx=n+1
           if (n.eq.indpx) then
              z1p2(i,j)=z(n)
              tairp2(i,j)=t(n)
              rhp2(i,j)=rh(i,j,n)
           endif


35         continue

c --- v6.4.0, Level 121203
           ldbaux=.false.
           if(qctot(i,j).GT.0.0) then
c ---         Set face heights for this profile
              call Z2FACE(io6,ldbaux,nlev,z,zfacep)
c ---         Process cloud water profile to CALMET layers
              if(ldbaux) then
                 write(io6,*)'PRFVAR cell i3D,j3D = ',i,j
                 write(io6,*)'M3D Time in LST = ',mdathr
              endif
              call PRFVAR(io6,ldbaux,nlev,nz,qcpzp,zfacep,zface,
     &                    threshqc,qcpz,zupbotp(i,j),
     &                    zuptopp(i,j),qcavgp(i,j))
c ---         Place vertical profile into 3D array
              do kk=1,mxnz
                 qcijpz(i,j,kk)=qcpz(kk)
              enddo
           else
              zupbotp(i,j)=0.0
              zuptopp(i,j)=0.0
              qcavgp(i,j)=0.0
              do kk=1,mxnz
                 qcijpz(i,j,kk)=0.0
              enddo
           endif

c         
c ---      Sort arrays by ascending height (useless with CALMM5)
c ---      Note: qcksrt3 takes 7 variables since 061231 b 
c ***      call qcksrt3(nlev,z,wd,ws,t,vpt1)
          
c ---      Convert wd,ws to u,v components and store in grid arrays
c ---      Store temperature in grid array
           nlevag=0
           do 45 k=1,nlev
               nlevag = nlevag + 1

c --- v6.4.0, Level 121203
              if(LLCC .OR. LPS) then

c ---            Convert wd from true north (south) to Lambert Conformal
c ---            map north (south)
c ---            MM4 west longitudes are negative but RLON0 is positive
                 dlong =  rlon0 + xlong4(i,j)
c --- Cod e to handle 180 degree longitude straddle
                 if (dlong .gt. 180.) dlong = dlong - 360.
                 if (dlong .lt. -180.) dlong = dlong + 360.
                 if (xlat1 .lt. 0.) then
c --- Sou thern Hemisphere
                   wdmap = wd(k) + (conec*dlong)
                 else
c --- Nor thern Hemisphere
                   wdmap = wd(k) - (conec*dlong)
                 end if
                 if(wdmap.LT.0.) wdmap = wdmap + 360.
                 if(wdmap.GT.360.) wdmap = wdmap - 360.
                 wd(k) = wdmap
               endif
c ---          Convert ws from knots to m/s  - remove JSS 12/98
c ******* **** ws(k) = ws(k) * 0.51444
               wdrad = deg2rad*wd(k)
               up(i,j,nlevag) = -ws(k) * sin(wdrad)
               vp(i,j,nlevag) = -ws(k) * cos(wdrad)
               tp(i,j,nlevag) = t(k)
               vptp(i,j,nlevag) =vpt1(k)
               zp(i,j,nlevag) = z(k)



c frr 030106 : sometimes more than 1 levels below ground (e.g. with synoptic
c              models such as ETA in M3D format )
c ---          INDEX is the height of the lowest "MM5" level above ground
               if(zp(i,j,k).lt.0.0) index=k+1
      
45         continue

c ---      keep track of previous step number of vertical layers
c ---      frr 040225 (for previous hour temperature profile)
           nlevag0 = nlevag1

           nlevag1=nlevag+1
 
c ---      SOLAR ANGLE:
c ---      Explicit MM5 time is interpreted as hour-ending time. Therefore 
c ---      use sinalp at (mhr-1/2) i.e. sinalp(i,j,mhr+1) (in MOD6 sinalp has 
c ---      26 values ranging from 23:30 previous day to 0:30 on next day )
c ---      (i,j, loop is on MM5 grid, not on CALMET grid where sinalp
c ---      is defined) - Sina computation moved outside of k loop
c
c ---      NOTE (F.Robe 060215)
c ---      Around 11PM-midnight CALMET time, MM5 record #2 is on the next day therefore
c ---      strictly speaking, one should use sinalp (hour) on the next day (which is not yet computed)
c ---      However from one day to the next, sinalp(hour) does not change much. Besides, 
c ---      this occurs in the middle of the night anyway and not close to sunrise, so it won't affect
c ---      sunrise time in most cases. Although that might not be quite true for large isteppg, 
c ---      or at very high lat during the summer 
           sina=sinalp(inearg(i,j),jnearg(i,j),mhr+1)

c frr 030106
c           initialize pot.temp history for temp extrapolation 
            if (ifirstpg.le.1 )then
c ---          Make sure not to pass duplicate levels to subroutine (050113-frr)
               if (z(index).ne.z(index+1))then
                 index1=index+1
               else
                 index1=index+2
               endif
               call stull0(pt(index),z(index),pt(index1),z(index1),
     :                     pt20(i,j),pt30(i,j))

            endif

C ---      INTERPOLATE PROGNOSTIC SOUNDINGS VERTICALLY TO DIAGNOSTIC
C ---      MODEL LEVELS
           DO 75 K = 1,NZ
c         
c ---        Persist data below bottom level
c frr 010306 : use lowest MM5 level above ground
c             IF(CELLZC(K).LT.zp(i,j,1))then
             IF(CELLZC(K).LT.zp(i,j,index))then
c frr (09/01)  U,V at future time
c                UDAT(I,J,K)=UP(I,J,1)
c                VDAT(I,J,K)=VP(I,J,1)
c                UDAT2(I,J,K)=UP(I,J,1)
c                VDAT2(I,J,K)=VP(I,J,1)
c                TMM4(I,J,K)=TP(I,J,1)
c                VPTDAT(I,J,K)=VPTP(I,J,1)
                UDAT2(I,J,K)=UP(I,J,index)
                VDAT2(I,J,K)=VP(I,J,index)
                TMM4(I,J,K)=TP(I,J,index)
                VPTDAT(I,J,K)=VPTP(I,J,index)
c          
c ---        Persist data above top MM4 level
             else if(CELLZC(K).GE.zp(i,j,nlevag))then
c frr (09/01)  U,V at future time
c               UDAT(I,J,K)=UP(I,J,nlevag)
c               VDAT(I,J,K)=VP(I,J,nlevag)
                UDAT2(I,J,K)=UP(I,J,nlevag)
                VDAT2(I,J,K)=VP(I,J,nlevag)
                TMM4(I,J,K)=TP(I,J,nlevag)
                VPTDAT(I,J,K)=VPTP(I,J,nlevag)
c          
c ---        Interpolate to CALMET level from surrounding MM5 levels
             else
c frr 030106 :only use above ground MM5 levels
c                DO KP = 2,nlevag
                DO KP = index+1,nlevag
                   KPM1 = KP - 1
                   IF(zp(i,j,KPM1).LE.CELLZC(K).AND.
     1                zp(i,j,KP).GT.CELLZC(K))THEN
                      ratio1=(CELLZC(K)-zp(i,j,KPM1))/
     1                       (zp(i,j,KP)-zp(i,j,KPM1))
c frr (09/01)
c                      UDAT(I,J,K)=UP(I,J,KPM1)+(UP(I,J,KP)-UP(I,J,KPM1))
c     1                            *ratio1
c                      VDAT(I,J,K)=VP(I,J,KPM1)+(VP(I,J,KP)-VP(I,J,KPM1))
c     1                            *ratio1
                     UDAT2(I,J,K)=UP(I,J,KPM1)+(UP(I,J,KP)-UP(I,J,KPM1))
     1                            *ratio1
                     VDAT2(I,J,K)=VP(I,J,KPM1)+(VP(I,J,KP)-VP(I,J,KPM1))
     1                            *ratio1
                      TMM4(I,J,K)=TP(I,J,KPM1)+(TP(I,J,KP)-TP(I,J,KPM1))
     1                            *ratio1

                      VPTDAT(I,J,K)=VPTP(I,J,KPM1)+(VPTP(I,J,KP)-
     1                            VPTP(I,J,KPM1))*ratio1
                      go to 77
                   endif
                enddo
77              continue
             endif
c           
c ---        Replace winds below first MM5 half-sigma level with 
c ---        extrapolated logarithmic profile winds. Ignore MM5 surface
c ---        (Z=0) winds, 
c          
c ---        Use a logarithmic profile to extrapolate winds down toward
c ---        the surface
             if(cellzc(k).lt.zp(i,j,index))then
c ---           Assume a typical roughness length for extrapolation 
c ---           purposes
                zoave=0.5
                xlnzo=alog(zoave)
c ---           ZP(i,j,index) is the lowest true MM5 half-sigma level
                xlnz2=alog(zp(i,j,index))
c ---           CELLZC(k) is the CALMET grid point height
                xlnz1=alog(cellzc(k))
c ---           Logarithmic profile scaling factor
                ratio2=(xlnz1-xlnzo)/(xlnz2-xlnzo)
c frr (09/01)
c                UDAT(I,J,K)=ratio2*UP(I,J,index)
c                VDAT(I,J,K)=ratio2*VP(I,J,index)
                UDAT2(I,J,K)=ratio2*UP(I,J,index)
                VDAT2(I,J,K)=ratio2*VP(I,J,index)
             endif
c frr 030106
c            Replace temperature below first MM5 half-sigma level with
c            extrapolated temperature.
c            During day: assume constant theta
c            At night: follow Stull (1983, Tellus 35Am p 219-230)
c            day/time determined by sinalp (passed on via gen.met)


c            First record pot.temp before sunset for extrapolation at night
c            record even if cellzc(k) not below lowest MM5 level at that
c            time because this may change during the night (MM5 levels
c            are usually not fixed in Z (but in sigma or p)
c            060318: update only (not for every k)
             if (sina.gt.0.and.k.eq.1)then
                pt20(i,j) = pt(index)
                pt30(i,j) = pt(index+1)
             endif

c            Extrapolate if CALMET level below lowest MM5 level
             if(cellzc(k).lt.zp(i,j,index))then
                 if (sina .le. 0.) then
c ---               nighttime
c ---               Make sure not to pass duplicate levels to subroutine (050113-frr)
                    if (zp(i,j,index).ne.zp(i,j,index+1))then
                       index1=index+1
                    else
                       index1=index+2
                    endif

c ---               Differentiate between land and water (060322-FRR)
                    if (ilu4(i,j).eq.iluoc3d) then
c ---                   ocean - 
                        if(itwprog.eq.2) then
c ---                       SSTP available: linearly interpolate 
c ---                       between 1st level and SST
                            zx=cellzc(k)/zp(i,j,index)
                            ptmm4=sstp2(i,j)*(1.-zx)
     :                                  +pt(index) *zx   
                        else  
c ---                      SSTP not available - extrapolate 1st-2nd MM5 levels
                           zx=(cellzc(k)-zp(i,j,index))/
     :                        (zp(i,j,index1)-zp(i,j,index))
                           ptmm4=pt(index)
     :                        +zx*(pt(index1)-pt(index))
                        endif                    
                    else
c ---                  land - surface cooling parameterized by Stull
                       call stull(zp(i,j,index) ,pt(index),
     :                        pt20(i,j),zp(i,j,index1),
     :                        pt(index1),pt30(i,j),cellzc(k)
     :                        ,ptmm4)
                    endif


c                   compute temp from pot.temp. and pressure level
c                   pressure at CALMET level  (assume p decreases exp with height)
c                   make sure no duplicate levels (050113)
                    if (zp(i,j,2).ne.zp(i,j,1)) then
                       denz= zp(i,j,2)-zp(i,j,1)
                       beta= log(ip(1)*1.0/ip(2))/denz
                    else
                       denz= zp(i,j,3)-zp(i,j,1)
                       beta= log(ip(1)*1.0/ip(3))/denz
                    endif
                    pc=exp( -beta* (cellzc(k)-zp(i,j,1)))
                    pc=ip(1)* pc

                    tmm4(i,j,k)= ptmm4 * ((pc/1000.)** 0.286)

c                   virt. pot. temp.~ pot temp
                    vptdat(i,j,k)=ptmm4

                else
c                  daytime: assume constant Tetha virt. and "dry" adiabat
c                  except overwater if SSTP is available (060315-frr)
                   if (itwprog.eq.2.and.ilu4(i,j).eq.iluoc3d) then
c                     Interpolate Temp. between SST and lowest M3D level (080512)
                      zx=cellzc(k)/zp(i,j,index)
                      tmm4(i,j,k)=sstp2(i,j)*(1.-zx)
     :                                  +tp(i,j,index) *zx   

                   else                
                      TMM4(I,J,K)= tp(i,j,index)+
     :                          0.0098*(zp(i,j,index)-cellzc(k))
                   endif
                   vptdat(i,j,k)=vptdat(i,j,index)
                endif
             endif


75         CONTINUE


c frr 030106 Extrapolate temperature to the surface (Z=0)                
                 if (sina .le. 0.) then
c                   nighttime
c ---               Make sure not to pass duplicate levels to subroutine (050113-frr)
                    if (zp(i,j,index).ne.zp(i,j,index+1))then
                       index1=index+1
                    else
                       index1=index+2
                    endif
c ---               Differentiate between land and water (060322-FRR)
                    if (ilu4(i,j).eq.iluoc3d) then
c ---                   ocean - 
                        if(itwprog.eq.2) then
c ---                       SSTP available: 
                            ptsurf=sstp2(i,j) 
                        else  
c ---                      SSTP not available - extrapolate 1st-2nd levels
                           zx=-zp(i,j,index)/
     :                        (zp(i,j,index1)-zp(i,j,index))
                           ptsurf=pt(index)
     :                        +zx*(pt(index1)-pt(index))
                        endif                    
                    else
c ---                  land - surface cooling parameterized by Stull
                       call stull(zp(i,j,index) ,pt(index),pt20(i,j),
     :                        zp(i,j,index1),pt(index1),
     :                        pt30(i,j),0.,ptsurf)
                    endif

c                   compute temp from pot.temp. and pressure level
c                   pressure at CALMET level  (assume p decreases exp with height)
c                   make sure no duplicate levels (050113)
                    if (zp(i,j,2).ne.zp(i,j,1)) then
                       denz= zp(i,j,2)-zp(i,j,1)
                       beta= log(ip(1)*1.0/ip(2))/denz
                    else
                       denz= zp(i,j,3)-zp(i,j,1)
                       beta= log(ip(1)*1.0/ip(3))/denz
                    endif
                    pc=exp( -beta* (0.-zp(i,j,1)))
                    pc=ip(1)* pc
                   
                    tsurf(i,j)= ptsurf * ((pc/1000.)** 0.286)

                else
c                  daytime: assume "dry" adiab  (constant Tetha virt)
c frr 030709: bug  vptdat(i,j,k)=vptdat(i,j,index)
                   Tsurf(I,J)= tp(i,j,index)+
     :                          0.0098*zp(i,j,index)
c ---              except overwater if sstp available:
                   if (itwprog.eq.2.and.ilu4(i,j).eq.iluoc3d) 
     :             Tsurf(I,J)=sstp2(i,j)
                endif

c ---     frr (030106) (only for valid records (not for skipping 070702)
c         store first level above ground for each MM5 gridpoint
          indx(i,j)=index


         else

          do 65 n=1,nlev
c ---       "Read" (skip) data
            read(io20,*) idum,idum
65        continue
        endif



c      end of loop on nxp,nyp
5      continue


c --- Move call to cloud 4 to after check on iskip (080709)

c frr (09/01)
c --- update time stamps for linear interpolation
c --- Will also have to update seconds when sub-hourly progn.timestep
c --- isec1=isec2; isec2=msec but as of 060215: fixed isec1=isec2=0)
      it1 = it2
      it2 = mdathr
c --- seconds (080205)
      isec1=isec2
      isec2=msec
      if (ifirstpg.eq.0) ifirstpg = 1

c --- Do another iteration through the i,j loop if current time not yet reached
      if (iskip .eq. 1) goto 1

c --- Compute cloud cover on MM5 grid if icloud=4
c --- Method 4 (MM5toGrads): cloud cover from prognostic relative humidity 
c --- at all levels
c --- Call to cloud4 moved after check on iskip to avoid calling when
c --- no new valid data has been read in (080709)
ccec101006      if (icloud.eq.4) call cloud4(nxp,nyp,nlev,rh,pp,zp,ccp,ceil4)
      if (mcloud.eq.4) call cloud4(nxp,nyp,nlev,rh,pp,zp,ccp,ceil4)

c
       goto 997
c
c ---  ran out of data, at least in the current file
999    continue
c ---  Multiple MM5.DAT: open next MM5.DAT file (if available)
c ---  and resume loop (at point where overlapping hours can be skipped)
c ---  071207: keep searching for first valid record in subsequent files
       if (nfm3d.lt.nm3d) then
           nfm3d=nfm3d+1
           if (imm53d.eq.0) call rdhd51(nfm3d)
           if (imm53d.eq.1) call rdhd52(nfm3d)
           if (imm53d.eq.2.or.imm53d.eq.3) 
     :             call rdhd53(nfm3d,itwprog,npsta)
           goto 1
       else
         if (iskip .eq. 1) then
             write(io6,*) ' ran out of MM5 data before start!'
         else
            write(io6,*) 'ran out of MM5 data during run...'
c           write(io6,*) 'On (yyyyjulhr): ',ndathr
            write(io6,*) 'On (yyyyjulhr-sec): ',ndathre,'- ',nsece
         endif
         stop
       end if


 997   continue
C
C      INTERPOLATE PROGNOSTIC SOUNDINGS HORIZONTALLY TO DIAGNOSTIC MODEL
C      GRID
C
c ---  Convert diagnostic grid spacing from m to km
       dxk = dx * 0.001
       dyk = dy * 0.001
c
c ---  Compute cell center x,y of diagnostic grid cell (1,1)
c ***  xorigcc = utmxor + (0.5*dxk)
c ***  yorigcc = utmyor + (0.5*dyk)
c ---  Compute diagnostic grid coordinates in real space
       xorigcc = xmap0 + (0.5 * dxk)
       yorigcc = ymap0 + (0.5 * dyk)
c
c ---  Loop over diagnostic grid
       do 125 j = 1,ny
c ---  Compute Y of cell center
       y = yorigcc + (j - 1) * dyk
       do 125 i = 1,nx
c ---    Compute X of cell center
         x = xorigcc + (i - 1) * dxk       
c      
c frr (09/01)
c ---    Store previous time step for interpolation in time FRR (09/2001)
         do 121 k = 1,nz
          uprog1(i,j,k) = uprog2(i,j,k)
          vprog1(i,j,k) = vprog2(i,j,k) 
          tprog1(i,j,k) = tprog2(i,j,k)
          vptprog1(i,j,k) = vptprog2(i,j,k)                   

c ---    Interpolate horizontally from prognostic grid to diagnostic
c ---    grid x,y using inverse distance squared at four nearest points.
c      
          call r2interp(i,j,x,y,udat2,k,uprog2(i,j,k))
          call r2interp(i,j,x,y,vdat2,k,vprog2(i,j,k))
          call r2interp(i,j,x,y,tmm4,k,tprog2(i,j,k))
          call r2interp(i,j,x,y,vptdat,k,vptprog2(i,j,k))
 121     continue
      
c frr (09/01)
c ---    Get temperature vertical profile at closest MM5 gridpoint
c ---    (to compute mixing heights in mixht2 - noobs mode)
c frr 030106 : only use above ground MM5 levels and extrapolate to surface

         index=indx(igrab(i,j,1),jgrab(i,j,1))

         do 122 k = 2,nlevag1+1-index
            tz1(i,j,k) = tz2(i,j,k)
            zl1(i,j,k) = zl2(i,j,k)
            tz2(i,j,k) = tp(igrab(i,j,1),jgrab(i,j,1),index+k-2)
            zl2(i,j,k) = zp(igrab(i,j,1),jgrab(i,j,1),index+k-2)
 122     continue

c persistence aloft
         do 123 k=nlevag1+2-index,nlevag1
            tz1(i,j,k) = tz2(i,j,k)
            zl1(i,j,k) = zl2(i,j,k)
            tz2(i,j,k) = tz2(i,j,k-1)
            zl2(i,j,k) = zl2(i,j,k-1)+1.
 123     continue

c extrapolation at surface (if MM5 levels below surface, ensure all tz levels
c are just above surface
           tz1(i,j,1) = tz2(i,j,1)
           zl1(i,j,1) = 0.
           zl2(i,j,1) = 0.
           tz2(i,j,1)=tsurf(igrab(i,j,1),jgrab(i,j,1))
        
c frr (09/01) 2D array of surface density
c ---    Surface air density on CALMET grid
         rho1(i,j)=rho2(i,j)
         call r2interp2(i,j,x,y,rhop,rho2(i,j))
         
c --- v6.4.0, Level 121203
c ---    Swap previous future LWC into current
         qcup1(i,j)=qcup2(i,j)
         zuptop1(i,j)=zuptop2(i,j)
         zupbot1(i,j)=zupbot2(i,j)
         do kz=1,nz
            qc3d1(i,j,kz)=qc3d2(i,j,kz)
         enddo
c ---    Transfer cloud LWC from M3D grid to CALMET grid
c ---    Method 1:  Use nearest cell to preserve M3D cloud pattern
         qcup2(i,j)=qcavgp(igrab(i,j,1),jgrab(i,j,1))
         zuptop2(i,j)=zuptopp(igrab(i,j,1),jgrab(i,j,1))
         zupbot2(i,j)=zupbotp(igrab(i,j,1),jgrab(i,j,1))
         do kz=1,nz
            qc3d2(i,j,kz)=qcijpz(igrab(i,j,1),jgrab(i,j,1),kz)
         enddo

cc ---    Method 2:  Interpolate using 1/R2 (needs refinement!)
cc ---    Use CINTERP where a zero should not be in average
c         call CINTERP(i,j,x,y,qcavgp,qcup2(i,j))
c         call CINTERP(i,j,x,y,zuptopp,zuptop2(i,j))
c         call CINTERP(i,j,x,y,zupbotp,zupbot2(i,j))
c         do kz=1,nz
c            call R2INTERP(i,j,x,y,qcijpz,kz,qc3d2(i,j,kz))
c         enddo

         if(ldbaux) then
            if(qctot(igrab(i,j,1),jgrab(i,j,1)).GT.0.0) then
               write(io6,*)'LWC transferred to CALMET grid'
               write(io6,*)'i,j,i3D,j3D = ',i,j,
     &                      igrab(i,j,1),jgrab(i,j,1)
               write(io6,*)'LWC = ',(qc3d2(i,j,kz),kz=1,nz)
            endif
         endif

         
c frr (09/01) 2D array of surface relative humidity on CALMET grid
         irhprog1(i,j) = irhprog2(i,j)
         call r2interp(i,j,x,y,rh,1,rhprog(i,j))
         irhprog2(i,j) = int(rhprog(i,j))


c frr (021105) 2D array of relative humidity at 850 mb on CALMET grid
         rh850pg1(i,j) = rh850pg2(i,j)
c ---    070702: use r2interp2 for 2D array 
c ---    (and r2interp for a slice of a 3D array)
c        call r2interp(i,j,x,y,rh850,1,rh850pg2(i,j))
         call r2interp2(i,j,x,y,rh850,rh850pg2(i,j))

c ---    cloud cover (061231)
         ccgrid1(i,j) = ccgrid2(i,j)
c ---    070702: use r2interp2 for 2D array 
c ---    (and r2interp for a slice of a 3D array)
c        call r2interp(i,j,x,y,ccp,1,ccgrid2(i,j))
ccec101006         if (icloud.eq.4) call r2interp2(i,j,x,y,ccp,ccgrid2(i,j))
         if (mcloud.eq.4) call r2interp2(i,j,x,y,ccp,ccgrid2(i,j))


 125    continue

c ---   if qc data available, compute ceiling height and accumulated
c ---   cloud water content
ccec101006        if (icloud.ge.3) then
        if (mcloud.ge.3) then
          if ( ( (ioutmm5.ge.83).and.(ioutmm5.le.85) ).OR.
     &         ( (ioutmm5.ge.93).and.(ioutmm5.le.95) ) ) then
            do 127 j=1,ny
c ---       Compute Y of cell center
            y = yorigcc + (j - 1) * dyk
            do 127 i=1,nx
c ---          Compute X of cell center
               x = xorigcc + (i - 1) * dxk       
c ---          interpolate ceiling height based on qc to calmet grid
c              call cinterp(i,j,x,y,ceil,1,ceilprog)
               call cinterp(i,j,x,y,ceil,ceilprog)
c ---          convert ceiling height from meters to hundreds of feet
               iceilg1(i,j)=iceilg2(i,j)
               iceilg2(i,j)= int ( ceilprog/30.28 )
c ---          Vertically integrated cloud water
               qcprog1(i,j)=qcprog2(i,j)
c ---          bug (070702: use r2interp2 for 2D array 
c              call r2interp(i,j,x,y,qctot,1,qcprog2(i,j))
               call r2interp2(i,j,x,y,qctot,qcprog2(i,j))
127         continue
ccec101006          else if (icloud.eq.4) then
          else if (mcloud.eq.4) then
            do 1277 j=1,ny
            y = yorigcc + (j - 1) * dyk
            do 1277 i=1,nx
               x = xorigcc + (i - 1) * dxk       
               iceilg1(i,j)=iceilg2(i,j)
c ---          interpolate ceiling height based on cloud cover level to calmet grid
c ---          070702: use cinterp  for ceiling height (r2interp is not ok anyway
c              for 2D arrays, should have used r2interp2 if not cinterp) 
c               call r2interp(i,j,x,y,ceil4,1,ceilprog)
               call cinterp(i,j,x,y,ceil4,ceilprog)
               iceilg2(i,j)=int(ceilprog/30.28 )
1277         continue
          endif
        endif

c frr (09/01)
c ---   Interpolate precipitation rate onto CALMET grid
c       Using an interpolation technique similar to that in GRIDE         
        if (npsta.eq.-1) then
c ---      cec (03/02/14)
c ---      add rmm1 = rmm2 to have rmm1.ne.0 when prognostic time step
           do j=1,ny
           do i=1,nx
              rmm1(i,j)=rmm2(i,j)
           enddo
           enddo
           call interpqr(rain,rmm2)
        endif
c frr (09/01)
c ---    QA check prognostic timestep
         if (ifirstpg.eq.2) then
c --        Simplify: Use deltsec function (no special cases)
c ---       With actual seconds (080205)
c             call deltsec(it1,0,it2,0,istepmm5)
             call deltsec(it1,isec1,it2,isec2,istepmm5)
             if (istepmm5.ne.isteppgs) then
                write(io6,9010)isteppg,it2,isec2,it1,isec1
9010            format(//1x,'WARNING- Possible error ',
     &          /1x,'Check actual prognostic time step in MM5.DAT ',
     &          /1x,' User input is: ISTEPPG = ',i7,
     &          /1x,'it1=',i10,' and seconds: ',i5,
     &          /1x,'it2=',i10,' and seconds: ',i5)

                stop
             endif
             ifirstpg = 3
         endif

c ---    Read next record if start of run to allow interpolation in time
         if (ifirstpg.eq.1) then
             ifirstpg=2

             do 128 k = 1,nz
               do 126 j = 1,ny
               do 126 i = 1,nx
                 uprog1(i,j,k) = uprog2(i,j,k)
                 vprog1(i,j,k) = vprog2(i,j,k) 
                 tprog1(i,j,k) = tprog2(i,j,k)
                 vptprog1(i,j,k) = vptprog2(i,j,k)
126            continue
               do 227 j = 1,nyp
               do 227 i = 1,nxp
                 udat1(i,j,k) = udat2(i,j,k)
                 vdat1(i,j,k) = vdat2(i,j,k) 
227            continue
128          continue

c ---        M3DMEt.MEt variables (051113)
             do 2227 j = 1,nyp
             do 2227 i = 1,nxp
                sstp1(i,j) = sstp2(i,j)
                tairp1(i,j) = tairp2(i,j)
                rhp1(i,j)=rhp2(i,j)
                z1p1(i,j)=z1p2(i,j)
2227         continue

             do 228 j = 1,ny
             do 228 i = 1,nx
               iceilg1(i,j)=iceilg2(i,j)
               qcprog1(i,j)=qcprog2(i,j)
               rmm1(i,j) = rmm2(i,j)
               rho1(i,j) = rho2(i,j)
               irhprog1(i,j)=irhprog2(i,j)
               rh850pg1(i,j)=rh850pg2(i,j)
               ccgrid1(i,j)=ccgrid2(i,j)
228          continue

c --- v6.4.0, Level 121203
             do j=1,ny
               do i=1,nx
                 qcup1(i,j)=qcup2(i,j)
                 zuptop1(i,j)=zuptop2(i,j)
                 zupbot1(i,j)=zupbot2(i,j)
                 do k=1,nz
                   qc3d1(i,j,k)=qc3d2(i,j,k)
                 enddo
               enddo
             enddo

c set up temperature profile for use in MIXDT2 (Mix.H. growth)
             nlevag0= nlevag1
             do 1321 i = 1,nx
             do 1321 j = 1,ny
                do 1322 k = 1,mxnzp+1
                   tz0(i,j,k) = tz2(i,j,k)
                   zl0(i,j,k) = zl2(i,j,k)
1322            continue
1321         continue

             goto 1
         endif

      endif

c frr (09/01) landing point if interpolating in time (no new read)
555   continue

c --- Interpolate in time
c --- dtinc:  0.<=real<1 during run; dtinc possibly =1 in last step of run)
c --- Sub-hourly timesteps - use seconds (060215)
       call deltsec(it1,isec1,ndathre,nsece,ndeltinc)
       dtinc = (1.*ndeltinc)/isteppgs

      if (dtinc.lt.0.or.dtinc.gt.1.) then
         write(6,*)'STOP in RDMM5- DTINC out of bounds'
         write(io6,*)'STOP in RDMM5- DTINC out of bounds'
         write(io6,*)'Current Time (YYYYJJJHH) (LST): ',ndathre
         write(io6,*)'Current ending seconds (LST): ',nsece 
         write(io6,*)'Current M3D times in memory (LST): ',it1,it2
         write(io6,*)'Current M3D seconds in memory : ',isec1,isec2
         write(io6,*)'Value of dtinc: ',dtinc
         STOP
      endif

c --- not need for following test anylonger with seconds - Always integer (060215)      
c     allow dtinc should be <= 1 but allow round-off errors=> 1.001
c      if (dtinc.gt.1.001) dtinc = 1.*(ndathr-100+24-it1)/isteppg 

      do 115 j = 1,nyp
      do 115 i = 1,nxp
        do 1115 k = 1,nz
          udat(i,j,k)= udat1(i,j,k)+dtinc*(udat2(i,j,k)-udat1(i,j,k))
          vdat(i,j,k)= vdat1(i,j,k)+dtinc*(vdat2(i,j,k)-vdat1(i,j,k))
 1115   continue

c ---   M3DMET.MET variables (051113)
        sstp(i,j) = sstp1(i,j)+dtinc*(sstp2(i,j)-sstp1(i,j))
        tairp(i,j)= tairp1(i,j)+dtinc*(tairp2(i,j)-tairp1(i,j))
        rhp(i,j)=rhp1(i,j)+dtinc*(rhp2(i,j)-rhp1(i,j))
        z1p(i,j)=z1p1(i,j)+dtinc*(z1p2(i,j)-z1p1(i,j))

 115  continue

c --- v6.4.0, Level 121203
      do j=1,ny
        do i=1,nx
          qcup(i,j)=qcup1(i,j)+dtinc*(qcup2(i,j)-qcup1(i,j))
          zuptop(i,j)=zuptop1(i,j)+dtinc*(zuptop2(i,j)-zuptop1(i,j))
          zupbot(i,j)=zupbot1(i,j)+dtinc*(zupbot2(i,j)-zupbot1(i,j))
          do k=1,nz
            qc3d(i,j,k)=qc3d1(i,j,k)+dtinc*(qc3d2(i,j,k)-qc3d1(i,j,k))
          enddo
        enddo
      enddo

      do 15 j = 1,ny
      do 15 i = 1,nx

       do 215 k = 1,nz
         uprog(i,j,k)= uprog1(i,j,k)+dtinc*(uprog2(i,j,k)-uprog1(i,j,k))
         vprog(i,j,k)= vprog1(i,j,k)+dtinc*(vprog2(i,j,k)-vprog1(i,j,k))
         tprog(i,j,k)= tprog1(i,j,k)+dtinc*(tprog2(i,j,k)-tprog1(i,j,k))
         vptprog(i,j,k)= vptprog1(i,j,k)
     &                  +dtinc*(vptprog2(i,j,k)-vptprog1(i,j,k))

215    continue
       rmm(i,j)= rmm1(i,j)+dtinc*(rmm2(i,j)-rmm1(i,j))
       rho(i,j)= rho1(i,j)+dtinc*(rho2(i,j)-rho1(i,j))
       irhpg(i,j)= irhprog1(i,j)+dtinc*(irhprog2(i,j)-irhprog1(i,j))
c ---  frr 021105
       rh850pg(i,j)= rh850pg1(i,j)+dtinc*(rh850pg2(i,j)-rh850pg1(i,j))

c ---  frr 061231 - Cloud cover from all RH data (MM5toGrads)
ccec101006       if (icloud.eq.4)then
       if (mcloud.eq.4)then
          ccgrid(i,j)= ccgrid1(i,j)+dtinc*(ccgrid2(i,j)-ccgrid1(i,j))
       endif
15    continue
c
c frr (09/01) precip code  - 030119: also frozen based on temperature
        if (npsta.eq.-1) then
          do 135 i=1,nx
          do 135 j=1,ny
            if (rmm(i,j).gt.0.)then
               if (tprog(i,j,1).lt.273.15) then
                  ipcodepg(i,j)=20
               else
                  ipcodepg(i,j)=10
               endif
            else
               ipcodepg(i,j)=0
            endif
135       continue
        endif

c frr(09/01)
ccec101006      if (icloud.eq.3) then
      if (mcloud.eq.3) then
c ---   cloud cover from prognostic relative humidity at 850 MB
        call cloud3(nx,ny,rh850pg,ccgrid)
      endif
 
ccec101006      if (icloud.ge.3) then
      if (mcloud.ge.3) then
c ---  if qc data available, compute ceiling height otherwise use default

        if ( ( (ioutmm5.ge.83).and.(ioutmm5.le.85) ).OR.
     &       ( (ioutmm5.ge.93).and.(ioutmm5.le.95) ) ) then

          do 137 j=1,ny
          do 137 i=1,nx
c ---       linearly interpolate ceiling height if non zero values at t1 and t2
c ---       otherwise pick the non zero value
c ---       Test for t1 and t2 (080411)
c           if ( iceilg1(i,j).ne.0 .and. iceilg1(i,j).ne.0 )then 
            if ( iceilg1(i,j).ne.0 .and. iceilg2(i,j).ne.0 )then 
             iceilg(i,j)= iceilg1(i,j)+dtinc*(iceilg2(i,j)-iceilg1(i,j))
            else
             iceilg(i,j)= max(iceilg1(i,j),iceilg2(i,j))
            endif
c ---       impose zero cloud cover and zero ceiling height if qc=0
            qcprog(i,j)= qcprog1(i,j)+dtinc*(qcprog2(i,j)-qcprog1(i,j))
            if ( qcprog(i,j).lt.1.e-6 ) then
               ccgrid(i,j)= 0.
               iceilg(i,j)=0
            endif
137       continue
c ---     !!! Important: in RDMM5, the lowest actual cloud ceiling height
c ---         is the lowest MM5 level height, not the ground (0) even for 
c ---         fog. If this ever changed, the logic of using 0 for clear sky
c ---         should be reviewed (F. Robe - 080411)

        else

          do 138 j=1,ny
          do 138 i=1,nx          
ccec101006            if (icloud.eq.3)iceilg(i,j) = 80
            if (mcloud.eq.3)iceilg(i,j) = 80
ccec101006            if (icloud.eq.4) then
            if (mcloud.eq.4) then
c ---         Test for t1 and t2 (080411)
c             if ( iceilg1(i,j).ne.0 .and. iceilg1(i,j).ne.0 )then 
              if ( iceilg1(i,j).ne.0 .and. iceilg2(i,j).ne.0 )then 
             iceilg(i,j)= iceilg1(i,j)+dtinc*(iceilg2(i,j)-iceilg1(i,j))
             else
             iceilg(i,j)= max(iceilg1(i,j),iceilg2(i,j))
             endif
            endif

138       continue
 
        endif

      endif

      return
      end
c----------------------------------------------------------------------
      subroutine STULL (z2,t2,t20,z3,t3,t30,z1,t1)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 110324              STULL
c ---          F.Robe, SRC
c
c --- PURPOSE:  extrapolation of prog temperature down to surface CALMET
c               level during the night, based on Stull (1983)
c               Assumptions: initial profile is a dry adiabatic (cst Theta)
c               Therefore, the fact that z2 and z3 change with time does not
c               matter (theta2=~theta3, indpt of z2,z3 at sunset
c               This assumption is also necessary to compute theta1
c               
c --- UPDATES:
c --- V5.545 Level 040612 to V5.633 Level 110324 (F.Robe)
c            During a nightime warming (e.g. warm front) allow the same
c            warming at lower CALMET levels as warming at the lowest 3D.DAT
c            level.
c     V5.544 Level 030106 to V5.545 Level 040612
c            Bound H to avoid exponential overflow 
c 
c
c --- INPUT:  T2 - real - MM5 potential temperature at MM5 level Z2
c
c             Z2 - real - altitude above ground of lowest above ground MM5
c                         level
c
c             T20- real - T2 at t =0 , usually t=0 just before sunset (except
c                         during first night if run starts at night)
c
c             T3 - real - MM5 potential temperature at MM5 level Z3
c
c             Z3 - real - altitude above ground of second lowest above
c                         ground MM5 level (Z3>Z2>Z1>0)
c                         
c             T30- real - T2 at t =0 , usually t=0 just before sunset
c
c
c
c
c --- OUTPUT: T1 - real - extrapolated potentila temp. at CALMET level Z1
c             Z1 - real - altitude above ground of near surface calmet level
c

c ---------------------------------------------------------------------

c
c     empirical constant in Stull exponential profile
      alpha= 0.77

c     temperature drop since sunset at Z2 and Z3
      dt2=t2-t20
      dt3=t3-t30


c     If lowest 2 MM5 gridpoints are below the inversion
c     => retrieve curve parameters and extrapolate downward
c     

c     Compute scale height (make sure H>0 and non singular)

      if ( (t3.gt.t2). and.
     :     (dt3.lt.0.) .and. (dt2.lt.0) .and. (dt2.lt.dt3)) then

         H=alpha*(z3-z2)/log(dt2/dt3)

c     if Z2 and Z3 straddle the inversion, make assumption on inversion height:
c     assume H=z3/5 (empirical, based on inversion height~5H and z3~h)
c     Make this assumption also if dt2 or dt3 not "well-behaved"

      else 
         H=z3/5.
      endif

c     Bound H to avoid exponential overflow 
      H=max(H,z2/10.)




c     surface temperature drop since sunset
      dts=min(0.,dt2*exp(alpha*z2/H))

c     Bound surface cooling (arbitrary but prevents pb when T2<<T3 inducing
c     exponentially large (unrealistic) cooling at the surface)
      dts=max(dts,-15.)

      dt1= dts*exp(-alpha*z1/H)


c --- frr 110324 -
c     allow for near surface warm up e.g. during a warm front: 
c     In this case, allow CALMET temp to follow the same pattern i.e. to warm up by
c     as much as T2 has warmed up 
c     This does not add any radiative cooling but at least does not induce a discrepancy
c     in CALMET if the whole MM5 profile  is warming up
      if (dt2.gt.0)  dt1=dt2   



c     assuming t1=t2 at sunset, t10=t20 => t1=dt1+t10=dt1+t20
      t1=  dt1+t20


c     Note: if no cooling at z2: no cooling at z1 either but usually
c     cooling starts close to surface (pb especially if Z2 is >> )
c     in that case, no way of knowing what happens at the surface...

      return

      end
c ---------------------------------------------------------------------
      subroutine STULL0 (t2,z2,t3,z3,t20,t30)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 030106             STULL0
c ---          F.Robe, SRC
c
c --- PURPOSE:  Initialize Stull's temperature profile at night
c               based on Stull (1983)
c               Useful as CALMET runs must start between 0-5AM (i.e. after sunset)
c
c --- INPUT:  T2 - real - MM5 potential temperature at MM5 level Z2
c
c             Z2 - real - altitude above ground of lowest above ground MM5
c                         level
c
c
c             T3 - real - MM5 potential temperature at MM5 level Z3
c
c             Z3 - real - altitude above ground of second lowest above
c                         ground MM5 level (Z3>Z2>Z1>0)
c                         
c
c
c
c --- OUTPUT: T20 - real - T2 at sunset
c             T30 - real - T3 at sunset
c

c ---------------------------------------------------------------------
c
c     empirical constant in Stull exponential profile
      alpha= 0.77

c     Stull:
c     t3=t30+dts * exp(-alpha*z3/H)
c     t2=t20+dts * exp(-alpha*z2/H)

c     assume z3~inversion height(h)  and h~5H
      H=z3/5.

c     assume t30=t20 (dry adiabatic profile at sunset)
c     => t3-t2=dts * [ exp(-alpha*z3/H) - exp(-alpha*z2/H) ]    

      dts= (t3-t2)/ (  exp(-alpha*z3/H) - exp(-alpha*z2/H) ) 
      dts=min (dts,0.)

c     Bound surface cooling (arbitrary but prevents pb when T2<<T3 inducing
c     exponentially large (unrealistic) cooling at the surface)
      dts=max(dts,-15.)

      t30=t3-dts* exp(-alpha*z3/H)
      t20=t30
      return
      end
c----------------------------------------------------------------------
      subroutine rdnwd(io,n,xbuf)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130              RDNWD
c ---          J. Scire, SRC
c
c --- PURPOSE:  Read "N" words from an unformatted data file
c
c --- INPUTS:
c                IO - integer    - Fortran unit no. of input file
c                 N - integer    - Number of words to read
c
c --- OUTPUT:
c           XBUF(N) - real array - Array of values from data file
c
c --- RDNWD called by:  RDP
c --- RDNWD calls:      none
c----------------------------------------------------------------------
      real xbuf(n)
c
      read(io)xbuf
c
      return
      end
c----------------------------------------------------------------------
      subroutine rdow(idathrb)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203               RDOW
c ---          J. Scire, Earth Tech, Inc.
c ---          Modified by M. Fernau
c
c --- PURPOSE:  Read overwater meteorological data for each
c               appropriate station
c               (valid date/hr of data stored in data arrays is
c               compared with current date/hr to determine if it
c               is time to read the next record)
c
c --- UPDATES:
c
c --- V6.206 (060322) to v6.4.0 (121203)
c      - Add wind dir. rotation for Polar Stereographic projection
c
c --- V6.205 (060309)to V6.206 (060322)(F.Robe)
c     (1) Correct another date matching test so works also around midnight
c
c --- v6.2 (060215)to V6.205 (060309)(F.Robe)
c     (1) Correct date matching test so works also around midnight
c
c --- v5.613 (051227) to v6.2 (060215)(F.Robe)
c     (1) interpret the model time as explicit beginning time, not
c         hour-ending time
c
c --- V5.61 (051111) to v5.613 (051227) (F.Robe)
c     (1) Read SEA.DAT level 2.11 (Air Temp Sensor height, Water Temp
c         Sensor depth, dt with 2 decimals). Store values in
c         OVRWAT.MET
c
c --- V5.6d (050428) to v5.61 (051111) (DGS)
c     (1) Test for missing values of TWAVE, HWAVE using 9999. and
c         then reset to -999. for later use in COARE
c     (2) Sea.dat version number for each file
c
c --- V5.6 (050328) to v5.6d (050428)(F.Robe)
c     (1) Compute logarithmic adjustment coefficients after "too-early obs" 
c         have been read for all stations
c         
c --- V5.5 (030402) to V5.6 (050328) (F.Robe)
c     (1) Compute logarithmic adjustment coefficient to extrapolate
c         wind measurements from anemometer height to first CALMET level
c         Zlogwsta stored in OVRWAT.MET
c
c     (2) Modify to read new SEA.DAT format (2.1) 
c         - 2 new variables: dominant wave period (TWAVE) and 
c           significant wave height (HWAVE) that can be used in 
c           COARE waveparameterizations-
c           Missing and default values: -999.
c         - one old variable removed (XOWLON)
c         - Can still read old SEA.DAT format (pre 2.1)
c 
c     (3) Compute xowlon internally (no longer in SEA.DAT for
c         SEA.DAT versions 2.1 and higher). xowlon is internally
c         an EAST longitude (no longer West longitude)
c
c     (4) Change type of xkm,ykm from real*8 to real*4
c
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c               - Add list-file unit to YR4 call
c               - /MAP/ replaces /LON/
c               - LLCC replaces LLCONF
c               - Remap station (x,y) if needed
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUT:
c       IDATHRB - integer      - Current date and hour (YYYYJJJHH where
c                                YYYY=year, JJJ=Julian day,
c                                HH=hour (00-23) (explicit beginning time!)
c
c       Common block /OVRWAT/ variables
c          NOWSTA, IOOW(mxows), IOWBEG(mxows), IOWEND(mxows),
c          XOR2, YOR2, CACTIONOW, VECTIOW, VECTOOW, DATUMOW, LREMAP,
c          rverow(mxows)
c
c       Common block /MAP/ variables
c          XLAT1,RLON0,LLCC,CONEC,DATUM,CACTIONLL,VECTILL,VECTOLL
c          LPS
c       Parameters: MXOWS, IO6
c
c --- OUTPUT:
c       common block /OVRWAT/ variables
c          XOWSTA(mxows), YOWSTA(mxows), ZOWSTA(mxows),
c          ZTAIR(mxows), ZSST(mxows),
c          IOWBEG(mxows), IOWEND(mxows),
c          DTOW(mxows), TAIROW(mxows), RHOW(mxows), ZIOW(mxows),
c          TGRADB(mxows),TGRADA(mxows),WSOW(mxows),
c          WDOW(mxows),XOWLON(mxows), XOWLAT(mxows)
c          TWAVE(Mxows),HWAVE(mxows),z0ow(mxows)
c
c --- RDOW called by: COMP
c --- RDOW calls:     YR4
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c xkm,ykm output from globe should be real*4
c      real*8 xkm,ykm
c
      include 'ovrwat.met'
      include 'map.met'
      include 'grid.met'

c --- For coordinate transformations
      character*4 c4hem

      data z0min/2.e-6/
      data rmiss/9998./
c
c --- loop over stations -- read new data if current data values are
c --- expired
      if(nowsta.lt.1)return

      do 100 i=1,nowsta
c
c --- In MOD6, idathrb is the explicit beginning time of the current timestep
c --- while iowend is an hour-ending time (FRR - 060215)
c     if(idathr.gt.iowend(i))then

      if(idathrb.gt.(iowend(i)-1))then 
c
c ---    read a new data record for station "i"
         io=ioow(i)
10       continue
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(i).ge.2.10999)then 
             read(io,*,end=999)xowkm,yowkm,
     &                     zowsta(i),ztair(i),zsst(i),i1yr,i1jul,i1hr,
     1       i2yr,i2jul,i2hr,dtow(i),tairow(i),rhow(i),ziow(i),
     2       tgradb(i),tgrada(i),wsow(i),wdow(i),twave(i),hwave(i)

c ---    SEA.DAT version 2.1 and higher: new variables: twave, rwave; removed:xowlon
         else if (rverow(i).ge.2.099)then
             read(io,*,end=999)xowkm,yowkm,
     &                     zowsta(i),i1yr,i1jul,i1hr,
     1       i2yr,i2jul,i2hr,dtow(i),tairow(i),rhow(i),ziow(i),
     2       tgradb(i),tgrada(i),wsow(i),wdow(i),twave(i),hwave(i)

c ---        Do not accept zero wave period
             if(twave(i).EQ.0.0) then
                write(io6,*)
                write(io6,*)
                write(io6,*)'ERROR IN SUBR. RDOW reading SEA.DAT'
                write(io6,*)'Wave period should not be zero'
                write(io6,*)'File # ',i
                write(io6,*)'Time: ',i1yr,i1jul,i1hr
                write(*,*)'Halted in RDOW -- See list file.'
                stop
             endif

c ---        Convert missing value indicator to COARE format
             if(twave(i).GT.rmiss) twave(i)=-999.
             if(hwave(i).GT.rmiss) hwave(i)=-999.
         else
            read(io,*,end=999)xowkm,yowkm,xowlon(i),
     &                     zowsta(i),i1yr,i1jul,i1hr,
     1      i2yr,i2jul,i2hr,dtow(i),tairow(i),rhow(i),ziow(i),
     2      tgradb(i),tgrada(i),wsow(i),wdow(i)



c ---       EAst longitude used in the code (new since v5.6 050328)
            xowlon(i)=-xowlon(i)
         endif
         call YR4(io6,i1yr,ierrb)
         call YR4(io6,i2yr,ierre)
         if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in RDOW'
c         
c
c ---    compute date/hour variables
         iowbeg(i)=i1yr*100000+i1jul*100+i1hr
         iowend(i)=i2yr*100000+i2jul*100+i2hr
c
c --- In MOD6, idathrb is the explicit beginning time of the current timestep
c --- while iowbeg is an hour-ending time (FRR - 060215)
c        if(idathr.lt.iowbeg(i))then
c        if(idathrb.lt.(iowbeg(i)-1))then  : this test does not work around midnight (060206)
         call deltsec(idathrb,0,iowbeg(i),0,ndels)      
         if(ndels.gt.3600.)then
            write(io6,22)i,io,idathrb,iowbeg(i)
22          format(//2x,'ERROR IN SUBR. RDOW reading overwater met. ',
     1      'data -- required date/hour not found'/5x,'File no. = ',i5,
     2      3x,'I/O unit no. = ',i5/5x,'Date/hour = ',i9,5x,
     3      'Date/hour read from file = ',i9)
            stop
         endif

c ---    if(idathr.gt.iowend(i))go to 10
         if(idathrb.gt.(iowend(i)-1))go to 10

c ---    Remap station (x,y) if needed
         if(LREMAP) then
            call GLOBE(io6,cactionow,datumow,vectiow,datum,vectoow,
     &                 xowkm,yowkm,xkm,ykm,idum,c4hem)
         else
            xkm=xowkm
            ykm=yowkm
         endif

c ---    Compute the N.lat/E.lon of overwater stations 
c ---    XOWLON no longer in SEA.DAT (SEA.DAT version 2.1 and higher)
         if ( rverow(i).gt.2.099) then
            x=xkm
            y=ykm

            call GLOBE(io6,cactionll,datum,vectill,datum,vectoll,
     &              x,y,xowlon(i),xowlat(i),izone,c4hem)

           
         endif
c ********************************************************8

c
c ---    convert to relative coordinates
c ---    convert to m from km
         xowsta(i)=1000.*(xkm-xor2)
         yowsta(i)=1000.*(ykm-yor2)

c
c --- If using Polar Stereographic Projection or
c --- If using Lambert conformal compute delta longitudes and
c --- convert wind direction from true north (south) to
c --- map north (south); assumes Western hemisphere longitudes
c --- are input as NEGATIVE values)
c

c --- v6.4.0, Level 121203
         if(LLCC .OR. LPS) then

           dlonow = rlon0 + xowlon(i)
c --- Code to handle 180 degree longitude straddle
           if (dlonow .gt. 180.) dlonow = dlonow - 360.
           if (dlonow .lt. -180.) dlonow = dlonow + 360.
           if (wdow(i) .LE. 9998.) then
             if (wdow(i) .LT. .01 .and. wsow(i) .LT. .01) goto 20
             if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
               wdow(i) = wdow(i) + (conec * dlonow)
             else
c --- Northern Hemisphere
               wdow(i) = wdow(i) - (conec * dlonow)
             end if
             if(wdow(i) .LT. 0.) wdow(i) = wdow(i) + 360.
             if(wdow(i) .GT. 360.) wdow(i) = wdow(i) - 360.
           endif
20         continue
         endif

c     else if(idathr.lt.iowbeg(i))then
c     else if(idathrb.lt.(iowbeg(i)-1))then: this test does not work around midnight (060322)
      else 
         call deltsec(idathrb,0,iowbeg(i),0,ndels)      
         if(ndels.gt.3600.)then
c
c ---      date/hr requested is out of range of stored data
           write(io6,112)i,io,idathrb,iowbeg(i),iowend(i)
112        format(//2x,'ERROR IN SUBR. RDOW -- Date/hour requested ',
     1     'for overwater data is not within range '/2x,'of data in ',
     2     'file'/5x,'File no. = ',i5,3x,'I/O unit no. = ',i5
     3     /5x,'Date/hour beginning at explicit time = ',i9,5x,
     4     'Range read from file -- Beginning date/hour(ending) = ',
     5     i9,3x,'Ending date/hour(ending) = ',i9)
           stop
         endif
      endif
      go to 100
c
c --- end-of-file reached before date/hour found
999   continue
      write(io6,122)i,io,idathrb
122   format(//2x,'ERROR IN SUBR. RDOW reading overwater met. ',
     1 'data'//2x,'end-of-file reached before required date/hour ',
     2 'found'/5x,'File no. = ',i5,3x,'I/O unit no. = ',i5/5x,
     3 'Date/hour = ',i9)
      stop
c
100   continue
c
c --- Compute scaling factors to extrapolate surface wind observations
c --- to first CALMET level (neutral logarithmic profile)
c --- frr 050328  - Stored in OVRWAT.MET
      do n=1,nowsta
c ---    z0: overwater roughness length
c ---    Use Hosker formula (1974) here, knowing that not quite accurate
c ---    as it requires wind at 10m , not at Zowsta.
         if(wsow(n).gt.0.0 .and. wsow(n).lt.9998.)then
           z0ow(n)= 2.0e-6 * wsow(n) ** 2.5
           z0ow(n) = amax1(z0min,z0ow(n))
         else
           z0ow(n) = z0min
         endif
         xlnzo=alog(z0ow(n))
c ---    z1: first CALMET level
         xlnz1=alog(zmid(1))
c ---    z2: anemometer height (if missing, assume 10m)
         if (zowsta(n).gt.9998) then
            xlnz2=alog(10.)
         else
            xlnz2=alog(zowsta(n))
         endif
c ---    Logarithmic profile scaling factor
c        u(k=1)=zlogssta*u(zowsta)
         zlogwsta(n)=(xlnz1-xlnzo)/(xlnz2-xlnzo)

      end do
c ---                                    

      return
      end
c----------------------------------------------------------------------
      subroutine rdp(iformp,npsta,ippack,io,iskip,iyr,ijul,ihr,xprecp)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 030402                RDP
c ---          J. Scire, Earth Tech, Inc.
c
c --- PURPOSE:  Read and process precipitation data for one hour
c        If data are packed,   2 records/hour -- read, unpack, & decode
c        If data are unpacked, 1 record/hour  -- read and decode
c
c --- UPDATE
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c               - Add list-file unit to INCR, YR4 calls
c --- V5.1-V5.2     000602a (DGS): Change old 1-24 to 0-23 hour format
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c            IFORMP - integer    - Data format flag (0=data not used,
c                                  1=unformatted, 2=formatted)
c             NPSTA - integer    - Number of precipitation stations
c            IPPACK - integer    - Data packing code (0=unpacked,
c                                  1=packed)
c                IO - integer    - Fortran unit no. of precip. input
c                                  file
c             ISKIP - integer    - Unpacking flag (used only if IPPACK=1)
c                                  (If ISKIP=0, data are unpacked, if
c                                  ISKIP=1, data are read but not
c                                  unpacked)
c        Parameters: IO6, MXPS
c
c --- OUTPUT:
c               IYR - integer    - Year of precip. data (4 digits)
c              IJUL - integer    - Julian day number of precip. data
c               IHR - integer    - Ending hour (0-23) of precip. data
c     XPRECP(NPSTA) - real array - Unpacked Precip. rates (mm/hr) for
c                                  each station (9999. indicates
c                                  missing value)
c
c --- RDP called by:  READHD
c --- RDP calls:      RDNWD, UNPACK, DEDAT, YR4, INCR
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real xprecp(npsta),xbuf(mxps)
c
      if(iformp.eq.0)then
c ---    precip data not used
         do 5 i=1,npsta
         xprecp(i)=9999.
5        continue
c
      else if(iformp.eq.1)then
c
c ---    precip. data unformatted
         if(ippack.eq.0)then
c
c ---       read unpacked data
            read(io)idathr,xprecp
         else
c
c ---       read first record of packed data
            read(io)idathr,nwords
c
c ---       read second record of packed data (if necessary)
            if(nwords.eq.0)then
c
c ---          second record is omitted if all values are zero
               if(iskip.eq.0)then
                  do 10 i=1,npsta
                  xprecp(i)=0.0
10                continue
               endif
            else
c
c ---          read second record with "nwords"
               call rdnwd(io,nwords,xbuf)
c
c ---          unpack precipitation rates
               if(iskip.eq.0)call unpack(nwords,xbuf,npsta,xprecp)
            endif
         endif
c
c ---    decode date and time
         call dedat(idathr,iyr,ijul,ihr)
c
      else if(iformp.eq.2)then
c
c ---    precip. data formatted
         read(io,*)iyr,ijul,ihr,xprecp
      else
         write(io6,12)iformp
12       format(//2x,'ERROR IN SUBR. RDP -- invalid value of IFORMP'/
     1   5x,'IFORMP = ',i10)
         stop
      endif

c --- Check for old 1-24 hour format
      if(ihr.EQ.24) then
c ---    Step back 1 hour (to hour 23)
         ihr=23
c ---    Move forward 1 hour (to hour 0 of 'next' day)
         istep=1
         call INCR(io6,iyr,ijul,ihr,istep)
      endif
c
      call YR4(io6,iyr,ierr)
      if(ierr.NE.0) stop 'Halted in RDP'
c
      return
      end
c----------------------------------------------------------------------
      subroutine rdpn(iformp,npsta,ippack,io,iskip,
     1       ndathrb,nsecb,ibdathrn,ibsecn,iedathrn,iesecn,xprecp)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 080205               RDPN
c ---          F.Robe (Earth Tech Inc.)
c              after RDP version 030402 (J.Scire Earth Tech)
c
c --- UPDATES:
c ---  V6.0 Level 051128 to V6.32 Level 080205(F.Robe)
c         - Add QA checks to ensure that the record frequency is 
c           at least hourly and that there is valid data (no gap)
c
c --- V5.6 Level 041123 to V6.0 Level 051128 (F.Robe)
c        - Implement explicit times and allow sub-hourly frequency
c          and timesteps
c
c --- PURPOSE:  Read and process precipitation data 
c        If data are packed,   2 records/hour -- read, unpack, & decode
c        If data are unpacked, 1 record/hour  -- read and decode
c        Read 2.1 versions (explicit beg/ending times with seconds)
c
c --- INPUTS:
c            IFORMP - integer    - Data format flag (0=data not used,
c                                  1=unformatted, 2=formatted)
c             NPSTA - integer    - Number of precipitation stations
c            IPPACK - integer    - Data packing code (0=unpacked,
c                                  1=packed)
c                IO - integer    - Fortran unit no. of precip. input
c                                  file
c             ISKIP - integer    - Unpacking flag (used only if IPPACK=1)
c                                  (If ISKIP=0, data are unpacked, if
c                                  ISKIP=1, data are read but not
c                                  unpacked)
c           NDATHRB - iteger     - Current time step beginning time 
c                                  (YYYYJJJHH) (explicit)
c            NSECB  - integer    - Current timestep beginning seconds
c
c        Parameters: IO6, MXPS
c
c --- OUTPUT:
c           IBDATHRN - iteger     - data record beginning time 
c                                  (YYYYJJJHH) (explicit)
c            IBSECN  - integer    - data record beginning seconds
c           IEDATHRN - integer    - data record ending time 
c                                  (YYYYJJJHH) (explicit)
c            IESECN  - integer    - data record ending seconds
c     XPRECP(NPSTA) - real array - Unpacked Precip. rates (mm/hr) for
c                                  each station (9999. indicates
c                                  missing value)
c
c --- RDPN called by:  READHD
c --- RDPN calls:      RDNWD, UNPACK, DEDAT, YR4, INCR
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real xprecp(npsta),xbuf(mxps)
c

c --- Do not read any record if previously read data is still valid (051128)
c --- Check if current timstep beginning time is between previously read
c --- data beginning and ending times
      call deltsec(ibdathrn,ibsecn,ndathrb,nsecb,ndelsecb)
      call deltsec(iedathrn,iesecn,ndathrb,nsecb,ndelsece)

      if (ndelsecb.ge.0 .and. ndelsece.lt.0 ) then
c ---    use the existing data record 
         return
      endif


1     continue


      if(iformp.eq.0)then
c ---    precip data not used
         do 5 i=1,npsta
         xprecp(i)=9999.
5        continue
c
      else if(iformp.eq.1)then
c
c ---    precip. data unformatted
         if(ippack.eq.0)then
c
c ---       read unpacked data
            read(io)ibdathr,ibsecn,iedathr,iesecn,xprecp
         else
c
c ---       read first record of packed data
            read(io)ibdathr,ibsecn,iedathr,iesecn,nwords
c
c ---       read second record of packed data (if necessary)
            if(nwords.eq.0)then
c
c ---          second record is omitted if all values are zero
               if(iskip.eq.0)then
                  do 10 i=1,npsta
                  xprecp(i)=0.0
10                continue
               endif
            else
c
c ---          read second record with "nwords"
               call rdnwd(io,nwords,xbuf)
c
c ---          unpack precipitation rates
               if(iskip.eq.0)call unpack(nwords,xbuf,npsta,xprecp)
            endif
         endif
c
c ---    decode date and time
         call dedat(ibdathr,ibyrn,ibjuln,ibhrn)
         call dedat(iedathr,ieyrn,iejuln,iehrn)
c
      else if(iformp.eq.2)then
c
c ---    precip. data formatted
         read(io,*)ibyrn,ibjuln,ibhrn,ibsecn,ieyrn,iejuln,iehrn,
     :               iesecn,xprecp

         call YR4(io6,ibyrn,ierr)
         if(ierr.NE.0) stop 'Halted in RDPN -Y2K'
         call YR4(io6,ieyrn,ierr)
         if(ierr.NE.0) stop 'Halted in RDPN -Y2K'

c ---    Convert seconds to hours and hours to 0-23
         if (ibhrn.ge.24) then
            ibsecn=ibsecn+(ibhrn-23)*3600
            ibhrn=23
         endif
         if(ibsecn.GE.3600) then
            nhrinc=ibsecn/3600
            ibsecn=ibsecn-nhrinc*3600
            call INCR(io6,ibyrn,ibjuln,ibhrn,nhrinc)
         endif
         if (iehrn.ge.24) then
            iesecn=iesecn+(iehrn-23)*3600
            iehrn=23
         endif
         if(iesecn.GE.3600) then
            nhrinc=iesecn/3600
            iesecn=iesecn-nhrinc*3600
            call INCR(io6,ieyrn,iejuln,iehrn,nhrinc)
         endif            

         ibdathrn=ibyrn*100000+ibjuln*100+ibhrn
         iedathrn=ieyrn*100000+iejuln*100+iehrn

 
      else
         write(io6,12)iformp
12       format(//2x,'ERROR IN SUBR. RDPN -- invalid value of IFORMP'/
     1   5x,'IFORMP = ',i10)
         stop
      endif
c
c
c --- Check that the record frequency is at most hourly
c     (080205)
      call deltsec(ibdathrn,ibsecn,iedathrn,iesecn,ndeltat)
      if(ndeltat.gt.3600) then
         write(6,*)'STOP in subroutine RDPN'
         write(6,*)'Surface data record is longer than 1 hour'
         write(io6,*)'STOP in subroutine RDPN'
         write(io6,*)'Surface data record is longer than 1 hour'
         write(io6,*)
     :        'Surface data should be provided at least once per hour'
         write(io6,*)'Beginning Time (YYYYJJJHH - seconds)',
     :               ibdathrn,'  -  ',ibsecn
         write(io6,*)'End Time (YYYYJJJHH - seconds)',
     :               iedathrn,'  -  ',iesecn   
         STOP
      endif 

c --- Check if current timestep beginning time is between data beginning
c --- and ending times
      call deltsec(ibdathrn,ibsecn,ndathrb,nsecb,ndelsecb)
      call deltsec(iedathrn,iesecn,ndathrb,nsecb,ndelsece)

c

      if (ndelsecb.ge.0 .and. ndelsece.lt.0 ) then
c ---   Beg-end times of precip record straddle current time
c ---   use this data record
      else if (ndelsecb.lt.0) then
c ---    No data for current timestep (missing record or starts too late)
         write(6,*)'STOP in subroutine RDPN - Check list file'
         write(io6,*)'STOP in SUbroutine RDPN'
         write(io6,*)'No precipitation data for current timestep'
         write(io6,*)'Current timestep begins at:',ndathrb,'- ',nsecb
         write(io6,*)'Next precipitation record begins at:',
     :            ibdathrn,'- ',ibsecn
         STOP
      else
c ---    Relevant record not yet reached
c ---    read next record
         goto 1  
      endif

      return
      end
c----------------------------------------------------------------------
      subroutine rds(iforms,nssta,ispack,io,iskip,ibuf,iyr,ijul,ihr,
     1 ws,wd,iceil,icc,tempk,irh,pres,ipcode)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203                RDS
c ---          J. Scire, Earth Tech, Inc.
c ---          Modified by M. Fernau, Earth Tech
c
c --- PURPOSE:  Read a record of surface meteorological data
c               (missing value indicator = 9999. (real) or
c                9999 (integer)) -- If packing is used, data will
c                be unpacked before returning
c
c --- UPDATE
c
c --- V5.5 (030402) to v6.4.0 (121203)
c      - Add wind dir. rotation for Polar Stereographic projection
c
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c               - Add list-file unit to YR4 call
c               - Add /MAP/ (/LON/ revised)
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c            IFORMS - integer    - Data format flag (1=unformatted,
c                                  2=formatted)
c             NSSTA - integer    - Number of surface stations
c            ISPACK - integer    - Data packing code (0=unpacked,
c                                  1=packed)
c                IO - integer    - Fortran unit no. of surface data
c             ISKIP - integer    - Flag controlling unpacking of data
c                                  if ISKIP=0 data are unpacked, if
c                                  ISKIP=1, data are read but not
c                                  unpacked (used only if ISPACK=1)
c     IBUF(3,NSSTA) - int. array - Buffer to temporarily store packed
c                                  data (used only if ISPACK = 1)
c        Parameters: IO6
c        Common block /LON/ variables
c          DLONGS
c        Common block /MAP/ variables
c          XLAT1,LLCC,CONEC
c          LPS
c
c --- OUTPUT:
c               IYR - integer    - Year of surface data (4 digits)
c              IJUL - integer    - Julian day of data
c               IHR - integer    - Hour of data
c         WS(NSSTA) - real array - Wind speed (m/s)
c         WD(NSSTA) - real array - Wind direction (degrees)
c      ICEIL(NSSTA) - int. array - Ceiling height (hundreds of ft)
c        ICC(NSSTA) - int. array - Opaque sky cover (tenths)
c      TEMPK(NSSTA) - real array - Temperature (deg. K)
c        IRH(NSSTA) - int. array - Relative humidity (percent)
c       PRES(NSSTA) - real array - Surface pressure (mb)
c     IPCODE(NSSTA) - int. array - Precipitation code
c
c --- RDS called by:  READHD, COMP
c --- RDS calls:      UNPCKS, DEDAT, YR4
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'lon.met'
      include 'map.met'
c
      real ws(nssta),wd(nssta),tempk(nssta),pres(nssta)
c
      integer iceil(nssta),icc(nssta),irh(nssta),ipcode(nssta)
      integer ibuf(3,nssta)
c
      if(iforms.eq.1)then
c
c ---    unformatted data
         if(ispack.eq.0)then
c ---       read unpacked, unformatted data
            read(io)idathr,ws,wd,iceil,icc,tempk,irh,pres,ipcode
         else
c ---       read packed, unformatted data --
c ---       date/hr word + 3 words/station
            read(io)idathr,ibuf
c ---       unpack data (unless in skip mode)
            if(iskip.eq.0)call unpcks(nssta,ibuf,ws,wd,iceil,icc,
     1      tempk,irh,pres,ipcode)
         endif
c ---    decode date and time
         call dedat(idathr,iyr,ijul,ihr)
c
      else if(iforms.eq.2)then
c
c ---    formatted data
         read(io,*)iyr,ijul,ihr,(ws(n),wd(n),iceil(n),icc(n),tempk(n),
     1   irh(n),pres(n),ipcode(n),n=1,nssta)
c
      else
         write(io6,12)iforms
12       format(//2x,'ERROR IN SUBR. RDS -- invalid value of IFORMS'/
     1   5x,'IFORMS = ',i10)
         stop
      endif
c
      call YR4(io6,iyr,ierr)
      if(ierr.NE.0) stop 'Halted in RDS'
c

c --- v6.4.0, Level 121203
      if(LLCC .OR. LPS) then

c**     convert wind direction from true north (south) to map
c **    north (south) (EMI 7/30/92)
        do 20 i=1,nssta
            if(wd(i).LE.9998.)then
               if(wd(i).LT.0.01 .and. ws(i).LT.0.01) go to 20
               if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
                 wd(i) = wd(i) + (conec * dlongs(i))
               else
c --- Northern Hemisphere
                 wd(i) = wd(i) - (conec * dlongs(i))
               end if
               if(wd(i).LT.0.) wd(i) = wd(i) + 360.
               if(wd(i).GT.360.) wd(i) = wd(i) - 360.
            endif
20      continue
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine rdsn(iforms,nssta,ispack,io,iskip,ibuf, 
     1       ndathrb,nsecb,ibdathrn,ibsecn,iedathrn,iesecn,
     1       ws,wd,iceil,icc,tempk,irh,pres,ipcode)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203               RDSN
c              F.Robe, Earth Tech, Inc.
c ---          After subroutine RDS (J. Scire, Earth Tech, Inc.)

c --- PURPOSE:  Read a record of surface meteorological data
c               with explicit beg/ending times with seconds
c               (missing value indicator = 9999. (real) or
c               9999 (integer)) -- If packing is used, data will
c               be unpacked before returning
c               
c---UPDATES
c
c --- V6.32 Level 080205 to v6.4.0 (121203)
c         - Add wind dir. rotation for Polar Stereographic projection
c
c ---  V6.01 Level 041123 to V6.32 Level 080205(F.Robe)
c         - Add QA checks to ensure that the record frequency is 
c           at least hourly and that there is valid data (no gap)
c
c ---  V5.61 Level 051116 to 6.01 Level 041123 (F.Robe)
c         - Ensure that a new record is read only if needed (i.e. not
c           at every call to rdsn - important if shorter timestep
c           than frequency update of surface records) 
c           timestep 
c          
c ---  V5.6  Level 041123 to v5.61 Level 051116 (F.Robe)
c         - Read sub-hourly data records
c
c --- INPUTS:
c            IFORMS - integer    - Data format flag (1=unformatted,
c                                  2=formatted)
c             NSSTA - integer    - Number of surface stations
c            ISPACK - integer    - Data packing code (0=unpacked,
c                                  1=packed)
c                IO - integer    - Fortran unit no. of surface data
c             ISKIP - integer    - Flag controlling unpacking of data
c                                  if ISKIP=0 data are unpacked, if
c                                  ISKIP=1, data are read but not
c                                  unpacked (used only if ISPACK=1)
c     IBUF(3,NSSTA) - int. array - Buffer to temporarily store packed
c                                  data (used only if ISPACK = 1)
c           NDATHRB - iteger     - Current time step beginning time 
c                                  (YYYYJJJHH) (explicit)
c            NSECB  - integer    - Current timestep beginning seconds
c
c        Parameters: IO6
c        Common block /LON/ variables
c          DLONGS
c        Common block /MAP/ variables
c          XLAT1,LLCC,CONEC
c          LPS
c
c --- OUTPUT:
c           IBDATHRN - iteger     - data record beginning time 
c                                  (YYYYJJJHH) (explicit)
c            IBSECN  - integer    - data record beginning seconds
c           IEDATHRN - integer    - data record ending time 
c                                  (YYYYJJJHH) (explicit)
c            IESECN  - integer    - data record ending seconds
c         WS(NSSTA) - real array - Wind speed (m/s)
c         WD(NSSTA) - real array - Wind direction (degrees)
c      ICEIL(NSSTA) - int. array - Ceiling height (hundreds of ft)
c        ICC(NSSTA) - int. array - Opaque sky cover (tenths)
c      TEMPK(NSSTA) - real array - Temperature (deg. K)
c        IRH(NSSTA) - int. array - Relative humidity (percent)
c       PRES(NSSTA) - real array - Surface pressure (mb)
c     IPCODE(NSSTA) - int. array - Precipitation code
c
c --- RDSN called by:  READHD, COMP
c --- RDSN calls:      UNPCKS, DEDAT, YR4, SHIFTEND
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'lon.met'
      include 'map.met'

c
      real ws(nssta),wd(nssta),tempk(nssta),pres(nssta)
c
      integer iceil(nssta),icc(nssta),irh(nssta),ipcode(nssta)
      integer ibuf(3,nssta)
c

c --- Do not read any record if previously read data is still valid (051128)
c     Check if current timstep beginning time is between data beginning and ending times
      call deltsec(ibdathrn,ibsecn,ndathrb,nsecb,ndelsecb)
      call deltsec(iedathrn,iesecn,ndathrb,nsecb,ndelsece)

      if (ndelsecb.ge.0 .and. ndelsece.lt.0 ) then
c ---    use the existing data record
         return
      endif
      


1     continue

      if(iforms.eq.1)then
c
c ---    unformatted data
         if(ispack.eq.0)then
c ---       read unpacked, unformatted data
               read(io)ibdathrn,ibsecn,iedathrn,iesecn,
     :                 ws,wd,iceil,icc,tempk,irh,pres,ipcode
          else
c ---       read packed, unformatted data --
c ---       date/hr word + 3 words/station
               read(io)ibdathrn,ibsecn,iedathrn,iesecn,ibuf
c ---       unpack data (unless in skip mode)
            if(iskip.eq.0)call unpcks(nssta,ibuf,ws,wd,iceil,icc,
     1      tempk,irh,pres,ipcode)
         endif
c
      else if(iforms.eq.2)then
c
c ---    formatted data
            read(io,*)ibyrn,ibjuln,ibhrn,ibsecn,ieyrn,iejuln,iehrn,
     1      iesecn,(ws(n),wd(n),iceil(n),icc(n),tempk(n),
     2      irh(n),pres(n),ipcode(n),n=1,nssta)

c ---       Make sure year is YYYY (Y2K)
            call YR4(io6,ibyrn,ierr)
            if(ierr.NE.0) stop 'Halted in RDSN: Y2K -See list file'

c ---       Convert seconds to hours and hours to 0-23
            if (ibhrn.ge.24) then
               ibsecn=ibsecn+(ibhrn-23)*3600
               ibhrn=23
            endif
            if(ibsecn.GE.3600) then
               nhrinc=ibsecn/3600
               ibsecn=ibsecn-nhrinc*3600
               call INCR(io6,ibyrn,ibjuln,ibhrn,nhrinc)
            endif
            if (iehrn.ge.24) then
               iesecn=iesecn+(iehrn-23)*3600
               iehrn=23
            endif
            if(iesecn.GE.3600) then
               nhrinc=iesecn/3600
               iesecn=iesecn-nhrinc*3600
               call INCR(io6,ieyrn,iejuln,iehrn,nhrinc)
            endif            

c ---       Record datestamp
            ibdathrn=ibyrn*100000+ibjuln*100+ibhrn
            iedathrn=ieyrn*100000+iejuln*100+iehrn

      else
         write(io6,12)iforms
12       format(//2x,'ERROR IN SUBR. RDSN -- invalid value of IFORMS'/
     1   5x,'IFORMS = ',i10)
         stop
      endif

c --- Check that the record frequency is at most hourly
c     (080205)
      call deltsec(ibdathrn,ibsecn,iedathrn,iesecn,ndeltat)
      if(ndeltat.gt.3600) then
         write(6,*)'STOP in subroutine RDSN'
         write(6,*)'Surface record is longer than 1 hour'
         write(6,*)'Check LST file'
         write(io6,*)'STOP in subroutine RDSN'
         write(io6,*)'Surface data record is longer than 1 hour'
         write(io6,*)
     :        'Surface data should be provided at least once per hour'
         write(io6,*)'Beginning Time (YYYYJJJHH - seconds)',
     :                ibdathrn,'  -  ',ibsecn
         write(io6,*)'End Time (YYYYJJJHH - seconds)',
     :                iedathrn,'  -  ',iesecn   
         STOP
      endif 

c     Check if current timstep beginning time is between data beginning and ending times
      call deltsec(ibdathrn,ibsecn,ndathrb,nsecb,ndelsecb)
      call deltsec(iedathrn,iesecn,ndathrb,nsecb,ndelsece)

      if (ndelsecb.ge.0 .and. ndelsece.lt.0 ) then
c ---   Beg-end times of surface record straddle current time
c ---   use this data record
      else if (ndelsecb.lt.0) then
c ---    No data for current timestep (missing record or starts too late)
         write(6,*)'STOP in subroutine RDSN - Check list file'
         write(io6,*)'STOP in SUbroutine RDSN'
         write(io6,*)'No surface data for current timestep'
         write(io6,*)'Current timestep begins at: ',ndathrb,'- ',nsecb
         write(io6,*)'Next surface record begins at: ',
     :            ibdathrn,'- ',ibsecn
         STOP
      else
c ---    Relevant record not yet reached
c ---    read next record
         goto 1  
      endif

c --- v6.4.0, Level 121203
      if(LLCC .OR. LPS) then

c**     convert wind direction from true north (south) to map
c **    north (south) (EMI 7/30/92)
        do 20 i=1,nssta
            if(wd(i).LE.9998.)then
               if(wd(i).LT.0.01 .and. ws(i).LT.0.01) go to 20
               if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
                 wd(i) = wd(i) + (conec * dlongs(i))
               else
c --- Northern Hemisphere
                 wd(i) = wd(i) - (conec * dlongs(i))
               end if
               if(wd(i).LT.0.) wd(i) = wd(i) + 360.
               if(wd(i).GT.360.) wd(i) = wd(i) - 360.
            endif
20      continue
      endif
c
      return
      end
c----------------------------------------------------------------------
c      subroutine rdup(iup,iunit,iflag,iconvrt,nsdt,jsec,jhrz,jjul,jyr)
      subroutine rdup(iup,iunit,iflag,iconvrt,jhrz,jjul,jyr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203               RDUP
c ---          J. Scire, SRC
c ---          Modified by M. Fernau, Earth Tech
c ---          Modified (2/98) by J. Scire to allow comma-delimited
c              format
c
c --- PURPOSE:  Read a set of upper air soundings -- input data
c               include:  pressure (mb), height (m above MSL),
c               temp (deg. C), wind direction (deg.), and
c               wind speed (m/s)
c
c               Wind direction & wind speed converted to
c               u,v components (m/s) -- Height (m above MSL) converted
c               to height (m above LGL) (however, no conversions are
c               made if iconvrt=0) -- If iconvrt is 1, records with no
c               data will cause termination of run
c
c               Modified to allow missing wind speed, wind direction,
c               and temperature in the soundings
c
c --- UPDATE
c
c --- V6.32 (080205) to v6.4.0 (121203)
c               - Add wind dir. rotation for Polar Stereographic
c                 projection
c
c --- v6.215 (061020) to V6.32 (080205) (FRR)
c               - Back to MOD5 version (V5.81-070128 with 99 levels):
c                 return ending times of soundings instead of beg. times
c               - No seconds in output list (no seconds in old up.dat)
c                
c
c --- v6.2(060215) to V6.215 (061020)  (DGS)
c               - Return begin time that precedes the snapshot time by
c                 1 CALMET step (may not be 1 hr)
c --- V5.5 (030402)to v6.2(060215)  (FRR)
c               - Return explicit beginning time instead of hour-ending
c                 (assumed to be 1hr before sounding time)
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c               - Add list-file unit to JULDAY, YR4 calls
c               - Read/write UP.DAT station ID as i8
c               - Add /MAP/ (/LON/ revised)
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c                  IUP - integer       - Number of upper air station
c                                        (1, 2, ..., nusta)
c                IUNIT - integer       - Fortran I/O unit no. to read
c                IFLAG - integer       - Flag indicating which arrays
c                                        into which upper air data is
c                                        to be read (+1 = bb arrays,
c                                                    -1 = aa arrays)
c              ICONVRT - integer       - Flag determining if data are
c                                        convert from WS, WD to U,V and
c                                        m MSL to m LGL (0=no, 1=yes)
c        Common block /MET1/ variables
c            IDUSTA(mxus), IFMTU(mxus)
c        Common block /LON/ variables
c            DLONGU
c        Common block /MAP/ variables
c            XLAT1,LLCC,CONEC
c            LPS
c        Parameters: MXSS, MXUS, MXPS, MXLEV, IO6
c
c --- OUTPUT:
c                 JHRZ - integer       - Time (GMT) sounding read
c                                        (aa or bb GMT)
c                 JJUL - integer       - Julian day of sounding
c                                        read (GMT)
c                  JYR - integer       - Year of sounding read (GMT)
c        Common block /upmet/ variables
c            Paa(mxus,mxlev), ZLaa(mxus,mxlev), TZaa(mxus,mxlev)
c            Uaa(mxus,mxlev), Vaa(mxus,mxlev),  NLaa(mxus)
c            Pbb(mxus,mxlev), ZLbb(mxus,mxlev), TZbb(mxus,mxlev)
c            Ubb(mxus,mxlev), Vbb(mxus,mxlev),  NLbb(mxus)
c
c --- RDUP called by:  COMP, READHD
c --- RDUP calls:      JULDAY, YR4
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      include 'upmet.met'
      include 'met1.met'
      include 'lon.met'
      include 'map.met'
c
      data xmiss/999./
c
c --- Reduce missing value indicator by a slight amount to allow for
c --- machine roundoff
      xmissm=xmiss-0.01
c
c --- Read data into "aa" arrays (IFLAG=-1) or "bb" arrays (IFLAG=+1)
      if(iflag.eq.1)then
         go to 101
      else if(iflag.ne.-1)then
         write(io6,*)'ERROR in SUBR. RDUP -- Invalid value for IFLAG ',
     1   '-- IFLAG = ',iflag
         stop
      endif

c
c --- read upper air data into "aa" arrays
      read(iunit,3)nosta,iyraa,imoaa,idyaa,ihraa,nlevaa
c --- (070128) - allow more than 99 levels of data (change i2 to i5)
c *** 3     format(9x,i8,5x,4i2,38x,i2)
3     format(9x,i8,5x,4i2,35x,i5)
      call YR4(io6,iyraa,ierr)
      if(ierr.NE.0) stop 'Halted in RDUP'
c
c --- check station id
      if(nosta.ne.idusta(iup))then
         write(io6,79)iup,idusta(iup),nosta,iyraa,imoaa,idyaa,ihraa
79       format(//1x,'ERROR IN SUBR. RDUP -- upper air station IDs ',
     1    'do not match'//1x,'station: ',i2,2x,'station ID: ',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
      call julday(io6,iyraa,imoaa,idyaa,ijulaa)
c
c --- return date/hour of sounding just read (used if skipping)
      jhrz=ihraa
      jjul=ijulaa
      jyr=iyraa
c
      if(nlevaa.lt.1)then
c
c ---    periods with no data are allowed only when skipping to find
c ---    starting date (i.e., when iconvrt = 0)
         if(iconvrt.eq.0)then
            return
         else
            write(io6,81)iup,iyraa,imoaa,idyaa,ihraa
81          format(//1x,'ERROR IN SUBR. RDUP -- no upper air data ',
     1      'for upper air station: ',i2//1x,'(year,month,day) = (',
     2      i4,',',i2,',',i2,')',2x,'hour = ',i2,' (GMT)')
            stop
         endif
      endif
c
c --- check that no. levels does not exceed array dimension
      if(nlevaa.gt.mxlev)then
         write(io6,86)iup,iyraa,imoaa,idyaa,ihraa,nlevaa,mxlev
86       format(//1x,'ERROR IN SUBR. RDUP -- too many levels for ',
     1   'array dimension'//1x,'upper air station: ',i2,2x,
     2   '(year,month,day) = (',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
      nlaa(iup)=nlevaa
      if(ifmtu(iup).eq.1)then
c ---    Original slash-delimited format
         read(iunit,4)(paa(iup,ii),zlaa(iup,ii),tzaa(iup,ii),
     1   uaa(iup,ii),vaa(iup,ii),ii=1,nlevaa)
4        format(4(3x,f6.1,1x,f5.0,1x,f5.1,1x,f3.0,1x,f3.0))
      else if(ifmtu(iup).eq.2)then
c ---    Comma-delimited data format
         read(iunit,*)(paa(iup,ii),zlaa(iup,ii),tzaa(iup,ii),
     1   uaa(iup,ii),vaa(iup,ii),ii=1,nlevaa)
      else
         write(io6,*)'ERROR in SUBR. RDUP - Invalid format type - ',
     1   'IFMTU = ',ifmtu(iup),' IUP = ',iup
         stop
      endif
c
c --- Convert ws, wd to u,v components -- ht(MSL) to height above LGL
      if(iconvrt.eq.0)go to 89
      zb=zlaa(iup,1)
      do 289 i=1,nlevaa
c
c --- Check for sounding level heights
      if(zlaa(iup,i).ge.9998.)go to 92
c
      zlaa(iup,i)=zlaa(iup,i)-zb
c

c --- v6.4.0, Level 121203
      if((LLCC .OR. LPS) .AND.
     &    uaa(iup,i).GT.0.01 .AND. vaa(iup,i).GT.0.01) then

c**     Convert wd from true north (south) to map north (south)
c**     before converting to U and V
c**     wdmap = wd-theta, where theta=conec*dlongu         EMI 7/30/92
c ---   Convert ws, wd to U, V components
        if(uaa(iup,i).lt.xmissm.and.vaa(iup,i).lt.xmissm)then
          if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
            wdmap = uaa(iup,i) + (conec*dlongu(iup))
          else
c --- Northern Hemisphere
            wdmap = uaa(iup,i) - (conec*dlongu(iup))
          end if
          if(wdmap.LT.0.) wdmap = wdmap + 360.
          if(wdmap.GT.360.) wdmap = wdmap - 360.
c**           print *,dlongu(iup),uaa(iup,i),wdmap
          dir=0.0174533*wdmap
          spd=vaa(iup,i)
          uaa(iup,i)=-spd*sin(dir)
          vaa(iup,i)=-spd*cos(dir)
        else
          uaa(iup,i)=xmiss
          vaa(iup,i)=xmiss
        endif
      else
c ---   Convert ws, wd to U, V components
        if(uaa(iup,i).lt.xmissm.and.vaa(iup,i).lt.xmissm)then
           dir=0.0174533*uaa(iup,i)
           spd=vaa(iup,i)
           uaa(iup,i)=-spd*sin(dir)
           vaa(iup,i)=-spd*cos(dir)
        else
           uaa(iup,i)=xmiss
           vaa(iup,i)=xmiss
        endif
      endif
289   continue
89    continue
      return
92    continue
      write(io6,94)iyraa,ijulaa,ihraa,iup,i,paa(iup,i),zlaa(iup,i),
     1 tzaa(iup,i),uaa(iup,i),vaa(iup,i)
94    format(/1x,'ERROR IN SUBR. RDUP -- missing sounding data'/
     1 /1x,'yr = ',i4,3x,'Julian day = ',i3,2x,'hour (GMT) = ',i2,3x,
     2 'station = ',i5,3x,'level = ',i5//1x,'pres. = ',f7.1,3x,
     3 'elev. = ',f7.0,3x,'temp. = ',f7.1,3x,'dir = ',f5.1,3x,'ws = ',
     4 f5.1)
      stop
c
c --- read upper air data into bbZ arrays
101   continue
      read(iunit,3)nosta,iyrbb,imobb,idybb,ihrbb,nlevbb
      call YR4(io6,iyrbb,ierr)
      if(ierr.NE.0) stop 'Halted in RDUP'
c
c --- check station id
      if(nosta.ne.idusta(iup))then
         write(io6,79)iup,idusta(iup),nosta,iyrbb,imobb,idybb,ihrbb
         stop
      endif
c
      call julday(io6,iyrbb,imobb,idybb,ijulbb)
c
c --- return date/hour of sounding just read (used if skipping)
      jhrz=ihrbb
      jjul=ijulbb
      jyr=iyrbb
c
      if(nlevbb.lt.1)then
c
c ---    periods with no data are allowed only when skipping to
c ---    starting date (i.e., when iconvrt = 0)
         if(iconvrt.eq.0)then
            return
         else
            write(io6,81)iup,iyrbb,imobb,idybb,ihrbb
            stop
         endif
      endif
c
c --- check that no. levels does not exceed array dimension
      if(nlevbb.gt.mxlev)then
         write(io6,86)iup,iyrbb,imobb,idybb,ihrbb,nlevbb,mxlev
         stop
      endif
c
c --- read data records
      nlbb(iup)=nlevbb
      if(ifmtu(iup).eq.1)then
c ---    Original slash-delimited format
         read(iunit,4)(pbb(iup,ii),zlbb(iup,ii),tzbb(iup,ii),
     1   ubb(iup,ii),vbb(iup,ii),ii=1,nlevbb)
      else if(ifmtu(iup).eq.2)then
c ---    Comma-delimited data format
         read(iunit,*)(pbb(iup,ii),zlbb(iup,ii),tzbb(iup,ii),
     1   ubb(iup,ii),vbb(iup,ii),ii=1,nlevbb)
      else
         write(io6,*)'ERROR in SUBR. RDUP - Invalid format type - ',
     1   'IFMTU = ',ifmtu(iup),' IUP = ',iup
         stop
      endif
c
c --- convert ws, ws to u,v components -- ht(MSL) to height above LGL
      if(iconvrt.eq.0)go to 189
      zb=zlbb(iup,1)
      do 389 i=1,nlevbb
c
c --- check for missing sounding level heights
      if(zlbb(iup,i).ge.9998.)go to 192
c
      zlbb(iup,i)=zlbb(iup,i)-zb
c

c --- v6.4.0, Level 121203
      if((LLCC .OR. LPS) .AND.
     &    ubb(iup,i).GT.0.01 .AND. vbb(iup,i).GT.0.01) then

c**     Convert wd from true north (south) to map north (south)
c**     before converting to U and V
c**     wdmap = wd-theta, where theta=conec*dlongu         EMI 7/30/92
c ---   Convert ws, wd to U, V components
        if(ubb(iup,i).lt.xmissm.and.vbb(iup,i).lt.xmissm)then
           if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
             wdmap = ubb(iup,i) + (conec*dlongu(iup))
           else
c --- Northern Hemisphere
             wdmap = ubb(iup,i) - (conec*dlongu(iup))
           end if
           if(wdmap.LT.0.) wdmap = wdmap + 360.
           if(wdmap.GT.360.) wdmap = wdmap - 360.
           dir=0.0174533*wdmap
           spd=vbb(iup,i)
           ubb(iup,i)=-spd*sin(dir)
           vbb(iup,i)=-spd*cos(dir)
        else
           ubb(iup,i)=xmiss
           vbb(iup,i)=xmiss
        endif
      else
c ---   Convert ws, wd to U, V components
        if(ubb(iup,i).lt.xmissm.and.vbb(iup,i).lt.xmissm)then
           dir=0.0174533*ubb(iup,i)
           spd=vbb(iup,i)
           ubb(iup,i)=-spd*sin(dir)
           vbb(iup,i)=-spd*cos(dir)
        else
           ubb(iup,i)=xmiss
           vbb(iup,i)=xmiss
        endif
      endif
389   continue
189   continue
      return
192   continue
      write(io6,94)iyrbb,ijulbb,ihrbb,iup,i,pbb(iup,i),zlbb(iup,i),
     1 tzbb(iup,i),ubb(iup,i),vbb(iup,i)
      stop
      end
c----------------------------------------------------------------------
      subroutine rdupn(iup,iunit,iflag,iconvrt,jsec,jhrz,jjul,jyr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203              RDUPN
c ---          F. Robe, SRC
c ---          After Subroutine RDUP (J.Scire 030412)
c
c --- PURPOSE:  Read a set of upper air soundings -- input data
c               include:  pressure (mb), height (m above MSL),
c               temp (deg. C), wind direction (deg.), and
c               wind speed (m/s)
c               Time format (2.1) with beg/ending times with seconds
c
c               Wind direction & wind speed converted to
c               u,v components (m/s) -- Height (m above MSL) converted
c               to height (m above LGL) (however, no conversions are
c               made if iconvrt=0) -- If iconvrt is 1, records with no
c               data will cause termination of run
c
c               Modified to allow missing wind speed, wind direction,
c               and temperature in the soundings
c
c --- UPDATES:  
c
c --- v6.32 (080205) to v6.4.0 (121203)
c            - Add wind dir. rotation for Polar Stereographic
c              projection
c
c --- v6.216 (061230) to v6.32 (080205)
c            - Return end time of soundings
c            - No need to define artificial beg time for snapshots
c            - Note that for UP.DAT format 2.1 a sounding with
c              different beginning and end times is NOT a time-averaged
c              sounding
c
c --- V6.215 (061020) to v6.216 (061230)
c            - Fixed typo (isecbgb instead of isecbb)
c            
c --- v5.61 (051116) to V6.215 (061020)  (DGS)
c           - Snaphot sounding (begin time = end time) is given a
c             new begin time that precedes the snapshot time by 1
c             CALMET step
c     V5.6 (041123) to v5.61 (051116) (FRR)
c           - Ouput explicit beginning time of sounding  with seconds
c
c --- INPUTS:
c                  IUP - integer       - Number of upper air station
c                                        (1, 2, ..., nusta)
c                IUNIT - integer       - Fortran I/O unit no. to read
c                IFLAG - integer       - Flag indicating which arrays
c                                        into which upper air data is
c                                        to be read (+1 = bb arrays,
c                                                    -1 = aa arrays)
c              ICONVRT - integer       - Flag determining if data are
c                                        convert from WS, WD to U,V and
c                                        m MSL to m LGL (0=no, 1=yes)
c        Common block /MET1/ variables
c            IDUSTA(mxus), IFMTU(mxus)
c        Common block /LON/ variables
c            DLONGU
c        Common block /MAP/ variables
c            XLAT1,LLCC,CONEC
c            LPS
c        Parameters: MXSS, MXUS, MXPS, MXLEV, IO6
c
c --- OUTPUT:
c                 JSEC - integer       - Ending second sounding read
c                 JHRZ - integer       - Ending Time (GMT) sounding read
c                                        (aa or bb GMT) (explicit)
c                 JJUL - integer       - Ending Julian day of sounding
c                                        read (GMT)(explicit)
c                  JYR - integer       - Ending Year of sounding read (GMT)
c                                        (explicit)
c        Common block /upmet/ variables
c            Paa(mxus,mxlev), ZLaa(mxus,mxlev), TZaa(mxus,mxlev)
c            Uaa(mxus,mxlev), Vaa(mxus,mxlev),  NLaa(mxus)
c            Pbb(mxus,mxlev), ZLbb(mxus,mxlev), TZbb(mxus,mxlev)
c            Ubb(mxus,mxlev), Vbb(mxus,mxlev),  NLbb(mxus)
c
c --- RDUPN called by:  COMP
c --- RDUPN calls:      INCRS, JULDAY, GRDAY, YR4
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      include 'upmet.met'
      include 'met1.met'
      include 'lon.met'
      include 'map.met'
c
      data xmiss/999./
c
c --- Reduce missing value indicator by a slight amount to allow for
c --- machine roundoff
      xmissm=xmiss-0.01
c
c --- Read data into "aa" arrays (IFLAG=-1) or "bb" arrays (IFLAG=+1)
      if(iflag.eq.1)then
         go to 101
      else if(iflag.ne.-1)then
         write(io6,*)'ERROR in SUBR. RDUPN -- Invalid value for IFLAG ',
     1   '-- IFLAG = ',iflag
         stop
      endif

c
c --- explicit beg/ending times with seconds (041123)
      read(iunit,3)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(io6,iyrba,ierr)
      if(ierr.NE.0) stop 'Halted in RDUPN - Y2K'
      call YR4(io6,iyrea,ierr)
      if(ierr.NE.0) stop 'Halted in RDUPN - Y2K'

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

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

c --- Is sounding a snapshot?
c --- Note: all soundings of format 2.1 are treated as instantaneous (080205)
c      isnap=0
c      idhb=iyrba*100000+ijulba*100+ihrba
c      idhe=iyrea*100000+ijulea*100+ihrea
c      if(idhb.EQ.idhe .AND. isecba.EQ.isecea) isnap=1
    
c --- check station id
      if(nosta.ne.idusta(iup))then
         write(io6,79)iup,idusta(iup),nosta,iyrba,imoba,idyba,ihrba,
     :     isecba
79       format(//1x,'ERROR IN SUBR. RDUPN -- upper air station IDs ',
     1    'do not match'//1x,'station: ',i2,2x,'station ID: ',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)',
     4    2x,'second = ',i4)
         stop
      endif
c
c --- return end date/hour/second of sounding just read (used if skipping)
      jhrz=ihrea
      jjul=ijulea
      jyr=iyrea
      jsec=isecea

c --- Shift begin-time back 1 step if sounding is a snapshot
c --- No need anylonger as end time are returned (080205)
c      if(isnap.EQ.1) then
c         nsecadd=-nsdt
c         call INCRS(io6,jyr,jjul,jhrz,jsec,nsecadd)
c      endif

c
      if(nlevaa.lt.1)then
c
c ---    periods with no data are allowed only when skipping to find
c ---    starting date (i.e., when iconvrt = 0)
         if(iconvrt.eq.0)then
            return
         else
            write(io6,81)iup,iyrea,imoea,idyea,ihrea,isecea
81          format(//1x,'ERROR IN SUBR. RDUPN -- no upper air data ',
     1      'for upper air station: ',i2//1x,'(year,month,day) = (',
     2      i4,',',i2,',',i2,')',2x,'hour = ',i2,':',i4,' (GMT)')

            stop
         endif
      endif
c
c --- check that no. levels does not exceed array dimension
      if(nlevaa.gt.mxlev)then
         write(io6,86)iup,iyrea,imoea,idyea,ihrea,isecea,nlevaa,mxlev
86       format(//1x,'ERROR IN SUBR. RDUP -- too many levels for ',
     1   'array dimension'//1x,'upper air station: ',i2,2x,
     2   '(year,month,day) = (',i4,',',i2,',',i2,')',2x,'hour = ',i2,
     3   ':',i4,' GMT'//1x,'No. levels = ',i5,3x,
     4   'Current array dimension = ',i5)
         stop
      endif
c
c --- Read data records
      nlaa(iup)=nlevaa
      if(ifmtu(iup).eq.1)then
c ---    Original slash-delimited format
         read(iunit,4)(paa(iup,ii),zlaa(iup,ii),tzaa(iup,ii),
     1   uaa(iup,ii),vaa(iup,ii),ii=1,nlevaa)
4        format(4(3x,f6.1,1x,f5.0,1x,f5.1,1x,f3.0,1x,f3.0))
      else if(ifmtu(iup).eq.2)then
c ---    Comma-delimited data format
         read(iunit,*)(paa(iup,ii),zlaa(iup,ii),tzaa(iup,ii),
     1   uaa(iup,ii),vaa(iup,ii),ii=1,nlevaa)
      else
         write(io6,*)'ERROR in SUBR. RDUP - Invalid format type - ',
     1   'IFMTU = ',ifmtu(iup),' IUP = ',iup
         stop
      endif
c
c --- Convert ws, wd to u,v components -- ht(MSL) to height above LGL
      if(iconvrt.eq.0)go to 89
      zb=zlaa(iup,1)
      do 289 i=1,nlevaa
c
c --- Check for sounding level heights
      if(zlaa(iup,i).ge.9998.)go to 92
c
      zlaa(iup,i)=zlaa(iup,i)-zb
c

c --- v6.4.0, Level 121203
      if((LLCC .OR. LPS) .AND.
     &    uaa(iup,i).GT.0.01 .AND. vaa(iup,i).GT.0.01) then
c**     Convert wd from true north (south) to map north (south)
c**     before converting to U and V
c**     wdmap = wd-theta, where theta=conec*dlongu         EMI 7/30/92
c ---   Convert ws, wd to U, V components
        if(uaa(iup,i).lt.xmissm.and.vaa(iup,i).lt.xmissm)then
          if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
            wdmap = uaa(iup,i) + (conec*dlongu(iup))
          else
c --- Northern Hemisphere
            wdmap = uaa(iup,i) - (conec*dlongu(iup))
          end if
          if(wdmap.LT.0.) wdmap = wdmap + 360.
          if(wdmap.GT.360.) wdmap = wdmap - 360.
c**           print *,dlongu(iup),uaa(iup,i),wdmap
          dir=0.0174533*wdmap
          spd=vaa(iup,i)
          uaa(iup,i)=-spd*sin(dir)
          vaa(iup,i)=-spd*cos(dir)
        else
          uaa(iup,i)=xmiss
          vaa(iup,i)=xmiss
        endif
      else
c ---   Convert ws, wd to U, V components
        if(uaa(iup,i).lt.xmissm.and.vaa(iup,i).lt.xmissm)then
           dir=0.0174533*uaa(iup,i)
           spd=vaa(iup,i)
           uaa(iup,i)=-spd*sin(dir)
           vaa(iup,i)=-spd*cos(dir)
        else
           uaa(iup,i)=xmiss
           vaa(iup,i)=xmiss
        endif
      endif
289   continue
89    continue
      return
92    continue
      write(io6,94)iyrea,ijulea,ihrea,isecea,iup,i,paa(iup,i),
     1 zlaa(iup,i),tzaa(iup,i),uaa(iup,i),vaa(iup,i)
94    format(/1x,'ERROR IN SUBR. RDUP -- missing sounding data'/
     1 /1x,'yr = ',i4,3x,'Julian day = ',i3,2x,'hour (GMT) = ',i2,':',
     2 i4,3x,'station = ',i3,3x,'level = ',i3//1x,'pres. = ',f7.1,3x,
     3 'elev. = ',f7.0,3x,'temp. = ',f7.1,3x,'dir = ',f5.1,3x,'ws = ',
     4 f5.1)
      stop
c
c --- read upper air data into bbZ arrays
101   continue
c      read(iunit,3)nosta,iyrbb,imobb,idybb,ihrbb,nlevbb
c      call YR4(io6,iyrbb,ierr)
c --- explicit beg/ending times with seconds (041123)
      read(iunit,3)nosta,iyrbgb,imobgb,idybgb,ihrbgb,isecbgb,
     :                   iyreb,imoeb,idyeb,ihreb,iseceb, nlevbb
      call YR4(io6,iyrbgb,ierr)
      if(ierr.NE.0) stop 'Halted in RDUP - Y2K'
      call YR4(io6,iyreb,ierr)
      if(ierr.NE.0) stop 'Halted in RDUP - Y2K'

c --- Condition begin time
      call JULDAY(io6,iyrbgb,imobgb,idybgb,ijulbgb)
      nsecadd=isecbgb
c     isecbb=0   --- 061230 (typo)
      isecbgb=0
      if(ihrbgb.GT.23) then
         nsecadd=nsecadd+(ihrbgb-23)*3600
         ihrbgb=23
      endif
      call INCRS(io6,iyrbgb,ijulbgb,ihrbgb,isecbgb,nsecadd)
      call GRDAY(io6,iyrbgb,ijulbgb,imobgb,idybgb)

c --- Condition end time
      call JULDAY(io6,iyreb,imoeb,idyeb,ijuleb)
      nsecadd=iseceb
      iseceb=0
      if(ihreb.GT.23) then
         nsecadd=nsecadd+(ihreb-23)*3600
         ihreb=23
      endif
      call INCRS(io6,iyreb,ijuleb,ihreb,iseceb,nsecadd)
      call GRDAY(io6,iyreb,ijuleb,imoeb,idyeb)

c --- Is sounding a snapshot?
c --- All soundings are treated as instantaneous (on end time) (080205)
c      isnap=0
c      idhb=iyrbgb*100000+ijulbgb*100+ihrbgb
c      idhe=iyreb*100000+ijuleb*100+ihreb
c      if(idhb.EQ.idhe .AND. isecbgb.EQ.iseceb) isnap=1

      if(ierr.NE.0) stop 'Halted in RDUP'
c
c --- check station id
      if(nosta.ne.idusta(iup))then
         write(io6,79)iup,idusta(iup),nosta,iyreb,imoeb,idyeb,ihreb,
     :    isecbgb
         stop
      endif
c
c --- return end date/hour of sounding just read (used if skipping)
      jhrz=ihreb
      jjul=ijuleb
      jyr=iyreb
      jsec=iseceb

c --- Shift begin-time back 1 step if sounding is a snapshot
c --- No need since end times are returned (no longer beg. times)
c      if(isnap.EQ.1) then
c         nsecadd=-nsdt
c         call INCRS(io6,jyr,jjul,jhrz,jsec,nsecadd)
c      endif

      if(nlevbb.lt.1)then
c
c ---    periods with no data are allowed only when skipping to
c ---    starting date (i.e., when iconvrt = 0)
         if(iconvrt.eq.0)then
            return
         else
            write(io6,81)iup,iyrbgb,imobgb,idybgb,ihrbgb,isecbgb
            stop
         endif
      endif
c
c --- check that no. levels does not exceed array dimension
      if(nlevbb.gt.mxlev)then
         write(io6,86)iup,iyreb,imoeb,idyeb,ihreb,iseceb,
     :       nlevbb,mxlev
         stop
      endif
c
c --- read data records
      nlbb(iup)=nlevbb
      if(ifmtu(iup).eq.1)then
c ---    Original slash-delimited format
         read(iunit,4)(pbb(iup,ii),zlbb(iup,ii),tzbb(iup,ii),
     1   ubb(iup,ii),vbb(iup,ii),ii=1,nlevbb)
      else if(ifmtu(iup).eq.2)then
c ---    Comma-delimited data format
         read(iunit,*)(pbb(iup,ii),zlbb(iup,ii),tzbb(iup,ii),
     1   ubb(iup,ii),vbb(iup,ii),ii=1,nlevbb)
      else
         write(io6,*)'ERROR in SUBR. RDUP - Invalid format type - ',
     1   'IFMTU = ',ifmtu(iup),' IUP = ',iup
         stop
      endif
c
c --- convert ws, ws to u,v components -- ht(MSL) to height above LGL
      if(iconvrt.eq.0)go to 189
      zb=zlbb(iup,1)
      do 389 i=1,nlevbb
c
c --- check for missing sounding level heights
      if(zlbb(iup,i).ge.9998.)go to 192
c
      zlbb(iup,i)=zlbb(iup,i)-zb
c

c --- v6.4.0, Level 121203
      if((LLCC .OR. LPS) .AND.
     &    ubb(iup,i).GT.0.01 .AND. vbb(iup,i).GT.0.01) then

c**     Convert wd from true north (south) to map north (south)
c**     before converting to U and V
c**     wdmap = wd-theta, where theta=conec*dlongu         EMI 7/30/92
c ---   Convert ws, wd to U, V components
        if(ubb(iup,i).lt.xmissm.and.vbb(iup,i).lt.xmissm)then
           if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
             wdmap = ubb(iup,i) + (conec*dlongu(iup))
           else
c --- Northern Hemisphere
             wdmap = ubb(iup,i) - (conec*dlongu(iup))
           end if
           if(wdmap.LT.0.) wdmap = wdmap + 360.
           if(wdmap.GT.360.) wdmap = wdmap - 360.
           dir=0.0174533*wdmap
           spd=vbb(iup,i)
           ubb(iup,i)=-spd*sin(dir)
           vbb(iup,i)=-spd*cos(dir)
        else
           ubb(iup,i)=xmiss
           vbb(iup,i)=xmiss
        endif
      else
c ---   Convert ws, wd to U, V components
        if(ubb(iup,i).lt.xmissm.and.vbb(iup,i).lt.xmissm)then
           dir=0.0174533*ubb(iup,i)
           spd=vbb(iup,i)
           ubb(iup,i)=-spd*sin(dir)
           vbb(iup,i)=-spd*cos(dir)
        else
           ubb(iup,i)=xmiss
           vbb(iup,i)=xmiss
        endif
      endif
389   continue
189   continue
      return
192   continue
      write(io6,94)iyrbgb,ijulbgb,ihrbgb,isecbgb,iup,i,
     1 pbb(iup,i),zlbb(iup,i),tzbb(iup,i),ubb(iup,i),vbb(iup,i)
      stop
      end
c----------------------------------------------------------------------
      subroutine rdupn2(iup,iunit,iflag,iconvrt,jsec,jhrz,jjul,jyr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203             RDUPN2
c ---          F. Robe, TRC
c              After Subroutine RDUPN
c
c --- PURPOSE:  Read a set of upper air soundings -- input data
c               include:  pressure (mb), height (m above MSL),
c               temp (deg. C), wind direction (deg.), and
c               wind speed (m/s)
c               Time format (2.2) with beg/ending times with seconds
c               Soundings can be instantaneous (beg.time=end time)
c               or time-averaged (beginning time < end time)
c
c               Wind direction & wind speed converted to
c               u,v components (m/s) -- Height (m above MSL) converted
c               to height (m above LGL) (however, no conversions are
c               made if iconvrt=0) -- If iconvrt is 1, records with no
c               data will cause termination of run
c
c               Modified to allow missing wind speed, wind direction,
c               and temperature in the soundings
c
c --- UPDATES:  
c
c --- v6.32 (080205) to v6.4.0 (121203)
c            - Add wind dir. rotation for Polar Stereographic
c              projection
c
c
c --- INPUTS:
c                  IUP - integer       - Number of upper air station
c                                        (1, 2, ..., nusta)
c                IUNIT - integer       - Fortran I/O unit no. to read
c                IFLAG - integer       - Flag indicating which arrays
c                                        into which upper air data is
c                                        to be read (+1 = bb arrays,
c                                                    -1 = aa arrays)
c              ICONVRT - integer       - Flag determining if data are
c                                        convert from WS, WD to U,V and
c                                        m MSL to m LGL (0=no, 1=yes)
c        Common block /MET1/ variables
c            IDUSTA(mxus), IFMTU(mxus)
c        Common block /LON/ variables
c            DLONGU
c        Common block /MAP/ variables
c            XLAT1,LLCC,CONEC
c            LPS
c        Parameters: MXSS, MXUS, MXPS, MXLEV, IO6
c
c --- OUTPUT:
c                 JSEC - integer       - Beginning or end second 
c                                        sounding read
c                 JHRZ - integer       - Beginning or end Time (GMT) of
c                                        sounding read (aa or bb GMT)
c                                        (explicit)
c                 JJUL - integer       - Beginning or end Julian day of sounding
c                                        read (GMT)(explicit)
c                  JYR - integer       - Beginning or end Year of sounding read (GMT)
c                                        (explicit)
c        Common block /upmet/ variables
c            Paa(mxus,mxlev), ZLaa(mxus,mxlev), TZaa(mxus,mxlev)
c            Uaa(mxus,mxlev), Vaa(mxus,mxlev),  NLaa(mxus)
c            Pbb(mxus,mxlev), ZLbb(mxus,mxlev), TZbb(mxus,mxlev)
c            Ubb(mxus,mxlev), Vbb(mxus,mxlev),  NLbb(mxus)
c            ISNAP(mxus)
c
c --- RDUPN2 called by:  COMP
c --- RDUPN2 calls:      INCRS, JULDAY, GRDAY, YR4
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      include 'upmet.met'
      include 'met1.met'
      include 'lon.met'
      include 'map.met'
c
      dimension ustor(mxus,mxlev), vstor(mxus,mxlev), zlstor(mxus,mxlev)
      dimension tzstor(mxus,mxlev), pstor(mxus,mxlev)
      dimension jstorhrz(mxus), jstorjul(mxus),jstoryr(mxus)
      dimension nstorlev(mxus),jstorsec(mxus)

      data xmiss/999./

c --- Keep time-averaged ending records in memory for next update
      save ustor,vstor,zlstor,tzstor,pstor
      save jstorhrz,jstorjul,jstoryr,jstorsec,nstorlev

c
c --- Reduce missing value indicator by a slight amount to allow for
c --- machine roundoff
      xmissm=xmiss-0.01
c

c --- Read data into "aa" arrays (IFLAG=-1) or "bb" arrays (IFLAG=+1)
      if(iflag.eq.1)then
         go to 101
      else if(iflag.ne.-1)then
         write(io6,*)'ERROR in SUBR. RDUPN -- Invalid value for IFLAG ',
     1   '-- IFLAG = ',iflag
         stop
      endif

c
c --- explicit beg/ending times with seconds 
      read(iunit,3)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(io6,iyrba,ierr)
      if(ierr.NE.0) stop 'Halted in RDUPN - Y2K'
      call YR4(io6,iyrea,ierr)
      if(ierr.NE.0) stop 'Halted in RDUPN - Y2K'

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

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

c --- Is sounding a snapshot?
      isnap(iup)=0
      idhb=iyrba*100000+ijulba*100+ihrba
      idhe=iyrea*100000+ijulea*100+ihrea
      if(idhb.EQ.idhe .AND. isecba.EQ.isecea) isnap(iup)=1
c --- check station id
      if(nosta.ne.idusta(iup))then
         write(io6,79)iup,idusta(iup),nosta,iyrea,imoea,idyea,ihrea,
     :     isecba
79       format(//1x,'ERROR IN SUBR. RDUPN -- upper air station IDs ',
     1    'do not match'//1x,'station: ',i2,2x,'station ID: ',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)',
     4    2x,'second = ',i4)
         stop
      endif
c
c --- If sounding is a snapshot, return beginning=end time
c --- If sounding is time-averaged, return beginning time
c --- and save end time for next update of BB array
      jhrz=ihrba
      jjul=ijulba
      jyr=iyrba
      jsec=isecba

      if (isnap(iup).eq.0) then
         jstorhrz(iup)=ihrea
         jstorjul(iup)=ijulea
         jstoryr(iup)=iyrea
         jstorsec(iup)=isecea
       endif 

c
      if(nlevaa.lt.1)then
c
c ---    periods with no data are allowed only when skipping to find
c ---    starting date (i.e., when iconvrt = 0)
         if(iconvrt.eq.0)then
            return
         else
            write(io6,81)iup,iyrea,imoea,idyea,ihrea,isecea
81          format(//1x,'ERROR IN SUBR. RDUPN -- no upper air data ',
     1      'for upper air station: ',i2//1x,'(year,month,day) = (',
     2      i4,',',i2,',',i2,')',2x,'hour = ',i2,':',i4,' (GMT)')

            stop
         endif
      endif
c
c --- check that no. levels does not exceed array dimension
      if(nlevaa.gt.mxlev)then
         write(io6,86)iup,iyrea,imoea,idyea,ihrea,isecea,nlevaa,mxlev
86       format(//1x,'ERROR IN SUBR. RDUP -- too many levels for ',
     1   'array dimension'//1x,'upper air station: ',i2,2x,
     2   '(year,month,day) = (',i4,',',i2,',',i2,')',2x,'hour = ',i2,
     3   ':',i4,' GMT'//1x,'No. levels = ',i5,3x,
     4   'Current array dimension = ',i5)
         stop
      endif
c
c --- Read data records
      nlaa(iup)=nlevaa
      if(ifmtu(iup).eq.1)then
c ---    Original slash-delimited format
         read(iunit,4)(paa(iup,ii),zlaa(iup,ii),tzaa(iup,ii),
     1   uaa(iup,ii),vaa(iup,ii),ii=1,nlevaa)
4        format(4(3x,f6.1,1x,f5.0,1x,f5.1,1x,f3.0,1x,f3.0))
      else if(ifmtu(iup).eq.2)then
c ---    Comma-delimited data format
         read(iunit,*)(paa(iup,ii),zlaa(iup,ii),tzaa(iup,ii),
     1   uaa(iup,ii),vaa(iup,ii),ii=1,nlevaa)
      else
         write(io6,*)'ERROR in SUBR. RDUP - Invalid format type - ',
     1   'IFMTU = ',ifmtu(iup),' IUP = ',iup
         stop
      endif
c
c --- Convert ws, wd to u,v components -- ht(MSL) to height above LGL
      if(iconvrt.eq.0)go to 89
      zb=zlaa(iup,1)
      do 289 i=1,nlevaa
c
c --- Check for sounding level heights
      if(zlaa(iup,i).ge.9998.)go to 92
c
      zlaa(iup,i)=zlaa(iup,i)-zb
c

c --- v6.4.0, Level 121203
      if((LLCC .OR. LPS) .AND.
     &    uaa(iup,i).GT.0.01 .AND. vaa(iup,i).GT.0.01) then

c**     Convert wd from true north (south) to map north (south)
c**     before converting to U and V
c**     wdmap = wd-theta, where theta=conec*dlongu         EMI 7/30/92
c ---   Convert ws, wd to U, V components
        if(uaa(iup,i).lt.xmissm.and.vaa(iup,i).lt.xmissm)then
          if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
            wdmap = uaa(iup,i) + (conec*dlongu(iup))
          else
c --- Northern Hemisphere
            wdmap = uaa(iup,i) - (conec*dlongu(iup))
          end if
          if(wdmap.LT.0.) wdmap = wdmap + 360.
          if(wdmap.GT.360.) wdmap = wdmap - 360.
c**           print *,dlongu(iup),uaa(iup,i),wdmap
          dir=0.0174533*wdmap
          spd=vaa(iup,i)
          uaa(iup,i)=-spd*sin(dir)
          vaa(iup,i)=-spd*cos(dir)
        else
          uaa(iup,i)=xmiss
          vaa(iup,i)=xmiss
        endif
      else
c ---   Convert ws, wd to U, V components
        if(uaa(iup,i).lt.xmissm.and.vaa(iup,i).lt.xmissm)then
           dir=0.0174533*uaa(iup,i)
           spd=vaa(iup,i)
           uaa(iup,i)=-spd*sin(dir)
           vaa(iup,i)=-spd*cos(dir)
        else
           uaa(iup,i)=xmiss
           vaa(iup,i)=xmiss
        endif
      endif
289   continue
89    continue

c --- If time-averaged record, store AA array for next update of BB array
      if (isnap(iup).eq.0) then
         nstorlev(iup)=nlevaa
         do 889 i=1,nlevaa
            ustor(iup,i)=uaa(iup,i) 
            vstor(iup,i)=vaa(iup,i) 
            zlstor(iup,i)=zlaa(iup,i) 
            tzstor(iup,i)=tzaa(iup,i) 
            pstor(iup,i)=paa(iup,i) 
889      continue
      endif      


      return
92    continue
      write(io6,94)iyrea,ijulea,ihrea,isecea,iup,i,paa(iup,i),
     1 zlaa(iup,i),tzaa(iup,i),uaa(iup,i),vaa(iup,i)
94    format(/1x,'ERROR IN SUBR. RDUP -- missing sounding data'/
     1 /1x,'yr = ',i4,3x,'Julian day = ',i3,2x,'hour (GMT) = ',i2,':',
     2 i4,3x,'station = ',i3,3x,'level = ',i3//1x,'pres. = ',f7.1,3x,
     3 'elev. = ',f7.0,3x,'temp. = ',f7.1,3x,'dir = ',f5.1,3x,'ws = ',
     4 f5.1)
      stop
c
c --- read upper air data into bbZ arrays
101   continue


c --- if time-averaged soundings do not read new one, just
c --- update BB times and arrays with previously stored AA arrays
c --- and exit
      if (isnap(iup).eq.0) then
         jhrz=jstorhrz(iup)
         jjul=jstorjul(iup)
         jyr=jstoryr(iup)
         jsec=jstorsec(iup)

         nlbb(iup)=nstorlev(iup)
         
         do 989 i=1,nlbb(iup)
            ubb(iup,i)=ustor(iup,i)
            vbb(iup,i)=vstor(iup,i) 
            zlbb(iup,i)=zlstor(iup,i) 
            tzbb(iup,i)=tzstor(iup,i)
            pbb(iup,i)=pstor(iup,i) 
989      continue

         return
      endif

c --- If snapshot soundings, read the next one    
c --- explicit beg/ending times with seconds 
      read(iunit,3)nosta,iyrbgb,imobgb,idybgb,ihrbgb,isecbgb,
     :                   iyreb,imoeb,idyeb,ihreb,iseceb, nlevbb
      call YR4(io6,iyrbgb,ierr)
      if(ierr.NE.0) stop 'Halted in RDUP - Y2K'
      call YR4(io6,iyreb,ierr)
      if(ierr.NE.0) stop 'Halted in RDUP - Y2K'

c --- Condition begin time
      call JULDAY(io6,iyrbgb,imobgb,idybgb,ijulbgb)
      nsecadd=isecbgb
c     isecbb=0   --- 061230 (typo)
      isecbgb=0
      if(ihrbgb.GT.23) then
         nsecadd=nsecadd+(ihrbgb-23)*3600
         ihrbgb=23
      endif
      call INCRS(io6,iyrbgb,ijulbgb,ihrbgb,isecbgb,nsecadd)
      call GRDAY(io6,iyrbgb,ijulbgb,imobgb,idybgb)

c --- Condition end time
      call JULDAY(io6,iyreb,imoeb,idyeb,ijuleb)
      nsecadd=iseceb
      iseceb=0
      if(ihreb.GT.23) then
         nsecadd=nsecadd+(ihreb-23)*3600
         ihreb=23
      endif
      call INCRS(io6,iyreb,ijuleb,ihreb,iseceb,nsecadd)
      call GRDAY(io6,iyreb,ijuleb,imoeb,idyeb)

c --- Is sounding a snapshot?
      isnapb=0
      idhb=iyrbgb*100000+ijulbgb*100+ihrbgb
      idhe=iyreb*100000+ijuleb*100+ihreb
      if(idhb.EQ.idhe .AND. isecbgb.EQ.iseceb) isnapb=1

c --- Mixing time-averaged and snapshot soundings in the same UP.DAT
c --- is not allowed
c --- At this point the sounding has to be a snapshot 
      if (isnapb.eq.0) then
          write(6,*)' STOP in RDUPN2 - See list file'
          write(io6,*)'STOP in RDUPN2 '
          write(io6,*)'Mix of snapshots and time-averaged soundings'
          write(io6,*)'UP.DAT number:', iup
          write(io6,*)'Beg. Date(YYYJJJHH -Sec):',idhb,isecbgb
          STOP
      endif

      if(ierr.NE.0) stop 'Halted in RDUP'
c
c --- check station id
      if(nosta.ne.idusta(iup))then
         write(io6,79)iup,idusta(iup),nosta,iyreb,imoeb,idyeb,ihreb,
     :    iseceb
         stop
      endif
c
c --- return end date/hour of sounding just read (used if skipping)
      jhrz=ihreb
      jjul=ijuleb
      jyr=iyreb
      jsec=iseceb


      if(nlevbb.lt.1)then
c
c ---    periods with no data are allowed only when skipping to
c ---    starting date (i.e., when iconvrt = 0)
         if(iconvrt.eq.0)then
            return
         else
            write(io6,81)iup,iyreb,imoeb,idyeb,ihreb,iseceb
            stop
         endif
      endif
c
c --- check that no. levels does not exceed array dimension
      if(nlevbb.gt.mxlev)then
         write(io6,86)iup,iyreb,imoeb,idyeb,ihreb,iseceb,
     :       nlevbb,mxlev
         stop
      endif
c
c --- read data records
      nlbb(iup)=nlevbb
      if(ifmtu(iup).eq.1)then
c ---    Original slash-delimited format
         read(iunit,4)(pbb(iup,ii),zlbb(iup,ii),tzbb(iup,ii),
     1   ubb(iup,ii),vbb(iup,ii),ii=1,nlevbb)
      else if(ifmtu(iup).eq.2)then
c ---    Comma-delimited data format
         read(iunit,*)(pbb(iup,ii),zlbb(iup,ii),tzbb(iup,ii),
     1   ubb(iup,ii),vbb(iup,ii),ii=1,nlevbb)
      else
         write(io6,*)'ERROR in SUBR. RDUP - Invalid format type - ',
     1   'IFMTU = ',ifmtu(iup),' IUP = ',iup
         stop
      endif
c
c --- convert ws, ws to u,v components -- ht(MSL) to height above LGL
      if(iconvrt.eq.0)go to 189
      zb=zlbb(iup,1)
      do 389 i=1,nlevbb
c
c --- check for missing sounding level heights
      if(zlbb(iup,i).ge.9998.)go to 192
c
      zlbb(iup,i)=zlbb(iup,i)-zb
c

c --- v6.4.0, Level 121203
      if((LLCC .OR. LPS) .AND.
     &    ubb(iup,i).GT.0.01 .AND. vbb(iup,i).GT.0.01) then

c**     Convert wd from true north (south) to map north (south)
c**     before converting to U and V
c**     wdmap = wd-theta, where theta=conec*dlongu         EMI 7/30/92
c ---   Convert ws, wd to U, V components
        if(ubb(iup,i).lt.xmissm.and.vbb(iup,i).lt.xmissm)then
           if (xlat1 .lt. 0.) then
c --- Southern Hemisphere
             wdmap = ubb(iup,i) + (conec*dlongu(iup))
           else
c --- Northern Hemisphere
             wdmap = ubb(iup,i) - (conec*dlongu(iup))
           end if
           if(wdmap.LT.0.) wdmap = wdmap + 360.
           if(wdmap.GT.360.) wdmap = wdmap - 360.
           dir=0.0174533*wdmap
           spd=vbb(iup,i)
           ubb(iup,i)=-spd*sin(dir)
           vbb(iup,i)=-spd*cos(dir)
        else
           ubb(iup,i)=xmiss
           vbb(iup,i)=xmiss
        endif
      else
c ---   Convert ws, wd to U, V components
        if(ubb(iup,i).lt.xmissm.and.vbb(iup,i).lt.xmissm)then
           dir=0.0174533*ubb(iup,i)
           spd=vbb(iup,i)
           ubb(iup,i)=-spd*sin(dir)
           vbb(iup,i)=-spd*cos(dir)
        else
           ubb(iup,i)=xmiss
           vbb(iup,i)=xmiss
        endif
      endif

389   continue
189   continue

      return
192   continue
      write(io6,94)iyreb,ijuleb,ihreb,iseceb,iup,i,
     1 pbb(iup,i),zlbb(iup,i),tzbb(iup,i),ubb(iup,i),vbb(iup,i)
      stop
      end
c----------------------------------------------------------------------
      subroutine rdwt(noobs,iprog,cellzc)
c---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 950531               RDWT
c ---          E. Insley, SRC
c ---          Modified by J. Scire , F.Robe (09/01)
c
c --- PURPOSE:  Read the weighting factors used for station observations
c               vs the MM4 data used as observations or Step 1 Field
c
c --- INPUTS:
c frr (09/01)
c        NOOBS      integer     - No observation flag
c                                 0: sf and upper air obs.
c                                 1: no upper air obs.
c                                 2: no sf or upper air obs.
c
c        IPROG      integer     - Control variable determining if gridded
c                                 prognostic model wind fields are used
c                                 by the diagnostic wind field model
c                                 (0 = no prog data used,
c                                  1 = CSUMM as Step 1 Field,
c                                  2 = CSUMM as Initial Guess Field,
c                                  3 = MM4 as Step 1 Field,
c                                  4 = MM4 as Initial Guess Field,
c                                  5 = MM4 as observation)
c        CELLZC     real array  - Diagnostic Wind Model Cell Center Heights
c
c        Common block /FILNAM/ variables:
c            WTDAT
c
c        Parameters:
c            MXNX, MXNY, MXNZ, MXUS, MXOWS, IO6, IO19
c
c --- OUTPUT:
c
c        Common block /WTGRD/ variables:
c            WO(mxnx,mxny,mxnz)
c
c --- RDWT called by: SETUP
c --- RDWT calls:      none
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      character*42 c1,c2,c3
      dimension cellzc(mxnz)
c
      include 'wtgrd.met'
      include 'filnam.met'
c NEW -frr (12/96) - D5 replaced by grid.met
      include 'grid.met'
c      COMMON /D5/  NX, NY, NZ, DX, DY, DZ(mxnz), NZPRNT
      common /rwtdum/x0fin,y0fin,dfin,x0crs,y0crs,nxcrs,nycrs,
     1 dcrs
      common /rwtdm2/c1,c2,c3
c
      if((iprog.EQ.3 .OR. iprog.EQ.5 .OR. iprog.EQ.13 .OR. iprog.EQ.15) 
     :   .and. noobs.lt.2) then
c frr (09/01) - no weight file if no observations at all
c
c ---   Read header info
        read(io19,121) c1
        read(io19,121) c2
        read(io19,121) c3
121     format(a42)
        read(io19,101) x0fin,y0fin,nxfin,nyfin,dfin
        read(io19,102) x0crs,y0crs,nxcrs,nycrs,dcrs
c**
c        write(io6,*) 'x0fin,y0fin,nxfin,nyfin,dfin= ',x0fin,y0fin,
c     1                nxfin,nyfin,dfin
c        write(io6,*) 'x0fcrs,y0crs,nxcrs,nycrs,dcrs= ',x0crs,y0crs,
c     1                nxcrs,nycrs,dcrs
c**
101     format(15x,2f8.1,2i5,f8.3)
102     format(15x,2f8.1,2i5,f8.3,//)
c ---   Read weighting factors - Loop over height-groups
        do 5 k=1,nz
          read(io19,120) ht
120       format(12x,f12.4)
c**       write(io6,*) ' Ht = ',ht
c ---     Check to see that the heights of the weighting factors match
c ---     the diagnostic model cell center heights
          if(ht.NE.cellzc(k))then
            write(io6,130)
130         format(1x,'ERROR in Subr. RDWT -- Weighting Factor Levels ',
     1            'Do Not Match Diagnostic Model Cell Center Heights.')
            write(io6,*)'k=',k,' HT=',ht,' cellzc =',cellzc(k)
            stop
          endif
c ---     Skip header line of grid indexes
          read(io19,*)
c ---     Loop over rows
          do 15 jj=nyfin,1,-1
c ---       Read gridded weighting factors
            read(io19,113) (wo(i,jj,k),i=1,nxfin)
113         format(6x,150(1x,f3.2))
15        continue
c ---     Skip header line of grid indexes
          read(io19,*)
5       continue
c
c ---   Close the WT.DAT file
        close(io19)
      else if(iprog.EQ.1) then
c ---   Fill in weight array with equal weighting over the grid
        do 25 j=1,ny
        do 25 i=1,nx
        do 25 k=1,nz
          wo(i,j,k) = 0.5
25      continue
      else if(iprog.EQ.0 .OR. iprog.EQ.2 .OR.iprog.EQ.4 .OR.
     :        iprog.eq.14) then
c ---   Fill in weight array with full weighting for station observations
        do 35 j=1,ny
        do 35 i=1,nx
        do 35 k=1,nz
          wo(i,j,k) = 1.0
35      continue
c frr(09/01) no weight if no observations (noobs=2)
      else if( (iprog.EQ.3 .OR. iprog.EQ.5 .or.iprog.EQ.13
     :     .OR. iprog.EQ.15) .and. noobs.eq.2)then
c ---   Fill in weight array with full weighting for MM4/MM5 data
        do 45 j=1,ny
        do 45 i=1,nx
        do 45 k=1,nz
          wo(i,j,k) = 0.0
45      continue
      else
        write(io6,*) 'ERROR in Subr. RDWT - Invalid value of IPROG - ',
     1               'IPROG = ',iprog
        stop
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine readcf(idiop2,title,iprog2,itest,n3d,nig,igfflag)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level:  121203            READCF
c ---          J. Scire, R. Mentzer, SRC
c              Modified by M. Fernau, J. Scire , F.Robe
c              Earth Tech, Inc.
c              Modified by F. Robe, TRC
c
c --- PURPOSE:  Read CALMET control file inputs
c
c --- UPDATES:
c
c --- v6.332 (110212) to v6.4.0 (121203)
c               - Add wind dir. rotation for Polar Stereographic
c                 projection
c
c --- v6.330 level 101006 to v6.332 Level 110212 (F.Robe)
c               - Read in new user parameters IZICRLX and TZICRLX
c                 (stored in ZIPARM.MET)
c               - Apply MREG check to IZICRLX (=0)
c
c --- v6.327 level 090511 to v6.330 level 101006 (CEC)
c               - Change ICLOUD into MCLOUD and ICLDOUT
c               - Add a new version of CALMET.INP (2.2)
c
c --- v6.32 (080205) to v6.327 Level 090511 (F.Robe)
c               - Write out QAMETG.bna plot file with CALMET boundaries

c --- V6.31 (071203) to V6.32 (080205)
c               - Read in new input variable ISTEPPGS (prognostic 
c                 timestep in seconds) and change the QA tests
c                 accordingly (expressed in seconds instead of hours)
c                 Previous input parameter ISTEPPG still recognized.
c
c --- V6.3 (070717) to V6.31 (071207)
c               - Perform coordinate conversion of precipitation stations
c                 locations based on the presence of precipitation data
c                 rather than that of upper air data when the 
c                 precipitation station coordinates are included in the
c                 CALMET.INP file
c
c --- V6.223 (070702) to V6.3 (070717)
c               - Read new input parameter MREG for screening 
c                 regulatory settings
c               - Set configuration switches ISFCMET and IPSIFCN from
c                 value of ICOARE
c               - Shift simulation ending hour by 1 hour if the input
c                 file is in MOD5 format *(hour-ending convention)
c               - Compute runlength in subhourly timesteps if the input
c                 file is a MOD5-type (hourly, ending times)
c
c --- v6.218 (070113) to V6.223 (070702)(FRR)
c               - Echo all input parameters, even those not listed in the 
c                 user's input file (for which default values are assigned)
c               - THRESHL default value reset tp 0 for consistency with
c                 older version and regulatory assumptions
c
c --- v6.217 (061231) to v6.218 (070113) (FRR) 
c               - Allow ISURFT=-1 (2-D surface temperature used for
c                 terrain-induced circulations) and ISURFT=-2 (averaged
c                 prognostic surface temp (with ITPROG=2 only)
c               - Allow IUPT=-1 (2-D surface lapse rate used for
c                 terrain-induced circulations) and IUPT=-2 (domain-averaged
c                 prognostic lapse rate; with ITPROG>0 only)
c               - Reworded output comments describing values selected for
c                 ISURFT,IUPT, IDIOPT1,IDIOPT2,IDIOPT3, IUPWND and ZUPWND 
c               - Added a QA check on ITPROG (must be 0,1 or 2)
c
c --- v6.215 (061020) to v6.217 (061231) (FRR) 
c               - Allow ICLOUD=4
c
c --- v6.212 (060519) to v6.215 (061020) (DGS)
c               - Allow MESOPAC output only with 1-hour timestep
c
c --- v6.210 (060408) to v6.212 (060519) (DGS)
c               - Place starting date QA tests inside IF-blocks related
c                 to control file version (MOD5 input file failed test)
c                 (irhprog,iprog,noobs)
c               - Reset character*4 CTIME array from (1,4) to (70) to
c                 match character*70 ABTZ declaration
c
c --- v6.209 (060331) to v6.210 (060408)(F. Robe)
c               - Add user-input parameter irhprog and related QA checks 
c                 (irhprog,iprog,noobs)
c
c --- v6.2 (060215) to v6.209 (060331) (DGS)
c               - Report problem with a late starting-time with the
c                 explicit begin time for the starting period (not
c                 hour-ending)
c
c --- V5.711 (060106) to v6.2 (060215) (F.Robe)
c               - First line in CALMET.INP flags new input format (2.1)
c               - Additional parameters in CALMET.INP version 2.1
c                  (beginning seconds, and ending dates +UTC time zone)
c               - IRLG and IBTZ are no longer an input but are computed
c                 internally . They remain in the dictionary so old input
c                 files can still be read in
c               - New input parameter:NSECDT (timestep in seconds) in 
c                 Input Group #1 - Default value - NSECDT= 3600 seconds 
c               - Compute isteppgs (prognostic timestep in seconds)
c                 and make sure it is a multiple of CALMET timestep
c
c --- v5.7 (051230) to V5.711 (060106) (F.Robe)
c               - Read new input parameters related to IGF based
c                 on coarse CALMET.dAT files :NIGF,IGFMET,IGFDAT(nigf)
c                 
c --- V5.614 (051228) to v5.7 (051230) (J. Scire)
c               - Change default value for IWARM and ICOOL options
c                 in COARE to OFF
c
c --- V5.61 (051109) to v5.611 (051113)(F.Robe)
c               - Add ILUOC3D to input group 6
c               - Add QA test for new possible value for ITWPROG = 2 
c
c --- v5.6g (051109) to v5.61 (051111)(DGS)
c               - Reset defaults as follows:
c                 ICOARE = 10  (not 0)
c                 IMXHT = 1    (not -1)
c
c --- V5.6c (050419) to v5.6g (051109)(DGS)
c               - Correct QA test for IEXTRP=1 that requires BIAS(2+)=1
c                 so that no warning is made if the bias is already set
c                 properly.
c               - Skip BIAS/IEXTRP checks if surface obs are not used
c
c --- 5.6a (050331) to V5.6c (050419):
c               - Add COARE input variables (IWARM,ICOOL)
c               - Move ICOARE and DSHELF from input group 5 to input
c                 group 6
c
c --- V5.6 (050328) to V5.6a (050331):
c               - Correct QA test for IEXTRP<0 that requires BIAS(1)=-1
c                 so that no warning is made if the bias is already set
c                 properly.
c
c --- V5.551 (050310) to V5.6 (050328):
c               - Add mixing height input variables (IMIXH,ITWPROG,TRESHW)
c               - Additional parameter ICOARE to select the overwater
c                 boundary layer method (DeltaT or COARE).Input Group #5
c                 default value icoare =0 (for backward compatibility)
c               - Additional parameter dshelf = coastal/shallow water
c                 length scale (for COARE parameterization)
c                 in Input Group #5- Default: 0km
c               - Additional parameters ldbcst, dcst.grd to write out
c                 gridded field of distance to the coast 
c
c --- V5.549 050128 to V5.551 050310 (DGS)
c               - Modify output format statements to allow surface
c                 station IDs to be at least 6 digits long
c
c --- V5.548a (050101) to V5.549 050128 (DGS)
c               - Add call to COORDSVER and write info to list file
c
c --- V5.548(041101) to V5.548a (050101)
c               - Include d3.met (as variables kbar,nbar,xybar are moved from
c                 common wparm.met to common d3.met
c
c --- V5.547 (041016) to V5.548(041101) (FRR)
c               - Additional parameter KBAR indicating the level up to which
c                 barriers apply
c
c --- V5.546 (040924) to V5.547 (FRR)
c               - Additional parameters to read in several MM4-MM5 files 
c                 (number of files nm3d and filenames m3ddat)
c
c --- V5.541 (031106) to V5.546 (040924) (DGS)
c               - Add QA check for datum = UNKNOWN
c
c 
c --- V5.54 (031017) to V5.541 (031106) (KAM)
c               - Correction to the variable type definitions
c                 of IAVET and TGDEFA
c
c --- V5.51 (030515) to V5.54 (031017) (DGS)
c               - Allow location data for surface, upper, and precip
c                 stations to be missing from control file if they are
c                 provided in the corresponding data files
c
c --- V5.5 (030402) to V5.51 (030515) (J. Scire)
c               - Correction to the variable type definition of IAVET
c
c --- V5.4 (020211) to V5.5 (030402)  (DGS)
c               - Add list-file unit to JULDAY call
c               - rdate changed to include YYYY format for year
c                 (MM-DD-YYYY)
c               - New map projection and datum specification
c               - Lat/Lon of SW corner computed from input (x,y)
c               - QA checks repositioned
c               - Explicitly reset met station number to zero if NOOBS
c                 selection indicates type of met data not used
c               - Do not close control file after use
c
c --- V5.3         020211  (FRR): allow input of prognostic temperature
c                                 and noobs option from control file
c ---                             allow input of non hourly MM5 data 
c                                 from control file
c --- V5.2         000602b (JSS): allow input of radiation parameters
c                                 from control file
c --- V5.0-V5.1    991104  (DGS): enforce YYYY format for year
c --- V5.0-V5.1    991104  (DGS): include MM5.DAT choices for IPROG in
c                                 QA output to list file
c
c --- INPUTS:
c      Common block /QA/
c              ver, level, rdate, rtime
c      Common block /FLAGS/
c              iomesg, lmesg
c      Parameters:
c              IO5, IO6, MVER, MLEVEL
c
c --- OUTPUT:
c       TITLE(3) - Char*80 array - Three line run title
c      IDIOP2(5) - Integer array - Flags for diagnostic wind field
c                                  options
c         IPROG2 - integer       - Control variable determining use of
c                                  prognostic data (1=CSUMM as Step 1
c                                  field; 2=CSUMM as initial guess field;
c                                  3=MM4 as Step 1 field; 4=MM4 as initial
c                                  guess field, 5=MM4 as "observations")
c                                  13=MM5 as Step 1 field; 14=MM5 as initial
c                                  guess field, 15=MM5 as "observations")
c          ITEST - integer       - Flag indicating if execution is to
c                                  include COMPUTATIONAL phase
c                                  (ITEST = 1 to STOP program after
c                                             SETUP phase,
c                                   ITEST = 2 to CONTINUE execution to
c                                             include computations)
c
c            n3d - integer       - Number of MM4/MM5 data files 
c
c            nig - integer       - Number of IGF-CALMET data files
c          igfflag -integer      - Flag to use coarse CALMET as IGF
c
c
c
c       Variables from common blocks:
c       /GEN/, /GRID/, /MET1/, /ZIPARM/, /OVRWAT/, OUTPT/, /WPARM/, /TMP/
c       /LON/, /HFLUX/, /MAP/, /IGF/
c
c --- READCF called by:  SETUP
c --- READCF calls:      READFN, READIN, JULDAY, QAYR4, YR4C,
c                        GLOBE1, GLOBE, NIMADATE, COORDSVER
c----------------------------------------------------------------------
c
c --- Include parameter statements
      include 'params.met'
      include 'params.cal'
c
c
      character*16 inputset,inputver
      character*64 inputmod
      character*70 abtz

      real zbuf(mxnz)
      integer ivleng(mxvar,mxsg),ivtype(mxvar,mxsg)
      integer idiop2(5),metbxid(mxbxwnd)
      character*12 cvdic(mxvar,mxsg)
      logical lecho, lerrcf, lwarncf
c ***
      character*132 ctemp
      character*80 title(3)
      character*50 verdoc
      dimension xbbar(mxbar),ybbar(mxbar),xebar(mxbar),yebar(mxbar)
c ***
      character*4 clatlon(16,4)
      character*4 ctime(70)
      character*4 cpmap(8),cdatum(8)

c --- For coordinate transformations
      character*8 cmapi,cmapo
      character*12 caction
      character*4 c4hem
      real*8 vecti(9),vecto(9)
c
c --- Include common blocks
      include 'gen.met'
      include 'grid.met'
      include 'hflux.met'
      include 'met1.met'
      include 'ziparm.met'
      include 'ovrwat.met'
      include 'outpt.met'
      include 'wparm.met'
      include 'qa.met'
      include 'breez.met'
      include 'lon.met'
      include 'map.met'
      include 'tmp.met'
      include 'filnam.met'
      include 'flags.met'
      include 'mm4hdo.met'
      include 'd3.met'
      include 'igf.met'
c
      data lecho/.true./, lerrcf/.false./, lwarncf/.false./
c
c
      data cvdic/'IBYR','IBMO','IBDY','IBHR','IBSEC',
     1 'IEYR','IEMO','IEDY','IEHR','IESEC','ABTZ','IBTZ','IRLG',
     1 'NSECDT','IRTYPE','LCALGRD','ITEST','MREG',42*' ',
     2 'PMAP','DATUM','FEAST','FNORTH','IUTMZN','UTMHEM',
     2 'RLAT0','RLON0','XLAT1','XLAT2','NX','NY','DGRIDKM',
     2 'XORIGKM','YORIGKM','NZ','ZFACE',  43*' ',
     3 'LSAVE','LPRINT','IPRINF','IUVOUT','IWOUT','ITOUT','STABILITY',
     3 'USTAR','MONIN','MIXHT','WSTAR','PRECIP','SENSHEAT','CONVZI',
     3 'LDB','NN1','NN2','LDBCST','IOUTD','NZPRN2','IPR0','IPR1',
     3 'IPR2','IPR3','IPR4','IPR5','IPR6','IPR7','IPR8','IFORMO',30*' ',
     4 'NOOBS','NSSTA','NPSTA','IFORMS','IFORMP',
     4 'ICLOUD','ICLDOUT','MCLOUD','IFORMC',51*' ',
     5 'IWFCOD','IFRADJ','IKINE','IOBR','IEXTRP','RMIN2',
     5 'FEXTR2','IPROG','ISTEPPG','ISTEPPGS','IGFMET',
     5 'LVARY','RMAX1','RMAX2','RMAX3',
     5 'RMIN','TERRAD','R1','R2','RPROG','DIVLIM','NITER','NSMTH',
     5 'NINTR2','CRITFN','ALPHA','NBAR','XBBAR','YBBAR',
     5 'XEBAR','YEBAR','KBAR',
     5 'IDIOPT1','IDIOPT2','IDIOPT3','IDIOPT4','IDIOPT5','ISURFT',
     5 'IUPT','ZUPT','IUPWND','ZUPWND','LLBREZE','NBOX','XG1','XG2',
     5 'YG1','YG2','XBCST', 'YBCST','XECST','YECST','NLB','METBXID',
     5 'BIAS','ISLOPE','ICALM',3*' ',
     6 'CONSTB','CONSTE','CONSTN','DPTMIN','DZZI','ZIMIN',
     6 'ZIMAX','ZIMINW','ZIMAXW','IAVEZI','MNMDAV','HAFANG','ILEVZI',
     6 'FCORIOL','CONSTW','ITPROG','ITWPROG','ILUOC3D','IRAD','IAVET',
     6 'TGDEFB','TGDEFA','JWAT1','JWAT2','TRADKM','NUMTS','NFLAGP',
     6 'SIGMAP','CUTP','HA1','HA2','HB1','HB2','HC1','HC2','HC3',
     6 'IMIXH','THRESHL','THRESHW','ICOARE','DSHELF','IWARM','ICOOL',
     6  'IRHPROG','IZICRLX','TZICRLX',14*' ',
     7  60*' ',60*' ',60*' '/
c

c --- Variable dimension (1: scalar)
      data ivleng/10*1,70,7*1, 42*0,
     2   2*8,4*1,4*16,6*1,mxnzp1, 43*0,
     3   3*1, 3*mxnz, 24*1, 30*0,
     4   9*1, 51*0,
     5   6*1, mxnz, 15*1, 2*mxnz, 3*1, 4*mxbar, 10*1, 2,
     5   2*1, 9*mxbox, mxbxwnd, mxnz, 2*1,3*0,
     6   22*1, 2*mxwb, 22*1, 14*0,
     7   60*0,
     8   60*0,
     9   60*0/
c
c
c --- Variable types (ivtype) are coded as:
c          0 = null
c          1 = real
c          2 = integer
c          3 = logical
c          4 = character
      data ivtype/10*2,4,4*2,3,2*2,42*0,
     2 2*4,2*1,2,5*4,2*2,3*1,2,1, 43*0,
     3 2*3, 12*2, 3,2*2,3,12*2, 30*0,
     4 9*2, 51*0,
     5 5*2, 2*1, 4*2, 3, 9*1, 3*2, 2*1, 2, 4*1,8*2, 1, 2, 1, 3, 2,
     5 8*1, 2*2, 1, 2*2, 3*0,
     6 9*1, 2*2, 1, 2, 2*1, 5*2, 2*1, 2*2, 1, 2*2, 9*1, 1*2,
     6 2*1, 2, 1, 4*2, 1, 14*0,
     7 60*0, 60*0, 60*0/

c --- Scale factor for Tangential TM projection
      tmsone=1.00000
c
c
      if(lmesg)write(iomesg,*)'ENTERING SETUP PHASE'
c ------------------
c --- Input format 
c -------------------
c --- New format: first line includes dataset types, version number
c --- and description (starts at 2.1) (060215)
      read(io5,'(2a16,a64)') inputset,inputver,inputmod
       
C
c ------------------
c --- Read title (First 3 lines of the control file) 
c -------------------
      read(io5,102)title
102   format(a80/a80/a80)

c -------------------------------------------------
c --- Read file names from control file - IG # 0(a)
c -------------------------------------------------

      call readfn(1,nusta,nowsta,nm3d,nigf)
c --- set other variable name to pass through calling list
      n3d=nm3d
      nig=nigf
c
c --- Open the output LIST file
      open(io6,file=metlst,status='unknown')
c
c --- Write page header
      write(io6,1400)ver,level

c --- v6.4.0, Level 121203
1400  format(40x,'CALMET',3x,'Version: ',a12,3x,'Level: ',a8/

     1 1x,13('**********')/)
c
c --- Write clock date/time of run
      write(io6,1402)rtime,rdate
1402  format(//2x,'Clock time: ',a8/
     1         2x,'      Date: ',a10)
c
c --- Check that the version and level number in the parameter
c --- file matches those in the code itself
      if(ver.ne.mver.or.level.ne.mlevel)then
         write(io6,8)ver,level,mver,mlevel
8        format(/1x,'ERROR in SUBR. SETUP -- The CALMET version ',
     1   'and level numbers do not match those in the parameter file'/

c --- v6.4.0, Level 121203
     2   5x,'    Model Code - Version: ',a12,' Level: ',a8/
     3   5x,'Parameter File - Version: ',a12,' Level: ',a8)

         stop
      endif
c
c --- Obtain COORDS version information
      call COORDSVER(io6,verdoc)
      write(io6,*)
      write(io6,*)
      write(io6,*)'Internal Coordinate Transformations by ',verdoc
      write(io6,*)
c
      write(io6,1410)title
1410  format(//2x,'Run Title:'/
     1 3(5x,a80/))

c ---------------------------------------------------------------------
c --- Read upper air, overwater, MM5 and misc. files  - IG # 0(b,c,d,e)
c ---------------------------------------------------------------------

      call readfn(2,nusta,nowsta,nm3d,nigf)

c --------------------------------------------
c --- General run control parameters -- IG # 1
c --------------------------------------------
c --- Initialize the temporary array for the time zone
      do j=1,70
         ctime(j)(1:1)=' '
         abtz(j:j)=' '
      enddo

c --- initialize input parameters to check input file version consistency
      ibsec=-9999
      iesec=-9999
      iehr =-9999
      ibtz =-9999

      call readin(cvdic(1,1),ivleng(1,1),ivtype(1,1),io5,io6,lecho,
     1 IBYR,IBMO,IBDY,IBHR,IBSEC,IEYR,IEMO,IEDY,IEHR,IESEC,CTIME(1),
     2 IBTZ,IRLG,NSECDT,IRTYPE,LCALGRD,ITEST,MREG,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)


c ---  transfer the char*4 data into the char*70 variable
       do j=1,70
          if(ctime(j)(1:1).ne.' ')abtz(j:j)=ctime(j)(1:1)
       enddo

c ---    Convert UTC time zone to/from integer base sf time zone
         if (inputver.EQ.'2.1'.or.inputver.EQ.'2.2') then
c ---       CALMEt.INP version 2.1 or 2.2
c ---       Strip charct time zone from blanks and take 8 characters
            ij=0
            do j=1,70
               if (abtz(j:j).ne.' ') then
                  ij=ij+1
                  if (ij.gt.8) then
                     write(io6,*)'wrong format for UTC time zone ABTZ'
                     STOP 'wrong format for input UTC time zone - STOP'
                  endif
                  axtz(ij:ij)=abtz(j:j)
               endif
            end do
c ---       transform Char*8 UTC time zone to real time zone
            call utcbasr(axtz,xbtz)
c ---       Integer time zone
            ibtz=int(xbtz)
         else
c ---        old format (pre 2.1) - convert ibtz time zone to UTC for output
             xbtz=ibtz*1.
             call basrutc(xbtz,axtz)
         endif

c ---   Check consistency of input parameters and input file version number
c ---   Expect explicit begining/ending times and UTC time zone if version 2.1
c ---   stop if inconsistent
        if (inputver.EQ.'2.1'.or.inputver.EQ.'2.2') then
           if ((ibsec.eq.-9999).or.(iesec.eq.-9999).or.
     :         (iehr.eq.-9999)) then
              write(io6,*)' INCONSISTENT Input format and parameters'
              write(io6,*)' Input file format: ', inputver
              write(io6,*)'IBSEC=',ibsec,'IESEC=',iesec,'IEHR=',iehr
              write(io6,*)' Check input file - STOP '
              STOP ' STOP - Check list file for error'
           else if (axtz(1:3).ne.'UTC') then
              write(io6,*)' INCONSISTENT Input format and parameters'
              write(io6,*)' Input file format: ', inputver
              write(io6,*)'ABTZ=',AXTZ, ' - Must follow: UTC+HHMM '
              write(io6,*)' Check input file - STOP '
              STOP ' STOP - Check list file for error'
           endif
        else
         if ((ibsec.ne.-9999).or.(iesec.ne.-9999).or.
     :         (iehr.ne.-9999))then
         write(io6,*)'INCONSISTENT Input format and  parameters'
        write(io6,*)'Explicit beginning/ending times for V2.1 or higher'
         write(io6,*)'CALMET.INP V2.1 requires first header line'
         write(io6,*)'or CALMET.INP V2.2 requires first header line'
         write(io6,*)'Check input file - STOP '
         STOP ' STOP - Check list file for error'
        endif
        endif
      
c --------------------------------------------------------
c --- Map Projection and Grid control parameters -- IG # 2
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
         clat0(j:j)=' '
         clon0(j:j)=' '
         clat1(j:j)=' '
         clat2(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,2),ivleng(1,2),ivtype(1,2),io5,io6,lecho,
     1 CPMAP,CDATUM,FEAST,FNORTH,IUTMZN,UTMHEM,
     2 CLATLON(1,1),CLATLON(1,2),CLATLON(1,3),CLATLON(1,4),
     2 NX,NY,DGRIDKM,XORIGKM,YORIGKM,NZ,ZFACE,
     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)


c --- Pad the char*4 UTM Hemisphere
      utmhem(2:4)='   '

c --- Transfer the char*4 data into the char*16 variables
      do j=1,16
         if(clatlon(j,1)(1:1).ne.' ')clat0(j:j)=clatlon(j,1)(1:1)
         if(clatlon(j,2)(1:1).ne.' ')clon0(j:j)=clatlon(j,2)(1:1)
         if(clatlon(j,3)(1:1).ne.' ')clat1(j:j)=clatlon(j,3)(1:1)
         if(clatlon(j,4)(1:1).ne.' ')clat2(j:j)=clatlon(j,4)(1:1)
      enddo

c --- Transfer the char*4 data into the char*8 variables
      if(cpmap(1)(1:1).ne.' ') then
         do j=1,8
            pmap(j:j)=cpmap(j)(1:1)
         enddo
      endif
      if(cdatum(1)(1:1).ne.' ') then
         do j=1,8
            datum(j:j)=cdatum(j)(1:1)
         enddo
      endif

c --- Translate character lat/lon to real NLat/ELon
      if(clat0(1:1).NE.' ') call XTRACTLL(io6,'LAT ',clat0,rnlat0)
      if(clon0(1:1).NE.' ') call XTRACTLL(io6,'LON ',clon0,relon0)
      if(clat1(1:1).NE.' ') call XTRACTLL(io6,'LAT ',clat1,xlat1)
      if(clat2(1:1).NE.' ') call XTRACTLL(io6,'LAT ',clat2,xlat2)

c --- Set logicals for map projection PMAP
      if(pmap.EQ.'UTM     ')  lutm =.TRUE.
      if(pmap.EQ.'LCC     ')  llcc =.TRUE.
      if(pmap.EQ.'PS      ')  lps  =.TRUE.
      if(pmap.EQ.'EM      ')  lem  =.TRUE.
      if(pmap.EQ.'LAZA    ')  llaza=.TRUE.
      if(pmap.EQ.'TTM     ')  lttm =.TRUE.

c --- Adjust projection information if needed
      if(LEM) then
c ---    Equatorial Mercator projection matches at 0.0N, 
c ---    and places the northing origin at 0.0N
         rnlat0=0.0
         xlat1=0.0
         xlat2=0.0
      endif

c ----------------------------
c --- Output options -- IG # 3
c ----------------------------

      call readin(cvdic(1,3),ivleng(1,3),ivtype(1,3),io5,io6,lecho,
     1 LSAVE,LPRINT,IPRINF,IUVOUT,IWOUT,ITOUT,IMTOUT(1),IMTOUT(2),
     2 IMTOUT(3),IMTOUT(4),IMTOUT(5),IMTOUT(6),IMTOUT(7),IMTOUT(8),
     3 LDB,NN1,NN2,LDBCST,IOUTD,NZPRN2,IPR0,IPR1,IPR2,IPR3,
     4 IPR4,IPR5,IPR6,IPR7,IPR8,IFORMO,
     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)

c -----------------------------------------
c --- Meteorological data options -- IG # 4
c -----------------------------------------

      call readin(cvdic(1,4),ivleng(1,4),ivtype(1,4),io5,io6,lecho,
ccec101006 1 noobs,NSSTA,NPSTA,IFORMS,IFORMP,ICLOUD,IFORMC,
     1 noobs,NSSTA,NPSTA,IFORMS,IFORMP,ICLOUD,ICLDOUT,MCLOUD,IFORMC,
cfrr 1 NSSTA,NPSTA,IFORMS,IFORMP,noobs,ICLOUD,IFORMC,
     2 idum,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)
c
       if (icloud.eq.999.and.inputver.ne.'2.2')then
        write(io6,*)' ICLOUD should be equal to 0,1,2,3 or 4'
        write(io6,*)' ICLOUD =',icloud
        write(io6,*)' Check a CALMET.INP V2.1 format or before'
        write(io6,*)' or change '
        write(io6,*)' to CALMET.INP V2.2 in the first header line'
        write(io6,*)' if MCLOUD and ICLDOUT are used instead of ICLOUD'
        write(io6,*)' Check input file - STOP '
        STOP ' STOP - Check list file for error'
       endif
       if ((mcloud.eq.999.or.icldout.eq.999).and.inputver.eq.'2.2')then
        write(io6,*)' INCONSISTENT Input format and  parameters'
        write(io6,*)' ICLOUD should be replaced by MCLOUD and ICLOUD'
        write(io6,*)' Check a CALMET.INP V2.2 format'
        write(io6,*)' Check input file - STOP '
        STOP ' STOP - Check list file for error'
       endif

c --- Check NOOBS selection and reset NSSTA,NOWSTA,NUSTA if needed
      if(noobs.EQ.1) then
         if(nusta.GT.0) then
           write(io6,*)
           write(io6,*) 'READCF:  Warning in Input Group 4'
           write(io6,*) 'No upper air needed for   NOOBS = ',noobs
           write(io6,*) 'NUSTA reset to 0 from ',nusta
           lwarncf=.TRUE.
           nusta=0
         endif
      elseif(noobs.EQ.2) then
         if(nusta.GT.0 .OR. nssta.GT.0 .OR. nowsta.GT.0) then
           write(io6,*)
           write(io6,*) 'READCF:  Warning in Input Group 4'
           write(io6,*) 'No observations for       NOOBS = ',noobs
           write(io6,*) 'NSSTA  reset to 0 from ',nssta
           write(io6,*) 'NUSTA  reset to 0 from ',nusta
c ---      SEa.DAT files are allowed in NOOBS=2 mode (041001- CEC)
c          write(io6,*) 'NOWSTA reset to 0 from ',nowsta
           lwarncf=.TRUE.
           nssta=0
c          nowsta=0
           nusta=0
         endif
      endif
c
c --- Match CLOUD PARAMETERS between CALMET.INP version 2.2 and before
c
	if(inputver.ne.'2.2') then
	 if (ICLOUD.eq.0) then
           ICLDOUT=0
           MCLOUD=1
         elseif(ICLOUD.eq.1) then
           ICLDOUT=1
           MCLOUD=1
         elseif (ICLOUD.eq.2) then
           ICLDOUT=0
           MCLOUD=2
         elseif (ICLOUD.eq.3) then
           ICLDOUT=0
           MCLOUD=3
         elseif (ICLOUD.eq.4) then
           ICLDOUT=0
           MCLOUD=4
         else
           write(io6,*)' ERROR in READCF:ICLOUD is equal to 0,1,2,3or4'
           write(io6,*)' Please choose one of these options'
           write(io6,*)' Current Value of ICLOUD = ',ICLOUD
           write(io6,*)' Check input file - STOP '
           STOP ' STOP - Check list file for error'
         endif
        else
          if(ICLDOUT.gt.1) then
           write(io6,*)' ERROR in READCF:ICLDOUT is equal to 0 or 1'
           write(io6,*)' Please choose one of these options'
           write(io6,*)' Current Value of ICLDOUT = ',ICLDOUT
           write(io6,*)' Check input file - STOP '
           STOP ' STOP - Check list file for error'
          endif
          if(MCLOUD.gt.4.or.MCLOUD.le.0) then
           write(io6,*)' ERROR in READCF:MCLOUD is equal to 1,2,3 or 4'
           write(io6,*)' Please choose one of these options'
           write(io6,*)' Current Value of MCLOUD = ',MCLOUD
           write(io6,*)' Check input file - STOP '
           STOP ' STOP - Check list file for error'
          endif
          if(MCLOUD.eq.2.and.ICLDOUT.eq.1) then
           write(io6,*)' ERROR in READCF: if MCLOUD =2, no gridded'
           write(io6,*)' CLOUD.DAT needs to be output'
           write(io6,*)' since gridded data come from CLOUD.DAT'
           write(io6,*)' ICLDOUT needs to be switched to 0'
           write(io6,*)' Check input file - STOP '
           STOP ' STOP - Check list file for error'
         endif
        endif
c
c -----------------------------------------------
c --- Wind field options and parameters -- IG # 5
c -----------------------------------------------
c --- Initialize kbar - nbar initialized in block data (050101)
      kbar=nz

c --- initialize igfmet (compatibility with old files)
      igfmet=0 

c --- Initialize isteppg and isteppgs (080205)
      isteppg=0
      isteppgs=0

      call readin(cvdic(1,5),ivleng(1,5),ivtype(1,5),io5,io6,lecho,
     1 IWFCOD,IFRADJ,IKINE,IOBR,IEXTRP,RMIN2,FEXTR2,IPROG,ISTEPPG,
     2 ISTEPPGS,
     2 IGFMET,LVARY,RMAX1,RMAX2,RMAX3,RMIN,TERRAD,R1,R2,RPROG,DIVLIM,
     3 NITER,NSMTH,NINTR2,CRITFN,ALPHA,NBAR,XBBAR,YBBAR,XEBAR,YEBAR,
     4 KBAR,IDIOPT(1),IDIOPT(2),IDIOPT(3),IDIOPT(4),IDIOPT(5),
     5 ISURFT,IUPT,ZUPT,IUPWND,ZUPWND,LLBREZE,NBOX,XG1,XG2,YG1,YG2,
     5 XBCST,YBCST,XECST,YECST,NLB,METBXID,BIAS,ISLOPE,ICALM,
     6 idum,idum,idum)

c --- set other variable name to pass through calling list
      igfflag=igfmet

c --- Prognostic timestep in seconds (if not in the input file)
      if (isteppgs.eq.0) ISTEPPGS= isteppg*3600

c ------------------------------------------------------
c --- Mixing height and temperature parameters -- IG # 6
c ------------------------------------------------------
c --- 050328 - Default value for icoare such that backward compatible
c --- icoare=0 (deltaT method)
c --- 051111 - Reset default
      icoare=10
c --- 050328 - Default value for dshelf (deep sea everywhere)
      dshelf=0. 
c --- 050419 - Default value for iwarm-icool (on) changed to
c --- off (051230)
      iwarm=0
      icool=0

c --- 050328 - Initialize new mixing height parameters such that
c     the old CALMET.INP files can be used 
c      imixh=-1
c --- 051111 - Reset default
      imixh=1
      itwprog=0
      threshw=0.05
c     threshl=0.05  - value reset (070702)
      threshl=0.0

c --- 110212 - read in izicrlx and tzicrlx (default set in block data)
      call readin(cvdic(1,6),ivleng(1,6),ivtype(1,6),io5,io6,lecho,
     1 CONSTB,CONSTE,CONSTN,DPTMIN,DZZI,ZIMIN,ZIMAX,ZIMINW,ZIMAXW,
     2 IAVEZI,MNMDAV,HAFANG,ILEVZI,FCORIOL,CONSTW,ITPROG,ITWPROG,
     2 ILUOC3D,IRAD,IAVET,TGDEFB,
     3 TGDEFA,JWAT1,JWAT2,TRADKM,NUMTS,NFLAGP,SIGMAP,CUTP,HA1,HA2,
     4 HB1,HB2,HC1,HC2,HC3,IMIXH,THRESHL,THRESHW,ICOARE,DSHELF,
     5 IWARM,ICOOL,IRHPROG,IZICRLX,TZICRLX,idum,idum,idum,idum,
     6 idum,idum,idum,idum,idum,idum,idum,idum,idum,idum)
c

c --- Compute temperature radius of influence (in grid units)
      trad=tradkm/dgridkm

c --- Set directives for choice of surface temperatures and wind
c --- speed profile stability functions PSIU based on ICOARE
      if(icoare.EQ.0) then
c ---    Use model formulations prior to COARE module implementation
         isfcmet=1
         ipsifcn=1
      else
c ---    Use formulation consistent with COARE module
         isfcmet=0
         ipsifcn=0
      endif
c ------------------------------------------------------------------
c --- Remainder of control file is read using free-reads, and
c --- key strings are searched to locate the beginning of station
c --- assignments (control file delimiters are not interpreted)
c ------------------------------------------------------------------

c --- Met station information may be provided in the met files.  If
c --- information is not presented in control file, set a flag to make
c --- sure that it is found in the met files.  Any information found in
c --- the met files will replace that provided in the control file.
      lcfsfc=.FALSE.
      lcfupr=.FALSE.
      lcfprc=.FALSE.

c -----------------------------------------
c --- Surface meteorological data -- IG # 7
c -----------------------------------------

c *** Use free read until control file reader is enhanced to
c *** accomodate character inputs
c FRR (01/09) accept no surface station if noobs=2
c      if (nssta.eq.0 .and. noobs.eq.2) goto 666
      if (nssta.eq.0) goto 666

112   continue
      read(io5,113,end=666)ctemp
113   format(a132)
      if(ctemp(3:5).eq.'US1')go to 213
      if(ctemp(3:5).eq.'PS1')go to 313
      if(ctemp(3:5).ne.'SS1')go to 112
c
c --- Do not let array index exceed max dimension here - read
c --- all stations in control file, but clamp array index at
c --- the max value.  Later QA test will stop execution if
c --- too many stations are provided.
c
      do 114 j=1,nssta
         i=MIN(j,mxss)
c ***    read(ctemp(9:132),*)csnam(i),idssta(i),xssta(i),yssta(i),
c ***1        xslat(i),xslon(i),xstz(i),zanem(i)
c
c ---    Replace internal free-formatted read with write/read
c ---    to a scratch file
         open(io98,status='scratch')
         write(io98,'(a)')ctemp(9:132)
         rewind(io98)
         read(io98,*)csnam(i),idssta(i),xssta(i),yssta(i),
     1               xstz(i),zanem(i)
c ***1               xslat(i),xslon(i),xstz(i),zanem(i)
         close(io98)
c ***
         read(io5,113)ctemp
114   continue
      lcfsfc=.TRUE.

666   continue

c ------------------------------------
c --- Upper air station data -- IG # 8
c ------------------------------------

c *** Use free read until control file reader is enhanced to
c *** accomodate character inputs
c      if (noobs .gt. 0 ) goto 667
      if (nusta .eq. 0 ) goto 667

212   continue
      read(io5,113,end=667)ctemp
      if(ctemp(3:5).eq.'PS1')go to 313
      if(ctemp(3:5).ne.'US1')go to 212
c
c --- Do not let array index exceed max dimension here - read
c --- all stations in control file, but clamp array index at
c --- the max value.  Later QA test will stop execution if
c --- too many stations are provided.
c
213   do 214 j=1,nusta
         i=MIN(j,mxus)
c *** read(ctemp(9:132),*)cunam(i),idusta(i),xusta(i),yusta(i),
c ***1 xulat(i),xulon(i),xutz(i)
c
c ---    Replace internal free-formatted read with write/read
c ---    to a scratch file
         open(io98,status='scratch')
         write(io98,'(a)')ctemp(9:132)
         rewind(io98)
         read(io98,*)cunam(i),idusta(i),xusta(i),yusta(i),
     1    xutz(i)
c ***1     xulat(i),xulon(i),xutz(i)
         close(io98)
c ***
         read(io5,113)ctemp
214   continue
      lcfupr=.TRUE.

667   continue

c ----------------------------------------
c --- Precipitation station data -- IG # 9
c ----------------------------------------

c *** Use free read until control file reader is enhanced to
c *** accomodate character inputs
      if (npsta .eq. 0 ) goto 668
312   continue
      read(io5,113,end=668)ctemp
      if(ctemp(3:5).ne.'PS1')go to 312
c
c --- Do not let array index exceed max dimension here - read
c --- all stations in control file, but clamp array index at
c --- the max value.  Later QA test will stop execution if
c --- too many stations are provided.
c
313   do j=1,npsta
         i=MIN(j,mxps)
c ***    read(ctemp(9:132),*)cpnam(i),idpsta(i),xpsta(i),ypsta(i)
c
c ---    Replace internal free-formatted read with write/read
c ---    to a scratch file
         open(io98,status='scratch')
         write(io98,'(a)')ctemp(9:132)
         rewind(io98)
         read(io98,*)cpnam(i),idpsta(i),xpsta(i),ypsta(i)
         close(io98)
c ***
         read(io5,113)ctemp
      enddo
      lcfprc=.TRUE.

668   continue


c -----------------------------------------------------------
c --- Perform QA checks
c -----------------------------------------------------------

c --- IG #1
c ---------
c

c ---  Check that the timestep is a fraction of an hour
       if (mod(3600,nsecdt).ne.0) then
         write(io6,*)'NSECDT must be a fraction of 1 hour (in seconds)'
         stop 'STOP in READCF - NSECDT must be a fraction of 1 hour' 
       endif

      if (inputver.EQ.'2.1'.or.inputver.EQ.'2.2') then
c ---    QA on starting/ending  year of simulation
         call QAYR4(io6,ibyr,0,ierr)
         if(ierr.NE.0) lerrcf=.TRUE.
         call QAYR4(io6,ieyr,0,ierr)
         if(ierr.NE.0) lerrcf=.TRUE.
         call JULDAY(io6,ibyr,ibmo,ibdy,ibjul)
         call JULDAY(io6,ieyr,iemo,iedy,iejul)

c ---    Make sure hours are between 0-24
         if ((ibhr.gt.24) . or. (iehr.gt.24)) then
            write(io6,*)'IBHR-IEHR must be between 0 and 23'
            stop 'STOP in READCF - IBHR-IEHR must be between 0 and 23'
         else if (ibhr.eq.24) then
            ibhr=0
            call INCR(io6,ibyr,ibjul,ibhr,24)
            call GRDAY(io6,ibyr,ibjul,ibmo,ibdy)
         else if (iehr.eq.24) then
            iehr=0
            call INCR(io6,ieyr,iejul,iehr,24)
            call GRDAY(io6,ieyr,iejul,iemo,iedy)
         endif

c ---    If explicit times, convert to hour-ending times for internal
c ---    computations (041207)

c ---    Only accept multiple of the timestep 
         if((mod(ibsec,nsecdt).ne.0).or.(mod(iesec,nsecdt).ne.0)) then
            write(io6,*)'Beg/ending seconds must be a multiple ',
     :       'of the timestep'
            write(io6,*)'Timestep NSECDT=',nsecdt
            write(io6,*)'IBSEC =',ibsec
            write(io6,*)'IESEC =',iesec 
            write(io6,*)' STOP in READCF'
            STOP 'Beginning/ending seconds must be a multiple of NSECDT'
         endif

c ---    Convert seconds to hours
         if(ibsec.GE.3600) then
            nhrinc=ibsec/3600
            ibsec=ibsec-nhrinc*3600
            call INCR(io6,ibyr,ibjul,ibhr,nhrinc)
            call GRDAY(io6,ibyr,ibjul,ibmo,ibdy)
         endif
         if(iesec.GE.3600) then
            nhrinc=iesec/3600
            iesec=iesec-nhrinc*3600
            call INCR(io6,ieyr,iejul,iehr,nhrinc)
            call GRDAY(io6,ieyr,iejul,iemo,iedy)
         endif

c ---    output variables in explicit times 
         ibyrn=ibyr
         ibmon=ibmo
         ibdyn=ibdy
         ibjuln=ibjul
         ibhrn=ibhr
         ibsecn=ibsec
         ieyrn=ieyr
         iemon=iemo
         iedyn=iedy
         iejuln=iejul
         iehrn=iehr
         iesecn=iesec

c ---    Compute run length in hours
         call deltt(ibyr,ibjul,ibhr,ieyr,iejul,iehr,irlg)


c ---    Beginning/ending dates
         nbegdat=ibyrn*100000+ibjuln*100+ibhrn
         nenddat=ieyrn*100000+iejuln*100+iehrn

c ---    Total number of seconds in the run
         call deltsec (nbegdat,ibsecn,nenddat,iesecn,ntotsec)

c ---    Stop if ending date is earlier than beginning date
         if (ntotsec.le.0) then
            write(io6,130)ibyr,ibjul,ibhr,ibsec,ieyr,iejul,iehr,iesec
130      format(//2x,'STOP in READCF -- End date is earlier ',
     1   'than beginning date'/
     2   5x,'Run Beg date/hr/sec: ieyr, iejul, iehr, iesec = ',4i10/
     3   5x,'Run end date/hr/sec: jeyr, jejul, jehr ,jesec = ',4i10)
            STOP 'End date is earlier than beginning date'
         endif

c ---    compute run length in sub-hourly steps (stored in GEN.MET):
         irsublg=ntotsec/nsecdt

c ---    Convert explicit beginning time to hour-ending beg. times
c ---    as hour-ending times are used in the computational part of CALMET
c ---    Explicit ending time is the same as hour-ending ending time
c ---    because only hourly data are dealt with at this stage (041207)
         call INCR(io6,ibyr,ibjul,ibhr,+1)
         call GRDAY(io6,ibyr,ibjul,ibmo,ibdy)

      else
c ---    QA on starting year of simulation
         call QAYR4(io6,ibyr,0,ierr)
         if(ierr.NE.0) lerrcf=.TRUE.
         call JULDAY(io6,ibyr,ibmo,ibdy,ibjul)

c ---    Make sure hours are between 0-24
         if ((ibhr.gt.24)) then
            write(io6,*)'IBHR must be between 0 and 24'
            stop 'STOP in READCF - IBHR must be between 0 and 24'
         else if (ibhr.eq.24) then
            ibhr=0
            call INCR(io6,ibyr,ibjul,ibhr,24)
            call GRDAY(io6,ibyr,ibjul,ibmo,ibdy)
         endif

c ---    Input format with hour-ending times and length of run
c ---    Convert to explict beginning/ending times for output purposes
         ibyrn=ibyr
         ibmon=ibmo
         ibdyn=ibdy
         ibjuln=ibjul
         ibhrn=ibhr
         ibsecn=0
         call INCR(io6,ibyrn,ibjuln,ibhrn,-1)
         call GRDAY(io6,ibyrn,ibjuln,ibmon,ibdyn)
 
c        Compute ending hour: (fixed 070717)
         ieyrn=ibyr
         iejuln=ibjul
         iehrn=ibhr
         call incr(io,ieyrn,iejuln,iehrn,irlg-1)
         call GRDAY(io6,ieyrn,iejuln,iemon,iedyn)
         iesecn=0


c ---    Beginning/ending dates (070717)
         nbegdat=ibyrn*100000+ibjuln*100+ibhrn
         nenddat=ieyrn*100000+iejuln*100+iehrn

c ---    Total number of seconds in the run (070717)
         call deltsec (nbegdat,ibsecn,nenddat,iesecn,ntotsec)

c ---    compute run length in sub-hourly steps (stored in GEN.MET):
c --     070717
         irsublg=ntotsec/nsecdt

      endif         

c --- Test for valid starting hour
c --- Run must start before sunrise because mixing height algorithm
c --- uses a prognostic equation depending on heat flux
      if(irtype.ne.0.and.ibhr.gt.5)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 1'
c DGS    Report time at the start of the first period
         write(io6,'(1x,a34,i2.2,1x,i4.4)')
     &     'Invalid beginning time (HH SSSS): ',ibhrn,ibsecn
         write(io6,*) 'Run must start before 5 am (LST)'
         lerrcf=.TRUE.
      endif
c --- Check base time zone
      if(ibtz.GT.12 .OR. ibtz.LT.-12) then
c ---    Time zone outside valid range
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 1'
         write(io6,*) 'Invalid base time zone:  IBTZ = ',ibtz
         write(io6,*) 'Expected  -12 <= IBTZ <= 12'
         lerrcf=.TRUE.
      endif
c --- Test for valid regulatory check selection
      if(mreg.LT.-1 .OR. mreg.GT.1)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 1'
         write(io6,*) 'Invalid Regulatory Option: MREG = ',mreg
         write(io6,*) 'Expected  0 <= MREG <= 1'
         write(io6,*) 'MREG is a mandatory input to the control file'
         lerrcf=.TRUE.
      endif
c --- Test for missing regulatory check selection
      if(mreg.EQ.-1)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 1'
         write(io6,*) 'No Regulatory Option (MREG) specified '
         write(io6,*) 'MREG is a mandatory input to the control file'
         lerrcf=.TRUE.
      endif

c --- IG #2
c ---------
c
c --- Test for valid PMAP (restricted set until wind rotation
c --- and map factor codes are implemented)
      if(lutm.OR.llcc.OR.lttm) then
c        OK

c --- v6.4.0, Level 121203
      elseif(LPS) then
c ---    Added PS rotation

      else
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 2'
         write(io6,*) 'Unacceptable PMAP             = ',pmap
         write(io6,*) 'PMAP must be UTM,LCC,TTM'
         write(io6,*) '          or PS'
         lerrcf=.TRUE.
      endif
cc --- Test for valid PMAP
c      if(lutm.OR.llcc.OR.lps.OR.lem.OR.llaza.OR.lttm) then
cc        OK
c      else
c         write(io6,*)
c         write(io6,*) 'READCF:  Error in Input Group 2'
c         write(io6,*) 'Unknown PMAP                  = ',pmap
c         write(io6,*) 'PMAP must be UTM,LCC,PS,EM,LAZA,TTM'
c         lerrcf=.TRUE.
c      endif
c
c --- Test for valid IUTMZN
      if((iutmzn.LT.1 .OR. iutmzn.GT.60) .AND. LUTM) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 2'
         write(io6,*) 'IUTMZN out of range           = ',iutmzn
         write(io6,*) 'IUTMZN should be 1 to 60'
         lerrcf=.TRUE.
      endif
c
c --- Test for valid UTMHEM
      if((utmhem.NE.'N   '.AND.utmhem.NE.'S   ') .AND. LUTM) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 2'
         write(io6,*) 'UTMHEM out of range           = ',utmhem
         write(io6,*) 'UTMHEM should be N or S'
         lerrcf=.TRUE.
      endif
c
c --- Test for lat/lon of origin for LCC/PS/EM/LAZA/TTM map projection
      if(LLCC .or. LPS .or. LEM .or. LLAZA .or. LTTM) then
         if(rnlat0 .LT. -900.0 .OR. relon0 .LT. -900.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 2'
            write(io6,*) 'Missing lat/lon of origin for ',pmap
            lerrcf=.TRUE.
         elseif(rnlat0 .LT. -90.0 .OR. rnlat0 .GT. 90.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 2'
            write(io6,*) 'RLAT0 (as N) out of range     = ',rnlat0
            write(io6,*) '|RLAT0| should be 0 to 90 degrees'
            lerrcf=.TRUE.
         elseif(relon0 .LT. -180.0 .OR. relon0 .GT. 180.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 2'
            write(io6,*) 'RLON0 (as E) out of range     = ',relon0
            write(io6,*) '|RLON0| should be 0 to 180 degrees'
            lerrcf=.TRUE.
         endif
      endif
c
c --- Test for matching latitudes for LCC map projection
      if(LLCC) then
         if(xlat1 .LT. -900.0 .OR. xlat2 .LT. -900.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 2'
            write(io6,*) 'Missing matching lats for ',pmap
            lerrcf=.TRUE.
         elseif(xlat1 .LT. -90.0 .OR. xlat1 .GT. 90.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 2'
            write(io6,*) 'XLAT1 (as N) out of range     = ',xlat1
            write(io6,*) '|XLAT1| should be 0 to 90 degrees'
            lerrcf=.TRUE.
         elseif(xlat2 .LT. -90.0 .OR. xlat2 .GT. 90.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 2'
            write(io6,*) 'XLAT2 (as N) out of range     = ',xlat2
            write(io6,*) '|XLAT2| should be 0 to 90 degrees'
            lerrcf=.TRUE.
         endif
      endif
c
c --- Test for matching latitudes for PS/EM map projection
      if(LPS .or. LEM) then
         if(xlat1 .LT. -900.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 2'
            write(io6,*) 'Missing matching lats for ',pmap
            lerrcf=.TRUE.
         elseif(xlat1 .LT. -90.0 .OR. xlat1 .GT. 90.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 2'
            write(io6,*) 'XLAT1 (as N) out of range     = ',xlat1
            write(io6,*) '|XLAT1| should be 0 to 90 degrees'
            lerrcf=.TRUE.
         endif
      endif
c
c --- Test for grid size
      if(nx.GT.mxnx .OR. nx.LE.0 .OR. ny.GT.mxny .OR. ny.LE.0)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 2'
         write(io6,*) 'NX,NY out of range            = ',nx,ny
         write(io6,*) 'Expected >0 and <= MXNX, MXNY = ',mxnx,mxny
         lerrcf=.TRUE.
      endif
c
c --- Test for number of vertical layers
      if(nz.GT.mxnz .OR. nz.LE.0)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 2'
         write(io6,*) 'NZ out of range               = ',nz
         write(io6,*) 'Expected >0 and <= MXNZ       = ',mxnz
         lerrcf=.TRUE.
      endif
c --- Test for invalid DATUM (040924)
      if(datum.EQ.'UNKNOWN ') then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 2'
         write(io6,*) 'DATUM cannot be UNKNOWN'
         lerrcf=.TRUE.
      endif

c --- IG #4
c ---------
c
c --- Test for max number of stations
      if(nssta.gt.mxss.or.nusta.gt.mxus.or.npsta.gt.mxps.or.
     1   nowsta.gt.mxows)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 4'
         write(io6,*) 'Number of met stations exceeds parameter limit'
         write(io6,*) 'Surface Stations: NSSTA, MXSS = ',nssta,mxss
         write(io6,*) 'Upper Stations:   NUSTA, MXUS = ',nusta,mxus
         write(io6,*) 'Precip Stations:  NPSTA, MXPS = ',npsta,mxps
         write(io6,*) 'Sea Stations:   NOWSTA, MXOWS = ',nowsta,mxows
         lerrcf=.TRUE.
      endif
c
c --- Test for NOOBS
      if(noobs.LT.0 .OR. noobs.GT.2)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 4'
         write(io6,*) 'NOOBS out of range            = ',noobs
         write(io6,*) 'Expected 0,1,2 '
         lerrcf=.TRUE.
      endif
c
c 030119 - NPSTA=-1 option only with MM4 or MM5 data
      if(NPSTA.eq.-1 .AND. iprog.lt.3)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Groups 4 and 5'
         write(io6,*) 'NPSTA=-1 only possible with MM4 or MM5 data'
         write(io6,*) 'NPSTA=',npsta,'  IPROG=',iprog
         lerrcf=.TRUE.
      endif
c
c --- Test for too few surface met stations
      if (nssta.eq.0 .and. noobs.lt.2) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 4'
         write(io6,*) 'Surface stations are needed if NOOBS<2'
         write(io6,*) 'NSSTA=',nssta,'  NOOBS=',noobs
         lerrcf=.TRUE.
      endif
c
c --- Test for too few upper air stations
      if (nusta.eq.0 .and. noobs.eq.0) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 4'
         write(io6,*) 'Upper air stations are needed if NOOBS=0'
         write(io6,*) 'NUSTA=',nusta,'  NOOBS=',noobs
         lerrcf=.TRUE.
      endif
c
      if(inputver.eq.'2.2') then
       if(mcloud.lt.1.or.mcloud.gt.4)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 4'
         write(io6,*) 'Invalid cloud option,  MCLOUD = ',mcloud
         write(io6,*) 'MCLOUD must be 1, 2, 3 or 4'
         lerrcf=.TRUE.
       endif
c frr (09/01) ICLOUD must be = 2, 3 or 4 if NOOBS = 2 (no surface observations)
       if(mcloud.lt.2 .and. noobs.eq.2)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 4'
         write(io6,*) 'Invalid cloud option,  MCLOUD = ',mcloud
         write(io6,*) 'MCLOUD must be  2, 3 or 4 if NOOBS = 2'
         lerrcf=.TRUE.
       endif
      else
c --- Test for ICLOUD option
c frr (09/01) additional option icloud=3 (gridded cloud cover from MM5 data)
       if(icloud.lt.0.or.icloud.gt.4)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 4'
         write(io6,*) 'Invalid cloud option,  ICLOUD = ',icloud
         write(io6,*) 'ICLOUD must be 0, 1, 2, 3 or 4'
         lerrcf=.TRUE.
       endif
c frr (09/01) ICLOUD must be = 2, 3 or 4 if NOOBS = 2 (no surface observations)
       if(icloud.lt.2 .and. noobs.eq.2)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 4'
         write(io6,*) 'Invalid cloud option,  ICLOUD = ',icloud
         write(io6,*) 'ICLOUD must be  2, 3 or 4 if NOOBS = 2'
         lerrcf=.TRUE.
       endif
      endif
       
c
      if(iformo.lt.1.or.iformo.gt.2 .OR.
     &   iforms.lt.1.or.iforms.gt.2 .OR.
     &   iformp.lt.1.or.iformp.gt.2 .OR.
     &   iformc.lt.1.or.iformc.gt.2)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 3 or 4'
         write(io6,*) 'Format codes must be either 1 or 2'
         write(io6,*) 'IFORMO, IFORMC = ',iformo,iformc
         write(io6,*) 'IFORMS, IFORMP = ',iforms,iformp
         lerrcf=.TRUE.
      endif

c --- Do not allow MESOPAC output if the timestep is not 1 hour
      if(iformo.EQ.2 .AND. nsecdt.NE.3600) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 3'
         write(io6,*) 'MESOPAC output requires 1-hour timestep'
         write(io6,*) 'IFORMO, NSECDT = ',iformo,nsecdt
         lerrcf=.TRUE.
      endif

c --- Test for NOOBS interaction with other selections
c ----------------------------------------------------
c
c --- NOOBS mode only with MM5 data  or , since 030119, MM4 data
      if(noobs .ge. 1 .and. iprog.ne.13 .and. iprog.ne.14
     &   .and. iprog .ne.15 .and. iprog.ne.3 .and. iprog.ne.4
     &  .and. iprog .ne.5)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Groups 4 and 5'
         write(io6,*) 'Incorrect value of IPROG for NOOBS mode'
         write(io6,*) 'NOOBS = ',noobs,'  IPROG = ',iprog
         write(io6,*) 'Expected IPROG = 3,4,5,13,14,15 '
         lerrcf=.TRUE.
      endif
c
c --- NOOBS mode with MM4 and DIAG.DAT
      if (idiopt(3).eq.0 .and. iprog.eq.5 .and. iwfcod.eq.1
     &   .and. noobs .ge. 1) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Groups 4 and 5'
         write(io6,*)'If using diagnostic wind module and MM4 only ',
     1   'as observations then must use DIAG.DAT to input ' ,
     2   'domain-averaged wind components:'
         write(io6,*) 'IPROG=5,IWFCOD=1,NOOBS=1or2 ==> IDIOPT(3)=1'
         lerrcf=.TRUE.
      endif
c
c --- NOOBS mode with MM5 and DIAG.DAT
      if (idiopt(3).eq.0 .and. iprog.eq.15 .and. iwfcod.eq.1
     &   .and. noobs .ge. 1) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Groups 4 and 5'
         write(io6,*)'If using diagnostic wind module and MM5 only ',
     1   'as observations then must use DIAG.DAT to input ' ,
     2   'domain-averaged wind components:'
         write(io6,*) 'IPROG=15,IWFCOD=1,NOOBS=1or2 ==> IDIOPT(3)=1'
         lerrcf=.TRUE.
      endif

c --- Parameter for prognostic temp (ITPROG)
      if (itprog.ne.0 .and. itprog.ne.1 .and. itprog.ne.2) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Incorrect value of ITPROG     = ',itprog
         write(io6,*) 'ITPROG must be 0, 1, or 2'
         lerrcf=.TRUE.
      endif

      if (itprog.ge.1 .and. iprog.lt.3)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Incorrect value of ITPROG     = ',itprog
         write(io6,*) 'Expected ITPROG=0 with IPROG  = ',iprog
         lerrcf=.TRUE.
      endif
c 
      if (irhprog.ge.1 .and. iprog.lt.3)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Incorrect value of IRHPROG     = ',irhprog
         write(io6,*) 'Expected IRHPROG=0 with IPROG  = ',iprog
         lerrcf=.TRUE.
      endif
c
      if (itprog.eq.0  .and. noobs.ge.1)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Incorrect value of ITPROG     = ',itprog
         write(io6,*) 'Expected ITPROG>0 with NOOBS  = ',noobs
         write(io6,*)'3D Temperature must be computed from',
     1       ' prognostic data if no observation '
         lerrcf=.TRUE.
      endif

      if (itprog.ne.2  .and. noobs.eq.2)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Incorrect value of ITPROG     = ',itprog
         write(io6,*) 'Expected ITPROG=2 with NOOBS  = ',noobs
         write(io6,*)'3D Temperature must be computed from',
     1       ' prognostic data in no-observation mode '
         lerrcf=.TRUE.
      endif

c --- Automatically reset irhprog=1 if noobs=2 (for compatibility with older versions)
      if (irhprog.ne.1 .and. noobs.eq.2)then
         irhprog=1
         write(io6,*)
         write(io6,*) 'READCF:  Warning in Input Group 6'
         write(io6,*) 'Value of IRHPROG  reset to 1 '
         write(io6,*) 'Because Surface RH must be computed from',
     1       ' prognostic data in no-observation mode (NOOBS=2)'
      endif

c --- IG #5
c ---------
c
c --- TEst IGFMET value and compatibility with other options
      if (igfmet.eq.1) then
         if(iprog.eq.1 .or. iprog.eq.3  .or. iprog.eq.13) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Coarse CALMET used as IGF - IGFMET=',igfmet
         write(io6,*) 'Incompatible with IPROG=',iprog
         lerrcf=.TRUE.
         endif
      else if (igfmet.ne.0) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'IGFMET must be 0 or 1 -IGFMET=',igfmet
         lerrcf=.TRUE.
      endif

c --- Test Prognostic model timestep
c frr (02/10/22) allow maximum MM5 timestep of 12 hours only
c      if (isteppg.gt.12) then
      if (isteppgs.gt.43200) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Prognostic model timestep     = ',isteppg
         write(io6,*) 'Maximum timestep allowed is 12 hours'
         lerrcf=.TRUE.
      endif
c frr 030119: Non hourly prognostic data only possible for MM5
      if (isteppgs.ne.3600 .and. iprog.lt.13 ) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Prognostic timestep (seconds) = ',isteppgs
         write(io6,*) 'Only timestep allowed for MM4 is 1 hour'
         lerrcf=.TRUE.
      endif

c --- Prognostic timestep must be a multiple of CALMET timestep
      if (mod(isteppgs,nsecdt).ne.0) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Prognostic timestep must be a multiple of', 
     :                ' CALMET timestep'
         write(io6,*) 'Prognostic timestep in seconds (ISTEPPGS) = ',
     :                 isteppgs
         write(io6,*) 'CALMET     timestep in seconds   (NSECDT) = ',
     :                 nsecdt
         lerrcf=.TRUE.
      endif

c --- Enforce compatibility between iextrp and bias options:
c --- ONLY when surface obs are used (check NOOBS) (051109)
c   - if iextrp<0: first guess sfc winds only depend on obs. at sfc
c                  stations
c --- QA test incomplete:  add test for bias(1) also
c     if (iextrp.lt.0)then
      if (iextrp.lt.0 .AND. bias(1).NE.-1. .AND. NOOBS.NE.2)then
         write(io6,*)
         write(io6,*) 'READCF:  Warning in Input Group 5'
         write(io6,*) 'BIAS(1) reset to -1. to be consistent with'
         write(io6,*) 'IEXTRP'
         write(io6,*) '(i.e., upper air data not used in Layer 1)'
         bias(1)=-1.
         LWARNCF=.TRUE.
      endif
c   - if no vertical extrapolation of sfc obs. no influence aloft 
c --- QA test incomplete:  check for biases not=1 before warning (051109)
      if (iabs(iextrp).eq.1 .AND. NOOBS.NE.2) then
         kreset=0
         do k=2,nz
            if(bias(k).NE.1.) then
               bias(k)=1.
               kreset=kreset+1
            endif
         end do
         if(kreset.GT.0) then
c ---      Report bias not equal to 1
           write(io6,*)
           write(io6,*) 'READCF:  Warning in Input Group 5'
           write(io6,*) 'BIAS(2)...(NZ) reset to +1. to be consistent',
     1     ' with IEXTRP'
           write(io6,*) '(i.e., sfc data not extrapolated vertically)'
           LWARNCF=.TRUE.
         endif
      endif
c
c
c --- Test number of barriers
      if(nbar.gt.mxbar)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Number of barriers exceeds parameter limit'
         write(io6,*) 'NBAR, MXBAR                   = ',nbar,mxbar
         lerrcf=.TRUE.
      endif
c
c --- Check number of lake breeze boxes
      if (nbox.gt.mxbox) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Number of lake breeze boxes exceeds limit'
         write(io6,*) 'NBOX, MXBOX                   = ',nbox,mxbox
         lerrcf=.TRUE.
      endif

c --- Check prognostic wind field options
c frr (09/01)
      if( (iprog.eq.1 .or. iprog.eq.3 .or. iprog.eq.13 )
     &     .AND. rprog.eq.0. ) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'IPROG=',IPROG,' RPROG=',rprog
         write(io6,*) 'RPROG must be non-zero if IPROG=1,3 or 13'
         lerrcf=.TRUE.
      endif
      if(iprog.eq.1 .and. iwfcod.eq.1) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'IPROG=',IPROG,' IWFCOD=',iwfcod
         write(io6,*) 'The Objective Analysis option must be selected'
         write(io6,*) 'if CSUMM model results are used as the'
         write(io6,*) 'Step 1 Field'
         lerrcf=.TRUE.
      else if(iprog.eq.2 .and. iwfcod.eq.0) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'IPROG=',IPROG,' IWFCOD=',iwfcod
         write(io6,*) 'The Diagnostic Wind module must be selected if '
         write(io6,*) 'CSUMM model results are used as the Initial ',
     1                'Guess Field'
         lerrcf=.TRUE.
      else if(iprog.eq.3 .and. iwfcod.eq.1) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'IPROG=',IPROG,' IWFCOD=',iwfcod
         write(io6,*) 'The Objective Analysis option must be selected'
         write(io6,*) 'if MM4 model results are used as the'
         write(io6,*) 'Step 1 Field'
         lerrcf=.TRUE.
      else if(iprog.eq.4 .and. iwfcod.eq.0) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'IPROG=',IPROG,' IWFCOD=',iwfcod
         write(io6,*) 'The Diagnostic Wind module must be selected if '
         write(io6,*) 'MM4 model results are used as the Initial ',
     1                'Guess Field'
         lerrcf=.TRUE.
      else if(iprog.eq.13 .and. iwfcod.eq.1) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'IPROG=',IPROG,' IWFCOD=',iwfcod
         write(io6,*) 'The Objective Analysis option must be selected'
         write(io6,*) 'if MM5 model results are used as the'
         write(io6,*) 'Step 1 Field'
         lerrcf=.TRUE.
      else if(iprog.eq.14 .and. iwfcod.eq.0) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'IPROG=',IPROG,' IWFCOD=',iwfcod
         write(io6,*) 'The Diagnostic Wind module must be selected if '
         write(io6,*) 'MM5 model results are used as the Initial ',
     1                'Guess Field'
         lerrcf=.TRUE.
      endif
c
c frr (09/01)
      if(noobs.ne.2 .AND. idiopt(1).eq.0 .AND.
     &  (isurft.eq.0.or.isurft.gt.nssta.or.isurft.lt.-2)) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Invalid sfc station    ISURFT =',isurft
         write(io6,*) 'Number must be -1 or 1 to ',nssta
         lerrcf=.TRUE.
      endif

      if(idiopt(1).ne.0 .AND. isurft.eq.-1) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'ISURFT=-1 not compatible with IDIOPT1=1'
         lerrcf=.TRUE.
      endif

      if(ITPROG.EQ.2 .AND. isurft.ne.-1 .and. isurft.ne.-2) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Invalid ISURFT =',isurft
         write(io6,*) 'ISURFT must be -1 or -2 with ITPROG=2'
         lerrcf=.TRUE.
      endif
c

c ---   New IUPT options in NOOBS mode
        if (itprog.gt.0 .and. iupt.ne.-2.and.iupt.ne.-1) then
          write(io6,*)
          write(io6,*) 'READCF:  Error in Input Group 5'
          write(io6,*) 'Invalid IUPT =',iupt
          write(io6,*) 'IUPT must be -2 or -1 with ITPROG>0'
          lerrcf=.TRUE.
        else if ( idiopt(2).eq.0 .AND. itprog.eq.0 .and.
     :    (iupt.lt.-1.or.iupt.eq.0 .or. iupt.gt.nusta) )then
          write(io6,*)
          write(io6,*) 'READCF:  Error in Input Group 5'
          write(io6,*) 'Invalid upper station  IUPT =',iupt
          write(io6,*) 'IUPT must be 1 to ',nusta
          write(io6,*) 'or IUPT=-1 for 2-D spatial interpolation'
          lerrcf=.TRUE.
        endif

 
c frr (09/01) perform QA checks only if matters (i.e. not in noobs mode)
      if(noobs .eq. 0) then

        if(iextrp .eq. 0 .or. iextrp .gt. 4 .or. iextrp .lt. -4) then
          write(io6,*)
          write(io6,*) 'READCF:  Error in Input Group 5'
          write(io6,*) 'Invalid extrapolation  IEXTRP =',iextrp
          write(io6,*) 'Expected |IEXTRP| = 1,2,3,4'
          lerrcf=.TRUE.
         endif
c
c ***   JC modifications of 8/23/93 for non-uniform first-guess field. ***
        if(idiopt(3).eq.0 .AND. iupwnd.ne.-1 .AND.
     &    (iupwnd.lt.1.or.iupwnd.gt.nusta) ) then
          write(io6,*)
          write(io6,*) 'READCF:  Error in Input Group 5'
          write(io6,*) 'Invalid upper station  IUPWND =',iupwnd
          write(io6,*) 'Number must be -1 or 1 to ',nusta
          lerrcf=.TRUE.
        endif

      endif
c
      if(idiopt(4).eq.1.and.irtype.ne.0)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Invalid wind option   IDIOPT4 =',idiopt(4)
         write(io6,*) 'Preprocessed wind input option is not allowed'
         write(io6,*) 'when computing full meteorological fields '
         write(io6,*) '(i.e., IRTYPE = 1)'
         lerrcf=.TRUE.
      endif
c
      if(idiopt(5).eq.1.and.irtype.ne.0)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Invalid wind option   IDIOPT5 =',idiopt(5)
         write(io6,*) 'Preprocessed wind input option is not allowed'
         write(io6,*) 'when computing full meteorological fields '
         write(io6,*) '(i.e., IRTYPE = 1)'
         lerrcf=.TRUE.
      endif
c
c --- Check compatibility between iextrp and noobs
c frr (021105: ok to extrapolate if noobs=1)
      if(noobs.gt.1 .and. abs(iextrp).ne.1) then
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Incorrect value of IEXTRP     = ',iextrp
         write(io6,*) 'Expected |IEXTRP|=1 with NOOBS= ',noobs
         write(io6,*) 'Full Noobs mode (no surface observations)'
         write(io6,*) 'Surface observations cannot be extrapolated'
         lerrcf=.TRUE.
      endif


c --- IG #6
c ---------
c
c --- Implement regulatory checks on Group 6 if requested
      if(mreg.EQ.1) then
c ---    ICOARE must be 0
         if(icoare.NE.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 6'
            write(io6,*) 'Incorrect value of ICOARE   = ',icoare
            write(io6,*) 'FAILS Regulatory Check'
            write(io6,*) 'ICOARE must be 0 when MREG = ',mreg
            lerrcf=.TRUE.
         endif
c ---    THRESHL must be 0.0
         if(threshl.NE.0.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 6'
            write(io6,*) 'Incorrect value of THRESHL  = ',threshl
            write(io6,*) 'FAILS Regulatory Check'
            write(io6,*) 'THRESHL must be 0.0 when MREG = ',mreg
            lerrcf=.TRUE.
         endif
c ---    IMIXH must be -1
         if(imixh.NE.-1) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 6'
            write(io6,*) 'Incorrect value of IMIXH    = ',imixh
            write(io6,*) 'FAILS Regulatory Check'
            write(io6,*) 'IMIXH must be -1 when MREG = ',mreg
            lerrcf=.TRUE.
         endif
c ---    ISURFT must be -2 in NOOBS mode
         if(itprog.eq.2 .and. isurft.NE.-2) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 5'
            write(io6,*) 'Incorrect value of ISURFT    = ',isurft
            write(io6,*) 'FAILS Regulatory Check'
            write(io6,*) 'ISURFT must be -2 if ITPROG = 2 when ',
     :                   'MREG = ',mreg
            lerrcf=.TRUE.
         endif
c ---    IUPT must be -2 in NOOBS mode
         if(itprog.gt.0 .and. iupt.NE.-2) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 5'
            write(io6,*) 'Incorrect value of IUPT    = ',iupt
            write(io6,*) 'FAILS Regulatory Check'
            write(io6,*) 'IUPT must be -2 if ITPROG>0 when ',
     :                   'MREG = ',mreg
            lerrcf=.TRUE.
         endif
c ---    IZICRLX must be 0
         if(izicrlx.NE.0) then
            write(io6,*)
            write(io6,*) 'READCF:  Error in Input Group 6'
            write(io6,*) 'Incorrect value of IZICRLX  = ',izicrlx
            write(io6,*) 'FAILS Regulatory Check'
            write(io6,*) 'IZICRLX must be 0 when MREG = ',mreg
            lerrcf=.TRUE.
         endif
      endif


c --- New mixing height parameters (frr 050328)
c --- Mixing Height parameterization
      if (abs(imixh).ne.1 .and. abs(imixh).ne.2 )then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Incorrect value of IMXIH    = ',imixh
         write(io6,*) 'IMIXH must be 1,-1,2 or -2'
         lerrcf=.TRUE.
      endif

c --- Overwater lapse rates (050328)
      if (itwprog.ne.0 .and. itwprog.ne.1 .and. itwprog.ne.2 ) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Incorrect value of ITWPROG     = ',itwprog
         write(io6,*) 'ITWPROG must be 0, 1 or 2'
         lerrcf=.TRUE.
      else if (itwprog.eq.1 .and. iprog.lt.3)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Expected ITWPROG=0 with IPROG  = ',iprog
         lerrcf=.TRUE.
      else if (itwprog.eq.2 .and. iprog.lt.13)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'ITWPROG=2 not possible with IPROG = ',iprog
        lerrcf=.TRUE.
      endif

c --- Buoyancy energy flux thresholds 
      if (threshw.lt.0.) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'THRESHW must be >= 0 '
         lerrcf=.TRUE.
      endif
      if (threshl.lt.0.) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'THRESHL must be >= 0 '
         lerrcf=.TRUE.
      endif

c --- Check convective mixing height relaxation flag and time (110212)
       if ((izicrlx.ne.1).and.(izicrlx.ne.0)) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'IZICRLX flag must be 1 (on) or 0 (off) '
         lerrcf=.TRUE.
      endif
       if (tzicrlx.lt.1.) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'TZICRLX must be greater than 1 second '
         write(io6,*) 'Default value is 800 seconds '
         lerrcf=.TRUE.
      endif


c --- Check overwater boundary layer method
      if ((icoare.ne.0).and.(icoare.ne.10).and. (abs(icoare).ne.11).and.
     :    (abs(icoare).ne.12)) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Unacceptable Overwater boundary layer option'
         write(io6,*)'ICOARE must be 0,10,11,-11,12 or-12 but ICOARE=',
     :    icoare
         lerrcf=.TRUE.
      else
c ---    set COARE wave method
         jwave=max(0,abs(icoare)-10)
      endif

c --- Check coastal/shallow water length scale
      if (dshelf.lt.0.) then                                         
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'dshelf must be > 0 '
         lerrcf=.TRUE.
      endif

c --- Check warm layer/cool skin (050419)
      if (iwarm.ne.1 .and. iwarm.ne.0) then                                         
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'IWARM must be =0 or 1 '
         lerrcf=.TRUE.
      endif
      if (icool.ne.1 .and. icool.ne.0) then                                         
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'ICOOL must be =0 or 1 '
         lerrcf=.TRUE.
      endif


c --- Precipitation Option
      if (nflagp .lt. 1 .or. nflagp .gt. 3) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Invalid precip option, NFLAGP = ',nflagp
         write(io6,*) 'NFLAGP must be  1, 2, or 3'
         lerrcf=.TRUE.
      end if
c
c --- Check MXWB from PARAMETER file
      if(mxwb .ne. 1)then
         write(io6,*)
         write(io6,*) 'READCF:  Error in PARAMETER file'
         write(io6,*) 'MXWB must be 1;   found MXWB = ',mxwb
         lerrcf=.TRUE.
      endif
c
c --- Check temperature interpolation
      if(irad .ne. 1 .and. irad .ne. 2) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 6'
         write(io6,*) 'Invalid temp interp      IRAD = ',irad
         write(io6,*) 'IRAD must be  1 or 2'
         lerrcf=.TRUE.
      endif
c
c --- Check level for upwind averaging
      if(iavezi.eq.1)then
        if(ilevzi.le.0.or.ilevzi.gt.nz)then
          write(io6,*)
          write(io6,*) 'READCF:  Error in Input Group 6'
          write(io6,*) 'Invalid level          ILEVZI =',ilevzi
          write(io6,*) 'Number must be 1 to ',nz
          lerrcf=.TRUE.
        endif
      endif

c --- Write warning message to screen
c -----------------------------------
      if(LWARNCF) then
         write(*,*)'WARNINGS are found in the CONTROL file'
         write(*,*)'Review messages written to the LIST file'
      endif

c --- STOP now if error exists in the control file
c ------------------------------------------------
      if(LERRCF) then
         write(*,*)'ERRORS are found in the CONTROL file'
         write(*,*)'Review messages written to the LIST file'
         stop
      endif

c -----------------------------------------
c --- Coordinate Conversions & Translations
c -----------------------------------------
c --- Get NIMA date for the transformation parameters
      call NIMADATE(daten)

c --- Assign lat/lon of projection origin to internal Nlat/Wlon variables
      rlat0=rnlat0
      rlon0=-relon0
c
c --- Calculate cone constant for LCC (used to adjust winds)
      conec=0.0
      if(LLCC) then
         d2r = 0.0174533
c ---    Use absolute value of latitudes, then adjust y coordinate
c ---    later if in Southern Hemisphere
         conec = log(cos(abs(xlat1) * d2r) / cos(abs(xlat2) * d2r))
         conec = conec / (log(tan(d2r * (45. - abs(xlat1) / 2.)) /
     &                     tan(d2r * (45. - abs(xlat2) / 2.))))
      endif

c --- v6.4.0, Level 121203
      if(LPS) then
c ---    Conefactor is one for the polar stereograpic projection
         conec = 1.0
      endif

c --- Set translation vectors going from projection(x,y)km
c --- to N.lat/E.lon
      iutmi=iutmzn
      if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmi=-iutmi
      cmapi=pmap
      if(cmapi.EQ.'TTM     ') cmapi='TM      '
      cmapo='LL      '
      idum=0
      rdum=0.0
      call GLOBE1(cmapi,iutmi,tmsone,xlat1,xlat2,rnlat0,relon0,
     &            feast,fnorth,
     &            cmapo,idum,rdum,rdum,rdum,rdum,rdum,
     &            rdum,rdum,
     &            caction,vecti,vecto)

c --- Compute the N.lat/W.lon of the SW corner of the grid 
      call GLOBE(io6,caction,datum,vecti,datum,vecto,
     &           xorigkm,yorigkm,xelon0,xnlat0,izone,c4hem)
      xlat0=xnlat0
      xlon0=-xelon0

c --- Compute N.latitude/W.longitude of each surface station
      if(LCFSFC) then
        do i=1,nssta
          call GLOBE(io6,caction,datum,vecti,datum,vecto,
     &                xssta(i),yssta(i),xelon,xnlat,izone,c4hem)
          xslat(i)=xnlat
          xslon(i)=-xelon
        enddo
      endif

c --- Compute N.latitude/W.longitude of each upper air station
      if(LCFUPR) then
        do i=1,nusta
           call GLOBE(io6,caction,datum,vecti,datum,vecto,
     &                xusta(i),yusta(i),xelon,xnlat,izone,c4hem)
           xulat(i)=xnlat
           xulon(i)=-xelon
        enddo
      endif

c --- Convert horizontal grid definition from km to m
      dgrid  = 1000. * dgridkm
      xorigr = 1000. * xorigkm
      yorigr = 1000. * yorigkm

c --- Assign grid reference corner to 'MAP0' variables (km)
      xmap0 = xorigkm
      ymap0 = yorigkm

c --- Assign overwater reference corner (km)
      xor2 = xorigkm
      yor2 = yorigkm

c --- Convert Barriers to relative coordinates in km
c --- 050101: barxy loaded in common block D3.MET in km 
c --- (no longer in wparm.met and no longer in meters)
      do ibar = 1, nbar
         barxy(1,ibar) = xbbar(ibar) - xorigkm
         barxy(2,ibar) = ybbar(ibar) - yorigkm
         barxy(3,ibar) = xebar(ibar) - xorigkm
         barxy(4,ibar) = yebar(ibar) - yorigkm
      enddo

c --- Write grid origin latitude/longitude and cartesian coordinates
      write(io6,*)
      write(io6,*)
      write(io6,*)
      write(io6,*)'Grid origin coordinates: (SW corner of cell 1,1)'
      write(io6,*)'  XMAP0 = ',xmap0,' (km)'
      write(io6,*)'  YMAP0 = ',ymap0,' (km)'
      write(io6,*)' N.Lat0 = ',xlat0,' (deg)'
      write(io6,*)' E.Lon0 = ',xelon0,' (deg)'
      write(io6,*)' W.Lon0 = ',xlon0,' (deg)'

c --- Convert and Write SURFACE station parameters
c
      if(nssta .eq. 0) then
         write(io6,*)
         write(io6,*)'   NO SURFACE STATIONS - noobs MUST BE = 2 '
      elseif(.not.LCFSFC) then
         write(io6,*)
         write(io6,*)'   NO SURFACE STATION DATA in control file '
         write(io6,*)'   These data must be provided in SURF.DAT '
      else
         write(io6,1485)
      endif
1485  format(//30x,'SURFACE STATIONS'/69x,'Time',3x,'Anemometer',5x,
     1 'Grid Coordinates'/1x,'Name',5x,'ID',8x,'  X  ',8x,'  Y  ',6x,
     2 'NLatitude',4x,'WLongitude',2x,'Zone',4x,'Height',11x,'X',9x,'Y'/
     3 20x,'(km)',9x,'(km)',9x,'(Deg)',8x,'(Deg)',14x,'(m)',10x,
     4 '(Origin = (0,0))'/)

      if(LCFSFC) then
        do 1500 i=1,nssta

c ---   Convert from km to m, and into relative coordinates
        xkm=xssta(i)
        ykm=yssta(i)

        xssta(i)=1000.*xkm-xorigr
        yssta(i)=1000.*ykm-yorigr

c ---   Compute grid coordinates for printing
        xgrdc=xssta(i)/dgrid
        ygrdc=yssta(i)/dgrid

        write(io6,1490)csnam(i),idssta(i),xkm,ykm,xslat(i),xslon(i),
     1  xstz(i),zanem(i),xgrdc,ygrdc
1490    format(1x,a4,1x,i8,3x,f10.1,3x,f10.1,3x,f10.3,3x,f10.3,2x,
     1  f5.1,3x,f5.1,7x,f10.3,f10.3)
1500    continue

c ---   compute delta longitudes
c ---   (assumes Western Hemisphere longitudes are input
c ---    as positive values) - EMI 07/28/92

c --- v6.4.0, Level 121203
        if(LLCC .OR. LPS) then

          do 1501 i=1,nssta
            dlongs(i) = rlon0 - xslon(i)
c ---       Code to handle 180 degree longitude straddle
            if (dlongs(i) .gt. 180.) dlongs(i) = dlongs(i) - 360.
            if (dlongs(i) .lt. -180.) dlongs(i) = dlongs(i) + 360.
1501      continue
        endif
      endif

1502  continue

c --- Convert and Write UPPER AIR station parameters
      if(nusta .eq. 0) then
         write(io6,*)
         write(io6,*)'     NO UPPER AIR STATIONS - noobs MUST BE >= 1'
      elseif(.not.LCFUPR) then
         write(io6,*)
         write(io6,*)'   NO UPPER AIR STATION DATA in control file '
         write(io6,*)'   These data must be provided in UP.DATs '
      else
         write(io6,1505)
      endif
1505  format(//30x,'UPPER AIR STATIONS'/69x,'Time',5x,
     1 'Grid Coordinates'/1x,'Name',5x,'ID',8x,'  X  ',8x,'  Y  ',
     2 6x,'NLatitude',4x,'WLongitude',2x,'Zone',8x,'X',9x,'Y'/
     3 20x,'(km)',9x,'(km)',9x,'(Deg)',8x,'(Deg)',14x,
     4 '(Origin = (0,0))'/)

      if(LCFUPR) then
        do 1510 i=1,nusta

c ---   convert from km to m, and into relative coordinates
        xkm=xusta(i)
        ykm=yusta(i)

        xusta(i)=1000.*xkm-xorigr
        yusta(i)=1000.*ykm-yorigr

c ---   compute grid coordinates for printing
        xgrdc=xusta(i)/dgrid
        ygrdc=yusta(i)/dgrid

        write(io6,1492)cunam(i),idusta(i),xkm,ykm,xulat(i),xulon(i),
     1   xutz(i),xgrdc,ygrdc
1492    format(1x,a4,3x,i5,4x,f10.1,3x,f10.1,3x,f10.3,3x,f10.3,2x,
     1   f5.1,2x,f10.3,f10.3)

1510    continue

c ---   compute delta longitudes (assume Western Hemisphere is
c ---   positive   - EMI 07/28/92

c --- v6.4.0, Level 121203
        if(LLCC .OR. LPS) then

          do 1511 i=1,nusta
c ---       Corrected for west longitudes which are defined as positive
            dlongu(i) =  rlon0 - xulon(i)
c ---       Code to handle 180 degree longitude straddle
            if (dlongu(i) .gt. 180.) dlongu(i) = dlongu(i) - 360.
            if (dlongu(i) .lt. -180.) dlongu(i) = dlongu(i) + 360.
1511      continue
        endif
      endif
1512  continue

c --- Write PRECIPITATION station data
      if(npsta.le.0)then
         write(io6,*)
         write(io6,*)'     NO PRECIPITATION STATIONS'
      elseif(.not.LCFPRC) then
         write(io6,*)
         write(io6,*)'   NO PRECIPITATION STATION DATA in control file '
         write(io6,*)'   These data must be provided in PRECIP.DAT '
      else
         write(io6,1605)
      endif
1605  format(//30x,'PRECIPITATION STATIONS'//
     1 1x,'Name',5x,'ID',8x,'  X  ',8x,'  Y  ',7x,'Grid Coordinates'/
     2 20x,'(km)',9x,'(km)',11x,'X',9x,'Y'/45x,'(Origin = (0,0))')
c
c --- MCB-E (071207) - Check should be on precipitation not upper air stations
c     if(LCFUPR) then
      if(LCFPRC) then
        do 1610 i=1,npsta
c
c ---   convert from km to m, and into relative coordinates
        xkm=xpsta(i)
        ykm=ypsta(i)
c
        xpsta(i)=1000.*xkm-xorigr
        ypsta(i)=1000.*ykm-yorigr
c
c ---   compute grid coordinates for printing
        xgrdc=xpsta(i)/dgrid
        ygrdc=ypsta(i)/dgrid
c
        write(io6,1609)cpnam(i),idpsta(i),xkm,ykm,xgrdc,ygrdc
1609    format(1x,a4,3x,i6,3x,f10.3,3x,f10.3,2x,f10.3,f10.3)
1610    continue
      endif

1611  continue

c --- duplicate iprog variable for passing back to calling subr.
      iprog2 = iprog
c --- duplicate option array for passing back to calling subr.
      do 1573 i=1,5
      idiop2(i)=idiopt(i)
1573  continue
c
      isl = 1
      istl = 0
c  convert to meters
      do 5045 kl=1,nbox
         xbcst(kl)=xbcst(kl)*1000.-xorigr
         ybcst(kl)=ybcst(kl)*1000.-yorigr
         xecst(kl)=xecst(kl)*1000.-xorigr
         yecst(kl)=yecst(kl)*1000.-yorigr
         istl=istl+nlb(kl)
         do 5043 jk=isl,istl
           ijk=jk-isl+1
           iboxid(kl,ijk)=metbxid(jk)
5043     continue
         isl=isl + nlb(kl)
5045  continue



c ------------------------------------------------
c --- Print out Plot files with Met grid boundary
c --- [BNA format] (090511)
c ------------------------------------------------
      open(io4,file='QAMETG.bna',status='REPLACE')

c --- Set Upper Right met grid corner (km)
c --- (Lower Left is xmap0,ymap0)
      xUR=xmap0+FLOAT(nx)*dgridkm
      yUR=ymap0+FLOAT(ny)*dgridkm

      write(io4,'(a15)') '" Met","grid",5'
      write(io4,'(f12.4,a1,f12.4)') xmap0,',',ymap0
      write(io4,'(f12.4,a1,f12.4)') xmap0,',',yUR
      write(io4,'(f12.4,a1,f12.4)') xUR, ',',yUR
      write(io4,'(f12.4,a1,f12.4)') xUR, ',',ymap0
      write(io4,'(f12.4,a1,f12.4)') xmap0,',',ymap0
      close(io4)



c -----------------------------------------------------------
c ----------------- Print input parameters ------------------
c -----------------------------------------------------------

      write(io6,1420)ibyrn,ibmon,ibdyn,ibjuln,ibhrn,ibsecn,
     :              ieyrn,iemon,iedyn,iejuln,iehrn,iesecn,axtz,
     :              irlg,irtype,lcalgrd,itest,mreg

1420  format(//2x,'Input group no. 1 -- General run parameters'/
     1 5x,'   Run starting date -- year: ',i4/
     2 5x,'                       month: ',i4/
     3 5x,'                         day: ',i4/
     4 5x,'                  Julian day: ',i4/
     5 5x,'                        hour: ',i4/
     6 5x,'                      second: ',i4/
     1 5x,'    Run  ending date -- year: ',i4/
     2 5x,'                       month: ',i4/
     3 5x,'                         day: ',i4/
     4 5x,'                  Julian day: ',i4/
     5 5x,'                        hour: ',i4/
     6 5x,'                      second: ',i4/
     6 5x,'               UTC time zone: ',a8//
     7 5x,'          Run length (hours): ',i4//
     8 5x,'                    Run type: ',i4,' (0=winds only, ',
     8                     '1=winds + other met. variables)'/
     9 5x,'Complete met fields computed: ',3x,l1//
     a 5x,'               TEST mode run: ',i4,' (1=yes, 2=no)'/
     1 5x,'            Regulatory check: ',i4,' (0=none, 1=USEPA)')
c
      write(io6,1430)nx,ny,dgrid,xorigr,yorigr,xlat0,xlon0,
     &               pmap,datum,daten
1430  format(//2x,'Input group no. 2 -- Grid parameters'/
     1 5x,'      No. horizontal grid cells: ',4x,i4,' x ',i4/
     2 5x,'       Horizontal grid size (m): ',f9.0/
     3 5x,'       Reference coordinates of  '/
     4 5x,'   SW corner of grid cell (1,1): (',f8.0,',',f8.0,')'/
     5 5x,'  N.Latitude SW corner of (1,1): ',f7.2/
     6 5x,' W.Longitude SW corner of (1,1): ',f7.2/
     7 5x,'                 Map Projection: ',a8/
     8 5x,'                  NIMA Datum ID: ',a8/
     9 5x,'                      NIMA Date: ',a12)

      if(LLCC.or.LLAZA.or.LTTM) then
         write(io6,1431) feast,fnorth
      endif
      if(LUTM) then
         write(io6,1432) utmhem,iutmzn
      endif
      if(LLCC.or.LPS.or.LEM.or.LLAZA.or.LTTM) then
         write(io6,1433) rlat0,rlon0
         if(LLCC.or.LPS) write(io6,1434) xlat1
         if(LLCC) write(io6,1435) xlat2
      endif

1431  format(5x,'  False Easting at proj. origin: ',f12.3/
     & 5x,' False Northing at proj. origin: ',f12.3)
1432  format(5x,'                 UTM Hemisphere: ',a4/
     & 5x,'                       UTM Zone: ',i4)
1433  format(5x,'     N.Latitude at proj. origin: ',f7.2/
     & 5x,'    W.Longitude at proj. origin: ',f7.2)
1434  format(5x,'         Standard N.Latitude #1: ',f7.2)
1435  format(5x,'         Standard N.Latitude #2: ',f7.2)

      nzp1=nz+1
      write(io6,1436)nz,(zface(n),n=1,nzp1)
1436  format(/5x,'       No. vertical grid cells: ',i8/
     1 5x,'Vertical cell face heights (m): ',12f8.1/
     2 (37x,12f8.1))

c --- Compute cell center heights for printing
      do i=1,nz
         zbuf(i)=0.5*(zface(i)+zface(i+1))
      enddo
      write(io6,1437)(zbuf(n),n=1,nz)
1437  format(5x,'       Cell center heights (m): ',12f8.1/
     2 (37x,12f8.1))

      write(io6,1445)lsave,iformo,lprint,iprinf,ldb,nn1,nn2,ldbcst
1445  format(//2x,'Input group no. 3 -- Output options'/
     1 11x,'Meteorological fields save in disk file ? (LSAVE) = ',l5/
     2 11x,'                   Format of output file (IFORMO) = ',i5,
     2 3x,'(1=CALMET, 2=MESOPAC II)'/
     3 11x,'         Meteorological fields printed ? (LPRINT) = ',l5/
     4 11x,'                          Print interval (IPRINF) = ',i5/
     5 5x,'Input met. data and internal parameters printed ? (LDB) = ',
     5 l5/
     6 5x,' Time steps for which LDB parameters printed (NN1, NN2) = ',
     6 i5,' to ',i5,/
     7 5x,'Distance to the coast printed in grd file? (LDBCST) = ',
     7 l5/)
c
      write(io6,1446)
1446  format(/11x,'Control variables for printing of 3-D fields'/
     1 20x,'(used only if LPRINT = .TRUE.)'/
     2 25x,'(0=not printed, 1=printed)'/
     3 21x,'LEVEL',3x,'U,V',4x,'W',4x,'TEMP'/)
      do 3446 i=1,nz
      write(io6,2446)i,iuvout(i),iwout(i),itout(i)
2446  format(21x,i3,6x,i1,5x,i1,5x,i1)
3446  continue
c
      write(io6,1447)imtout
1447  format(/11x,'Control variables for printing of other met. fields'
     1 /20x,'(used only if LPRINT = .TRUE.)'/23x,'VARIABLE',21x,
     2 'PRINTED (0=no, 1=yes)'/
     3 23x,'PGT stability class             ',i1/
     4 23x,'Friction velocity (u*)          ',i1/
     5 23x,'Monin-Obukhov length (L)        ',i1/
     6 23x,'Mixing height (zi)              ',i1/
     7 23x,'Convective velocity scale (w*)  ',i1/
     8 23x,'Precipitation rate              ',i1//
     9 23x,'Sensible heat flux (Qh)         ',i1/
     a 23x,'Convective mixing ht            ',i1)
c
      if(inputver.eq.'2.2') then
      write(io6,1450)noobs,nssta,iforms,nusta,npsta,iformp,nowsta,
     1 icldout,mcloud
1451  format(//2x,'Input group no. 4 -- Meteorological data options'/
     1 5x,'   MM4/5 only flag (NOOBS): ',i4/
     2 5x,'      No. surface stations: ',i4,5x,'Format type: ',i4/
     3 5x,'   No. rawinsonde stations: ',i4/
     4 5x,'No. precipitation stations: ',i4,5x,'Format type: ',i4/
     5 5x,'(if NPSTA = -1: precipitation read from MM5)',/
     6 5x,'    No. overwater stations: ',i4/
     7 5x,37x,'(Format type 1=unformatted, 2=formatted)'//
     8 5x,' Output of clouds data in a CLOUD.DAT file: ',i4/
     9 5x,' (ICLDOUT=0, no output; ICLDOUT=1, output created) '/
     1 5x,' Gridded cloud data option: ',i4/
     2 5x,38x,'1=CLOUD from Observations in SURF.DAT,'/
     3 5x,38x,'2=CLOUD.DAT read as INPUT and used,'/
     4 5x,38x,'3=CLOUD computed from progn. RH at 850mb (Teixera),'/
     5 5x,38x,'4=CLOUD computed from progn. RH at all levels',
     6      '(MM5toGrads)')
      else
      write(io6,1450)noobs,nssta,iforms,nusta,npsta,iformp,nowsta,
     1 icloud
1450  format(//2x,'Input group no. 4 -- Meteorological data options'/
     1 5x,'   MM4/5 only flag (NOOBS): ',i4/
     2 5x,'      No. surface stations: ',i4,5x,'Format type: ',i4/
     3 5x,'   No. rawinsonde stations: ',i4/
     4 5x,'No. precipitation stations: ',i4,5x,'Format type: ',i4/
     5 5x,'(if NPSTA = -1: precipitation read from MM5)',/
     6 5x,'    No. overwater stations: ',i4/
     7 5x,37x,'(Format type 1=unformatted, 2=formatted)'//
     8 5x,' Gridded cloud data option: ',i4,5x,'(0=CLOUD.DAT not used,'/
     9 5x,38x,'1=CLOUD.DAT created as OUTPUT,'/
     1 5x,38x,'2=CLOUD.DAT read as INPUT,'/
     2 5x,38x,'3=CLOUD computed from progn. RH at 850mb (Teixera),'/
     3 5x,38x,'4=CLOUD computed from progn. RH at all levels',
     4      '(MM5toGrads)')
       endif
c frr 030119 (new cloud option)
c
      if(nbar.gt.0)then
         write(io6,1460)
1460     format(//1x,5('-'),' BARRIER PARAMETERS',5('-'))
         write(io6,1461)kbar
1461     format(//1x,5x,' Barriers extending to layer kbar=  ',i2)

         write(io6,1462)
1462     format(//1x,5('-'),' Beginning ',5('-'),5x,6('-'),' Ending ',
     1   7('-'),6x,'Beginning',9x,'Ending'/6x,'X',11x,'Y',13x,'X',11x,
     2   'Y',10x,'I',6x,'J',8x,'I',6x,'J'/)
c
         do 1465 j=1,nbar
c
c ---    convert back to original km (from relative coord. in m)
c ---    for printing
c ---    Use original barrier input coordinate (why recompute??) (050101)
c         x1km=0.001*xybar(1,j)+xorigkm
c         y2km=0.001*xybar(2,j)+yorigkm
c         x3km=0.001*xybar(3,j)+xorigkm
c         y4km=0.001*xybar(4,j)+yorigkm
c
         i1=barxy(1,j)/dgridkm
         j1=barxy(2,j)/dgridkm
         i2=barxy(3,j)/dgridkm
         j2=barxy(4,j)/dgridkm

c        write(io6,1463)x1km,y2km,x3km,y4km,i1,j1,i2,j2
         write(io6,1463)xbbar(j),ybbar(j),xebar(j),yebar(j),i1,j1,i2,j2
1463     format(1x,2(f9.1,3x,f9.1,5x),2(i4,3x,i4,5x))
1465     continue

      endif
c
      write(io6,1470)iwfcod,lvary,rmax1,rmax2,rmax3,rmin,terrad,r1,r2
      write(io6,1472)(nintr2(n),n=1,nz)
      write(io6,1476)iprog,rprog
1470  format(//2x,'Input group no. 5 -- Wind field parameters'/
     1 5x,'                              Wind field code = ',i8,
     1    ' (0 = objective analysis, 1 = diagnostic)'/
     1 5x,'Varying radius of influence           (LVARY) = ',9x,L1,/
     2 5x,'Radius of influence - land - surface  (rmax1) = ',f10.1,
     2 ' (km)'/
     3 5x,'Radius of influence - land - aloft    (rmax2) = ',f10.1,
     3 ' (km)'/
     4 5x,'Radius of influence - water           (rmax3) = ',f10.1,
     4 ' (km)'/
     5 5x,'Radius of influence - minimum          (rmin) = ',f10.1,
     5 ' (km)'/
     6 5x,'Radius of influence - terrain        (terrad) = ',f10.1,
     6 ' (km)'/
     7 5x,'Weighting parameter - surface            (r1) = ',f10.1/
     8 5x,'Weighting parameter - aloft              (r2) = ',f10.1)
1472  format(/5x,'Maximum no. stations used in interpolation at one ',
     1 'grid point in each level (nintr2):'/(10x,20i4/))
1476  format(/5x,'Gridded prognostic model results used as input = ',i2/
     1 7x,'0 = no',/
     2 7x,'1 = Use CSUMM model winds as Step 1 inputs'/
     3 7x,'2 = Use CSUMM model winds as initial guess field'/
     4 7x,'3 = Use MM4.DAT file winds as Step 1 inputs',/
     5 7x,'4 = Use MM4.DAT file winds as initial guess field'/
     6 7x,'5 = Use MM4.DAT file winds as "observations"'/
     7 6x,'13 = Use MM5.DAT file winds as Step 1 inputs',/
     8 6x,'14 = Use MM5.DAT file winds as initial guess field'/
     9 6x,'15 = Use MM5.DAT file winds as "observations"'/
     1 5x,'Weighting parameter for prognostic ',
     2 'data  (rprog) = ',f10.1,' (km)'/)
c
       if (iprog.gt.0) write(io6,1477)isteppgs
1477   format(/5x,'Prognostic model output timestep (seconds):',i5)

       write(io6,1478)igfmet
1478   format(/5x,'Use coarse CALMET fields as IGF:',i4,/
     1 7x,'0 = no',/
     2 7x,'1 = yes'/)


        write(io6,1497)llbreze,nbox
        do 3456 jk=1,nbox
         write (io6,1498)jk,xg1(jk),xg2(jk),yg1(jk),yg2(jk),
     1 xbcst(jk),ybcst(jk),xecst(jk),yecst(jk),nlb(jk),
     2 (iboxid(jk,kk),kk=1,nlb(jk))
3456  continue
1497  format(/2x,'LAKE BREEZE parameters'/
     2 5x,'Utilize the Lake Breeze Module of CALMET (LLBREZE) = ',L1,/
     2 5x,'Number of regions (NBOX)  = ',i10,/)
1498  format(/3x,'Inputs for BOX # ',i10,/
     2 5x,'Four grid lines will determine the region of influence',/
     3 5x,' X-GRID 1 : ',f10.1,/
     3 5x,' X-GRID 2 : ',f10.1,/
     3 5x,' Y-GRID 1 : ',f10.1,/
     3 5x,' Y-GRID 2 : ',f10.1,/
     4 5x,'Beginning of coastline = ',2f10.1,'(M)',/
     5 5x,'End of coastline        =',2f10.1,'(M)',/
     6 5x,'Number of Met Stations within the region = ',i10,/
     7 5x,'Met Station Id numbers :',/(10x,20i6/))
c
      write(io6,*)
      write(io6,*)'divlim,niter = ',divlim,niter
      write(io6,*)'nsmth ',(nsmth(n),n=1,nz)
      write(io6,*)'iextrp = ',iextrp,' rmin2 = ',rmin2,
     1            ' fextr2 = ',fextr2
      write(io6,*)'bias = ',(bias(n),n=1,nz)
      write(io6,*)'critfn,terrad,ifradj,ikine,alpha,iobr = ',
     1             critfn,terrad,ifradj,ikine,alpha,iobr
      write(io6,*)'islope,icalm',islope,icalm
      write(io6,*)'nzprn2,ipr0,ipr1,ipr2,ipr3,ipr4,ipr5,ipr6,ipr7,',
     1 'ipr8,ioutd = ',nzprn2,ipr0,ipr1,ipr2,ipr3,ipr4,ipr5,ipr6,ipr7,
     2 ipr8,ioutd
c
      write(io6,1575)idiopt
1575  format(/5x,'Specification for diagnostic wind module data input'
     1 //10x,'             Surface temperature: ',i1,
     1       ' (0=computed internally, 1=preprocessed values input)'
     2  /10x,'Domain-averaged temp. lapse rate: ',i1,
     2       ' (0=computed internally, 1=preprocessed values input)'
     3  /10x,' Domain-averaged wind components: ',i1,
     3       ' (0=computed internally, 1=preprocessed values input)'
     4  /10x,'         Surface wind components: ',i1,
     4       ' (0=computed internally, 1=preprocessed values input)',
     5  /10x,'       Upper air wind components: ',i1,
     5       ' (0=computed internally, 1=preprocessed values input)')
c
c --- if computing surface temp., write surface station no. to use
c FRR (noobs option)
c      if(idiopt(1).eq.0)then
      if(idiopt(1).eq.0 .and. itprog.lt.2 )then
         write(io6,*)
         write(io6,*)'     Surface station no. used for surf. temp. ',
     1   'in diagnostic wind field module (-1 is 2D array): ',isurft
      endif
c
c --- if computing domain-ave temp. lapse rate, write upper air station
c --- no. to use, and depth through which to average

      if(idiopt(2).eq.0)then
c
         write(io6,*)

         if (iupt.eq.-1) then
            write(io6,*)' 2-D varying temperature lapse rate (IUPT=-1)'
            if (noobs.eq.0) then 
               write(io6,*)'     Interpolating between all upper air',
     1                     ' stations' 
            else
               write(io6,*)'     Interpolating prognostic data'
            endif
         else
            write(io6,*)' Domain averaged lapse rate '
            if (noobs.eq.0) then
               write(io6,*)'     Upper air station no. used for ',
     1            'domain-averaged temp. lapse rate (IUPT): ',iupt
            else
               write(io6,*)'     Prognostic data used for domain-',
     1         'averaged temp. lapse rate  '
            endif
         endif
         write(io6,*)'     Depth through which temp.lapse rate ',
     1   'is computed (ZUPT): ',zupt

      endif
c
c --- if computing domain-ave wind components, read upper air station
c --- no. to use, and depth through which to average
      if(idiopt(3).eq.0.and.IUPWND.GT.0.and.NOOBS.EQ.0)then
c
         write(io6,*)
         write(io6,*)'     Upper air station no. used for domain-',
     1   'averaged wind components (IUPWND): ',iupwnd
         write(io6,*)'     (IUPWND = -1 to use all stations -- i.e., ',
     1   'spatially-variable initial '
         write(io6,*)'      guess field)'
         write(io6,*)'     Depth through which domain-averaged wind ',
     1   'components are computed: ',zupwnd(1),' TO ',zupwnd(2)
      endif
c
c --- write message if preprocessed surface and upper air components
c --- are used (allowed only if met. fields other than winds are not
c --- being computed)
      if(idiopt(4).eq.1)then
         write(io6,*)
         write(io6,*)'     Preprocessed surface winds are read ',
     1   'from an input file'
      endif
      if(idiopt(5).eq.1)then
         write(io6,*)
         write(io6,*)'     Preprocessed upper air winds are read ',
     1   'from an input file'
      endif
c
         write(io6,1578)constb,conste,constn,constw,fcoriol,dptmin,
     &                  dzzi,nflagp,sigmap,cutp
1578  format(//2x,'Input group no. 6 -- Mixing height, temperature,',
     1   ' radiation and precipitation parameters'/
     1   5x,' Neutral mechanical mix. ht. constant (constb) = ',f10.4/
     2   5x,'    Convective mixing height constant (conste) = ',f10.4/
     3   5x,'        Stable mixing height constant (constn) = ',f10.4/
     3   5x,'     Overwater mixing height constant (constw) = ',f10.4/
     4   5x,'Absolute value of Coriolis parameter (fcoriol) = ',1pe10.3,
     4   ' (1/s)'//
     5   5x,'  Minimum pot. temp. lapse rate in layer above',/
     5   5x,'                current mixing height (dptmin) = ',0pf10.4,
     5   ' (deg. K/m)'/
     6   5x,'   Depth of layer above mixing height used to '/
     6   5x,'                     compute lapse rate (dzzi) = ',f10.4,
     6   ' (m)'/
     6   5x,'     Precip interp. option: ',i4/
     7   5x,' Rad. Inf. for Precip (km): ',f10.4/
     8   5x,' Min. Prec. cutoff (mm/hr): ',f10.4)


         write(io6,1479)imixh, threshl,threshw,itwprog
1479   format(/5('-'),'Convective Mixing Height options',5('-'),/
     1 5x,' Method used to compute mixing height (imixh)',i4,/
     2 7x,' 1 = Maul-Carson for land and water cells'/
     3 7x,'-1 = Maul-Carson for land cells only; OCD overwater'/
     4 7x,' 2 = Batchvarova and Gryning for land and water cells'/
     5 7x,'-2 = Batchvarova and Gryning for land cells only;',
     5          'OCD overwater'//
     6 5x,' Threshold buoyancy fluxes required to sustain convective'/
     6 5x,' mixing height growth (in W/m3):'/
     7 7x,' Overland  (THRESHL) = ',f6.3,/
     7 7x,' Overwater (THRESHW) = ',f6.3,/
     8 5x,' Overwater lapse rates used in conv. mix.hgt growth:',i3/
     9 7x,' 0 : SEA.DAT lapse rates and deltaT (neutral if missing)'/
     9 7x,' 1 : progn. lapse rates & SEA.DAT deltaT (neutral if mis.)'/
     9 7x,' 2 : progn.lapse rates and progn. deltaT' )
 
       if (iprog.gt.2)  write(io6,1579)iluoc3d
1579  format(/5x,' LU category in progn. datasets (ILUOC3d):',i4)      
c

         write(io6,1580)icoare
1580   format(/5('-'),'Overwater surface fluxes',5('-'),/
     1 5x,' Method used to compute overwater fluxes (icoare)',i4,/
     2 7x,'  0 = original deltaT method (OCD)'/
     3 7x,' 10 = COARE with no wave parameterization'/
     4 7x,' 11 = COARE with wave option jwave=1 (Oost et al.)'/
     5 7x,'-11 = COARE with wave option jwave=1 and obs. wave prop.'/
     6 7x,' 12 = COARE with wave option jwave=2 (Taylor and Yelland)'/
     7 7x,'-11 = COARE with wave option jwave=2 and obs. wave prop.'/)

c --- Echo internal switches set by ICOARE:
      write(io6,*)'          (internal ipsifcn set to ',ipsifcn,')'
      write(io6,*)'          (internal isfcmet set to ',isfcmet,')'
 
       if(icoare.gt.0) write (io6,1581)dshelf,iwarm,icool
1581   format(/
     1 5x,'Coastal/Shallow water length scale (DSHELF in km)',f6.1,/
     2 5x,'COARE warm layer computation (IWARM)(1:on-0:off):',i3,/
     3 5x,'COARE cool skin  computation (ICOOL)(1:on-0:off):',i3,/)




c
         write(io6,1480)zimax,zimin,ziminw,zimaxw
1480     format(//,
     :   5('-'),' Other Mixing Height Parameters',5('-'),/
     1   5x,'        Maximum overland mixing height (zimax) = ',f10.4,
     1   ' (m)'/
     2   5x,'        Minimum overland mixing height (zimin) = ',f10.4,
     2   ' (m)'/
     3   5x,' Minimum computed overwater mixing ht (ziminw) = ',f10.4,
     3   ' (m)'/
     4   5x,' Maximum computed overwater mixing ht (zimaxw) = ',f10.4,
     4   ' (m)')
c
         write(io6,1482)iavezi,mnmdav,hafang,ilevzi
1482     format(/
     1   5x,'   Spatial averaging of mixing hts. ? (iavezi) = ',i10,
     1   ' (0=no, 1=yes)'/
     2   5x,' Max. search radius in mixing ht ave. (mnmdav) = ',i10,
     2   ' (grid cells)'/
     3   5x,'            Half-angle of upwind cone (hafang) = ',f10.4,
     3   ' (deg.)'/
     4   5x,'   Level of winds used in upwind ave. (ilevzi) = ',i10)
c
         write(io6,1483)irad
 1483    format(/
     &   5x,'Temperature interpolation type (1=1/R;2=1/R**2)= ',i10)
c
         write(io6,2484)tradkm
 2484    format(/5x,'Radius of influence - temperature ',
     1   'interpolation= ',f10.1,' (km)')
c
         write(io6,2483)itprog 
 2483    format(/5x,'3-D temperature option- ITPROG =',i2,/
     1   5x,'0= Temperature from surface and upper air observations'/
     2   5x,'1= Temperature from surface obs. and prognostic data '/
     3   5x,'2= Temperature from prognostic data only')

c         write(io6,2485)numts
 2485    format(/
     &   5x,'Maximum # stations, temperature interpolation  = ',i10)
c
         write(io6,1486)iavet
 1486    format(/
     &   5x,'Spatial averaging of temperature ? (iavet)     = ',i10,
     &   ' (0=no, 1=yes)')
c
         write(io6,1495)tgdefb
 1495    format(/
     &   5x,'Default T gradient below mix. ht. over water   = ',f10.4,
     &   ' (K/m)')
c
         write(io6,1496)tgdefa
 1496    format(/
     &   5x,'Default T gradient above mix. ht. over water   = ',f10.4,
     &   ' (K/m)')
c
         write(io6,1484)
1484     format(//1x,' Beginning land use ',5x,' Ending ',
     1     'land use for water interpolation '/)
         write(io6,1489) jwat1(1),jwat2(1)
1489     format(1x,8x,i5,16x,i5)
c
c ---    Heat flux parameters
         write(io6,1491)ha1,ha2,hb1,hb2,hc1,hc2,hc3
1491     format(//1x,'Radiation parameters'/
     1   5x,'Turbidity coefficient 1 (ha1)  = ',f10.2,' (W/m**2)'/
     2   5x,'Turbidity coefficient 2 (ha2)  = ',f10.2,' (W/m**2)'/
     3   5x,'Cloudiness coefficient 1 (hb1) = ',f10.4/
     4   5x,'Cloudiness coefficient 2 (hb2) = ',f10.4/
     5   5x,'Net radiation coefficient 1 (hc1) = ',1pe12.4,
     5                                           ' (W/m**2/K**6)'/
     6   5x,'Net radiation coefficient 2 (hc2) = ',0pf10.2,'(W/m**2)'/
     7   5x,'Net radiation coefficient 3 (hc3) = ',f10.4)

c



      return
      end
c----------------------------------------------------------------------
      subroutine readge(ldb)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 030515             READGE
c ---          J. Scire, Earth Tech, Inc.
c
c --- PURPOSE:  Read geophysical data from data file (GEO.DAT)
c
c               land use (ILANDU), terrain elevations (ELEV),
c               surface roughness (Z0), albedo (ALBEDO),
c               Bowen ratio (BOWEN), soil heat flux parameter (HCG),
c               anthropogenic heat flux (QF), leaf area index (XLAI)
c
c --- UPDATE
c     Ver 5.51, Level 030515 from Ver 5.5 Level 030402   D. Strimaitis          
c               - Add read for false easting/northing for LCC,LAZA,TTM
c               - Fix reference lat/lon variable names for QA tests
c     Ver 5.5, Level 030402 from Ver 5.4 Level 000602d   D. Strimaitis          
c               - New header for GEO.DAT file
c               - LLCONF replaced with LLCC
c               - /MAP/ replaces /LON/
c               - Transfer header comments to scratch file
c
c --- INPUTS:
c                LDB - logical    - Control variable determining
c                                   the printing of internal arrays
c                                   (useful for testing)
c       Common block /QA/ variables:
c         NCOMMOUT
c       Common block /GEO/ variables:
c         IOGEO
c       Common block /GRID/ variables:
c         NX, NY, DGRID, XORIGR, YORIGR 
c       Common block /MAP/ variables:
c         iutmzn,feast,fnorth,
c         rnlat0,relon0,xlat1,xlat2,
c         pmap,utmhem,datum
c       Parameters: MXNX, MXNY, MXNZ, MXNZP1, MXLU, IO6, IOX
c
c --- OUTPUT:
c       Common block /QA/ variables:
c         NCOMMOUT
c       Common block /GEO/ variables:
c         ILANDU(mxnx,mxny), ELEV(mxnx,mxny), Z0(mxnx,mxny),
c         XLAI(mxnx,mxny),
c         NLU, ILUCAT(mxlu), IWAT1, IWAT2  (if IOPT(1) = 1)
c       Common block /HFLUX/ variables:
c         ALBEDO(mxnx,mxny),BOWEN(mxnx,mxny),HCG(mxnx,mxny),
c         QF(mxnx,mxny)
c
c --- READGE called by:  SETUP
c --- READGE calls:      FILLGEO, OUT, ALLCAP, LRSAME, XTRACTLL
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'

      include 'qa.met'
      include 'geo.met'
      include 'grid.met'
      include 'hflux.met'
      include 'map.met'

      integer iopt(7)
      logical ldb,ldate
      character*70 messag
      character*80 titlege

c --- Local Variables for GEO.DAT
      character*16 dataset,dataver,blank16
      character*64 datamod
      character*4 xyunitin
      character*8 pmapin,utmhemin,datumin
      character*12 datenin
      character*16 clat0in,clon0in,clat1in,clat2in
      character*33 blank33,break33
      character*132 blank,break

      logical lutmin,llccin,lpsin,lemin,llazain,lttmin
      logical LRSAME
      logical lerror

      data ldate/.false./
      data nlim/1/
      data blank16/'                '/

      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

      lutmin =.FALSE.
      llccin =.FALSE.
      lpsin  =.FALSE.
      lemin  =.FALSE.
      llazain=.FALSE.
      lttmin =.FALSE.

      lerror=.FALSE.

      clat0in=blank16
      clon0in=blank16
      clat1in=blank16
      clat2in=blank16

      write(io6,*)
      write(io6,*)
      write(io6,*)
      write(io6,'(a30,50x)')'GEO.DAT File Header ----------'
      write(io6,*)

c --- Dataset, Version, Modifier
      read(iogeo,'(2a16,a64)') dataset,dataver,datamod
      write(io6,'(2a16,a64)') dataset,dataver,datamod
c --- Convert Dataset to upper case
      do i=1,16
         call ALLCAP(dataset(i:i),nlim)
      enddo
      if(dataset.NE.'GEO.DAT') then
c ---    FATAL ERROR
         write(io6,*)
         write(io6,*)'READGE: Invalid input file DATASET: ',dataset
         write(io6,*)'        Expected GEO.DAT'
         lerror=.TRUE.
         goto 999
      endif
c --- To scratch file
      write(iox,'(a132)') blank
      write(iox,'(a132)') break
      write(iox,'(a132)') blank
      write(iox,'(2a16,a64)') dataset,dataver,datamod
      ncommout=ncommout+4

c --- Number of comment records
      read(iogeo,'(i4)') ncomment
      write(io6,'(i4)') ncomment

c --- Comment (optional/repeatable)
      do i=1,ncomment
         read(iogeo,'(a80)') titlege
         write(io6,'(a80)') titlege
c ---    To scratch file
         write(iox,'(a80)') titlege
         ncommout=ncommout+1
      enddo

c --- Map projection
      read(iogeo,'(a8)') pmapin
      write(io6,'(a8)') pmapin
      do i=1,8
         call ALLCAP(pmapin(i:i),nlim)
      enddo

      if(pmapin.EQ.'UTM     ')  lutmin =.TRUE.
      if(pmapin.EQ.'LCC     ')  llccin =.TRUE.
      if(pmapin.EQ.'PS      ')  lpsin  =.TRUE.
      if(pmapin.EQ.'EM      ')  lemin  =.TRUE.
      if(pmapin.EQ.'LAZA    ')  llazain=.TRUE.
      if(pmapin.EQ.'TTM     ')  lttmin =.TRUE.

c --- Map projection parameters
      if(LUTMIN) then
         read(iogeo,'(i4,a4)') izonein,utmhemin
         write(io6,'(i4,a4)') izonein,utmhemin
      elseif(LLCCIN) then
         read(iogeo,'(4a16)') clat0in,clon0in,clat1in,clat2in
         write(io6,'(4a16)') clat0in,clon0in,clat1in,clat2in
      elseif(LPSIN) then
         read(iogeo,'(3a16)') clat0in,clon0in,clat1in
         write(io6,'(3a16)') clat0in,clon0in,clat1in
      elseif(LEMIN.or.LLAZAIN.or.LTTMIN) then
         read(iogeo,'(2a16)') clat0in,clon0in
         write(io6,'(2a16)') clat0in,clon0in
      endif
c --- Map false Easting/Northing
      if(LLCCIN.or.LLAZAIN.or.LTTMIN) then
         read(iogeo,*) feastin,fnorthin
         write(io6,*) feastin,fnorthin
      else
         feastin=feast
         fnorthin=fnorth
      endif
c --- Map DATUM
      read(iogeo,'(a8,a12)') datumin,datenin
      write(io6,'(a8,a12)') datumin,datenin
      do i=1,8
         call ALLCAP(datumin(i:i),nlim)
      enddo
c --- Grid
      read(iogeo,'(2i8,4f12.3)') nxin,nyin,xorin,yorin,dgridin,dgridin
      write(io6,'(2i8,4f12.3)') nxin,nyin,xorin,yorin,dgridin,dgridin
c --- XYUNIT
      read(iogeo,'(a4)') xyunitin
      write(io6,'(a4)') xyunitin
      write(io6,*)
      write(io6,*)


c --- QA header information
c -------------------------

c --- Units
      do i=1,4
         call ALLCAP(xyunitin(i:i),nlim)
      enddo
      if(xyunitin.NE.'KM  ') then
         write(io6,*)
         write(io6,*)'READGE:  Problem in input file: ',dataset
         write(io6,*)'         XY units must be KM'
         write(io6,*)'         Input file: ',xyunitin
         lerror=.TRUE.
      endif

c --- Grid information
c --- Convert from km to m
      dgridm=1000.*dgridin
      xorm=1000.*xorin
      yorm=1000.*yorin
      if(nx.NE.nxin.OR.ny.NE.nyin) then
         write(io6,*)
         write(io6,*)'READGE:  Problem in input file: ',dataset
         write(io6,*)'         Number of grid cells does not match'
         write(io6,*)'         Input file NX,NY  : ',nxin,nyin
         write(io6,*)'         Control file NX,NY: ',nx,ny
         lerror=.TRUE.
      endif
      if(.not.LRSAME(0.0001,dgridm,dgrid))then
         write(io6,*)
         write(io6,*)'READGE:  Problem in input file type: ',dataset
         write(io6,*)'         Grid cell size does not match'
         write(io6,*)'         Input file  : ',dgridm
         write(io6,*)'         Control file: ',dgrid
         lerror=.TRUE.
      endif
      if((.not.LRSAME(0.0001,xorm,xorigr)).or.
     1   (.not.LRSAME(0.0001,yorm,yorigr)))then
         write(io6,*)
         write(io6,*)'READGE:  Problem in input file: ',dataset
         write(io6,*)'         SW corner coordinates do not match'
         write(io6,*)'         Input file xm,ym  : ',xorm,yorm
         write(io6,*)'         Control file xm,ym: ',xorigr,yorigr
         lerror=.TRUE.
      endif

c --- Projection checks
      if(pmap.NE.pmapin) then
         write(io6,*)
         write(io6,*)'READGE:  Problem in input file: ',dataset
         write(io6,*)'         Map projection PMAP does not match'
         write(io6,*)'         Input file  : ',pmapin
         write(io6,*)'         Control file: ',pmap
         lerror=.TRUE.
      endif
      if(LUTMIN .AND. LUTM) then
         if(izonein.NE.iutmzn)then
            write(io6,*)
            write(io6,*)'READGE:  Problem in input file: ',dataset
            write(io6,*)'         UTM zone does not match'
            write(io6,*)'         Input file  : ',izonein
            write(io6,*)'         Control file: ',iutmzn
            lerror=.TRUE.
         endif
         if(utmhemin.NE.utmhem)then
            write(io6,*)
            write(io6,*)'READGE:  Problem in input file: ',dataset
            write(io6,*)'         UTM Hemisphere does not match'
            write(io6,*)'         Input file  : ',utmhemin
            write(io6,*)'         Control file: ',utmhem
            lerror=.TRUE.
         endif
      endif

c --- False Easting/Northing checks
      if(.not.LRSAME(0.0001,feastin,feast))then
         write(io6,*)
         write(io6,*)'RDHEAD:  Problem in input file type: ',dataset
         write(io6,*)'         False Easting does not match'
         write(io6,*)'         Input file  : ',feastin
         write(io6,*)'         Control file: ',feast
         lerror=.TRUE.
      endif
      if(.not.LRSAME(0.0001,fnorthin,fnorth))then
         write(io6,*)
         write(io6,*)'RDHEAD:  Problem in input file type: ',dataset
         write(io6,*)'         False Northing does not match'
         write(io6,*)'         Input file  : ',fnorthin
         write(io6,*)'         Control file: ',fnorth
         lerror=.TRUE.
      endif

c --- Check lat/lon variables
      if(clat0in(1:1).NE.' ') then
        call XTRACTLL(io6,'LAT ',clat0in,reflatin)
        if(.not.LRSAME(0.0001,reflatin,rnlat0))then
          write(io6,*)
          write(io6,*)'READGE:  Problem in input file: ',dataset
          write(io6,*)'         REFLAT does not match'
          write(io6,*)'         Input file  : ',reflatin
          write(io6,*)'         Control file: ',rnlat0
          lerror=.TRUE.
        endif
      endif
      if(clon0in(1:1).NE.' ') then
        call XTRACTLL(io6,'LON ',clon0in,reflonin)
        if(.not.LRSAME(0.0001,reflonin,relon0))then
          write(io6,*)
          write(io6,*)'READGE:  Problem in input file: ',dataset
          write(io6,*)'         REFLON does not match'
          write(io6,*)'         Input file  : ',reflonin
          write(io6,*)'         Control file: ',relon0
          lerror=.TRUE.
        endif
      endif
      if(clat1in(1:1).NE.' ') then
        call XTRACTLL(io6,'LAT ',clat1in,xlat1in)
        if(.not.LRSAME(0.0001,xlat1in,xlat1))then
          write(io6,*)
          write(io6,*)'READGE:  Problem in input file: ',dataset
          write(io6,*)'         XLAT1 does not match'
          write(io6,*)'         Input file  : ',xlat1in
          write(io6,*)'         Control file: ',xlat1
          lerror=.TRUE.
        endif
      endif
      if(clat2in(1:1).NE.' ') then
        call XTRACTLL(io6,'LAT ',clat2in,xlat2in)
        if(.not.LRSAME(0.0001,xlat2in,xlat2))then
          write(io6,*)
          write(io6,*)'READGE:  Problem in input file: ',dataset
          write(io6,*)'         XLAT2 does not match'
          write(io6,*)'         Input file  : ',xlat2in
          write(io6,*)'         Control file: ',xlat2
          lerror=.TRUE.
        endif
      endif

c --- DATUM
      if(datumin.NE.datum)then
         write(io6,*)
         write(io6,*)'READGE:  Problem in input file: ',dataset
         write(io6,*)'         DATUM does not match'
         write(io6,*)'         Input file  : ',datumin
         write(io6,*)'         Control file: ',datum
         lerror=.TRUE.
      endif

c --- STOP now if error exists in the header
999   if(LERROR) then
         write(*,*)'ERRORS are found in the input GEO.DAT file'
         write(*,*)'Review messages written to the LIST file'
         stop
      endif

c
c --- ********** LAND USE DATA
      read(iogeo,*)iopt(1)
      if(iopt(1).eq.0)then
         write(io6,14)
14       format(/1x,'Default land use categories used')
      else if(iopt(1).eq.1)then
c
c ---    read new land use categories
         read(iogeo,*)nlu,iwat1,iwat2
         if(nlu.le.0.or.nlu.gt.mxlu)then
            write(io6,11)nlu,mxlu
11          format(//2x,'ERROR IN SUBR. READGE -- invalid value of ',
     1      'NLU -- NLU = ',i5,2x,'MXLU = ',i5)
            stop
         endif
c
         read(iogeo,*)(ilucat(n),n=1,nlu)
         write(io6,12)nlu,iwat1,iwat2,(ilucat(n),n=1,nlu)
12       format(//1x,'New land use categories entered'
     1   /5x,'No. categories (nlu) = ',i5
     2   /5x,'Range of land use categories corresponding to WATER = ',
     3   i5,' to ',i5/5x,'New land use categories: ',20i5,
     4   (/30x,20i5))
      endif
c
c --- read and print gridded land use data
      do 20 j=ny,1,-1
      read(iogeo,*)(ilandu(n,j),n=1,nx)
20    continue
      messag='Land use categories'
      call out(xdum,ilandu,2,5,ldate,messag,nx,ny)
c
c --- ********** TERRAIN ELEVATIONS
c
c --- read factor for conversion to meters
      read(iogeo,*)htfac
c
      do 30 j=ny,1,-1
      read(iogeo,*)(elev(n,j),n=1,nx)
30    continue
c
c --- print terrain data in user units
      write(io6,32)htfac
32    format(//1x,'Factor to convert user TERRAIN HEIGHT units ',
     1 'to meters (HTFAC) = ',f10.4)
      messag='Terrain heights (user units)'
      call out(elev,idum,1,5,ldate,messag,nx,ny)
c
c --- if necessary, convert user units to m
      if(htfac.ne.1.0)then
         do 40 i=1,nx
         do 40 j=1,ny
         elev(i,j)=htfac*elev(i,j)
40       continue
      endif
c
c --- ********** SURFACE ROUGHNESS
      read(iogeo,*)iopt(2)
c
c --- read Z0 data or compute from land use categories
      call fillgeo(iogeo,iopt(2),ilucat,nlu,z0lu,ilandu,nx,ny,z0)
      if(iopt(2).eq.0)then
c
c ---    print DEFAULT z0-land use table
         write(io6,121)
121      format(//2x,'Surface roughness (z0) computed from default ',
     1   'z0-land use table')
         write(io6,122)
122      format(//2x,'Land Use',6x,'Roughness'/2x,'Category',8x,
     1   'Length'/19x,'(m)'/)
         do 128 i=1,nlu
         write(io6,125)ilucat(i),z0lu(i)
125      format(3x,i4,6x,f10.4)
128      continue
      else if(iopt(2).eq.1)then
c
c ---    print USER-INPUT z0-land use table
         write(io6,131)
131      format(//2x,'Surface roughness (z0) computed from USER-INPUT ',
     1   'z0-land use table')
         write(io6,122)
         do 138 i=1,nlu
         write(io6,125)ilucat(i),z0lu(i)
138      continue
      else
c
c ---    user-input gridded z0 field
         messag='Gridded surface roughness length field (m)'
         call out(z0,idum,1,5,ldate,messag,nx,ny)
      endif
c
c --- ********** ALBEDO
      read(iogeo,*)iopt(3)
c
c --- read ALBEDO data or compute from land use categories
      call fillgeo(iogeo,iopt(3),ilucat,nlu,alblu,ilandu,nx,ny,albedo)
      if(iopt(3).eq.0)then
c
c ---    DEFAULT albedo-land use table used
         write(io6,141)
141      format(//2x,'Albedo computed from default ',
     1   'albedo-land use table')
      else if(iopt(3).eq.1)then
c
c ---    print USER-INPUT albedo-land use table
         write(io6,142)
142      format(//2x,'Albedo computed from USER-INPUT ',
     1   'albedo-land use table')
         write(io6,143)
143      format(//2x,'Land Use',5x,'  Albedo '/2x,'Category'/)
         do 148 i=1,nlu
         write(io6,125)ilucat(i),alblu(i)
148      continue
      else
c
c ---    user-input gridded albedo field
         messag='USER-INPUT albedo field'
         call out(albedo,idum,1,5,ldate,messag,nx,ny)
      endif
c
c --- ********** BOWEN RATIO
      read(iogeo,*)iopt(4)
c
c --- read BOWEN RATIO data or compute from land use categories
      call fillgeo(iogeo,iopt(4),ilucat,nlu,bowlu,ilandu,nx,ny,bowen)
      if(iopt(4).eq.0)then
c
c ---    DEFAULT Bowen ratio-land use table used
         write(io6,151)
151      format(//2x,'Bowen ratio computed from default ',
     1   'Bowen ratio-land use table')
      else if(iopt(4).eq.1)then
c
c ---    print USER-INPUT Bowen ratio-land use table
         write(io6,152)
152      format(//2x,'Bowen ratio computed from USER-INPUT ',
     1   'Bowen ratio-land use table')
         write(io6,153)
153      format(//2x,'Land Use',4x,'Bowen ratio'/2x,'Category'/)
         do 158 i=1,nlu
         write(io6,125)ilucat(i),bowlu(i)
158      continue
      else
c
c ---    user-input gridded Bowen ratio field
         messag='USER-INPUT Bowen ratio field'
         call out(bowen,idum,1,5,ldate,messag,nx,ny)
      endif
c
c --- ********** SOIL HEAT FLUX PARAMETER
      read(iogeo,*)iopt(5)
c
c --- read soil heat flux parameter data or compute from
c --- land use categories
      call fillgeo(iogeo,iopt(5),ilucat,nlu,hcglu,ilandu,nx,ny,hcg)
      if(iopt(5).eq.0)then
c
c ---    DEFAULT soil heat flux parameter-land use table used
         write(io6,161)
161      format(//2x,'Soil heat flux parameter computed from default ',
     1   'Soil parameter-land use table')
      else if(iopt(5).eq.1)then
c
c ---    print USER-INPUT soil heat flux parameter-land use table
         write(io6,162)
162      format(//2x,'Soil heat flux parameter computed from ',
     1   'USER-INPUT soil parameter-land use table')
         write(io6,163)
163      format(//2x,'Land Use',5x,'Soil heat'/2x,'Category',5x,
     1   'flux parameter'/)
         do 168 i=1,nlu
         write(io6,125)ilucat(i),hcglu(i)
168      continue
      else
c
c ---    user-input gridded soil heat flux parameter field
         messag='USER-INPUT soil heat flux parameter field'
         call out(hcg,idum,1,5,ldate,messag,nx,ny)
      endif
c
c --- ********** ANTHROPOGENIC HEAT FLUX
      read(iogeo,*)iopt(6)
c
c --- read anthropogenic heat flux parameter data or compute from
c --- land use categories
      call fillgeo(iogeo,iopt(6),ilucat,nlu,qflu,ilandu,nx,ny,qf)
      if(iopt(6).eq.0)then
c
c ---    DEFAULT anthropogenic heat flux-land use table used
         write(io6,171)
171      format(//2x,'Anthropogenic heat flux computed from default ',
     1   'Heat flux-land use table')
      else if(iopt(6).eq.1)then
c
c ---    print USER-INPUT anthropogenic heat flux-land use table
         write(io6,172)
172      format(//2x,'Anthropogenic heat flux computed from ',
     1   'USER-INPUT heat flux-land use table')
         write(io6,173)
173      format(//2x,'Land Use',5x,'heat flux'/2x,'Category'/)
         do 178 i=1,nlu
         write(io6,125)ilucat(i),qflu(i)
178      continue
      else
c
c ---    user-input gridded anthropogenic heat flux field
         messag='USER-INPUT anthropogenic heat flux field'
         call out(qf,idum,1,5,ldate,messag,nx,ny)
      endif
c
c --- ********** LEAF AREA INDEX
      read(iogeo,*)iopt(7)
c
c --- read leaf area index data or compute from land use categories
      call fillgeo(iogeo,iopt(7),ilucat,nlu,xlailu,ilandu,nx,ny,xlai)
      if(iopt(7).eq.0)then
c
c ---    DEFAULT Leaf area index-land use table used
         write(io6,181)
181      format(//2x,'Leaf area index computed from default ',
     1   'Leaf area index-land use table')
      else if(iopt(7).eq.1)then
c
c ---    print USER-INPUT Leaf area index-land use table
         write(io6,182)
182      format(//2x,'Leaf area index computed from ',
     1   'USER-INPUT Leaf area index-land use table')
         write(io6,183)
183      format(//2x,'Land Use',5x,'    LAI  '/2x,'Category'/)
         do 188 i=1,nlu
         write(io6,125)ilucat(i),xlailu(i)
188      continue
      else
c
c ---    user-input gridded leaf area index flux field
         messag='USER-INPUT Leaf area index field'
         call out(xlai,idum,1,5,ldate,messag,nx,ny)
      endif
c
c --- write final gridded arrays if "debug write" option is on
c --- (arrays written above are not repeated)
      if(ldb)then
         if(iopt(2).ne.2)then
            messag='Gridded surface roughness length field (m)'
            call out(z0,idum,1,5,ldate,messag,nx,ny)
         endif
c
         if(iopt(3).ne.2)then
            messag='Gridded albedo field'
            call out(albedo,idum,1,5,ldate,messag,nx,ny)
         endif
c
         if(iopt(4).ne.2)then
            messag='Gridded Bowen ratio field'
            call out(bowen,idum,1,5,ldate,messag,nx,ny)
         endif
c
         if(iopt(5).ne.2)then
            messag='Gridded soil heat flux parameter field'
            call out(hcg,idum,1,5,ldate,messag,nx,ny)
         endif
c
         if(iopt(6).ne.2)then
            messag='Gridded anthropogenic heat flux field'
            call out(qf,idum,1,5,ldate,messag,nx,ny)
         endif
c
         if(iopt(7).ne.2)then
            messag='Gridded leaf area index field'
            call out(xlai,idum,1,5,ldate,messag,nx,ny)
         endif
      endif
c
      return
      end
c----------------------------------------------------------------------
      logical function lrsame(r0,r1,r2)
c----------------------------------------------------------------------
c
c --- CALMET     Version: 6.4.0     Level: 030402           LRSAME
c                D. Strimaitis,    Earth Tech, Inc.
c ---            From CALPOST V5.2, L991104c
c
c --- PURPOSE:  Compare 2 real numbers (r1,r2) to determine if their
c               fractional difference exceeds r0
c
c --- INPUTS:
c            r0 - real       - Fractional difference allowed
c            r1 - real       - Real value 1
c            r2 - real       - Real value 2
c
c
c --- OUTPUT:
c        lrsame - logical    - Key indicating result of test
c                              .TRUE.  -- values are 'same'
c                              .FALSE. -- values are NOT 'same'
c
c
c --- LRSAME called by:   (utility)
c --- LRSAME calls:       none
c----------------------------------------------------------------------
c
      data half/0.5/

      lrsame=.TRUE.

c --- Direct comparison
      if(r1.EQ.r2) return

      rdif=ABS(r1-r2)
      ravg=half*ABS(r1+r2)

      if(rdif.GE.ravg) then
c ---    Fractional difference greater than one!
         lrsame=.FALSE.
      else
         ftest=rdif/ravg
         if(ftest.GT.r0) lrsame=.FALSE.
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine readhd(ibyr,ibjul,ibhr,ibsec,ieyr,iejul,iehr,iesec,
     :                  ibtz,nsecdt,ldb,idiopt,iprog,igfmet)
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203              READHD
c ---          J. Scire, M. Fernau, Earth Tech, Inc.
c
c --- PURPOSE:  Read header records from meteorological data files
c               and perform QA checks
c
c --- UPDATES
c
c --- v6.334 (110421) to v6.4.0 (121203)
c               - Add wind dir. rotation for Polar Stereographic
c                 projection
c
c --- v6.330 (101006) to v6.334 (110421) (F.Robe)
c               - check that value of SIGMAP just includes 4
c                 nearest progn. gridpoints when NPSTA=-1 and reset
c                 if necessary
c
c --- v6.327 (090511) to v6.330 (101006) (CEC)
c               - Change ICLOUD into MCLOUD and ICLDOUT
c
c --- v6.326 (080325) to v6.327 (090511)
c               - Revised write Formats 75,76 to add more information
c                 and add write statement at stop (JSS)
c
c --- v6.32 (080205) to V6.321 (080325)
c               - Correct warning write statement to reflect precipitation
c                 dataset name rather than sf data filename 
c               - Correct list file statement (introduce character return
c                 to make sure values are lined up with correct text in lst
c                 file
c               - Check precip. station IDs based on LFCPRC not LFCSFC
c
c --- v6.302(070929) to v6.32 (080205)
c               - Initialize prognostic record beginning/end seconds
c               - 3D.DAT beginning time test includes seconds
c               - Add npsta to RDHD5 calling list
c
c --- v6.301 (070927) to v6.302 (070929)(JSS)
c               - Update documentation on routines being called
c               - Update documentation on parameters required 
c --- v6.207 (060328) to v6.215 (061020)(DGS)
c               - Test of time span for UP.DAT files did not fully
c                 account for time shift between base time zone and
c                 UTC, causing an unnecessary halt
c
c --- v6.205 (060309) to v6.207 (060328)(DGS)
c               - change test on beginning times MM4/CALMET 
c
c --- v6.2 (060215)to v6.205 (060309)(F.Robe)
c               - change test on beginning times MM5/CALMET 
c
c --- v5.711 (060106) to v6.2 (060215)(F.Robe)
c               - Switch from hour-ending times to explicit beg/ending times
c                 and allow sub-hourly timesteps
c               - Get SURF.DAT, PRECIP.DAT and UP.DAT dataset version numbers 
c                 from respective rdhd(u) subroutines and store them 
c                 in MET1.MET
c               - Remove irlg from calling list (no longer needed) and add
c                 nsecdt
c               - Initialize ifirstpg for all types of prognostic data
c                 (stored in internal common: progstep)
c
c --- v6.513 (051227) to v5.711 (060106)(F.Robe)
c               - Add flag igfmet to calling list and read IGF.DAT
c                 header
c
c --- v5.611 (051113) to v6.513 (051227) (F.Robe)
c               - Add ibtz to calling list to rdhdow
c --- v5.6e(050520) to v5.611 (051113) (F.Robe)
c               - Add itwprog to calling list to rdhd5
c --- v5.6d(050428) to v5.6e(050520) (DGS)
c               - Restore IPROG constraints before call to RDHD5
c --- V5.542 (031126) to v5.6d(050428) (F.Robe)
c               - Remove npsta from calling list to rdhd5
c --- V5.541 (031017) to V5.542 (031126)  (J. Scire)
c               - Correct calls to RDHD to include CLATS/CLONS and
c                 CLATP/CLONP arrays in the argument list, and 
c                 dimension these arrays in the calling routine
c                 (READHD).
c --- V5.5 (030402) to V5.54 (031017)  (DGS)
c               - Add processing code for station location data in
c                 updated met data files (lat/lon only)
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c               - Add list-file unit to INDECR, RDHDU calls
c               - Add arrays for call to RDHD for new format
c               - Add scratch file io unit to RDHDU arg list
c               - Add subroutine RDHDOW for new SEA.DAT header
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- Modified by F. Robe (1/98) to read MM5 data
c --- Modified by J. Scire (2/98) to allow comma-delimited upper air
c              data format
c --- Modified by M. Fernau to disable MM4/MM5 record skipping,
c              i.e., read header but don't position pointer
c --- Modified by J. Scire to eliminate conversion of precip. data
c ---          from ending hour to beginning hour
c
c
c --- INPUTS:
c               IBYR - integer    - Year of beginning of run
c              IBJUL - integer    - Julian day of beginning of run
c               IBHR - integer    - Hour of beginning of run
c              IBSEC - integer    - Second of beginning of run (explicit)
c               IEYR - integer    - Year of end of run (explicit)
c              IEJUL - integer    - Julian day of end of run (explicit)
c               IEHR - integer    - Hour of end of run (explicit)
c              IESEC - integer    - Second of end of run (explicit)
c               IBTZ - integer    - Base time zone
c             NSECDT - integer    - Timestep in seconds
c                LDB - logical    - Control variable determining
c                                   the printing of internal arrays
c                                   (useful for testing)
c          IDIOPT(5) - int. array - Diagnostic wind module input
c                                   flags (Element 4 -- surf. data
c                                   Element 5 -- upper air data) --
c                                   (0=compute internally, 1=use
c                                   preprocessed values)
c              IPROG - integer    - Control variable determining use
c                                   of prognostic data (1=CSUMM as Step 1
c                                   field; 2=CSUMM as initial guess field;
c                                   3=MM4 as Step 1 field; 4=MM4 as initial
c                                   guess field; 5=MM4 as observations)
c                                   13=MM5 as Step 1 field; 14=MM5 as initial
c                                   guess field; 15=MM5 as observations)
c              IGFMET - integer    - Control variable determining use
c                                   of IGF CALMET.dAT 
c
c       Common block /GRID/ variables:
c         dgrid,xorigr,yorigr
c       Common block /LON/ variables:
c         dlongs(mxss),dlongu(mxus)
c       Common block /MAP/ variables:
c         llcc,
c         lps,
c         iutmzn,conec,feast,fnorth,
c         rnlat0,relon0,xlat1,xlat2,
c         pmap,utmhem,datum
c       Common block /MET1/ variables:
c         IOS, NSSTA, IFORMS, IDSSTA(mxss)
c         IOP, NPSTA, IFORMP, IDPSTA(mxps), noobs
c         IOS, NUSTA, IDUSTA(mxus), CUNAM(mxus)
c         LCFSFC,LCFUPR,LCFPRC,
c         DATAVERS,DATAVERP,DATAVERU, SIGMAP
c       Common block /OVRWAT/ variables:
c         IOOW,NOWSTA
c        Parameters: MXSS, MXUS, MXLEV, MXPS, MXOWS, IO6, 
c                    MXNX, MXNY, MXNZ, MXNZP1, 
c                    MXNXP, MXNYP, MXNZP,
c                    MXNXI, MXNYI, MXNZI
c
c --- OUTPUT:
c       Common block /MET1/ variables:
c         IPPACK, ISPACK, ZANEM,DATAVERS,DATAVERP,DATAVERU, ...
c       Common block /OVRWAT/ variables:
c         CHOWSTA,IDOWSTA
c       Common block /IGF/nfigf
c       Common block /UPMET/ isnap(mxus)
c
c --- READHD called by:  SETUP
c --- READHD calls:      RDHD, DELTT, RDS, RDP, RDHDU, RDUP, RDHD4,
c                        INDECR, RDHD5, RDHDOW, GLOBE1, GLOBE, 
c                        DELTSEC, RDHDMET, GRDAY
c------------------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'

      include 'grid.met'
      include 'lon.met'
      include 'map.met'
      include 'met1.met'
      include 'met2.met'
      include 'met3.met'
      include 'upmet.met'
      include 'ovrwat.met'
      include 'mm4hdo.met'
      include 'igf.met'
c
c     Internal common (also in RDHD4,RDHD5,RDMM4,RDMM5,PROGRD)
      COMMON /PROGSTEP/ ifirstpg,nfm3d

      integer idsurf(mxss),idprec(mxps),idiopt(5)
      integer ishift(3)
      logical ldb, lstnloc, lfatal
      logical lht,ltemp,lwd,lws

c --- Declare local arrays for reading new station data format     
      real dumprec(mxps)
      character*8 datumu(mxus)
      character*16 clats(mxss),clons(mxss)
      character*16 clatp(mxps),clonp(mxps)

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

c --- Set translation vectors going from N.lat,E.lon to map(x,y)km
c --- for station locations provided in files
c --- Scale factor for Tangential TM projection
      tmsone=1.00000
      iutmo=iutmzn
      if(utmhem.EQ.'S   ' .AND. iutmzn.LT.900) iutmo=-iutmo
      cmapo=pmap
      if(cmapo.EQ.'TTM     ') cmapo='TM      '
      cmapi='LL      '
      idum=0
      rdum=0.0
      call GLOBE1(cmapi,idum,rdum,rdum,rdum,rdum,rdum,
     &            rdum,rdum,
     &            cmapo,iutmo,tmsone,xlat1,xlat2,rnlat0,relon0,
     &            feast,fnorth,
     &            caction,vecti,vecto)
c
c --- Read surface met. header records
c ------------------------------------
c frr (noobs option 2: no surface obs)
      if(idiopt(4).eq.1  .or. noobs.eq.2 )go to 151
c
      call RDHD(iforms,ios,jbyr,jbjul,jbhr,jbsec,
     1          jeyr,jejul,jehr,jesec,jbtz,jssta,
     1          ispack,datavers,idsurf,zanem,csnam,xslat,xslon,mxss,
     2          clats,clons,datumi,lstnloc)
c
c --- Write SURFACE station parameters
      write(io6,110)iforms,ispack,jbtz,jssta,jbyr,jbjul,jbhr,
     1 jeyr,jejul,jehr
110   format(///2x,'Data from Surface met. file header records'//
     1 5x,'      Format code: ',i5/
     2 5x,'     Packing code: ',i5/
     3 5x,'        Time zone: ',i5/
     4 5x,'     No. stations: ',i5//
     5 5x,'   Beginning year: ',i5/
     6 5x,'       Julian day: ',i5/
     7 5x,'             hour: ',i5//
     8 5x,'      Ending year: ',i5/
     9 5x,'       Julian day: ',i5/
     a 5x,'             hour: ',i5)

      if(LSTNLOC) then
c ---    Process station location data from file
         write(io6,1485)
1485  format(//30x,'SURFACE STATIONS'/69x,2x,'Anemometer',5x,
     1 'Grid Coordinates'/1x,'Name',5x,'ID',8x,'X-UTM',8x,'Y-UTM',6x,
     2 'NLatitude',4x,'WLongitude',5x,'Height',11x,'X',9x,'Y'/
     3 20x,'(km)',9x,'(km)',9x,'(Deg)',8x,'(Deg)',9x,'(m)',10x,
     4 '(Origin = (0,0))'/)

         do i=1,jssta
c
c ---       Pass source IDs into common
            idssta(i)=idsurf(i)
c
c ---       Compute map coordinates (km)
            call GLOBE(io6,caction,datumi,vecti,datum,vecto,
     &                 xslon(i),xslat(i),xssta(i),yssta(i),idum,c4hem)
c
c ---       Convert E.Lon to W.Lon
            xslon(i)=-xslon(i)
c

c --- v6.4.0, Level 121203
            if(LLCC .OR. LPS) then

c ---          Compute delta longitudes (West Lon.)
               dlongs(i) = rlon0 - xslon(i)
c ---          Code to handle 180 degree longitude straddle
               if (dlongs(i) .gt. 180.) dlongs(i) = dlongs(i) - 360.
               if (dlongs(i) .lt. -180.) dlongs(i) = dlongs(i) + 360.
            endif
c
c ---       Convert from km to m, and into relative coordinates
            xkm=xssta(i)
            ykm=yssta(i)
            xssta(i)=1000.*xkm-xorigr
            yssta(i)=1000.*ykm-yorigr
c
c ---       Compute grid coordinates for printing
            xgrdc=xssta(i)/dgrid
            ygrdc=yssta(i)/dgrid
c
            write(io6,1490)csnam(i),idssta(i),xkm,ykm,xslat(i),xslon(i),
     1                     zanem(i),xgrdc,ygrdc
1490        format(1x,a4,1x,i8,3x,f10.1,3x,f10.1,3x,f10.3,3x,f10.3,6x,
     1             f5.1,6x,f10.3,f10.3)
c
         enddo
c
      else
c ---    No station location data from file: report IDs
c ---    set variables for proper columns
c ---    j4 is no. rows in a "short" column
c ---    j5 is no. rows in a "long" column
c ---    j6 is the number of "long" columns
         j4=jssta/4
         j6=mod(jssta,4)
         if(j6.eq.0)then
            j5=j4
         else
            j5=j4+1
         endif
         ishift(1)=j5
         do i=2,3
            if(i.le.j6)then
               ishift(i)=ishift(i-1)+j5
            else
               ishift(i)=ishift(i-1)+j4
            endif
         enddo
c
c ---    Write surface station IDs
         ncol=min0(jssta,4)
         write(io6,112)(' ',n=1,ncol)
112      format(//2x,'Surface met. station ID numbers: '//
     1            3x,4(a1,'No.',6x,'ID',9x)/)
c
         do i=1,j4
            i2=i+ishift(1)
            i3=i+ishift(2)
            i4=i+ishift(3)
            write(io6,14)i,idsurf(i),i2,idsurf(i2),i3,idsurf(i3),i4,
     1                   idsurf(i4)
         enddo
         if(j6.gt.0)then
            n1=j5
            n2=n1+(j6-1)*j5
            write(io6,14)(n,idsurf(n),n=n1,n2,j5)
         endif
c
      endif

119   continue
c
c --- QA checks on surface met. data
      lfatal=.FALSE.
      if(ibtz.ne.jbtz.or.nssta.ne.jssta)then
         write(io6,120)ibtz,jbtz,nssta,jssta
120      format(//2x,'ERROR IN SUBR. READHD -- Surface met. header ',
     1   'data does not match control file inputs'/5x,'ibtz = ',i10,5x,
     2   'jbtz = ',i10/5x,'nssta = ',i10,5x,'jssta = ',i10)
         lfatal=.TRUE.
      endif
c
      if(LCFSFC) then
c ---    surface station IDs from surface file must match those in
c ---    control file
         nmatch=0
         do 122 i=1,nssta
         if(idsurf(i).eq.idssta(i))then
            nmatch=nmatch+1
         else
            write(io6,121)i,idsurf(i),idssta(i)
121         format(/1x,'ERROR IN SUBR. READHD -- Surface station ID ',
     1      'does not match value entered by user in control file'/5x,
     2      'I = ',i5,5x,'Station ID -- FILE: ',i10,5x,'USER INPUT: ',
     3      i10)
         endif
122      continue
         if(nmatch.ne.nssta) lfatal=.TRUE.
      endif
c
c --- check that surface met. file begin. time <= run begin. time
c --- determine number of records to skip  
      call deltt(jbyr,jbjul,jbhr,ibyr,ibjul,ibhr,nskip)
      if((nskip.lt.0).or.(nskip.eq.0 .and. ibsec.lt.jbsec))then
         write(io6,125)ibyr,ibjul,ibhr,ibsec,jbyr,jbjul,jbhr,jbsec
125      format(//2x,'ERROR IN SUBR. READHD -- Surface data does not ',
     1   'cover time period in run'/5x,/
     2  5x,'Run starting date/hr/sec: ibyr, ibjul, ibhr, ibsec = ',
     2  i10.4,i10.3,i10.2,i10.4/
     3  5x,'     Date/hr/sec in file: jbyr, jbjul, jbhr ,jbsec = ',
     3  i10.4,i10.3,i10.2,i10.4)
         lfatal=.TRUE.
      endif
c
c --- check that surface met. file end time >= run end time 
      call deltt(ieyr,iejul,iehr,jeyr,jejul,jehr,jleng)
      if((jleng.lt.0).or.(jleng.eq.0 .and. iesec.gt.jesec))    then
         write(io6,130)ieyr,iejul,iehr,iesec,jeyr,jejul,jehr,jesec
130      format(//2x,'ERROR IN SUBR. READHD -- Surface data does not ',
     1   'cover time period in run'/
     2   5x,'Run Ending date/hr/sec: ieyr, iejul, iehr, iesec = ',
     2   i10.4,i10.3,i10.2,i10.4/
     3   5x,'End Date/hr/sec in file: jeyr, jejul, jehr ,jesec = ',
     3   i10.4,i10.3,i10.2,i10.4)
         lfatal=.TRUE.
      endif

c --- Make sure that 1 set of station locations is provided
      if(LCFSFC .AND. LSTNLOC) then
         write(io6,*)
         write(io6,*)
         write(io6,*)'  ERROR IN SUBR. READHD -- station locations are'
         write(io6,*)'  provided in control file and SURF.DAT file.'
         write(io6,*)'  Use one or the other.'
         lfatal=.TRUE.
      elseif(.not.LCFSFC .AND. .not.LSTNLOC) then
         write(io6,*)
         write(io6,*)
         write(io6,*)'  ERROR IN SUBR. READHD -- station locations are'
         write(io6,*)'  missing from both control file and SURF.DAT'
         lfatal=.TRUE.
      endif

c --- Check for QA failure
      if(LFATAL) stop 'Halted in READHD --- See list file'
c
c
c --- Beginning date/hr of run
c     idathr=ibyr*100000+ibjul*100+ibhr 

c --- Skip to proper starting point in surface data file if old format
        if (datavers.eq.'2.1') then
c ---       explicit beg/ending time with seconds - Sub-hourly records/timesteps
c---        No need to skip if sub-hourly timestep as done anyway in normal call to rdsn
c ---       in subroutine comp
         else
c ---       hour-ending time format - hourly record only - so skip to beginning hour
            iskip=1
            do i=1,nskip
              call rds(iforms,nssta,ispack,ios,0,ibuf,iyr,ijul,ihr,
     1          ws,wd,iceil,icc,tempk,irh,pres,ipcode)
            enddo
         endif

151   continue
c
c --- Read precip. header records
c --------------------------------
c frr (09/01) if npsta =-1, use MM5 precip data
c      if(npsta.eq.0)go to 51
      if(npsta.le.0)go to 51
c
      call RDHD(iformp,iop,jbyr,jbjul,jbhr,jbsec,jeyr,jejul,jehr,
     1          jesec,jbtz,jpsta,
     1          ippack,dataverp,idprec,dumprec,cpnam,xplat,xplon,mxps,
     2          clatp,clonp,datumi,lstnloc)
c
c --- write data from precipitation header records
c --- write data from precipitation header records
      write(io6,10)iformp,ippack,jbtz,jpsta,jbyr,jbjul,jbhr,jbsec,
     1 jeyr,jejul,jehr,jesec
10    format(///2x,'Data from Precipitation file header records'//
     1 5x,'      Format code: ',i5/
     2 5x,'     Packing code: ',i5/
     3 5x,'        Time zone: ',i5/
     4 5x,'     No. stations: ',i5//
     5 5x,'   Beginning year: ',i5/
     6 5x,'       Julian day: ',i5/
     7 5x,'             hour: ',i5/
     7 5x,'           second: ',i5//
     8 5x,'      Ending year: ',i5/
     9 5x,'       Julian day: ',i5/
     a 5x,'             hour: ',i5/
     b 5x,'           second: ',i5)
c
      if(LSTNLOC) then
c ---    Process station location data from file
         write(io6,1605)
1605  format(//30x,'PRECIPITATION STATIONS'//
     1 1x,'Name',5x,'ID',8x,'  X  ',8x,'  Y  ',7x,'Grid Coordinates'/
     2 20x,'(km)',9x,'(km)',11x,'X',9x,'Y'/45x,'(Origin = (0,0))')

         do i=1,jpsta
c
c ---       Pass source IDs into common
            idpsta(i)=idprec(i)
c
c ---       Compute map coordinates (km)
            call GLOBE(io6,caction,datumi,vecti,datum,vecto,
     &                 xplon(i),xplat(i),xpsta(i),ypsta(i),idum,c4hem)
c
c ---       Convert E.Lon to W.Lon
            xplon(i)=-xplon(i)
c
c ---       Convert from km to m, and into relative coordinates
            xkm=xpsta(i)
            ykm=ypsta(i)
            xpsta(i)=1000.*xkm-xorigr
            ypsta(i)=1000.*ykm-yorigr
c
c ---       Compute grid coordinates for printing
            xgrdc=xpsta(i)/dgrid
            ygrdc=ypsta(i)/dgrid
c
            write(io6,1609)cpnam(i),idpsta(i),xkm,ykm,xgrdc,ygrdc
1609        format(1x,a4,3x,i6,3x,f10.3,3x,f10.3,2x,f10.3,f10.3)
c
         enddo
c
      else
c ---    No station location data from file: report IDs
c ---    set variables for proper columns
c ---    j4 is no. rows in a "short" column
c ---    j5 is no. rows in a "long" column
c ---    j6 is the number of "long" columns
         j4=jpsta/4
         j6=mod(jpsta,4)
         if(j6.eq.0)then
            j5=j4
         else
            j5=j4+1
         endif
         ishift(1)=j5
         do 11 i=2,3
         if(i.le.j6)then
            ishift(i)=ishift(i-1)+j5
         else
            ishift(i)=ishift(i-1)+j4
         endif
11       continue
c
c ---    write precip. station IDs
         ncol=min0(jpsta,4)
         write(io6,12)(' ',n=1,ncol)
12       format(//2x,'Precipitation station ID numbers: '//
     1    3x,4(a1,'No.',6x,'ID',9x)/)
c
         do i=1,j4
            i2=i+ishift(1)
            i3=i+ishift(2)
            i4=i+ishift(3)
            write(io6,14)i,idprec(i),i2,idprec(i2),i3,idprec(i3),i4,
     1                   idprec(i4)
14          format(3x,4(i3,5x,i6,7x))
         enddo
c
         if(j6.gt.0)then
            n1=j5
            n2=n1+(j6-1)*j5
            write(io6,14)(n,idprec(n),n=n1,n2,j5)
         endif
c
      endif

19    continue
c
c --- QA checks on precipitation data
      lfatal=.FALSE.
      if(ibtz.ne.jbtz.or.npsta.ne.jpsta)then
         write(io6,20)ibtz,jbtz,npsta,jpsta
20       format(//2x,'ERROR IN SUBR. READHD -- Precip. header ',
     1   'data does not match control file inputs'/5x,'ibtz = ',i10,5x,
     2   'jbtz = ',i10/5x,'npsta = ',i10,5x,'jpsta = ',i10)
         lfatal=.TRUE.
      endif
c
c     if(LCFSFC) then  - Not ok (080325)
      if(LCFPRC) then
c ---    precip. station IDs from precip. file must match those in
c ---    control file
         nmatch=0
         do 22 i=1,npsta
         if(idprec(i).eq.idpsta(i))then
            nmatch=nmatch+1
         else
            write(io6,21)i,idprec(i),idpsta(i)
21          format(/1x,'ERROR IN SUBR. READHD -- Precip. station ID ',
     1      'does not match value entered by user in control file'/5x,
     2      'I = ',i5,5x,'Station ID -- FILE: ',i10,5x,'USER INPUT: ',
     3      i10)
         endif
22       continue
         if(nmatch.ne.npsta) lfatal=.TRUE.
      endif
c
c --- check that precipitation file begin. time <= run begin. time
c --- determine number of records to skip  
      call deltt(jbyr,jbjul,jbhr,ibyr,ibjul,ibhr,nskip)
      if((nskip.lt.0).or.(nskip.eq.0 .and. ibsec.lt.jbsec))then
         write(io6,25)ibyr,ibjul,ibhr,ibsec,jbyr,jbjul,jbhr,jbsec
25      format(//2x,'ERROR IN SUBR. READHD -- Precipitation data does',
     1   ' not cover time period in run'/5x,/
     2  5x,'Run starting date/hr/sec: ibyr, ibjul, ibhr, ibsec = ',
     2  i10.4,i10.3,i10.2,i10.4/
     3  5x,'     Date/hr/sec in file: jbyr, jbjul, jbhr ,jbsec = ',
     3  i10.4,i10.3,i10.2,i10.4)
         lfatal=.TRUE.
      endif
c

c --- check that precipitation file end time >= run end time 
      call deltt(ieyr,iejul,iehr,jeyr,jejul,jehr,jleng)
      if((jleng.lt.0).or.(jleng.eq.0 .and. iesec.gt.jesec))    then
         write(io6,30)ieyr,iejul,iehr,iesec,jeyr,jejul,jehr,jesec
30      format(//2x,'ERROR IN SUBR. READHD -- Precip data does not ',
     1   'cover time period in run'/
     2   5x,'Run Ending date/hr/sec: ieyr, iejul, iehr, iesec = ',
     2   i10.4,i10.3,i10.2,i10.4/
     3   5x,'End Date/hr/sec in file: jeyr, jejul, jehr ,jesec = ',
     3   i10.4,i10.3,i10.2,i10.4)
         lfatal=.TRUE.
      endif
c
c --- Make sure that 1 set of station locations is provided
      if(LCFPRC .AND. LSTNLOC) then
         write(io6,*)
         write(io6,*)
         write(io6,*)'  ERROR IN SUBR. READHD -- station locations are'
         write(io6,*)'  provided in control file and PRECIP.DAT file.'
         write(io6,*)'  Use one or the other.'
         lfatal=.TRUE.
      elseif(.not.LCFPRC .AND. .not.LSTNLOC) then
         write(io6,*)
         write(io6,*)
         write(io6,*)'  ERROR IN SUBR. READHD -- station locations are'
         write(io6,*)'  missing from both control file and PRECIP.DAT'
         lfatal=.TRUE.
      endif

c --- Check for QA failure
      if(LFATAL) stop 'Halted in READHD --- See list file'
c
c --- skip to proper starting point in precip. data file
      iskip=1
      do i=1,nskip
         if (dataverp.eq.'2.1')then
c ---       2.1 time format with explicit beg/ending times with seconds 
c---        No need to skip here (done in rdpn when called by comp)
         else
            call rdp(iformp,npsta,ippack,iop,iskip,iyr,ijul,ihr,xprecp)
         endif
      enddo

51    continue
c
c --- Loop over upper air data files
c ----------------------------------
c FRR (09/2001) additional option for noobs
c      if(idiopt(5).eq.1 .or. noobs .eq. 1) go to 101
      if(idiopt(5).eq.1 .or. noobs .ge. 1) go to 101
c
      io=iou-1
      do 100 i=1,nusta
c *** rjy added initialization of new arrays on 1/25/90.
      justa(i) = 0
      jusdt(i) = 0
      ntzaa(i) = 0
      ntzbb(i) = 0
c --- All soundings are instantaneous in UP.DAT versions 2.1 and older
c --- In UP.DAT v2.2, time-averaged soundings are defined by ISNAP=0
c --- in subroutine RDUPN2 (080205)
      isnap(i) = 1
c
c --- read header records -- upper air data
      io=io+1
      call RDHDU(io,io6,iox,ibyru,ibjulu,ibhru,ibsecu,ieyru,iejulu,
     1           iehru,iesecu,ptop,jdat,dataveru,ifmtu(i),lht,ltemp,
     2           lwd,lws,idusta(i),cunam(i),xulat(i),xulon(i),
     3           uelev(i),datumu(i),lstnloc)
c
c --- write data from upper air header records
      write(io6,52)i,io
52    format(///2x,'Data from Upper Air data file -- no.: ',i5,3x,
     1 'unit no.: ',i5)
c
      write(io6,54)ibyru,ieyru,ibjulu,iejulu,ibhru,iehru
54    format(//6x,'Starting date:',16x,'Ending date:'/6x,9x,'Year = ',
     1 i4,17x,'Year = ',i4/10x,'Julian day = ',i3,12x,'Julian day = ',
     2 i3/16x,'Hour = ',i3,18x,'Hour = ',i3)
      write(io6,56)ptop,jdat,ifmtu(i)
56    format(//6x,'Pressure levels extracted:'//6x,20x,'Surface',
     1 ' to  ',F5.0,' mb'//6x,'Data type (JDAT): ',i2,' (1=TD6201, ',
     2 '2=NCDC CD, 3=other/unknown)'/6x,'Data format (IFMT): ',i2,
     3 ' (1=slash-delimited, 2=comma-delimited)')
      write(io6,58)lht,ltemp,lwd,lws
58    format(//6x,'Data level eliminated if height missing ? ',8x,L1/
     1 /6x,'Data level eliminated if temperature missing ? ',3x,L1/
     2 /6x,'Data level eliminated if wind direction missing ? ',L1/
     3 /6x,'Data level eliminated if wind speed missing ? ',4x,L1)

c --- check that upper air file begin time <= run begin time
c --- ndiff = run begin - UA begin (hours)
      call DELTT(ibyru,ibjulu,ibhru,ibyr,ibjul,ibhr,ndiff)
      ndiff=ndiff+ibtz
      if((ndiff.LT.0).or.
     &   (ndiff.EQ.0 .and. ibsec.lt.ibsecu))then
c ---       Compute Gregorian day for output purposes
            call grday(io6,ibyr,ibjul,ipmo,ipday)
            call grday(io6,ibyru,ibjulu,ipmou,ipdayu)
c ---       Compute Model start time in UTC for output purposes
c ---       Initialize UTC variables & compute in subr. INDECR
            ibyrUTC=ibyr
            ibjulUTC=ibjul
            ibhrUTC=ibhr
            call indecr(io6,ibyrUTC,ibjulUTC,ibhrUTC,ibtz,0,23)
            call grday(io6,ibyrUTC,ibjulUTC,ipmoUTC,ipdayUTC)
         write(io6,75)i,ibyr,ibjul,ipmo,ipday,ibhr,ibsec,
     1    ibyrUTC,ibjulUTC,ipmoUTC,ipdayUTC,ibhrUTC,ibsec,
     2    ibyru,ibjulu,ipmou,ipdayu,ibhru,ibsecu
75       format(//2x,'ERROR IN SUBR. READHD -- Upper air data does ',
     1   'not cover time period in run'/,6x,'Station no.: ',i5/
     2   36x,'Year  Julian Day  Month  Day  Hour  Seconds '/
c             xxxx      xxx       xx    xx   xx    xxxx
     3   6x,'Model run starting date/time:',
     3    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,' (LST)'/
     4   6x,'Model run starting date/time:',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,' (UTC)'/
     5   3x,'Beg. Date/time in UP.DAT header:',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,' (UTC)')
         lfatal=.TRUE.
      endif
c
c --- check that upper air file end time >= run end time 
c --- ndiff = run end - UA end (hours)
      call DELTT(ieyru,iejulu,iehru,ieyr,iejul,iehr,ndiff)
      ndiff=ndiff+ibtz
      if((ndiff.GT.0).or.
     &   (ndiff.EQ.0 .and. ibsecu.lt.ibsec))then
c ---       Compute Gregorian day for output purposes
            call grday(io6,ieyr,iejul,ipmo,ipday)
            call grday(io6,ieyru,iejulu,ipmou,ipdayu)
c ---       Compute Model start time in UTC for output purposes
c ---       Initialize UTC variables & compute in subr. INDECR
            ieyrUTC=ieyr
            iejulUTC=iejul
            iehrUTC=iehr
            call indecr(io6,ieyrUTC,iejulUTC,iehrUTC,ibtz,0,23)
            call grday(io6,ieyrUTC,iejulUTC,ipmoUTC,ipdayUTC)
         write(io6,76)i,ieyr,iejul,ipmo,ipday,iehr,iesec,
     1    ieyrUTC,iejulUTC,ipmoUTC,ipdayUTC,iehrUTC,iesec,
     2    ieyru,iejulu,ipmou,ipdayu,iehru,iesecu
76       format(//2x,'ERROR IN SUBR. READHD -- Upper air data does ',
     1   'not cover time period in run'/5x,'Station no.: ',i5/
     2   34x,'Year  Julian Day  Month  Day  Hour  Seconds '/
     3   3x,'  Model run ending date/time: ',
     3    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,' (LST)'/
     4   3x,'  Model run ending date/time: ',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,' (UTC)'/
     5   1x,'End Date/time in UP.DAT header: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,' (UTC)')
         lfatal=.TRUE.
      endif
c
c --- Make sure that 1 set of station locations is provided
      if(LCFUPR .AND. LSTNLOC) then
         write(io6,*)
         write(io6,*)
         write(io6,*)'  ERROR IN SUBR. READHD -- station locations are'
         write(io6,*)'  provided in control file and UP.DAT file.'
         write(io6,*)'  Use one or the other.'
         lfatal=.TRUE.
      elseif(.not.LCFUPR .AND. .not.LSTNLOC) then
         write(io6,*)
         write(io6,*)
         write(io6,*)'  ERROR IN SUBR. READHD -- station locations are'
         write(io6,*)'  missing from both control file and UP.DAT'
         lfatal=.TRUE.
      endif
c
c --- No Need To Skip to Proper Starting Point in Upper Air File Here
c --- It will be taken care of in Subr. RDUP

100   continue

c --- Check for QA failure
      if(LFATAL)then
         write(io6,*)
         write(io6,*)'Error in Subr. READHD--See error messages above'
         stop 'Halted in READHD --- See list file'
      endif
c
      if(LSTNLOC) then
c ---    Process station location data from files
         write(io6,1505)
1505  format(//30x,'UPPER AIR STATIONS'/69x,'Stn.',5x,
     1 'Grid Coordinates'/1x,'Name',5x,'ID',8x,'  X  ',8x,'  Y  ',
     2 6x,'NLatitude',4x,'WLongitude',2x,'Elev',8x,'X',9x,'Y'/
     3 20x,'(km)',9x,'(km)',9x,'(Deg)',8x,'(Deg)',14x,
     4 '(Origin = (0,0))'/)
c
         do i=1,nusta
c
c ---       Compute map coordinates (km)
            call GLOBE(io6,caction,datumu(i),vecti,datum,vecto,
     &                 xulon(i),xulat(i),xusta(i),yusta(i),idum,c4hem)
c
c ---       Convert E.Lon to W.Lon
            xulon(i)=-xulon(i)
c

c --- v6.4.0, Level 121203
            if(LLCC .OR. LPS) then

c ---          Compute delta longitudes (West Lon.)
               dlongu(i) = rlon0 - xulon(i)
c ---          Code to handle 180 degree longitude straddle
               if (dlongu(i) .gt. 180.) dlongu(i) = dlongu(i) - 360.
               if (dlongu(i) .lt. -180.) dlongu(i) = dlongu(i) + 360.
            endif

c ---       convert from km to m, and into relative coordinates
            xkm=xusta(i)
            ykm=yusta(i)
            xusta(i)=1000.*xkm-xorigr
            yusta(i)=1000.*ykm-yorigr

c ---       compute grid coordinates for printing
            xgrdc=xusta(i)/dgrid
            ygrdc=yusta(i)/dgrid

            write(io6,1492)cunam(i),idusta(i),xkm,ykm,xulat(i),xulon(i),
     1                     uelev(i),xgrdc,ygrdc
1492        format(1x,a4,3x,i5,4x,f10.1,3x,f10.1,3x,f10.3,3x,f10.3,2x,
     1             f5.0,2x,f10.3,f10.3)

         enddo
      endif

101   continue

c --- Record first access to prognostic data (if used) - 051128
c     Stored in internal common progstep
      ifirstpg=0
c

c --- new option: use coarse CALMET.DAT as IGF  (060106)

c --- Read header records from existing CALMET.DAT file
c -----------------------------------------------------
      if(igfmet.EQ.1 )then

c ---    First IGF-CALMET.DAT file 
         nfigf=1
         call rdhdmet
 
c --- No need to skip to starting point in IGF CALMET file here,
c --- it will be done in SUBR. RDMET2
c
      endif

c
c --- Read header records from MM5 data file
c ------------------------------------------
c --- Initialize prognostic beginning/end seconds (080205)
      ibsecm=0
      iesecm=0

c FRR (09/2001) additional option for noobs
      if(iprog.EQ.13 .or. iprog.EQ.14 .or. iprog.EQ.15 )then
c     &   .or. noobs .eq. 1) then
c frr (09/01) precipitation code reset, cloud option
c        call rdhd5
c ---    add npsta to calling list (080205)
ccec101006         call rdhd5 (icloud,itwprog,npsta)
         call rdhd5 (mcloud,itwprog,npsta,dxmm5)
c
c ---   write data from mm5 header records
        if(.not.ldb)go to 260
        write(io6,252)
252   format(///2x,'Data from MM5 Prognostic file header records',//)
c
        write(io6,154)ibyrm,ieyrm,ibjulm,iejulm,ibhrm,iehrm,
     :                ibsecm,iesecm
        write(io6,256)nzp
256     format(//6x,'Number of layers in the MM5 model grid: ',i2)
        write(io6,258)i1,j1,nxp,nyp
258   format(//6x,'Lower-left corner of MM5 extraction subdomain: I = ',
     1      i3/6x,'Lower-left corner of MM5 extraction subdomain: J = ',
     2      i3/6x,'Number of columns in MM5 extraction subdomain: ',i3/
     3         6x,'Number of rows in MM5 extraction subdomain: ',i3)
260     continue
c
c ---   Convert from GMT to LST
        idtz = 0 - ibtz
        call indecr(io6,ibyrm,ibjulm,ibhrm,idtz,0,23)
c
c ---   check that MM5 file begin. time <= run begin. time
c ---   if(ibyrm.gt.ibyr)then

c ---   Check with explicit times and subhourly timesteps

c ---   explicit beginning time of simulation:
        ndathrbb=ibyr*100000+ibjul*100+ibhr
c ---   ending second of beginning time step
        nsecbb=ibsec+nsecdt

c ---   time of first MM5 record (note that must be >= ending time of
c       first CALMET timestep NOT >= beginning time of simulation

        ndathrbm=ibyrm*100000+ibjulm*100+ibhrm

c ---   Seconds of MM5 first record (080205: sub-hourly in v3.x)
        call deltsec(ndathrbb,nsecbb,ndathrbm,ibsecm,ndeltas)

c       if(ndeltas.lt.0)then
        if(ndeltas.gt.0)then
           write(io6,275) ndathrbb,nsecbb,ndathrbm,ibsecm
275        format(//2x,'ERROR IN SUBR. READHD -- MM5 data does ',
     1     'not cover time period in run'/
     2     5x,'Run starting date (YYYJJJHH-SEC):',i10,'-',i5,
     2     ' (LST)'/
     3     5x,'Beginning date in file (YYYJJJHH-SEC):',i10,'-',i5,
     3     ' (LST)')
           stop
         endif
c --- No need to skip to starting point in MM5 file here,
c --- it will be done in SUBR. RDMM5
c
      endif
c
c FRR (09/2001)
      if(iprog.EQ.3 .or. iprog.EQ.4 .or. iprog.EQ.5)then 
c     &   .or. noobs .eq. 1) then
        call rdhd4(dxmm5)
c
c ---   write data from mm4 header records
        if(.not.ldb)go to 160
        write(io6,152)
152   format(///2x,'Data from MM4 Prognostic file header records',//)
c
        write(io6,154)ibyrm,ieyrm,ibjulm,iejulm,ibhrm,iehrm,
     :                ibsecm,iesecm

154   format(//6x,'Starting date:',16x,'Ending date:'/6x,9x,'Year = ',
     1  i4,17x,'Year = ',i4/10x,'Julian day = ',i3,12x,'Julian day = ',
     2  i3/11x,'Hour(GMT) = ',i3,13x,'Hour(GMT) = ',i3,
     3    /11x,'Seconds   = ',i4,13x,'Seconds   = ',i4)
        write(io6,156)nxmm4,nymm4,nzp,ptopmm4
156     format(//6x,'Number of columns in MM4 model grid: ',i3,/
     1         6x,'Number of rows in MM4 model grid: ',i3,/
     2         6x,'Number of layers in the MM4 model grid: ',i2,/
     3         6x,'Pressure levels extracted to:' ,f5.0,' mb')
        write(io6,158)i1,j1,nxp,nyp
158   format(//6x,'Lower-left corner of MM4 extraction subdomain: I = ',
     1      i3/6x,'Lower-left corner of MM4 extraction subdomain: J = ',
     2      i3/6x,'Number of columns in MM4 extraction subdomain: ',i3/
     3         6x,'Number of rows in MM4 extraction subdomain: ',i3)
160     continue
c
c ---   Convert from GMT to LST
        idtz = 0 - ibtz
        call indecr(io6,ibyrm,ibjulm,ibhrm,idtz,0,23)
c
c ---   check that MM4 file begin. time <= run begin. time
c ---   Check with explicit times and subhourly timesteps
c ---   beginning explicit time of simulation:
        ndathrbb=ibyr*100000+ibjul*100+ibhr
c ---   ending second of beginning time step
        nsecbb=ibsec+nsecdt
c ---   time of first MM4 record (note that must be >= ending time of
c       first CALMET timestep NOT >= beginning time of simulation
        ndathrbm=ibyrm*100000+ibjulm*100+ibhrm
c ---   Seconds of MM4 first record (only hourly MM4)
        nsecbm=0
c DGS   call deltsec(ndathrbb,nsecbb,ndathrbm,nsecbm,ndeltas)
        call deltsec(ndathrbm,nsecbm,ndathrbb,nsecbb,ndeltas)
        if(ndeltas.lt.0)then
c       if(ibyrm.gt.ibyr)then
           write(io6,175) ibyr,ibjul,ibhr,ibyrm,ibjulm,ibhrm
175        format(//2x,'ERROR IN SUBR. READHD -- MM4 data does ',
     1     'not cover time period in run'/
     2     5x,'Run starting date/hr: ibyr,  ibjul,  ibhr  = ',3i10,
     2     ' (LST)'/
     3     5x,'     Date/hr in file: ibyrm, ibjulm, ibhrm = ',3i10,
     3     ' (LST)')
           stop
c        else if(ibyrm.eq.ibyr.and.ibjulm.gt.ibjul)then
c           write(io6,175) ibyr,ibjul,ibhr,ibyrm,ibjulm,ibhrm
c           stop
c        else if(ibyrm.EQ.ibyr.and.ibjulm.EQ.ibjul.and.ibhrm.GT.ibhr)then
c           write(io6,175) ibyr,ibjul,ibhr,ibyrm,ibjulm,ibhrm
c           stop
        endif
c
c --- No need to skip to starting point in MM4 file here,
c --- it will be done in SUBR. RDMM4
c
      endif
c
c --- Get station ID info from overwater files
c --------------------------------------------
c
      if (nowsta .gt. 0) then
        do i = 1,nowsta
          call RDHDOW(i,ibtz)
        end do
      end if


c --- 110421- Check value of SIGMAP against DXMM5 when NPSTA=-1
c     dxmm5 < sigmap < sqrt(2)* dxmm5  (allow 5% round-off)
      if (npsta.eq.-1) then
         dxmax= (2**0.5)*dxmm5 *1.05
         if ((sigmap.lt.dxmm5).or.(sigmap.gt.dxmax)) then
            write(io6,*) 'WARNING '
            write(io6,*) 'SIGMAP RESET to SQRT(2)* MM5gridsize '
            sigmap=dxmax
         endif
      endif
            
 
      return
      end
c----------------------------------------------------------------------
      subroutine rreplac(dist2,nsta,rarr,rmiss,rdeflt,rvalue)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130            RREPLAC
c ---          J. Scire, SRC
c
c --- PURPOSE:  Replace the missing value of an REAL variable with
c               the value from the closest station with valid data --
c               If all values are missing, set variable equal to the
c               default value (RDEFLT)
c
c --- INPUTS:
c   DIST2(nsta) - real     - Distance**2 from each station to the
c                            current station with missing data
c          NSTA - integer  - Number of stations
c    RARR(nsta) - real     - Array of values at each station
c         RMISS - real     - Missing value indicator
c        RDEFLT - real     - Default value to be returned if all values
c                            are missing
c
c --- OUTPUT:
c        RVALUE - integer  - Value of the variable to be used in
c                            replacement of the missing value
c                            NOTE: if all values are missing,
c                            RVALUE is set equal to RDEFLT
c
c --- RREPLAC called by:  MISSFC
c --- RREPLAC calls:      none
c----------------------------------------------------------------------
c
      real dist2(nsta),rarr(nsta)
c
      data xmax/1.e38/
c
      dmin2=xmax
      ista=0
c
c --- Loop over stations
      do 10 i=1,nsta
c
c --- Find the closest non-missing value
      if(rarr(i).lt.rmiss)then
c
         if(dist2(i).lt.dmin2)then
            dmin2=dist2(i)
            ista=i
         endif
      endif
10    continue
c
c --- Return the appropriate value
      if(ista.ge.1)then
c
c ---    At least one station with non-missing data
         rvalue=rarr(ista)
      else
c
c ---    All values missing -- use default value
         rvalue=rdeflt
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine rsqwts(ix,jy,rsqwt)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 940930             RSQWTS
c ---          DG Strimaitis, SRC
c ---          MEF, SRC/ETCO, added separate land/water surface sites
c
c --- PURPOSE:  Compute inverse distance squared weights for all sfc.
c               and upper air locations (CALMET grid) at (ix,jy)
c
c --- INPUTS:
c
c                  ix,jy - integer    - Grid index for cell at which
c                                       weights are calculated
c
c     common/GRID/ ---
c                  DGRID - real       - Horizontal grid size (m)
c
c     common/MET1/ ---
c                  NSSTA - integer    - No. surface land wind stations
c                  NUSTA - integer    - No. upper air wind stations
c            XSSTA(MXSS) - real array - Surface station relative X
c                                       coordinate (m) (relative to grid
c                                       origin)
c            YSSTA(MXSS) - real array - Surface station relative Y
c                                       coordinate (m) (relative to grid
c                                       origin)
c            XUSTA(MXUS) - real array - Upper air station relative X
c                                       coordinate (m) (relative to grid
c                                       origin)
c            YUSTA(MXUS) - real array - Upper air station relative Y
c                                       coordinate (m) (relative to grid
c                                       origin)
c
c   common/OVRWAT/ ---
c                 NOWSTA - integer    - No. over water wind stations
c          XOWSTA(MXOWS) - real array - Surface station relative X
c                                       coordinate (m) (relative to grid
c                                       origin)
c          YOWSTA(MXOWS) - real array - Surface station relative Y
c                                       coordinate (m) (relative to grid
c                                       origin)
c
c --- OUTPUT:
c
c           RSQWT(MXWND) - real array - Inverse distance squared weights
c                                       of met station locations for ONE
c                                       grid-point in CALMET grid
c
c----------------------------------------------------------------------
c
      include 'params.met'
      include 'grid.met'
      include 'met1.met'
      include 'ovrwat.met'

      real rsqwt(mxwnd)

      data zero/0./
      dgridi=1.0/dgrid

c  Initialize array for weights
      n=mxwnd
      call XMIT(-n,zero,rsqwt)

c  Process grid cell ix,jy
c --- Note,(xusta,yusta) are relative to the SW corner of grid pt (1,1)
      xc=FLOAT(ix)-0.5
      yc=FLOAT(jy)-0.5

c  Compute the 1/r**2 weights for the surface met stations
      sumwt = 0.0
      nstat = nssta + nowsta
      do is=1,nstat
        if (is .le. nssta) then
          r2=(xssta(is)*dgridi-xc)**2 + (yssta(is)*dgridi-yc)**2
        else
          r2=(xowsta(is - nssta)*dgridi-xc)**2 +
     &       (yowsta(is - nssta)*dgridi-yc)**2
        end if
        if(r2 .LT. 1.0) then
          wt=1.0
        else
          wt=1.0/r2
        endif
        sumwt=sumwt+wt
        rsqwt(is)=wt
      enddo

c  Normalize the weights.
      sumwt=1.0/sumwt
      do is=1,nstat
         rsqwt(is)=rsqwt(is)*sumwt
      enddo

c  Compute the 1/r**2 weights for the upper air stations.
      sumwt=0.0
      do iu=1,nusta
         k=nstat+iu
         r2=(xusta(iu)*dgridi-xc)**2 + (yusta(iu)*dgridi-yc)**2
         if(r2 .LT. 1.0) then
            wt=1.0
         else
            wt=1.0/r2
         endif
         sumwt=sumwt+wt
         rsqwt(k)=wt
      enddo

c  Normalize the weights.
      sumwt=1.0/sumwt
      do iu=1,nusta
         k=nstat+iu
         rsqwt(k)=rsqwt(k)*sumwt
      enddo

      return
      end
c----------------------------------------------------------------------
      subroutine rtheta(u,v,array)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328             RTHETA
c
c --- UPDATES:
c
c --- V5.6 Level 050328 :explicit common replaced by include d6.met
c
c ---------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      include 'grid.met'
      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,irdp
      DIMENSION U(mxnx,mxny,*),V(mxnx,mxny,*)
      DIMENSION ARRAY(mxnx,mxny,*)
C
C     RTHETA PRINTS WIND FIELD SPEED AND DIRECTION
C
C     INPUTS:  U (R ARRAY) - GRIDDED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY) - GRIDDED Y-DIRECTION WIND COMPONENTS
c          array (r array) - work array to hold gridded wind
c                            speed (-,-,1) and direction (-,-,2)
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C     CONVERSION FACTOR FROM RADIANS TO DEGREES
C
      FACTOR=180./3.141592654
      DO 100 K=1,NZPRNT
      DO 50 J=1,NY
      DO 50 I=1,NX
      UU=U(I,J,K)
      VV=V(I,J,K)
      SUM =  UU**2 + VV**2
      ARRAY(I,J,1)=SQRT(SUM)
      ARRAY(I,J,2)=0.
      IF(SUM.LT.1.0E-10) GO TO 50
      ANGLE=270.-ATAN2(VV,UU)*FACTOR
      ARRAY(I,J,2)=AMOD(ANGLE,360.)
      if (array(i,j,2) .eq. 0.) array(i,j,2) = 360.
   50 CONTINUE
      if(iwr.gt.0)WRITE(IWR,60) K
      if(iwr.gt.0)WRITE(IWR,61)
      CALL WNDLPT(ARRAY(1,1,1))
      if(iwr.gt.0)WRITE(IWR,70) K
      if(iwr.gt.0)WRITE(IWR,71)
      CALL WNDLPT(ARRAY(1,1,2))
  100 CONTINUE
      RETURN
   60 FORMAT(//,5X,'WIND SPEED (M/S) AT LEVEL = ',I4)
   61 FORMAT(5X,26('-'))
   70 FORMAT(//,5X,'WIND DIRECTION (DEGREES) AT LEVEL = ',I4)
   71 FORMAT(5X,34('-'))
      END
c----------------------------------------------------------------------
      subroutine setcom(ldb)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130             SETCOM
c ---          J. Scire, SRC
c
c --- PURPOSE:  Set general model common block variables
c
c --- INPUTS:
c          LDB - logical       - Control variable determining
c                                the printing of internal arrays
c                                (useful for testing)
c       Common block /GEN/ variables:
c             irtype
c       Common block /GRID/ variables:
c             zface(mxnzp1),nx,ny,nz
c       Common block /MET1/ variables:
c             nssta,xssta(mxss),yssta(mxss),dgrid
c             nusta,xusta(mxus),yusta(mxus)
c             npsta,xpsta(mxps),ypsta(mxps)
c       Parameters: MXNX, MXNY, MXNZ, MXNZP1, MXSS, MXUS, MXPS
c
c --- OUTPUT:
c       Common block /GRID/ variables:
c             zmid(mxnz),nzp1
c       Common block /MET1/ variables:
c             nears(mxnx,mxny)
c             nearu(mxnx,mxny)
c             nearp(mxnx,mxny)
c
c --- SETCOM called by:  SETUP
c --- SETCOM calls:      OUT
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      logical ldb,ldate
      character*70 messag
c
      include 'gen.met'
      include 'grid.met'
      include 'met1.met'
c
      data rmax/1.e37/,ldate/.false./
c
c --- compute cell midpoint
      do 10 i=1,nz
      zmid(i)=0.5*(zface(i+1)+zface(i))
10    continue
c
c --- lowest grid cell midpoint must be at approx. 10 m for the
c --- computation of the micrometeorological parameters
c --- (no restrictions if only computing wind field -- irtype=0)
      if(irtype.eq.0)go to 14
      if(zmid(1).lt.9.0.or.zmid(1).gt.11.0)then
         write(io6,11)zmid(1),zface(1),zface(2)
11       format(//2x,'ERROR in SUBR. SETCOM -- height of first cell ',
     1   ' midpoint must be approx. 10 m'//2x,'zmid(1) = ',f10.2,3x,
     2   'zface(1) = ',f10.2,3x,'zface(2) = ',f10.2)
         stop
      endif
14    continue
c
      nzp1=nz+1
c
c --- find nearest surface meteorological station to each grid point
c --- and store station number in array "NEARS"
      if(nssta.le.0)go to 21
      do 20 i=1,nx
      xgdpt=(float(i)-0.5)*dgrid
      do 20 j=1,ny
      ygdpt=(float(j)-0.5)*dgrid
      dmin2=rmax
      ksv=0
c
c ---    loop over surface stations to find closest one to (I,J)
         do 12 k=1,nssta
         dist2=(xssta(k)-xgdpt)**2+(yssta(k)-ygdpt)**2
         if(dist2.lt.dmin2)then
            dmin2=dist2
            ksv=k
         endif
12       continue
c
      if(ksv.gt.0)then
         nears(i,j)=ksv
      else
         write(io6,18)i,j,ksv,'NEARS'
18       format(//1x,'ERROR IN SUBR. SETCOM -- invalid value of KSV '/
     1   5x,'I = ',i5,3x,'J = ',i5,3x,'KSV = ',i5,5x,a5)
         stop
      endif
20    continue
c
c --- write results if "debug write" switch is on
      if(ldb)then
         messag=' '
         messag(1:45)='Station number of closest surface station to '
         messag(46:60)='each grid point'
         call out(xdum,nears,2,5,ldate,messag,nx,ny)
      endif
21    continue
c
c --- find nearest upper air station to each grid point
c --- and store station number in array "NEARU"
c --- (skipped if only using MM4 data)
      if(nusta.le.0)go to 121
      do 120 i=1,nx
      xgdpt=(float(i)-0.5)*dgrid
      do 120 j=1,ny
      ygdpt=(float(j)-0.5)*dgrid
      dmin2=rmax
      ksv=0
c
c ---    loop over upper air stations to find closest one to (I,J)
         do 112 k=1,nusta
         dist2=(xusta(k)-xgdpt)**2+(yusta(k)-ygdpt)**2
         if(dist2.lt.dmin2)then
            dmin2=dist2
            ksv=k
         endif
112      continue
c
      if(ksv.gt.0)then
         nearu(i,j)=ksv
      else
         write(io6,18)i,j,ksv,'NEARU'
         stop
      endif
120   continue
c
c --- write results if "debug write" switch is on
      if(ldb)then
         messag=' '
         messag(1:47)='Station number of closest upper air station to '
         messag(48:62)='each grid point'
         call out(xdum,nearu,2,5,ldate,messag,nx,ny)
      endif
121   continue
c
c --- find nearest precipitation station to each grid point
c --- and store station number in array "NEARP"
      if(npsta.le.0)go to 221
      do 220 i=1,nx
      xgdpt=(float(i)-0.5)*dgrid
      do 220 j=1,ny
      ygdpt=(float(j)-0.5)*dgrid
      dmin2=rmax
      ksv=0
c
c ---    loop over precipitation stations to find closest one to (I,J)
         do 212 k=1,npsta
         dist2=(xpsta(k)-xgdpt)**2+(ypsta(k)-ygdpt)**2
         if(dist2.lt.dmin2)then
            dmin2=dist2
            ksv=k
         endif
212      continue
c
      if(ksv.gt.0)then
         nearp(i,j)=ksv
      else
         write(io6,18)i,j,ksv,'NEARP'
         stop
      endif
220   continue
c
c --- write results if "debug write" switch is on
      if(ldb)then
         messag=' '
         messag(1:45)='Station number of closest precip. station to '
         messag(46:60)='each grid point'
         call out(xdum,nearp,2,5,ldate,messag,nx,ny)
      endif
221   continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine setup(itest)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203              SETUP
c ---          J. Scire, SRC
c ---          MEF, SRC/ETCO added separate land/water surface sites
c
c --- PURPOSE:  setup phase of CALMET meteorological model
c
c --- UPDATES:
c
c --- V6.201 (060218) to v6.4.0 (121203)
c               - Add AUX file header output
c
c --- V6.2 (060215) to V6.201 (060218)  (DGS)
c               - add QA plot file subroutine
c
c --- V5.711 (060106) to v6.2 (060215)(F.Robe)
c                - Replace hour-ending times by explicit beg/ending times
c                - Remove irlg from calling list to readhd
c                - Pass nsecdt to microi 
c
c --- V5.6 (050328) to V5.711 (060106) (F.Robe)
c               - Add nigf to READCF and WRFIL calling lists
c
c --- V5.547 (041010)  to V5.6 (050328)  (F.Robe)
c               - add Z0 calling list to DIAGI
c               - Call to new subroutine SETCOAST to compute distance 
c                 to nearest shore
c               - Explicit common replaced by include d1.met 
c
c --- V5.543 (031215) to V5.547 (041010) (FRR)
c                - Modify calling list to subroutine READCF (nm3d)
c
c --- V5.5 (030402) to V5.543 (031215)  (DGS)
c               - Place SETCOM after READHD as station locations may
c                 be read from headers
c --- V5.4 (960521) to V5.5 (030402)  (DGS)
c               - Add structures to pass control file image and other
c                 inputs to header of CALMET.DAT
c
c --- INPUTS:
c          ITEST - integer - Flag indicating if execution is to
c                            include COMPUTATIONAL phase
c                            (ITEST = 1 to STOP program after
c                                       SETUP phase,
c                             ITEST = 2 to CONTINUE execution to
c                                       include computations)
c
c ---      Parameters:
c                   MXNX, MXNY, MXNZ, MXNZP1, MXSS, MXUS, MXPS,
c                   MXLU, MXOWS
c          Common block /MET1/ variables:
c                   NUSTA
c          Common block /OVRWAT/ variables:
c                   NOWSTA
c
c --- SETUP called by:  Main
c --- SETUP calls:      COMLINE, DATETM, READFN, WRFILES,
c                       READCF, OPENOT, READGE, SETCOM, READHD, MICROI,
c                       DIAGI, OUTHD, OUTPC1, RDWT, TFERCF, QAPLOT1
c --- v6.4.0, Level 121203
c ---                   OUTAUXHD
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      integer idiopt(5)
      character*80 title(3)
c
      include 'gen.met'
      include 'grid.met'
      include 'met1.met'
      include 'metpac.met'
      include 'geo.met'
      include 'outpt.met'
      include 'qa.met'
      include 'filnam.met'
      include 'flags.met'
      include 'wtgrd.met'
      include 'ovrwat.met'
c
      include 'd1.met'
c      COMMON /D1/ U(mxnx,mxny,mxnz),V(mxnx,mxny,mxnz),
c     1  W(mxnx,mxny,mxnzp1), UB(mxny,2,mxnz), VB(mxnx,2,mxnz),
c     1  USLOPE(mxnx,mxny,mxnz),  VSLOPE(mxnx,mxny,mxnz),
c     1  UG(mxnx,mxny,mxnz),  VG(mxnx,mxny,mxnz),
c     1  HTOPO(mxnx,mxny), HMAX(mxnx,mxny),
c     1  UTMXST(mxwnd), UTMYST(mxwnd), WT(mxwnd),
c     1  RS(mxwnd), IS(mxwnd), IST(mxwnd), JST(mxwnd),
c     1  US(mxnz,mxwnd), VS(mxnz,mxwnd),
c     1  CELLZB(mxnzp1), CELLZC(mxnz),
c     1  PEXP(7), FEXTRP(mxnz), DIV(mxnx,mxny,mxnz),
c     1  NINTRP(mxnz)
c
c --- Get date and time from system
      call datetm(rdate,rtime,rcpu)
c
c --- Get the name of the control file from the command line
      call comline(metinp)
c
c --- Open the control file
      open(io5,file=metinp,status='old')
c
c --- Read control file inputs
      call readcf(idiopt,title,iprog,itest,nm3d,nigf,igfmet)
c
c --- Pass image of CALMET control file to scratch file
      call TFERCF
c
c --- Write the files used in this run to the list file
      call wrfiles(nm3d,nigf)
c
c --- Open I/O files other than the control & list files
      call openot
c
c --- Read and write QA information to plot files (SEA.DAT locations)
      if(iqaplot.EQ.1) call QAPLOT1(ibtz)
c
c --- Read geophysical data
      call readge(ldb)

c --- Read header records of input met. data files & find proper
c --- starting point in each file (surface data file, precip. data
c --- file, upper air data file, over water file)
c     call readhd(ibyr,ibjul,ibhr,ibtz,irlg,ldb,idiopt,iprog,igfmet)
      call readhd(ibyrn,ibjuln,ibhrn,ibsecn,ieyrn,iejuln,iehrn,iesecn,
     :            ibtz,nsecdt,ldb,idiopt,iprog,igfmet)

c
c --- Set general model common block parameters
      call setcom(ldb)
c
c --- Set-up computations for micrometeorological module
      call microi(nsecdt)
c
c --- Wind field module set-up
      call diagi(elev,z0,nowsta)
c
c --- Write header records of output file
      if(lsave)then
        if(iformo.eq.1)then
c
c ---      CALMET-formatted output file
           call outhd

c --- v6.4.0, Level 121203
           if(iauxlwc.EQ.1) call OUTAUXHD
c ---      Done with scratch file
           close(iox)

        else if(iformo.eq.2)then
c
c ---      MESOPAC II-formatted output file
           ilwf=2
           iuwf=4
           vk=0.4
c ---      Compute coordinates in MESOPAC II met. grid units
           shift=dgrid/2.
c
c frr (09/01)noobs
           if (noobs.ne.2) then
             do 10 i=1,nssta
               xscoor(i)=(xssta(i)-shift)/dgrid+1.0
               yscoor(i)=(yssta(i)-shift)/dgrid+1.0
10           continue
           endif
c
           if (nusta .gt.0) then
             do 20 i=1,nusta
               xucoor(i)=(xusta(i)-shift)/dgrid+1.0
               yucoor(i)=(yusta(i)-shift)/dgrid+1.0
20           continue
           end if
c
           call outpc1(ldb,ibyr,ibjul,irlg,nssta,nusta,nx,ny,ibtz,
     1     ilwf,iuwf,dgrid,vk,xscoor,yscoor,xucoor,yucoor,z0,nears,
     2     ilandu)
         endif
      endif
c
c --- Read sigma weighting factors if using prognostic data (IPROG=3/13 or
c --- 5/15) -- otherwise fill in default values
c frr (09/01) - pass on noobs: no need for weight if no observations
c      call rdwt(iprog,cellzc)
      call rdwt(noobs,iprog,cellzc)

c --- frr 050328
c --- Set coastal variables (compute distance to coast)
      call setcoast(ilandu,iwat1,iwat2,ldbcst)
c
      return
      end
c----------------------------------------------------------------------
      subroutine similt(zzanem,el,z0,zi,ns,ipsifcn,us,vs,zimini)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070717             SIMILT
c ---          M. Fernau, J. Scire    EARTH TECH
c
c --- PURPOSE: Extrapolate surface wind speed and direction aloft using
c              the method of Van Ulden and Holtslag (J. Climate & Appl.
c              Meteor., vol 24, pp. 1196-1207, 1985)
c
c --- UPDATES:
c --- v5.612 (051214) to v6.3 (070717)
c          - add new control variable IPSIFCN to select call to PSIU
c            functions
c
c   - V5.6 (050328) to v5.612 (051214) (DGS-FRR)
c          - use double precision argument for psiud
c
c --- V5.5 (030402) to V5.6 (050328) (FRR)
c          - Update similarity profiles using COARE consistent stability
c            functions (Paulson (1970) and Dyer (1974) for the unstable
c            surface layer,coupled with a free convection relation for 
c            large z/L  (Gratchev et al, 2000) and new relations for stable
c            atm (Beljaars and Holtslag, 1991)
c            => use COARE stabitily functions PSIU and PSIT except for
c            Dyer's fit correction (PSIUD/PSITD)
c 
c --- V5.4 (970825) to V5.5 (030402)  (DGS)
c           - /MAP/ replaces /LON/
c
c --- Changes: F. Robe - 5/97
c              Replace the arbitrary 200m height for extrapolation
c              by user-selected minimum mixing height 
c
c ---          J. Scire, J. Chang (8/97)
c              Add restrictions to Monin-Obukhov length < 5 z0
c
c --- INPUTS:
c             ZZANEM - real       - station anemometer height (m)
c                 EL - real       - Monin-Obukhov length (m)
c                 Z0 - real       - roughness length (m)
c                 ZI - real       - mixing height (m)
c                 NS - integer    - Index of station in surface array
c                                   stability correction for wind
c                                   profile
c                                  (IPSIFCN=0 use CALMET v5.6;
c                                   IPSIFCN=1 use CALMET v5.53)
c     US(MXNZ,MXWND) - real array - U component (m/s) of observed winds
c                                   k=1 corresponds to anemometer height
c     VS(MXNZ,MXWND) - real array - V component (m/s) of observed winds
c                                   k=1 corresponds to anemometer height
c             ZIMINI - real       - Lower bound on mixing height 
c
c        Common block /GRID/
c           nx,ny,nz,nzp1,dgrid,zface,zmid
c        Common block /MAP/
c           xlat1
c        Parameters: mxnx,mxny,mxnz,mxwnd
c
c --- OUTPUT:
c
c     US(MXNZ,MXWND) - real array - U component (m/s) of observed winds
c                                   with surface extrapolation
c                                   k=1 corresponds to first CALMET level
c     VS(MXNZ,MXWND) - real array - V component (m/s) of observed winds
c                                   with surface extrapolation
c                                   k=1 corresponds to first CALMET level
c
c --- SIMILT called by:  ELUSTR2, WATER2, WIND1
c --- SIMILT calls:      function PSIUD, PSIUC
c----------------------------------------------------------------------
c
      include 'params.met'
      include 'grid.met'
      include 'map.met'
      dimension us(mxnz,mxwnd),vs(mxnz,mxwnd)
      real eltbli(9)
      real dhtbl2(9)
      real*8 psiud,r8

c --- Factor = 180 degrees / pi
      data d1/1.58/,d2/1.0/,factor/57.2957795/
c --- Values from Table 2, Van Ulden & Holtslag (1985)
      data ztbl2 /200./
c --- Values of L from van Ulden & Holtslag (ELTBL2)
c *** data eltbl2 /-30.,-100.,-370.,10000.,350.,130.,60.,20.,9./
c --- Values of 1/L (ELTBLI)
      data eltbli/-0.03333333,-0.01,-0.0027027,0.0,0.002857,0.007692,
     1  0.0166667,0.05,0.1111111/
      data dhtbl2 /12.,10.,9.,12.,18.,28.,35.,38.,39./

c
c --- Restrict Monin-Obukhov length to be at least 5*z0
      eladj=el
      if(abs(eladj).lt.5.*z0)then
         if(eladj.lt.0.)then
            eladj=-5.0*z0
         else
            eladj=5.0*z0
         endif
      endif
c
c --- Convert M-O length to 1/L (neutral = 0)
      if (abs(eladj) .ge. 10000.) then
        elinv = 0.
      else
        elinv = 1. / eladj
      end if
c
c --- Recover anemometer (not surface) wind speed and direction
      ws1 = sqrt(us(1,ns) **2 + vs(1,ns) **2)
      angle = 270. - atan2(vs(1,ns),us(1,ns)) * factor
      wd1 = amod(angle,360.)
      if (wd1 .eq. 0.) wd1 = 360.
c --- Calculate ln(z1/z0) and stability function psi-m(z1/L) at
c     anenometer height (not at CALMET level 1)050328
c     xlnz1z0 = alog(zmid(1) / z0)
      xlnz1z0 = alog(zzanem / z0)

      if (abs(elinv) .lt. .00005) then
c --- Neutral
        psim1 = 0.

      else
c       stable or unstable

c       050328: use new profiles (COARE) for stable and unstable atm
c       at this point ws is at zzanem (instead of zmid(!))

c        psim1 = PSIUD(zzanem/eladj)
        if(ipsifcn.EQ.0) then
           r8=zzanem/eladj
           psim1  = PSIUD(r8)
        elseif(ipsifcn.EQ.1) then
           psim1  = PSIUC(zzanem,eladj,16)
        else
           write(io6,*)'ERROR in SIMILT:  invalid IPSIFCN'
           write(io6,*)'  Expected IPSIFCN = 0 or 1'
           write(io6,*)'     Found IPSIFCN = ',ipsifcn
           stop 'ERROR in SIMILT -- see list file'
        endif

      endif

c     else if (elinv .gt. 0) then
c --- Stable
c       psim1 = -17. * (1. - exp(-0.29 * zmid(1) / eladj))
c      else
c --- Unstable
c       x = (1. - 16. * zmid(1) / eladj) ** .25
c       psim1 = 2. * alog((1. + x) * .5) + alog((1. + x * x) * .5)
c     &       - 2. * atan(x) + 1.5707963
c      end if

c --- Calculate turning angle D(h) using z = 200 m.
      if (abs(elinv) .lt. .00005) then
c --- Neutral
        dh200 = dhtbl2(4)
      else
c --- Interpolate from Table 2 values
        do i = 1,9
          if (eltbli(i) .ge. elinv) then
            if (i .eq. 1) then
              dh200 = dhtbl2(1)
            else
              dh200 = dhtbl2(i-1) +
     &                (dhtbl2(i) - dhtbl2(i-1)) *
     &                (elinv - eltbli(i-1)) /
     &                (eltbli(i) - eltbli(i-1))
            end if
            goto 1
          end if
        end do
        dh200 = dhtbl2(9)
      end if
 1    continue
c --- Calculate turning angle at anemometer height
      dzan = dh200 * d1 * (1. - exp(-d2 * zzanem / ztbl2))
c
c --- Loop over all levels above surface (including level 1 - 050328)
c     do k = 3,nzp1
      do k = 2,nzp1

c --- FRR (5/97): extrapolate below mixing height (no arbitrary 200m min)
c ---   if (zface(k) .le. amax1((zi + .001),200.)) then
        if (zface(k) .le. amax1((zi + .001),zimini)) then

          xlnzz0 = alog(zmid(k-1) / z0)
          if (abs(elinv) .lt. .00005) then
c ---       Neutral
            psim = 0.
          else
c ---       stable or unstable - use COARE-like PSIU functions (050328-frr)
c           psim=PSIUD(zmid(k-1)/eladj)
            if(ipsifcn.EQ.0) then
               r8=zmid(k-1)/eladj
               psim  = PSIUD(r8)
            elseif(ipsifcn.EQ.1) then
               psim  = PSIUC(zmid(k-1),eladj,16)
            else
               write(io6,*)'ERROR in SIMILT:  invalid IPSIFCN'
               write(io6,*)'  Expected IPSIFCN = 0 or 1'
               write(io6,*)'     Found IPSIFCN = ',ipsifcn
               stop 'ERROR in SIMILT -- see list file'
            endif
          endif

c --- Apply wind speed adjustment, eqn 52 of Van Ulden & Holtslag (1985)

          ws = ws1 * (xlnzz0 - psim) / (xlnz1z0 - psim1)
c --- Turn winds, eqn 51 of Van Ulden & Holtslag (1985)
          dwd = dh200 * d1 * (1. - exp(-d2 * zmid(k-1) / ztbl2))
          if (xlat1 .gt. 0.) then
c --- Winds veer in Northern Hemisphere
c     (Wind direction + shear between level and ground - shear between
c      anemometer and ground = WD + shear between level and anemometer)
            wd = wd1 + dwd - dzan
            if (wd .gt. 360.) wd = wd - 360.
          else
c --- Winds back in Southern Hemisphere
            wd = wd1 - dwd + dzan
            if (wd .le. 0.) wd = 360. + wd
          end if

c --- Retrieve u and v components
c --- NoteL now us(1,) vs(1,) are at zmid(1) and no longer at anemometer height
          wdrad = 0.0174533 * wd
          us(k-1,ns) = -ws * sin(wdrad)
          vs(k-1,ns) = -ws * cos(wdrad)
        else
c --> Above mixing height, exit
          goto 2
        end if
      end do
 2    continue
      return
      end
c----------------------------------------------------------------------
      subroutine slope(uslope,vslope,htopo,isurft,tinf,temp2d,hmax)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070113              SLOPE
c
c     THIS SUBROUTINE COMPUTES THE SLOPE FLOWS (U,V)
C     ACCORDING TO MAHRT's formula for shooting flows (1982)
c     THE SLOPE FLOWS ARE FUNCTION OF THE LOCAL SENSIBLE HEAT FLUX
C     AND ARE NOT COMPUTED OVER WATER
C
c --- UPDATES:
c --- V5.6 (050328) to V5.727(060828) - F.Robe
c          - Add option to use spatially varying temp2D instead of domain 
c            repreentative Tinf             
c          - Remove obsolete common /S1/
c
c --- V5.6 (050328-FRR) : explicit common replaced by include d6.met 
c
c     01/11/97 (FRR) - Slope flow parameterization according to
c                      Mahrt. Based on the local heat flux
c                      Requires new include files
c                    - Slope flow may exist in layers aloft.
c
C     INPUT:  HTOPO (R ARRAY) - GRIDDED TERRAIN HEIGHTS
c             ISURFT (I)      - Surface station number where domain 
c                               representative temperature is used from
c                               or trigger for using 2-D surface temp
c                               (ISURFT=-1; default); isurft=-2 is for
c                               domain-averaged prognostic sf temperature
C             TINF (R)        - DOMAIN REPRESENTATIVE SF TEMPERATURE
C             TEMP2D(R ARRAY) - Surface TEMPERATURE
C             HMAX (R ARRAY)  - MAXIMUM TERRAIN HEIGHTS WITHIN A
C                               GIVEN RADIUS
c --- include grid.met:
c        ZFACE(MXNX.MXNY) - real array - Grid cell face heights
c     DISTHMAX(MXNX,MXNY) - real array - Birdwise distance to the
c                                        highest peak within a radius
c                                        terrad
c     DISTHMIN(MXNX,MXNY) - real array - Birdwise distance to the
c                                        lowest valley bottom within a radius
c                                        terrad
c         HMIN(MXNX,MXNY) - real array - Altitude of the lowest valley
c                                        bottom within a radius TERRAD
c --- include geo.met:
c       ILANDU(MXNX,MXNY) -integer array - landuse category 
c          
c --- include metgrd.met:
c          QH (MXNX,MXNY) - real array - sensible heat flux 
c
c --- include params.met:
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C --- OUTPUT:  USLOPE (R ARRAY) - U-COMPONENTS OF THE SLOPE FLOW
C              VSLOPE (R ARRAY) - V-COMPONENTS OF THE SLOPE FLOW
C 
c --- SLOPE called by: DIAGNO
c     SLOPE calls: none
c -------------------------------------------------------------------------------


c --- include parameters
      include 'params.met'

c --- include GRID common block to get ZFACE and the new variable
c     DISTHMAX (birdwise distance to the highest peak)
      include 'grid.met'
c --- Include METGRID common block to get HF (sensible heat flux)
      include 'metgrd.met'
c --- Include GEO common block to get ILANDU, IWAT1,IWAT2
      include 'geo.met'

      include 'd6.met'

      DIMENSION USLOPE(mxnx,mxny,mxnz), VSLOPE(mxnx,mxny,mxnz),
     1          HTOPO(mxnx,mxny), HMAX(mxnx,mxny),temp2D(mxnx,mxny),
     2          usfc(mxnx,mxny),vsfc(mxnx,mxny)

      DATA ZERO/0./
C  rho*cp using the standard atmosphere density (1.225 kg/m3)& cp=1004J/K/kg
      data rhocp/1229.9/
c  cdk=cd+k= drag coefficient + entrainment coefficient
      data cdk/8.e-2/

C     DEFINE CONVERSION FACTORS
C
      RPD=0.017453
      DPR=57.296
C
C     INITIALIZE ARRAYS
C

      CALL XMIT(-mxxyz,ZERO,USLOPE)
      CALL XMIT(-mxxyz,ZERO,VSLOPE)
C

      DO 100 J=1,NY
      DO 100 I=1,NX

c --- No slope flow over water (iwat1 < ilandu < iwat2)
      if(ilandu(i,j).ge.iwat1.and.ilandu(i,j).le.iwat2) goto 100

c --- Use spatially varying temperature unless specifically requested
         if (isurft.gt.0.or.isurft.eq.-2) then
            temp=tinf
         else
            temp=temp2d(i,j)
         endif


      DELU=0.
      DELV=0.
C
C     CALCULATE THE TOPOGRAPHIC GRADIENTS
C
      DXI=0.5/DX
      DYI=0.5/DY
      HTOIM1=HTOPO(I,J)
      HTOJM1=HTOPO(I,J)
      IF (I .GT. 1) HTOIM1=HTOPO(I-1,J)
      IF (J .GT. 1) HTOJM1=HTOPO(I,J-1)
      HTOIP1=HTOPO(I,J)
      HTOJP1=HTOPO(I,J)
      IF (I .LT. NX) HTOIP1=HTOPO(I+1,J)
      IF (J .LT. NY) HTOJP1=HTOPO(I,J+1)
      DELHI=(HTOIP1-HTOIM1)*DXI
      DELHJ=(HTOJP1-HTOJM1)*DYI
C
C     CALCULATE THE SLOPE FLOW
C

      AALPHA=ATAN((DELHI**2+DELHJ**2)**0.5)
      IF (ABS(AALPHA) .LT. 0.009) GO TO 100
       SINALF=SIN(ABS(AALPHA))
      SINALT=(DELHI**2+DELHJ**2)**0.5
      IF (SINALT .LT. 0.) SINALT=0.


c --- Distance to the crest (downslope) or valley bottom (upslope)(dcrest)

        if (qh(i,j).lt.0.) then
           dcrest=sqrt((hmax(i,j)-htopo(i,j))**2+ disthmax(i,j)**2)
c--------- thickness of the slope flow  (hd; according to Horst-Doran, 1985)
           hd=0.05*(hmax(i,j)-htopo(i,j))
        else
c--------- thickness of the slope flow  (hd; according to Horst-Doran, 1985)
           hd=0.05*(htopo(i,j)-hmin(i,j))
           dcrest=sqrt((htopo(i,j)-hmin(i,j))**2+ disthmin(i,j)**2)
        endif

       if (hd.le.0.05) then
          uvally=0.
       else
c ---  Downslope
          if (qh(i,j).lt.0.)then
c ---------- bound on slope
             sinalf=min(sinalf,(hmax(i,j)-htopo(i,j))/dcrest)
c
             tempmef = -dcrest * cdk / hd
             tempmef=amax1(tempmef,-50.)
             UVALLY=-(sinalf*(9.81/temp)*abs(qh(i,j))*dcrest/rhocp/cdk)
     1              **(1./3.)*(1-exp(tempmef))**(1./3.)
          else
c ---  Upslope
             UVALLY=((9.81/temp)*abs(qh(i,j))*
     1                (htopo(i,j)-hmin(i,j))/rhocp)**(1./3.)
          endif
       endif

c
C     SET UP DRAINAGE VECTOR DIRECTIONS
C
      IF (DELHI .EQ. 0.) THEN
        IF (DELHJ .EQ. 0.) GO TO 100
        IF (DELHJ .LT. 0.) THET=270.
        IF (DELHJ .GT. 0.) THET=90.
      ELSE
        THETP=ATAN(DELHJ/DELHI)*DPR
      ENDIF
      IF (DELHI .LT. 0.) THET=THETP+180.
      IF (DELHI .GT. 0.) THEN
        IF (DELHJ .GT. 0.) THEN
          THET=THETP
        ELSE
          THET=THETP+360.
        ENDIF
      ENDIF
      IF (THET .GE. 0. .AND. THET .LE. 90.) THETD=90.-THET
      IF (THET .GT. 90. .AND. THET .LE. 360.) THETD=450.-THET
C
C     RESOLVE SLOPE FLOW INTO COMPONENTS
C
      ANG=(270.-THETD)*RPD
      DELU=-COS(ANG)*UVALLY
      DELV=-SIN(ANG)*UVALLY
C

C     SET UP USLOPE AND VSLOPE ARRAYS
c     Determine the layers affected by the slope flow
      do 111 k=1,nz
         if (hd.gt.zface(k+1)) then
            uslope(i,j,k)=delu
            vslope(i,j,k)=delv
         else if (hd.gt.zface(k)) then
            ratio=(hd-zface(k))/(zface(k+1)-zface(k))
            uslope(i,j,k)=delu*ratio
            vslope(i,j,k)=delv*ratio
         endif
111   continue                                          

C

  100 CONTINUE
C
C     PRINT OUT SLOPE WIND COMPONENTS at the surface
C
      DO 110 J=1,NY
      DO 110 I=1,NX
      USFC(I,J)=USLOPE(I,J,1)
      VSFC(I,J)=VSLOPE(I,J,1)
  110 CONTINUE
C
      if(iwr.gt.0)WRITE(IWR,1010)
      if(iwr.gt.0)WRITE(IWR,1020)
      CALL WNDLPT(USFC)
      if(iwr.gt.0)WRITE(IWR,1030)
      if(iwr.gt.0)WRITE(IWR,1020)
      CALL WNDLPT(VSFC)
C
 1010 FORMAT(/,5X,'X-COMPONENT OF SLOPE WIND (U) AT THE SURFACE')
 1020 FORMAT(5X,44('-'))
 1030 FORMAT(/,5X,'Y-COMPONENT OF SLOPE WIND (V) AT THE SURFACE')
      RETURN
      END
c----------------------------------------------------------------------
      subroutine smooth(u,v,ub,vb,nsmth)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 950201             SMOOTH
c ---          S. DOUGLAS, SAI
c ---          changes by M. Fernau, Earth Tech, to make NSMTH a
c              user-defined array
c
c --- include parameters
      include 'params.met'
      include 'breez.met'
      DIMENSION U(mxnx,mxny,*),V(mxnx,mxny,*),
     1          UB(mxny,2,*),VB(mxnx,2,*),nsmth(mxnz)
c NEW -frr (12/96) D5 replaced by grid.met
      include 'grid.met'
c      COMMON /D5/ NX,NY,NZ,DX,DY,dz(mxnz),NZPRINT
C
C     APPLIES SMOOTHING TO INTERPOLATED FILEDS
C
C    INPUTS:  U (R ARRAY)  - GRIDDED X-DIRECTION WIND COMPONENTS
C             V (R ARRAY)  - GRIDDED Y-DIRECTION WIND COMPONENTS
C             UB (R ARRAY) - U-COMPONENT BOUNDARY VALUES
C             VB (R ARRAY) - V-COMPONENT BOUNDARY VALUES
C          NSMTH (I ARRAY) - NUMBER OF SMOOTHING PASSES FOR ALL
C                            LAYERS
c        Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C     OUTPUTS:  U (R ARRAY)  - SMOOTHED X-DIRECTION WIND COMPONENTS
C               V (R ARRAY)  - SMOOTHED Y-DIRECTION WIND COMPONENTS
C
      DO 10 K=1,NZ
      DO 20 N=1,NSMTH(K)
C
C     SMOOTH SURFACE LAYER ONLY TWICE
c     (deleted by MEF, 950201, block data default for k=1 is 2)
C
c     IF (K .EQ. 1 .AND. N .GT. 2) GO TO 10
      DO 30 J=1,NY
      DO 30 I=1,NX
c  no smoothing inside lake breeze box
      if (llbreze) then
         if (k.eq.1)then
            do 90 ibx=1,nbox
            call box(ibx,float(i),float(j),ok)
            if (ok.gt.0.00)goto 30
90          continue
         endif
      endif
      IP1=I+1
      JP1=J+1
      IM1=I-1
      JM1=J-1
      UIM1=UB(J,1,K)
      IF (I .GT. 1) UIM1=U(IM1,J,K)
      UJM1=U(I,J,K)
      IF (J .GT. 1) UJM1=U(I,JM1,K)
      VIM1=V(I,J,K)
      IF (I .GT. 1) VIM1=V(IM1,J,K)
      VJM1=VB(I,1,K)
      IF (J .GT. 1) VJM1=V(I,JM1,K)
      UIP1=UB(J,2,K)
      IF (I .LT. NX) UIP1=U(IP1,J,K)
      UJP1=U(I,J,K)
      IF (J .LT. NY) UJP1=U(I,JP1,K)
      VIP1=V(I,J,K)
      IF (I .LT.NX) VIP1=V(IP1,J,K)
      VJP1=VB(I,2,K)
      IF (J .LT. NY) VJP1=V(I,JP1,K)
C
      U(I,J,K)=0.5*U(I,J,K)+0.125*(UIP1+UIM1+UJP1+UJM1)
      V(I,J,K)=0.5*V(I,J,K)+0.125*(VIP1+VIM1+VJP1+VJM1)
   30 CONTINUE
   20 CONTINUE
   10 CONTINUE
      RETURN
      END
c----------------------------------------------------------------------
      subroutine cloud3(nx,ny,rh,ccgrid)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 030119             CLOUD3
c ---          F.Robe, Earth Tech Inc.
c
c --- PURPOSE:  Calculate cloud cover based on the prognostic
c               relative humidity at ~ 850mb
c               After Teixeira (Monthly Weather Review, 2001)
c
c --- INPUTS:
c                   RH - real array   - prognostic rel. humidity
c                                       on calmet grid at 850 mb
c
c --- OUTPUTS:
c               CCGRID - real  array     - gridded cloud fraction



c       Common block variables:
c       Parameters:

c --------------------------------------------------------------------
c
      include 'params.met'

      real    ccgrid(mxnx,mxny),rh(mxnx,mxny)

c --- Teixera formula for cloud cover A   (for rh < 1)
c --- A = (D/K)*(l/qs)*( -1 + sqrt(1+4*(K/D)*(qs/l)*(1-rh)) ) / (2*(1-rh))
c --- where D : detrainment rate (4.e-06 s-1)
c ---       K : erosion coefficient (1e-06 s-1)
c ---       l : liquid water content
c ---       qs: saturation specific humidity
c --- Based on observations reported in Teixera, we assume qs/l=100.
c --- Note that A=0.18 even when RH=0 (overestimate light cloud cover)
c --- unless corrected by qc value
c
   
      do 10 j=1,ny
      do 10 i=1,nx

         if (rh(i,j).ge.99.) then
            ccgrid(i,j)= 1.
         else
            rhd = rh(i,j)/100.
            ccgrid(i,j)= 0.02*( -1 + sqrt(1.+100.*(1.-rhd)) ) / (1.-rhd)
         endif         

10    continue

      return
      end
c----------------------------------------------------------------------
      subroutine cloud4 (nxp,nyp,nlev,rh,prs,zp,ccp,ceil4)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070327             CLOUD4
c ---          F.Robe, TRC
c
c --- PURPOSE:  Calculate cloud cover based on the prognostic
c               relative humidity following MM5toGrads algorithm
c               (calcclfr) and ceiling height
c
c --- UPDATES:
c --- V6.220 (070206) to V6.221(070327) (Zhong Wu and F. Robe)
c        (1) Initialize cloud fraction arrays and indices in CLOUD4
c    
c --- Version 6.217 Level 061230 to Version 6.220 Level 070206 (F.Robe)
c        (1) compute ceiling height index
c
c     
c --- INPUTS: 
c               NXP,NYP,NLEV  - integer      - number of progn. gridpoints
c
c      RH(mxnxp,mxnyp,mxnzp)  - real array   - prognostic rel. humidity on MM5 grid
c                                         
c     pRS(mxnxp,mxnyp,mxnzp)  - real array   - prognostic pressure on MM5 grid
c
c      ZP(mxnxp,mxnyp,mxnzp)  - real array   - altitude above ground of prognostic
c                                              levels (on MM5 grid)
c
c
c --- OUTPUTS:
c         CCP(mxnxp,mxnyp)   - real array    - total cloud fraction on MM5 grid
c                         
c         CEIL4(mxnxp,mxnyp) - real array    - ceiling height(m)
c                        
c
c
c --- CLOUD4 called by: RDMM4, RDMM5
c
c --- CLOUD4 calls:none
c
c --------------------------------------------------------------------
c
      include 'params.met'

      real prs(mxnxp,mxnyp,mxnzp),rh(mxnxp,mxnyp,mxnzp)
      real clfrlo(mxnxp,mxnyp),clfrmi(mxnxp,mxnyp),clfrhi(mxnxp,mxnyp)
      real ccp(mxnxp,mxnyp),ceil4(mxnxp,mxnyp),zp(mxnxp,mxnyp,mxnzp)

c --- NOTES (F.Robe)
c --- prs: pressure in mb (!! not in Pascals as in original 
c          MM5tograds algorithm- FActor 100)
c --- k in CALMET increases from surface to upper levels, in MM5, it is
c          the other way around => change looping  order/
c --- rh: relative humidity (%)
c

      do i=1,nxp
      do j=1,nyp

C ---   Initialize cloud arrays (070327)
        clfrlo(i,j)=0.
        clfrmi(i,j)=0.
        clfrhi(i,j)=0.

c ---   initialize cloud levels (070327)
        kclo=nlev+1
        kcmd=nlev+1
        kchi=nlev+1

        do k=nlev,1,-1  
          if(prs(i,j,k).lt. 970.)kclo=k
          if(prs(i,j,k).lt. 800.)kcmd=k
          if(prs(i,j,k).lt. 450.)kchi=k
        enddo
        do k=1,nlev
          IF(K.GE.KCLO.AND.K.LT.KCMD)clfrlo(i,j)=
     &              AMAX1(RH(i,j,k),clfrlo(i,j))
          IF(K.GE.KCMD.AND.K.LT.KCHI)clfrmi(i,j)=
     &              AMAX1(RH(i,j,k),clfrmi(i,j))
          IF(K.GE.KCHI)clfrhi(i,j)=
     &             AMAX1(RH(i,j,k),clfrhi(i,j))
        enddo

        clfrlo(i,j)=4.0*clfrlo(i,j)/100.-3.0
        clfrmi(i,j)=4.0*clfrmi(i,j)/100.-3.0
        clfrhi(i,j)=2.5*clfrhi(i,j)/100.-1.5

c ---   Low, medium, high cloud fraction (MM5toGrads) 
        clfrlo(i,j)=amin1(clfrlo(i,j),1.0)
        clfrlo(i,j)=amax1(clfrlo(i,j),0.0)
        clfrmi(i,j)=amin1(clfrmi(i,j),1.0)
        clfrmi(i,j)=amax1(clfrmi(i,j),0.0)
        clfrhi(i,j)=amin1(clfrhi(i,j),1.0)
        clfrhi(i,j)=amax1(clfrhi(i,j),0.0)

 
c ---   Ceiling height CALMET): mid level of lowest layer with cloud
c       fraction >=0.5 (or with the largest cloud fraction <0.5)       
c
        if (clfrlo(i,j).ge.0.5)then
             kceil=kclo +(kcmd-kclo)/2
	else if (clfrmi(i,j).ge.0.5)then
             kceil=kcmd+(kchi-kcmd)/2
	else if (clfrhi(i,j).ge.0.5)then
             kceil=kchi
        else if (clfrlo(i,j).ge.clfrmi(i,j).and.
     :           clfrlo(i,j).ge.clfrhi(i,j)) then
             kceil=kclo+(kcmd-kclo)/2
        else if (clfrmi(i,j).ge.clfrlo(i,j).and.
     :           clfrmi(i,j).ge.clfrhi(i,j)) then
             kceil=kcmd+(kchi-kcmd)/2
        else
             kceil=kchi  
        endif 
 
c ---   Total cloud fraction (CALMET variable, not in MM5toGrads)
        ccp(i,j)=max(clfrlo(i,j),clfrmi(i,j),clfrhi(i,j))   

c ---   Ceiling height (0 if clear sky)
c ---   (CALMET variable, not in MM5toGrads)
        if (ccp(i,j).gt.1.e-09.and.kceil.le.nlev) then
           ceil4(i,j)=zp(i,j,kceil)
        else
           ceil4(i,j)=0.
        endif

          
      enddo
      enddo

      return
      end

c----------------------------------------------------------------------
      subroutine solar(njul,ibtz,sinalp)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060215              SOLAR
c ---          J Scire, SRC
c              Modified by F.Robe, Earth Tech, Inc.
c
c --- PURPOSE:  Calculate sin(solar elevation angle) at all
c               gridpoints (in "base time zone" time)
c
c --- UPDATES:
c --- V5.6 (050328) to v6.2 (060215) (FRR)
c               - Compute 26 hourly values of sinalp at the 1/2h.
c                 Sinalp array goes from 1 to 26 , corresponding to LST times
c                 23:30 previous day to 0:30 next day.
c               - Keep negative values of sinalp for linear interpolation
c
c --- V5.5 (030402) to V5.6 (050328)  (FRR)
c             (1) Latitudes and longitudes are no longer computed in SOLAR
c                 but passed via Common GRID (computed in microi at setup)
c                 Note in COMMON GRID: East longitudes (not West long.)
c
c --- V5.4 (030119) to V5.5 (030402)  (DGS)
c               - Replace UTM/LLC conversion with COORDS (GLOBE1,GLOBE)
c
c --- INPUTS:
c                  NJUL - integer    - Julian day number
c                  IBTZ - integer    - Base time zone (5=EST, 6=CST,
c                                      7=MST, 8=PST)
c
c
c --- VIA GRID.MET: gridded N. latitude and E.longitude 
c         xlat(mxnx,mxny),xlon(mxnx,mxny)
c
c --- OUTPUT:
c       SINALP(MXNX,MXNY,26) - real array - Sine of the solar elevation
c                                           angle at all gridpoint for
c                                           each hour of the day
c 
c
c --- SOLAR called by:  COMP
c --- SOLAR calls:     none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'grid.met'

c --- 050328: variables from met1.met are no longer used in SOLAR
c     (nothing new but just clean-up)
c     include 'met1.met'
c

c     real sinalp(mxnx,mxny,24)
      real sinalp(mxnx,mxny,26)
c --- All mapping variables defined outside of SOLAR


c --- constant 0.9856479 = 360./365.242
c
      d = (float(njul) -1.) * 0.9856479
      radd = 0.0174533 * d
      xsind = sin(radd)
      xcosd = cos(radd)
      rad2d = 2. * radd
      sin2d = sin(rad2d)
      cos2d = cos(rad2d)
      em = 12. + 0.12357 * xsind - 0.004289 * xcosd + 0.153809
     &     * sin2d + 0.060783 * cos2d
      sigma = 279.9348 + d + 1.914827 * xsind - 0.079525 * xcosd
     &        + 0.019938 * sin2d - 0.00162 * cos2d
      sincd = 0.39784989 * sin(0.0174533 * sigma)
      capd = asin(sincd)
      coscd = cos(capd)
c
c --- calculate sine of solar elevation angles for each gridpoint
c
      do 100 j=1,ny
      do 100 i=1,nx
        radlat = 0.0174533 * xlat(i,j)
        sinlat = sin(radlat)
        coslat = cos(radlat)
c
c --- constant 3.8197187 = 57.29578/15.
c
c ***   Needed only if sunrise/sunset times computed
c ***   caph = acos(-sinlat * sincd / (coslat * coscd)) * 3.8197187
c ***   dtemp = xlon(i,j) / 15. + em - ibtz
c !!!   if line above even un-commented, change sign of xlon to -xlon as
c !!!   since 050328, xlon is E.longitude (no longer W. longitude)
c
c --- sunrise/sunset not currently needed
c
c ***   tsr = dtemp - caph
c ***   tss = dtemp + caph
c ***   write(io6,*) ' sunrise: ',tsr,' sunset: ',tss
c
c --- in GMT calculation:
c --- variable 'ihr' is array subscript variable (1-24) -- actual clock
c --- time is 'ihr-1' (00-23), but want half hour later so 1-24
c --- actually represent 0:30 through 23:30 current day.
c
c --- zero negative values; these occur before sunrise or after sunset
c
c --- MOD6: compute for 26 hours from 23:30 previous day to 0:30 next day (explicit time)
c       do 30 ihr = 1,24
        do 30 ihr = 1,26
          gmt = float(ihr-1) - 0.5 + ibtz  
c ---     East longitudes since 050328 (no longer W. Longitudes_
c         solha = 15. * (gmt - em) - xlon(i,j)
          solha = 15. * (gmt - em) + xlon(i,j)
          sinalp(i,j,ihr) = sinlat * sincd + coslat * coscd
     &                       * cos(0.0174533 * solha)
c ---      Keep negative values for linear interpolation to mid time step
c          if (sinalp(i,j,ihr) .lt. 0.) sinalp(i,j,ihr) = 0.

30      continue
100   continue
      return
      end
c----------------------------------------------------------------------
      subroutine stheor(nhrz,zi,ziconv,us,vs,ns,is,js,nsurf,iupt,
ccec101006     1    itwprog,iicloud,ccgrid, rho, temp2d,rmm,qsw,qlw,
     1    itwprog,mmcloud,ccgrid, rho, temp2d,rmm,qsw,qlw,
     &    ipsifcn,isfcmet)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 101006             STHEOR
c ---          M. Fernau, Earth Tech
c ---          Modified by J. Scire to include gridded clouds
c
c --- PURPOSE:  Call routines to extrapolate surface winds aloft
c               using similarity theory
c
c --- UPDATES:
c --- V6.3 (070404) to v6.330 (101006) (CEC)
c           - Change ICLOUD into MCLOUD and ICLDOUT
c
c --- V6.218 (070113)to v6.3 (070404) 
c           - Add IPSIFCN to ELUSTR argument list
c           - Add IPSIFCN to WATER2 argument list
c           - Add IPSIFCN to WATER2P argument list
c           - Add ISFCMET to control temperature to use in ELUSTR2
c           - Add IUPT to calling list  (to pass to ELUSTR2)
c
c --- v5.612 (051214)to V6.218 (070113)(Frr)
c           - Remove iupt from calling list and from ELUSTR2 calling list
c
c     V5.611 (051113) to v5.612 (051214)(Frr)
c           - Replace call to water2p by call to water2 for surface stations
c
c             over water when itwprog<2 (bug)
c     (V5.6 Level(050328) to V5.611 (051113)(Frr)
c           - Add itwprog to calling list
c           - Call to WATER2/WATER2P depending on value of itwprog
c             (ITWPROG=2: use 3D.DAT deltaT not SEA.DAT)
c
c     (951021) to V5.6 Level(050328) (Frr)
c           - Receive and pass on imixh to water2 so that it can compute
c             the convective mixing height at the station with the
c             user-selected method and extrapolate winds accordingly
c           - Use interpolated surface temperature field temp2d
c           - Pass on short and long wave fluxes to WATER2 for COARE method 
c
c --- INPUTS:
c                   NRHZ - integer    - GMT hour (ending time)
c      ZICONV(mxnx,mxny) - real array - Convective mixing heights (m)
c                                       of previous timestep
c          ZI(mxnx,mxny) - real array - Previous timestep mixing heights (m)
c         US(MXNZ,MXWND) - real array - U component of observed winds
c         VS(MXNZ,MXWND) - real array - V component of observed winds
c                     NS - integer    - Location of station in surface
c                                       array
c                  IS,JS - integer    - Coordinates of grid cell in 
c                                       which station is located
c                  NSURF - integer    - Total # of surface sites
c                MMCLOUD - integer    - Flag indicating if gridded
c                                       cloud data are available
c                                       (2=yes, otherwise, no)
c      CCGRID(mxnx,mxny) - real array - Gridded cloud fraction
c                                       (Used only if MMCLOUD=2,3)
c         RMM(mxnx,mxny) - real array - 2D rainfall rate (at this point is only filled
c                                       if npsta=-1 (prognostic rainfall)
c         RHO(mxnx,mxny) - real array - 2D surface density
c      TEMP2D(mxnx,mxny) - real array - Surface temperature (on CALMET grid)
c         QSW(mxnx,mxny) - real array - net short wave flux at surface
c         QLW(mxnx,mxny) - real array - downward long wave flux at surface
c               IPSIFCN  - integer    - Flag controlling choice of PSI
c                                       stability correction for wind
c                                       profile
c                                      (IPSIFCN=0 use CALMET v5.6;
c                                       IPSIFCN=1 use CALMET v5.53)
c               ISFCMET  - integer    - Flag controlling surface
c                                       temperature to use in ELUSTR2
c                                      (ISFCMET=0 use full 2D;
c                                       ISFCMET=1 use surface stn if
c                                       ITPROG<2)
c
c
c
c        Common block /GRID/
c           nx,ny,nz,nzp1,dgrid,zface,zmid
c        Common block /MET1/
c           nssta, noobs ,itprog
c        Common block /MET2/
c           pres,icc,tempk
c        Common block /GEO/
c           ilandu,iwat1,iwat2,z0
c        Common block /ZIPARM/
c           fcoriol
c        Common block /HFLUX/
c           imixh
c        Parameters: mxnx,mxny,mxnz,mxwnd
c
c --- OUTPUT:
c         US(MXNZ,MXWND) - real array - U component of observed winds
c                                       with surface extrapolation
c         VS(MXNZ,MXWND) - real array - V component of observed winds
c                                       with surface extrapolation
c
c --- STHEOR called by:  DIAGNO
c --- STHEOR calls:      ELUSTR2, WATER2
c----------------------------------------------------------------------
c
      include 'params.met'
      include 'met1.met'
      include 'met2.met'
      include 'geo.met'
      include 'ziparm.met'
      include 'grid.met'
      include 'hflux.met'

      real us(mxnz,mxwnd),vs(mxnz,mxwnd)
      real ziconv(mxnx,mxny),zi(mxnx,mxny)
      real ccgrid(mxnx,mxny), rmm(mxnx,mxny)
      real temp2d(mxnx,mxny),rho(mxnx,mxny)
      real qsw(mxnx,mxny),qlw(mxnx,mxny)

c
 
      if (ns .gt. nssta) then
c ---   Treat SEA#.DAT station as water
c ---   frr 050328 (additional parameters passed on to water2 for COARE method)
c       actual anenometer height is already in WATER2 (via common)
        zzanem=9999.
        if (itwprog.eq.2) then
          call water2p(us,vs,is,js,ns,zzanem,imixh,fcori(is,js),nsurf,
     :            zi(is,js),qsw(is,js),qlw(is,js),rmm(is,js),nhrz,
     :            dcoast(is,js),ipsifcn)
        else
          call water2(us,vs,is,js,ns,zzanem,imixh,fcori(is,js),nsurf,
     :            zi(is,js),qsw(is,js),qlw(is,js),rmm(is,js),nhrz,
     :            dcoast(is,js),ipsifcn)
        endif
      else if (ilandu(is,js) .ge. iwat1 .and. ilandu(is,js)
     &         .le. iwat2) then
c ---    If SURF.DAT station but cell is water, treat as water
c ---    050328: pass on station anemometer height for proper extrapolation
         if (itwprog.eq.2) then
           call water2p(us,vs,is,js,ns,zanem(ns),imixh,fcori(is,js),
     :        nsurf,zi(is,js),qsw(is,js),qlw(is,js),rmm(is,js),nhrz,
     :              dcoast(is,js),ipsifcn)
         else
           call water2(us,vs,is,js,ns,zanem(ns),imixh,fcori(is,js),
     :          nsurf,zi(is,js),qsw(is,js),qlw(is,js),rmm(is,js),nhrz,
     :              dcoast(is,js),ipsifcn)
         endif
      else
c ---    Treat as land station
c ---    frr 021105: allow noobs mode (and also itprog=2)
c ---    frr 050328: pass station anemometer height to elustr2
c ---    and use temp2d rather than tempk/tprog
c ---    TEMP2D here is either the fully conditioned 2D field
c ---    or the 2D field from either the prognostic data or the
c ---    nearest surface station
         if(isfcmet.EQ.0 .OR. itprog.EQ.2) then
            temp=temp2d(is,js)
         elseif(isfcmet.EQ.1) then
            temp=tempk(ns)
         endif

         call elustr2(ziconv,us,vs,ns,zanem(ns),is,js,icc,iupt,
ccec101006     1   iicloud,itprog,ccgrid,zi,temp,rho(is,js),ipsifcn)
     1   mmcloud,itprog,ccgrid,zi,temp,rho(is,js),ipsifcn)
      end if
      return
      end
c----------------------------------------------------------------------
      subroutine temp3d(nyrze,njulze,nhrze,nsece,temp2d,ziconv,
     1                  tzgraa,tzgrbb,ztemp,zi,tprog)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 090511             TEMP3D
c ---          R. Yamartino, SRC
c ---          Modified by J. Scire to allow for missing data (900810)
c ---          Modified by M. Fernau to allow for 1/Radius weighting
c ---            and different treatment of land vs. water (940912)
c ---          Modified for MM4 data only; no UPn.DAT (941101)
c ---          Modified to have radius of influence and maximum number
c ---            of stations in surface interpolation (950321)
c ---          Modified by F.Robe to get 3D temp from prognostic data
c ---            at upper levels and/or surface (030119)(param:ITPROG)
c
c --- PURPOSE:  Compute a 3-D temperature field
c
c --- NOTE: Currently, if no upper air data exist, then MM4 data are
c           used in place of NWS upper air data.  If any NWS data 
c           exist, only NWS data are used.  This should be modified
c           to allow a weighted use of both.
c           FRR (09/2001): if ITPROG=1 upper air temperature from MM5
c           if ITPROG=2 upper air and surface temperature from MM5
c
c --- UPDATES :
c --- V6.32 Level 080205 to v6.327 Level 090511(FRR)
c     - Add more explicit information to 1089-1090 error write 
c       statements
c
c --- v6.223  Level 070702 to v6.32 (080205)(F.Robe)
c     (1) Use end times rather than beginning times
c
c --- V6.222 Level 070404 to v6.223  Level 070702 to (F.Robe)
c     (1) initialize ldwat sooner in the code to avoid non-initialization
c         if no water stations (with water tempresults depending on default
c          value assigned to ldwat by compiler )
c
c --- v6.2 Level 060215 to V6.222 Level 070404(F.Robe)
c     (1) bug fix: in noobs temp mode, adjust temperatures to adiabatic
c         profile under convective mixing height (was done under un-defined
c         variables i.e. 0 or random number depending on compiler)
c
c --- V5.6 level 050328 to v6.2 Level 060215 (F.Robe)
c     - Use explicit beginning times with seconds
c --- 5.6 level 050328
c     - No need to declare U,V anylonger as surface temperature is
c       now computed in SURFVAR
c
c --- INPUTS:
c                  NYRZE - integer    - Year of current hour (GMT)
c                                       (explicit end time)
c                 NJULZE - integer    - Day of current hour (GMT) 
c                                       (explicit end time)
c                  NHRZE - integer    - Current hour GMT time (0-23)
c                                       (explicit end time)
C                  NSECE - integer    - Current end second
c      TEMP2D(mxnx,mxny) - real array - Gridded Surface temp. (deg K)                      c            
c      ZICONV(mxnx,mxny) - real array - Convective mixing height (m)
c          ZI(mxnx,mxny) - real array - Mixing height (m)
c    TZGRaa(mxnzp1,mxus) - real array - Grid face temp. interpolations
c                                       for aa GMT sounding (deg. K)
c    TZGRbb(mxnzp1,mxus) - real array - Grid face temp. interpolations
c                                       for bb GMT sounding (deg. K)
c  TPROG(mxnx,mxny,mxnz) - real array - MM4 temperature array on CALMET grid
c        Common block /GRID/
c           nx,ny,nz,nzp1,dgrid,zface,zmid
c        Common block /MET1/
c           nssta,nusta,xssta,yssta,xusta,yusta,noobs,ITPROG
c        Common block /UPMET/
c           justa,justd,ntzaa,ntzbb
c        Common block /TMP/
c           irad,numwb,tgdefb,tgdefa,jwat1,jwat2,trad,numts,iavet
c        Common block /GEO/
c           ilandu,iwat1,iwat2,elev
c        Common block /OVRWAT/
c           tairow,nowsta,tgrada,tgradb 
c        Parameters: mxnx, mxny, mxnz, mxnzp1, mxss,
c                    mxus, mxps, mxlev, mxtmp
c
c --- OUTPUT:
c  ZTEMP(mxnx,mxny,mxnz) - real array - 3-D temperature field (deg. K)
c
c --- TEMP3D called by:  COMP
c --- TEMP3D calls:      DEDAT,DELTT
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real temp2d(mxnx,mxny)
      real zi(mxnx,mxny),ziconv(mxnx,mxny)
      real tzgraa(mxnzp1,mxus),tzgrbb(mxnzp1,mxus)
      real ztemp(mxnx,mxny,mxnz),tprog(mxnx,mxny,mxnz)
c     real u(mxnx,mxny),v(mxnx,mxny)
c --- local arrays
      real tzgr(mxnzp1,mxus),tgrdb(mxnx,mxny),tgrda(mxnx,mxny)
      real tzua(mxnzp1)
      real wtus(mxus)
      real tdist(mxtmp)
      integer stlist(mxtmp)
c
      include 'grid.met'
      include 'met1.met'
      include 'upmet.met'
      include 'tmp.met'
      include 'geo.met'
      include 'ovrwat.met'
c
      data xmiss/9999./
c
c
c --- If no upper air stations, use default value for ZTEMP
c     There are no default values for Ztemp and the combo nusta<=0 and itprog=0
c     is not valid (rejected in READCF - No need for this statement
c     frr (050328)
c     if(nusta.le.0 .and. itprog.eq.0 ) return
c
c --- Current timestamp (End GMT time)
      nowtze = nyrze*100000 + njulze*100 + nhrze

c --- Compute time interpolated temperatures for each upper air station.
c     Note that the aa and bb GMT values at each cell face are
c     available in the tzgraa and tzgrbb arrays.
c
c FRR (9/2001) noobs (3 options)
c      if (noobs .eq. 1) goto 6
      if (itprog.ge.1) goto 6
      do 10 iu = 1,nusta
        jorder = justa(iu)
        jdelta = jusdt(iu)
        ntzaas = ntzaa(iu)
        call dedat(ntzaas,jaayr,jaaday,jaahr)
        ntzbbs = ntzbb(iu)
        call dedat(ntzbbs,jbbyr,jbbday,jbbhr)
        ibbsec=jbbsec(iu)
        iaasec=jaasec(iu)

        if (jorder .gt. 0) then
c          call deltt(nyrz,njulz,nhrz,jbbyr,jbbday,jbbhr,jtogo)
c          call deltt(jaayr,jaaday,jaahr,nyrz,njulz,nhrz,jpast)
           call deltsec(nowtze,nsece,ntzbbs,ibbsec,jtogo)
           call deltsec(ntzaas,iaasec,nowtze,nsece,jpast)
        else
c          call deltt(nyrz,njulz,nhrz,jaayr,jaaday,jaahr,jtogo)
c          call deltt(jbbyr,jbbday,jbbhr,nyrz,njulz,nhrz,jpast)
           call deltsec(nowtze,nsece,ntzaas,iaasec,jtogo)
           call deltsec(ntzbbs,ibbsec,nowtze,nsece,jpast)

        end if
c
c --- Check for negative values of jtogo or jpast 
c
        if (jtogo .LT. 0 .OR. jpast .LT. 0) then

c ---     Convert to Gregorian Day for output purposes
          call dedat(nowtze,ioutyz,ioutjz,iouthz) 
          call grday(io6,ioutyz,ioutjz,ioutmz,ioutdz) 
          call dedat(ntzaas,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)
          call dedat(ntzbbs,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)  

            write(io6,1089)iu,
     :        ioutyz,ioutjz,ioutmz,ioutdz,iouthz,nsece,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,iaasec,
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,ibbsec

1089         format(//1x,'ERROR IN SUBR. TEMP3D -- Upper air ',
     1      'soundings do not straddle current hour'/
     1      2x,'Station no.: ',i5/,
     2   38x,'Year  Julian Day  Month  Day  Hour  Seconds '/,
c             xxxx      xxx       xx    xx   xx    xxxx
     4   '  Current model date/time (UTC-GMT): ',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 1 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 2 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4)

          stop
        end if
c
c --- Double check for upper air data inconsistencies
c
        if ((jpast + jtogo) .ne. jdelta) then

c ---     Convert to Gregorian Day for output purposes
          call dedat(nowtze,ioutyz,ioutjz,iouthz) 
          call grday(io6,ioutyz,ioutjz,ioutmz,ioutdz) 
          call dedat(ntzaas,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)
          call dedat(ntzbbs,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)  

            write(io6,1090)iu,
     :        ioutyz,ioutjz,ioutmz,ioutdz,iouthz,nsece,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,iaasec,
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,ibbsec

1090         format(//1x,'ERROR IN SUBR. TEMP3D -- Inconsistent ',
     1      'upper air times for station ',i3/
     2   38x,'Year  Julian Day  Month  Day  Hour  Seconds '/,
c             xxxx      xxx       xx    xx   xx    xxxx
     4   '  Current model date/time (UTC-GMT): ',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 1 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 2 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4)

          stop
        end if
c
c --- Interpolate in time to current hour and loop over all levels
c
        xfact = float(jtogo) / float(jdelta)
        if (jorder .lt. 0) then
          do 3 k = 2,nzp1
    3     tzgr(k,iu) = tzgraa(k,iu) - (tzgraa(k,iu) - tzgrbb(k,iu))
     &                 * xfact
        else
          do 5 k = 2,nzp1
    5     tzgr(k,iu) = tzgrbb(k,iu) - (tzgrbb(k,iu) - tzgraa(k,iu))
     &                 * xfact
        end if

10    continue
 6    continue
c
      dgridi = 1.0 / dgrid
c

c --- OVERWATER GRADIENTS

c --- Use Prognostic data if itprog=2
      if (itprog.eq.2) goto 51
         

c --- Determine whether overwater vs. land interpolation to be used
c     (assume mxwb is hardwired to 1)

c --- must initialize ldwat sooner or can be undefined (070702)
      ldwat = 0

c --- Skip if no overwater station
      if (nowsta.eq.0) goto 51
c
c --- Find maximum land use category
      maxcat = 0
      do lwi = 1,nlu
        if (ilucat(lwi) .gt. maxcat) maxcat = ilucat(lwi)
      end do
c
c --- If maximum land use category is < jwat1, no overwater T interpolation
      ldwat = 1
      if (maxcat .lt. jwat1(mxwb)) then
c ---    no overwater temp interpolation 
         ldwat = 0
         go to 51
      endif

c --- Total number of station
      nstat = nssta + nowsta

c --- Reduce the missing value indicator by a small amount to allow
c     for machine roundoff
      xmissm=xmiss-0.01
c
c --- Loop over grid cells
c
      do 50 i = 1,nx
c
c --- Note,(xssta,yssta) are relative to the SW corner of grid pt (1,1)
c
      xc = float(i) - 0.5
c
      do 50 j = 1,ny
        yc = float(j) - 0.5


c --- If using land/water interpolation, determine whether water
c     or land (assume mxwb is hardwired to 1)
        lndwat = 0
        if (ilandu(i,j) .ge. jwat1(mxwb) .and.
     &      ilandu(i,j) .le. jwat2(mxwb)) lndwat = 1
       
c ---   skip if not overwater gridpoint
        if (lndwat.eq.0) goto 50
c
c ---  Compute distance to all overwater stations
        numsta = 0
        do 30 is = nssta+1,nstat
          numsta=numsta+1
          xxx = xowsta(is - nssta)
          yyy = yowsta(is - nssta)
          r2 = (xxx * dgridi - xc)**2 +
     &         (yyy * dgridi - yc)**2

          tdist(numsta) = sqrt(r2)
          stlist(numsta) = is
   30   continue
c
c --- Sort list of eligible stations
c
        if (numsta .gt. 1) then
          do ii = 1,numsta-1
          do jj = ii+1,numsta
            if (tdist(ii).gt.tdist(jj)) then
              tmpvar = tdist(ii)
              tdist(ii) = tdist(jj)
              tdist(jj) = tmpvar
              itmpvar = stlist(ii)
              stlist(ii) = stlist(jj)
              stlist(jj) = itmpvar
            end if
          end do
          end do
        end if

        tgrda(i,j) = 0.0
        tgrdb(i,j) = 0.0
        sumwt2 = 0.0
        sumwt3 = 0.0
c
c --- Calculate TGRADs
c
c       If no station within radius of influence, take nearest one
        if (tdist(1) .gt. trad) then
           if (tgradb(stlist(1) - nssta) .lt. xmissm) then
c ---         Use observed TGRAD
              tgrdb(i,j) = tgradb(stlist(1) - nssta)
            else
c ---         Use default TGRAD
              tgrdb(i,j) = tgdefb
            end if

            if (tgrada(stlist(1) - nssta) .lt. xmissm) then
c ---          Use observed TGRAD 
               tgrda(i,j) = tgrada(stlist(1) - nssta)
            else
c ---         Use default TGRAD
              tgrda(i,j) = tgdefa
            end if

        else
c ---     Some stations within radius, use up to NUMTS of them
c
          do 888 is = 1,numsta
            if (tdist(is) .gt. trad) goto 889
            if (is .gt. numts) goto 889
            if (irad .eq. 2) tdist(is) = tdist(is) * tdist(is)
            if (tdist(is) .lt. 1.0) then
              wt = 1.0
            else
              wt = 1.0 / tdist(is)
            endif

            if (tgradb(stlist(is) - nssta) .lt. xmissm) then
                sumwt2 = sumwt2 + wt
                tgrdb(i,j) = tgrdb(i,j) +
     &                       wt * tgradb(stlist(is) - nssta)
            end if
            if (tgrada(stlist(is) - nssta) .lt. xmissm) then
                sumwt3 = sumwt3 + wt
                tgrda(i,j) = tgrda(i,j) +
     &                       wt * tgrada(stlist(is) - nssta)
            end if

 888      continue
 889      continue


            if (sumwt2 .gt. 0.) then
c ---          Use observed TGRAD
               tgrdb(i,j) = tgrdb(i,j) / sumwt2
            else
c ---          Use default TGRAD
               tgrdb(i,j) = tgdefb
            end if
            if (sumwt3 .gt. 0.) then
c ---          Use observed TGRAD
               tgrda(i,j) = tgrda(i,j) / sumwt3
            else
c ---          Use default TGRAD
               tgrda(i,j) = tgdefa
            end if

        end if
c

   50 continue
c
51    continue


c --- Load the 3-d temp array:
c
      do 150 i = 1,nx
c
c --- Note,(xusta,yusta) are relative to the SW corner of grid pt (1,1)
c
      xc = float(i) - 0.5
c
      do 150 j = 1,ny
c
c ---       2D surface temperature already computed in SURFVAR (frr 050328)
            ztemp(i,j,1)=temp2d(i,j)

c --- If using MM4/MM5 only aloft (no observations) just use TPROG as the
c     temperature field aloft
c
c FRR(09/2001) - flag itprog for prognostic temperature
c        if (noobs .eq. 1) then
        if (itprog .ge. 1) then
          do k = 2,nz
            ztemp(i,j,k) = tprog(i,j,k)
c frr (09/01)
c ---       Below convective mixing height, use dry adiabatic lapse rate
c ---       this is needed because of the spatial and temporal interpolation
c ---       performed on the prognostic data in RDMM5
c ---       bug fix: zic is not defined in noobs, use convective mixing height
c           if (zmid(k).le.zic)
            if (zmid(k).le.ziconv(i,j))
     &          ztemp(i,j,k) = ztemp(i,j,1)-0.0098*(zmid(k)-zmid(1))
          enddo
          go to 150
        endif
c
        yc = float(j) - 0.5
c
c --- Compute the weights for the upper air stations
c       (irad = 1 = 1/R; irad = 2 = 1/R**2)
c
        sumwt = 0.0
        do 115 iu = 1,nusta
          wtus(iu) = 0.0
          r2 = (xusta(iu) * dgridi - xc)**2 +
     &         (yusta(iu) * dgridi - yc)**2
          if (irad .eq. 1) r2 = sqrt(r2)
          if (r2 .lt. 1.0) then
            wt = 1.0
          else
            wt = 1.0 / r2
          endif
          sumwt = sumwt + wt
          wtus(iu) = wt
  115   continue
c
c --- Normalize the weights
c
        sumwt = 1.0 / sumwt
        do 117 iu = 1,nusta
  117     wtus(iu) = wtus(iu) * sumwt
c
c --- Load the upper air determined temperatures into tzua
c
        do 125 k = 2,nzp1
          tzuas = 0.0
          do 120 iu = 1,nusta
  120       tzuas = tzuas  +  wtus(iu) * tzgr(k,iu)
          tzua(k) = tzuas
  125   continue
c
c --- If using land/water interpolation, determine whether water 
c     or land (assume mxwb is hardwired to 1)
c
        if (ldwat .eq. 1) then
          lndwat = 0
          if (ilandu(i,j) .ge. jwat1(mxwb) .and.
     &        ilandu(i,j) .le. jwat2(mxwb)) lndwat = 1
        end if
        if (ldwat .eq. 0 .or. lndwat .eq. 0) then
c
c --- Use convective mixing height, adiabatic lapse rate, upper air
c     data method if not using L/W interpolation or if grid cell is
c     on land
c
c --- Fetch the convective mixing height
c
          zic = ziconv(i,j)
c
          do 145 k=2,nz
            kp1 = k + 1
            zlow = zface( k )
            tlow = tzua( k )
            zhgh = zface(kp1)
            thgh = tzua(kp1)
c
c --- Entire layer above convective mixing height, use average of
c     sounding levels
c
            if (zlow .gt. zic) ztemp(i,j,k) = 0.5 * (tlow + thgh)
c
c --- Entire layer below convective mixing height, use adiabatic
c     lapse rate
c
            if (zhgh .le. zic) ztemp(i,j,k) = ztemp(i,j,1) - 0.0098
     &                           * 0.5 * (zlow + zhgh)

            if (zlow .le. zic .and. zhgh .gt. zic) then
c
c --- Convective mixing height located in layer, use 3-point thickness
c     weighted average of temperature at the two cell faces and at
c     the CMH
c
              tlow = ztemp(i,j,1) - 0.0098 * zlow
              tmid = ztemp(i,j,1) - 0.0098 * zic
              ztemp(i,j,k) = 0.5 * ((tlow + tmid) * (zic - zlow) +
     &              (tmid + thgh) * (zhgh - zic)) / (zhgh - zlow)
            endif
  145     continue
        else
c
c --- Over water use user-determined TGRAD
c
c --- Substitute regular mixing height for convective MH
c
          zic = zi(i,j)
          do 146 k = 2,nz
            kp1 = k + 1
            zlow = zface(k)
            zhgh = zface(kp1)
            if (zhgh .le. zic) then
c
c --- Entire layer below the mixing height, use tgrad below
c
              ztemp(i,j,k) = ztemp(i,j,1) + tgrdb(i,j) * zmid(k)
            else if (zlow .gt. zic) then
c
c --- Entire layer above the mixing height, use tgrad above for
c     portion above the mixing height
c
              ztemp(i,j,k) = ztemp(i,j,1) + tgrdb(i,j) * zic +
     &                       tgrda(i,j) * (zmid(k) - zic)
            else if (zlow .le. zic .and. zhgh .gt. zic) then
c
c --- Mixing height is located in layer, use thickness weighted
c     3-point average
c
              tlow = ztemp(i,j,1) + tgrdb(i,j) * zlow
              tmid = ztemp(i,j,1) + tgrdb(i,j) * zic
              thgh = ztemp(i,j,1) + tgrdb(i,j) * zic +
     &               tgrda(i,j) * (zhgh - zic)
              ztemp(i,j,k) = 0.5 * ((tlow + tmid) * (zic - zlow) +
     &              (tmid + thgh) * (zhgh - zic)) / (zhgh - zlow)
            endif
  146     continue
        end if
  150 continue
      return
      end

c----------------------------------------------------------------------
      subroutine setcoast(ilandu,iwat1,iwat2,ldbcst)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328           SETCOAST
c              F.Robe, Earth Tech
c
c --- PURPOSE: compute distance to the nearest coast for all
c              overwater gridpoints
c
c
c --- INPUT:  ILANDU(MXNX,MXNY) - integer  - Gridded land use
C             IWAT1,IWAT2       - integers - land use category interval
c                                            for water cells
c                LDBCST         - logical  - flag to print out gridded field
c                                            of distance to the coast in
c                                            DCST.GRD file
c
c
C
c --- Input via common:
c         /GRID/: DX,DY
c         /PARAMS/ nx,ny
C --- OUTPUT via COMMON/GRID/
c             DCOAST(MXNX,MXNY) - real     - distance to the nearest coast
c                                            in kilometers 
C
C ---------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'grid.met'

      integer ilandu(mxnx,mxny)
      character*40 fmt
      logical ldbcst

      dcstmax=0.

c --- Grid dimension in Km
      dgridkm=dgrid*0.001


      do j=1,ny
         do i=1,nx
            if ((ilandu(i,j).ge.iwat1).and.(ilandu(i,j).le.iwat2))then
               distmin=1.e+6
c ---          compute distance to all other gridpoints
               do l=1,ny
                  do k=1,nx
                     xdist=(k-i)*dgridkm
                     ydist=(l-j)*dgridkm
                     dist=sqrt(xdist**2+ydist**2)
c ---                skip overwater gridpoints
                     if ((ilandu(k,l).ge.iwat1).and.
     :                   (ilandu(k,l).le.iwat2)) goto 10
c ---                find minimum distance to land cell
                     distmin=min(distmin,dist)
10                   continue
                  end do
               end do
               dcoast(i,j)=distmin
c ---       Land cells
            else
               dcoast(i,j)=0.
            endif
            dcstmax=max(dcstmax,dcoast(i,j))
         end do
      end do

c --- Create a gridded output file (if LDBCST)
      if (ldbcst) then
         fmt='(10000(1pe10.4,2x))'
c ---    Location of gridpoints (1,1) and (nx,ny) in km
         xb=(xorigr+dgrid)/1000.
         yb=(yorigr+dgrid)/1000.
         xe=xb+(nx-1)*dgrid/1000.
         ye=yb+(ny-1)*dgrid/1000.

         write(io27,'(a4)')'DSAA'
         write(io27,'(2i12)')nx,ny
         write(io27,'(2f12.4)')xb,xe
         write(io27,'(2f12.4)')yb,ye
         write(io27,'(2e12.4)')0.,dcstmax
c ---    Data records
         do j=1,ny
            write(io27,fmt)(dcoast(i,j),i=1,nx)
         enddo

      endif

      RETURN
      END

C ---------------------------------------------------------------------
      subroutine terset(htopo,hmax,terrad)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130             TERSET
c              S.DOUGLAS, SAI
c
c --- include parameters
      include 'params.met'
c NEW (frr: 12/18/96): new variable in GRID.MET: disthmax(mxnx,mxny)
c                      distance to the highest peak within TERRAD
c                      ("birdwise" i.e. in an horizontal plane)
c NEW (frr: 1/21/97): new variables in GRID.MET: DISTMIN(mxnx,mxny)
c                      distance to the lowest valley bottom within TERRAD
c                      ("birdwise" i.e. in an horizontal plane)
c                      and HMIN(mxnx,mxny):altitude of valley bottom
      include 'grid.met'   
c D5 replaced by grid.met (frr 12/96)
c      COMMON /D5/ NX,NY,NZ,DX,DY,dz(mxnz),NZPRNT

      DIMENSION HTOPO(mxnx,mxny),HMAX(mxnx,mxny)
C
C     THIS SUBROUTINE DETERMINES THE HEIGHT (HMAX) OF THE HIGHEST
C     TERRAIN WITHIN A RADIUS = TERRAD (KM) OF THE POINT I,J
c     and the height (hmin) of the valley bottom with radius=terrad
C
C
C     INPUT:  HTOPO (R ARRAY) - GRIDDED TERRAIN HEIGHTS
C             TERRAD (R)      - RADIUS OF SEARCH FOR HIGHEST TERRAIN
C                               HEIGHTS
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C     OUTPUT:  HMAX (R ARRAY) - MAXIMUM TERRAIN HEIGHT WITHIN A
C                               GIVEN RADIUS
C    Via grid.met: 
c              DISTHMAX(mxnx,mxny)
c              DISTHMIN(mxnx,mxny)
c              HMIN(mxnx,mxny)

      DXK=DX*0.001
      DYK=DY*0.001
      IRANGE=NINT(TERRAD/DXK)
      JRANGE=NINT(TERRAD/DYK)
      IBNDY=NX-IRANGE
      JBNDY=NY-JRANGE
C
      DO 5 J=1,NY
      DO 5 I=1,NX
        HMAX(I,J)=HTOPO(I,J)
        HMIN(I,J)=HTOPO(I,J)
   5  CONTINUE
c First crest
      DO 10 J=1,NY
      L1=1
      IF (J .GT. JRANGE) L1=J-JRANGE
      L2=NY
      IF (J .LT. JBNDY) L2=J+JRANGE
      DO 10 I=1,NX
      K1=1
      IF (I .GT. IRANGE) K1=I-IRANGE
      K2=NX
c *** IF (I .LT. IBDY) K2=I+IRANGE
      IF (I .LT. IBNDY) K2=I+IRANGE
        DO 20 L=L1,L2
        DO 20 K=K1,K2
          XDIST=(K-I)*DXK
          YDIST=(L-J)*DYK
          DIST=SQRT(XDIST**2+YDIST**2)
          IF (DIST .GT. TERRAD) GO TO 20
          if(htopo(k,l).gt.hmax(i,j)) disthmax(i,j)=dist*1000.
          HMAX(I,J)=AMAX1(HMAX(I,J),HTOPO(K,L))
  20    CONTINUE
  10  CONTINUE

c Then valley bottom
      DO 11 J=1,NY
      L1=1
      IF (J .GT. JRANGE) L1=J-JRANGE
      L2=NY
      IF (J .LT. JBNDY) L2=J+JRANGE
      DO 11 I=1,NX
      K1=1
      IF (I .GT. IRANGE) K1=I-IRANGE
      K2=NX
c *** IF (I .LT. IBDY) K2=I+IRANGE
      IF (I .LT. IBNDY) K2=I+IRANGE
        DO 21 L=L1,L2
        DO 21 K=K1,K2
          XDIST=(K-I)*DXK
          YDIST=(L-J)*DYK
          DIST=SQRT(XDIST**2+YDIST**2)
          IF (DIST .GT. TERRAD) GO TO 21
c distance to valley bottom (birdwise)
          if(htopo(k,l).lt.hmin(i,j)) disthmin(i,j)=dist*1000.
          HMin(I,J)=AMin1(HMin(I,J),HTOPO(K,L))
  21    CONTINUE
  11  CONTINUE
      RETURN
      END
c----------------------------------------------------------------------
      subroutine topof2(u,v,w,htopo,cellzb,gamma,isurft,tinf,
     :                  temp2d,alpha)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070113             TOPOF2
c              S.DOUGLAS, SAI
c
c
c --- PURPOSE: THIS SUBROUTINE IS ADAPTED FROM THE 3-D COMPLEX TERRAIN
C              WIND MODEL (YOCKE,1979).  THE VERTICAL VELOCITY DUE TO
C              TOPOGRAPHIC EFFECTS IS COMPUTED AND TRANSFORMED TO TERRAIN
C              FOLLOWING COORDINATES
C
c --- UPDATES:
c --- V5.6 (050328) to V6.218 (070113) (F.Robe)
c        (1) Remove obsolete /T1/Common
c        (2) Allow the use of 2-D surface temp instead of single 
c            domain-representative Tinf 
c        (3) Make former scalar gamma a 2-D array
c
c --- V5.6 (050328- FRR): explicit common replaced by include d6.met 
c --- Modified 3/98 by J. Scire to prevent numerical problems
c             when WS = 0.0
c --- Modified by Ed Chang; 8/93; SRC
c         - Changed underflow control constant from 100 to 50 at about
c           the 88th statement; within loop 120.
c
C --- INPUTS:
c             U (R ARRAY)      - GRIDDED X-DIRECTION WIND COMPONENTS
C             V (R ARRAY)      - GRIDDED Y-DIRECTION WIND COMPONENTS
C             HTOPO (R ARRAY)  - GRIDDED TERRAIN HEIGHTS
C             CELLZB (R ARRAY) - VERTICAL LEVEL HEIGHTS
C             GAMMA (R ARRAY)  - TEMPERATURE LAPSE RATES (HOURLY)
c             ISURFT (I)      - Surface station number where domain 
c                               representative temperature is used from
c                               or trigger for using 2-D surface temp
c                               (ISURFT=-1; default); isurft=-2 calls
c                               for domain-averaged progn.temp.
C             TINF (R)         - DOMAIN REPRESENTATIVE TEMPERATURE
C             TEMP2D (R ARRAY) - 2-D SURFACE TEMPERATURE
C             ALPHA (R)        - EMPIRICAL COEFFICIENT FOR
C                                TOPOGRAPHIC EFFECTS
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C --- OUTPUTS: 
c             W (R ARRAY) - TERRAIN INDUCED VERTICAL VELOCITY
C
c --- TOPOF2 called by:  DIAGNO
c --- TOPOF2 calls:      none
c
c -------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'grid.met'
      include 'd6.met'

      DIMENSION U(mxnx,mxny,*), V(mxnx,mxny,*),
     1          W(mxnx,mxny,*), HTOPO(mxnx,*), CELLZB(mxnzp1),
     2          TEMP2D (mxnx,mxny),w1(mxnx,mxny,mxnzp1),
     3          gamma(mxnx,mxny)
C     
C
C     CALCULATE THE STABILITY PARAMETER, S
C
      TAU=-0.01
C
C     CALCULATE THE VERTICAL VELOCITY
C
      DO 100 J=1,NY
      DO 100 I=1,NX

      if (isurft.gt.0.or.isurft.eq.-2) then
         temp=tinf
      else
         temp=temp2d(i,j)
      endif

      GAMMA2=GAMMA(i,j)-TAU
      IF (GAMMA2 .LT. 0.) S=-1.0
      IF (GAMMA2 .GE. 0.) S=(9.8*GAMMA2/TEMP)**0.5

C     CALCULATE THE WAVENUMBER OF THE ATMOSPHERE
C
      HINV = 500.
      IF (S .LE. 0.) THEN
        BK=2./HINV
      ELSE
c
c ---   Protect against divide by zero errors
c ***   BK = S/((U(I,J,NZ)**2+V(I,J,NZ)**2)**0.5)
        xws=(U(I,J,NZ)**2+V(I,J,NZ)**2)**0.5
        xws=amax1(xws,1.e-6)
        BK = S/xws
      ENDIF
C
C     CALCULATE THE TOPOGRAPHIC GRADIENTS
C
      DXI=0.5/DX
      DYI=0.5/DY
      HTOIM1=HTOPO(I,J)
      HTOJM1=HTOPO(I,J)
      IF (I .GT. 1) HTOIM1=HTOPO(I-1,J)
      IF (J .GT. 1) HTOJM1=HTOPO(I,J-1)
      HTOIP1=HTOPO(I,J)
      HTOJP1=HTOPO(I,J)
      IF (I .LT. NX) HTOIP1=HTOPO(I+1,J)
      IF (J .LT. NY) HTOJP1=HTOPO(I,J+1)
      DELHI=(HTOIP1-HTOIM1)*DXI
      DELHJ=(HTOJP1-HTOJM1)*DYI
C
C     CALCULATE THE VERTICAL VELOCITY DUE TO TOPOGRAPHIC EFFECTS
C
      WTOPO=U(I,J,1)*DELHI+V(I,J,1)*DELHJ
C
C     SET THE LOWER BOUNDARY CONDITION
C
      W1(I,J,1)=WTOPO
      W(I,J,1)=WTOPO
C
C     COMPUTE THE EXPONENTIAL DECAY OF VERTICAL VELOCITY
C
      DO 120 K=1,NZ
      KP1=K+1
      BKZ=BK*CELLZB(KP1)
      IF (BKZ .GT. 50.) BKZ=50.
      W1(I,J,KP1)=WTOPO*EXP(-BKZ)
C
C     CALCULATE DWDZ
C
      DZI=1.0/DZ(K)
      DWDZ1=(W1(I,J,KP1)-W1(I,J,K))*DZI
      DWDZ=ALPHA*DWDZ1
C
C     CALCULATE W FROM DWDZ
C
      W(I,J,KP1)=DWDZ/DZI+W(I,J,K)
  120 CONTINUE
C
C
C     TRANSFORM TO TERRAIN FOLLOWING COORDINATES
C
      W(I,J,1)=W(I,J,1)-U(I,J,1)*DELHI-V(I,J,1)*DELHJ
      DO 130 K=1,NZ
      KP1=K+1
      W(I,J,KP1)=W(I,J,KP1)-U(I,J,K)*DELHI-V(I,J,K)*DELHJ
  130 CONTINUE
  100 CONTINUE
      RETURN
      END
c----------------------------------------------------------------------
      function unidot(a,b)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130             UNIDOT
C
      DIMENSION A(3),B(3)
C
C     UNIDOT RETURNS THE DOT PRODUCT OF A UNIT VECTOR
C     PARALLEL TO "A" WITH A UNIT VECTOR PARALLEL TO "B"
C
C     INPUTS: A (R ARRAY) - VECTOR A
C             B (R ARRAY) - VECTOR B
C
C     OUTPUTS: UNIDOT (R) - DOT PRODUCT OF VECTORS A AND B
C
      DENOM = SQRT((A(1)**2+A(2)**2+A(3)**2)*(B(1)**2+B(2)**2+B(3)**2))
      UNIDOT = 0.
      IF(DENOM .EQ. 0.) RETURN
      DO 100 I=1,3
      UNIDOT = UNIDOT + A(I)*B(I)
  100 CONTINUE
      UNIDOT = UNIDOT/DENOM
      RETURN
      END
c----------------------------------------------------------------------
      subroutine unpack(nwords,xbuf,nvals,xdata)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130             UNPACK
c ---          J. Scire, SRC
c
c --- PURPOSE:  Unpack a packed array of data
c
c --- INPUTS:
c             NWORDS - integer    - Number of packed words
c       XBUF(NWORDS) - real array - Array of packed data
c              NVALS - integer    - No. of unpacked values stored in
c                                   packed array
c       Parameters: IO6
c
c --- OUTPUT:
c       XDATA(NVALS) - real array - Array of unpacked data
c
c --- UNPACK called by:  RDP
c --- UNPACK calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real xbuf(nwords),xdata(nvals)
c
      ii=0
      do 100 i=1,nwords
c
      if(xbuf(i).ge.0.)then
c
c ---    transfer actual value to unpacked array
         ii=ii+1
         xdata(ii)=xbuf(i)
      else
c
c ---    insert "jj" zero values into unpacked array
         jj=abs(xbuf(i))+0.1
         do 50 j=1,jj
         ii=ii+1
         xdata(ii)=0.0
50       continue
      endif
100   continue
c
c --- check that size of unpacked array matches expected value
      if(ii.ne.nvals)then
         write(io6,102)ii,nvals
102      format(//5x,'ERROR IN SUBR. UNPACK -- no. values unpacked ',
     1   'does not match expected value'//8x,'ii (no. unpacked) = ',
     2   i10//8x,'nvals (no. expected) = ',i10)
         stop
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine unpcks(nssta,ibuf,ws,wd,iceil,icc,tempk,irh,pres,
     1 ipcode)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130             UNPCKS
c ---          J. Scire, SRC
c
c --- PURPOSE:  Unpack an array of surface meteorological data using
c               integer packing (3 words/station)
c        Word 1:  TTTTPCRRR --  TTTT = temp. (XXX.X deg, K)
c                                 PC = precipitation code (XX)
c                                RRR = relative humidity (XXX. %)
c        Word 2: pPPPPCCWWW -- pPPPP = station pressure (pXXX.X mb,
c                                      with p = 0 or 1 only)
c                                 CC = opaque sky cover (XX tenths)
c                                WWW = wind direction (XXX. deg.)
c        Word 3:   HHHHSSSS --  HHHH = ceiling height (XXXX. hundreds
c                                      of feet)
c                               SSSS = wind speed (XX.XX m/s)
c
c --- INPUTS:
c             NSSTA - integer    - Number of surface stations
c     IBUF(3,NSSTA) - int. array - Array of packed data
c        Parameters: IO6
c
c --- OUTPUT:
c         WS(NSSTA) - real array - Wind speed (m/s)
c         WD(NSSTA) - real array - Wind direction (degrees)
c      ICEIL(NSSTA) - int. array - Ceiling height (hundreds of ft)
c        ICC(NSSTA) - int. array - Opaque sky cover (tenths)
c      TEMPK(NSSTA) - real array - Temperature (deg. K)
c        IRH(NSSTA) - int. array - Relative humidity (percent)
c       PRES(NSSTA) - real array - Surface station pressure (mb)
c     IPCODE(NSSTA) - int. array - Precipitation code
c
c --- UNPCKS called by:  RDS
c --- UNPCKS calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real ws(nssta),wd(nssta),tempk(nssta),pres(nssta)
c
      integer iceil(nssta),icc(nssta),irh(nssta),ipcode(nssta)
      integer ibuf(3,nssta)
c
      do 100 i=1,nssta
c
      iword1=ibuf(1,i)
      iword2=ibuf(2,i)
      iword3=ibuf(3,i)
c
c --- unpack temperature, precip. code, relative humidity
      it=iword1/100000
      ipc=iword1/1000-it*100
      ir=iword1-it*100000-ipc*1000
c
c --- use a standard missing value indicator of 9999 for all variables
      if(it.eq.9999)then
         tempk(i)=9999.
      else
         tempk(i)=float(it)/10.
      endif
c
      if(ipc.eq.99)then
         ipcode(i)=9999
      else
         ipcode(i)=ipc
      endif
c
      if(ir.eq.999)then
         irh(i)=9999
      else
         irh(i)=ir
      endif
c
c --- unpack station pressure, cloud cover, wind direction
      ip=iword2/100000
      ic=iword2/1000-ip*100
      iw=iword2-ip*100000-ic*1000
c --- NOTE: 1XXXX is allowed for station pressure and converts to
c ---       1XXX.X mb
      if(ip.eq.9999)then
         pres(i)=9999.
      else
         pres(i)=float(ip)/10.
      endif
c
      if(ic.eq.99)then
         icc(i)=9999
      else
         icc(i)=ic
      endif
c
      if(iw.eq.999)then
         wd(i)=9999.
      else
         wd(i)=iw
      endif
c
c --- unpack ceiling height, wind speed
      ih=iword3/10000
      is=iword3-ih*10000
c
      iceil(i)=ih
      if(is.eq.9999)then
         ws(i)=9999.
      else
         ws(i)=float(is)/100.
      endif
100   continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine vertav(iu,uu,vv,zz,nlev,nz,zface,uave,vave)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130             VERTAV
c ---          J. Scire, SRC
c
c --- PURPOSE:  Calculate the layer-averaged U and V wind components
c               at one upper station using sounding data.  Modified
c               to allow missing wind data.
c
c --- INPUTS:
c                   IU - integer    - Upper air station number
c                                     (1, 2, ..., nusta)
c       UU(mxus,mxlev) - real array - U wind components (m/s)
c       VV(mxus,mxlev) - real array - V wind components (m/s)
c       ZZ(mxus,mxlev) - real array - Height (m) of UU, VV (above LGL)
c                 NLEV - integer    - Number of sounding levels
c                   NZ - integer    - Number of vertical grid layers
c        ZFACE(mxnzp1) - real array - Height (m) of cell face
c
c --- OUTPUT:
c           UAVE(mxnz) - real array - Layer averaged U wind
c                                     component (m/s)
c           VAVE(mxnz) - real array - Layer averaged V wind
c                                     component (m/s)
c        Parameters: MXUS, MXLEV, MXNZ, MXNZP1, MXADD, IO6
c
c --- VERTAV called by:  COMP, PREPDI
c --- VERTAV calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real uu(mxus,mxlev),vv(mxus,mxlev),zz(mxus,mxlev)
      real u(mxadd),v(mxadd),z(mxadd)
      real zface(mxnzp1)
      real uave(mxnz),vave(mxnz)
      integer ibound(mxnzp1)
c
      data xmiss/999./
c
c --- Reduce missing value indicator by a slight amount to allow for
c --- machine roundoff
      xmissm=xmiss-0.01
c
c --- Transfer NON-MISSING U, V components into work arrays -- make
c --- all values positive
      nl=0
      do 15 k=1,nlev
c
c --- Skip levels with missing data
      if(uu(iu,k).ge.xmissm.or.vv(iu,k).ge.xmissm)go to 15
c
c --- Count number of non-missing levels
      nl=nl+1
      u(nl)=uu(iu,k)+1000.
      v(nl)=vv(iu,k)+1000.
      z(nl)=zz(iu,k)
15    continue
c
c --- interpolate wind components to cell boundaries
      nzp1=nz+1
c
      do 100 k=1,nzp1
c
c --- find level at or just below cell face
      zbound=zface(k)
      if(zbound.eq.0.0)go to 100
      do 20 j=2,nl
      if(z(j).ge.zbound)then
         if(z(j).eq.zbound)go to 100
         nbm=j-1
         nbp=j
         go to 22
      endif
20    continue
c
c --- sounding does not go high enough
      write(io6,21)zbound,nl,z(nl)
21    format(//1x,'ERROR IN SUBR. VERTAV -- cell face is above top ',
     1 'sounding level'//5x,'cell face height = ',f10.1,5x,'No. ',
     2 'sounding levels = ',i5,5x,'Top sounding height = ',f10.1)
      stop
c
c --- interpolate U, V to cell face
22    continue
      rat=(z(nbp)-zbound)/(z(nbp)-z(nbm))
      ubound=u(nbp)-(u(nbp)-u(nbm))*rat
      vbound=v(nbp)-(v(nbp)-v(nbm))*rat
c
c --- bump all values up in arrays to make room for new level
      do 25 kk=nl,nbp,-1
      kkp1=kk+1
      u(kkp1)=u(kk)
      v(kkp1)=v(kk)
      z(kkp1)=z(kk)
25    continue
c
c --- insert U, V at cell boundary
      nl=nl+1
      u(nbp)=ubound
      v(nbp)=vbound
      z(nbp)=zbound
100   continue
c
c --- find indexes corresponding to each cell face
      kkb=1
      do 150 k=1,nzp1
      zbound=zface(k)
      do 140 kk=kkb,nl
      if(z(kk).eq.zbound)then
         ibound(k)=kk
         kkb=kk+1
         go to 150
      endif
140   continue
c
c --- cell face height not found in Z array
      write(io6,142)zbound,kkb,nl,(z(n),n=kkb,nl)
142   format(//2x,'ERROR IN SUBR. VERTAV -- cell face height ',
     1 'not found in height array'//2x,'cell face height = ',f10.1,
     2 3x,'KKB = ',i5,3x,'NL = ',i5//2x,'heights: ',50(/5x,10f10.1))
      stop
150   continue
c
c --- compute the layer-averaged U, V in each cell
      do 200 k=1,nz
      sumu=0.0
      sumv=0.0
      ib=ibound(k)
      ibp1=ib+1
      it=ibound(k+1)
c
      do 180 n=ibp1,it
      nm1=n-1
      umin=amin1(u(nm1),u(n))
      vmin=amin1(v(nm1),v(n))
      dz=z(n)-z(nm1)
      sumu=sumu+(umin+0.5*abs(u(n)-u(nm1)))*dz
      sumv=sumv+(vmin+0.5*abs(v(n)-v(nm1)))*dz
180   continue
c
      dzi=1.0/(zface(k+1)-zface(k))
      uave(k)=sumu*dzi-1000.
      vave(k)=sumv*dzi-1000.
200   continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine water(u10,v10,imixh,qsw,qlw,dcoast,zu,ilandu,      
     :                 iwat1,iwat2,nx,ny,dgrid,fcori,nhrz,z0)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 110212              WATER
c ---          J. Scire, SRC
c
c --- PURPOSE:  Compute micrometeorological parameters over water using
c               delta temp. method or the COARE algorithm
c
c ---           Overwater mixing heights are computed if there are no
c ---           specified values in a overwater data file
c
c --- UPDATES:
c
c ---  v6.229 (100719) to v6.332(F.Robe)
c      (1) Actually pass old ZIC value to MIXHMC not old Zi (bug fix of bug fix)
c
c ---  V6.223 (070702) to v6.229 (100719)(F.Robe)
c      (1) Save Convective mixing height array and pass on old values to
c          MIXHMC and MIXHBG (rather than old values of the mixing height
c          be it mechanical or convective). Bug fix
c
c ---  V6.222 Level 070404 to V6.223 (070702)(F.Robe)
c      (1) assign z0 value sooner in the code so that filled in even 
c          when no valid overwater stations
c      (2) Define ilapse and pass on correct value of ilapse to MIXHMC and
c          MIXHBG if itwprog=2
c      (3) wstar overwater strictly based on convective mixing height                 
c          if computed (imixh>0)
c
c ---  V6.214 Level 060528 to V6.222 Level 070404(F.Robe)
c      (1) Include internal common to pass value of dptt to MIXHMC
c
c --- V6.205 (060318) to V6.214 (060528) (F.Robe):
c     (1) Differentiate between the buoyancy flux QB and the sensible heat flux 
c         Use QB to compute the convective velocity scale (WSTAR).
c         In DeltaT subroutine, the old QH was previously mislabelled "sensible
c         heat flux" but has always been the buoyancy flux (based on virtual potential
c         temperature). In COARE, QH strictly refers to the sensible heat flux
c     (2) To keep in line with true purpose of the so-called "sensible heat flux" array
c         stored in METGRD, assign QH=QB at end of subroutine.
c     (3) Skip definition of qe as never used   
c 
c --- V5.614 (051228) to V6.205 (060318) (DGS):
c     (1) Fixed typo that used the overwater (OW) Tair from
c         the last OW station in the list with the Tair-Tsea difference
c         from the nearest OW station when computing Tsea for the 
c         nearest OW station.
c     (2) Allow round-off error when checking ZOWSTA for missing values 
c         (use xmissm rather than xmiss) (FRR)
c     (3) Make sure SST passed on to COARE are above -3C (otherwise COARE
c         crashes)
c     (4) Add a check for missing Tairow before call to COARE and
c         replace by default Tair if missing  
c
c --- V5.613 (051227)to V5.614  (051228)(F.Robe):
c     (1) Pass actual SST sensor depth to COARE or use default 0.6m
c         if missing or not available in SEA.DAT
c
c --- V5.611 (051113) to V5.613 (051227)(F.Robe):
c     (1) Use actual height of Tair sensor instead of anemometer height
c         if available (SEA.DAT version 2.11+) 
c
c --- V5.6e (050520)to V5.611 (051113) (F.Robe):
c     (1) Pass anemometer height instead of nearow to deltaT
c     (2) Assume 10m measurement height if anemometer height is missing
c
c --- V5.6d (050428) to V5.6e (050520) (D. Strimaitis):
c     (1) Fix typo: ZIOBS should be IZIOBS
c
c --- V5.6c (050419) to V5.6d (050428) (F.Robe):     
c     (1) Make sure to compute the initial mechanical mix. hgt
c         when there are several OW stations but no valid mixH obs.
c
c --- V5.6a (050331) to V5.6c (050419) (F.Robe):     
c     (1) Pass iwarm,icool,(i,j) to COARE via calling list
c
c --- V5.6 (050328) to V5.6a (050331) (DGS):     
c     (1) Update references to Charnock
c
c --- V5.547 (041010) to V5.6 (050328) (F.Robe):     
c     (1) Compute convective mixing height (Batchvarova and Gryning) and keep
c          maximum of the mechanical and convective mixing height
c     (2) Add option to use the Coupled OPcean Atmosphere Response Experiment 
c         (COARE) bulk flux model for computing Zo, u*, L and QH overwater
c     (3) Revamp the subroutine to isolate the DELTAT method computations
c         in a separate suburoutine (in parallel with COARE)
c     (4) Depending on the value of the new ICOARE user-input parameter,
c         Compute Zo, u*, L and QH using the DELTAT or COARE methods
c     (5) Add option to use observed wave properties
c         (dominant period and height)
c     (6) Add necessary parameters for COARE method to the calling list
c         (zu,qsw,qlw,dcoast,icoare)
c
c --- V5.51 (030515) to V5.547 (041010)(F.Robe)
c     (1) Remove noobs from argument list as no longer needed
c
c --- V5.5 (030402) to V5.51 (030515) (J. Scire)
c     (1) Eliminate check to prevent mixing height to be computed
c         when NOOBS = 1 (no UP.DAT) or NOOBS = 2 (only 3D.DAT data)
c
c --- INPUT:
c       U10(mxnx,mxny) - real array    - Surface U component wind (m/s)
c                                        at height of ZU
c       V10(mxnx,mxny) - real array    - Surface V component wind (m/s)
c                                        at height of ZU
c                  IMIXH - integer    - Method for convective mixing height
c                                       1: Maul Carson overland and overwater
c                                       2: Batchvarova-Gryning overland and OW
c                                      -1: MC overland, OCD mechanical OW
c                                      -2: BG overland, OCD mechanical OW
c       QSW(mxnx,mxny) - real array    - net short wave radiative flux (W/m2)
c                                        at the surface
c       QLW(mxnx,mxny) - real array    - downward long wave radiative flux (W/m2)
c                                        at the surface
c    DCOAST(mxnx,mxny) - real array    - Distance from overwater gridpoint to
c                                        nearest shorec
c                   ZU - real          - height of the lowest CALMET gridpoint
c                                        where the surface winds are computed
c                                        (usually 10m)
c    ILANDU(mxnx,mxny) - integer array - Land use category at each
c                                        grid point
c         IWAT1, IWAT2 - integers      - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c                DGRID - real          - Grid cell size (m)
c     FCORI(mxnx,mxny) - real array    - Absolute value of the Coriolis
c                                        parameter (1/s)
c               NHRZ   - integer       - GMT hour (ending time)
c
c
c
c       Common block /OVRWAT/ variables:
c          NOWSTA, XOWSTA(mxows), YOWSTA(mxows), ZOWSTA(mxows),
c          ZTAIR (mxows), ZSST (mxows),
c          DTOW(mxows), TAIROW(mxows), RHOW(mxows),
c          ZIOW(mxows), TGRADA(mxows),ZIMINW, ZIMAXW, CONSTW, 
c          ICOARE,JWAVE , dshelf, iwarm,icool
c
c          ICOARE -  Overwater method  -JWAVE: wave method
c                 -  0: original deltaT method (OCD)
c                 - 10: COARE with wave option jwave=0 (Charnock)
c                 - 11: COARE with wave option jwave 1 (Oost et al)
c                 - 12: COARE with wave option 2 (Taylor and Yelland)
c
c       common block /METGRD/ arrays, all dimensioned (mxnx,mxny):
c          RMM (rainfall rate in mm/hr)
c
c       common block /GEN/itimstep
c       common block /TMP/tgdefa
c
c       Parameters: MXNX, MXNY, MXOWS, IO6
c
c
c --- OUTPUT:
c        Z0(mxnx,mxny) - real array    - Surface roughness lengths (m)
c 
c       common block /METGRD/ arrays, all dimensioned (mxnx,mxny):
c          IPGT, QH, USTAR, ZI, EL, WSTAR, RMM
c
c --- WATER called by: COMP
c --- WATER calls:     ESAT (function), DELTAT, COARE
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'tmp.met'
c
      real u10(mxnx,mxny),v10(mxnx,mxny),z0(mxnx,mxny)
      real qsw(mxnx,mxny),qlw(mxnx,mxny)
c     real qe(mxnx,mxny)
      real tair(mxows),twater(mxows),rh(mxows)
      real th(mxows),dthz(mxows)
      real dth10(mxows),th10(mxows),q(mxows),zanem(mxows)
      integer ilandu(mxnx,mxny)
      real dcoast(mxnx,mxny),fcori(mxnx,mxny)
c     100719 - save old convective mixing height
      real zicold(mxnx,mxny)

c --- COARE input/output real variables are real*8
      real*8 rzu,rzt,rws10,rtairc,rtsea,rzi,rrmm,rq,rqsw,rqlw
      real*8 rrlong,rz0,rustar,rqh,rqe,rtwave,rhwave
      real*8 rtstar,rqstar,rzsst
c

      include 'ovrwat.met'
      include 'gen.met'
      include 'metgrd.met'
c
      data z0min/2.0e-6/,rmax/1.e37/,xmiss/9999./,pres/1000./
      data vk/0.4/,g/9.81/,rhocp/1195.2/
      data r2min/1.e-30/
      data nearow/0/
      data  xmissm/9998.99/
      data  rtwave/-999./,rhwave/-999./

      common /tjump/ dptt(mxnx,mxny)

c     100719 - make sure to retain Zicold values from old timestep
      save zicold

c frr 050328 - do not compute xmissm  at every call to subroutine
c     instead include them in data statement 
c     xmissm=xmiss-0.01
c

c --- Set lapse rate flag for mixing height subroutine (070702)
      if (itwprog.eq.0) then
          ilapse=0
      else
          ilapse=1
      endif

c --- Compute internal, station-specific parameters
      if(nowsta.le.0)go to 51

      do 50 k=1,nowsta
c
c ---    air-sea temperature difference must be valid to use station
         if(dtow(k).ge.xmissm)then
            twater(k)=xmiss
            tair(k)=xmiss
            rh(k)=xmiss
            go to 50
         endif

c
c ---    overwater air temp. at measurement ht -- if missing,
c ---    assume T=60 F = 288.7 
         if(tairow(k).ge.xmissm)then
            tair(k)=288.7
         else
            tair(k)=tairow(k)
         endif
c
c ---    water temperature -- computed from air temp + air-sea delta temp
         twater(k)=tair(k)-dtow(k)
c
c ---    relative humidity -- if missing, assume 100 %
         if(rhow(k).ge.xmissm)then
            rh(k)=100.
         else
            rh(k)=rhow(k)
         endif
c
c ---    compute saturation and actual water vapor pressure (mb) at
c ---    measurement height
c ---    (NOTE: ESAT function uses temperature in deg. C)
c ---    (constant 0.01 converts rh from percent to fraction)
         tairc=tair(k)-273.15
         es=esat(tairc)
         e=0.01*rh(k)*es
c
c ---    compute saturation and actual mixing ratio (g h20/g dry air) at
c ---    measurement height
         ws=0.622*es/(pres-es)
         w=0.622*e/(pres-e)
c ---    050328 specific humidity (g H2O/ KG moist air (!! units))
         q(k)= w/(1+w)*1000.
c
c ---    compute virtual temperature (deg. K) at measurement height
         tv=tair(k)*(1.+0.61*w)
c
c ---    compute virtual potential temperatures (deg. K) at measurement ht
c ---    (potential temp. = temp. + 0.01 (deg. K/m) * height)
c ---    assume 10m measurement height if zowsta missing (051113)
         if (zowsta(k).lt.xmissm) then
            zanem(k)=zowsta(k)
         else
             zanem(k)=10.
         endif
	 dth=0.01*zanem(k)
         th(k)=tv+dth
c
c ---    compute virtual potential temp. (deg. K) at surface -- assume
c ---    surface relative humidity = 100 %
         twaterc=twater(k)-273.15
         es=esat(twaterc)
         ws=0.622*es/(pres-es)
         thsurf=twater(k)*(1.+0.61*ws)
         dthz(k)=th(k)-thsurf
c
c ---    convert measurement ht. - surface delta potential virtual
c ---    temperature to 10 m - surface value
c ---    constant 11.512925 = ln(10 m/z0) with z0=1.e-4 m
c ---    constant 9.2103404 = -ln(z0) with z0=1.e-4 m
         dth10(k)=dthz(k)*11.512925/(alog(zanem(k))+9.2103404)
         th10(k)=thsurf+dth10(k)

50    continue

51    continue

c --- loop over grid cells
c
      do 500 i=1,nx
      do 500 j=1,ny
c

c ---    process only water cells
         if(ilandu(i,j).lt.iwat1.or.ilandu(i,j).gt.iwat2)go to 500
c
c ---    wind speed at 10 m
         ws10=sqrt(u10(i,j)**2+v10(i,j)**2)

c ---    Roughness length  (Hosker method)
c ---    (is updated in COARE if COARE method selected but initial value
c ---    required in both cases to compute mixing height
         if(ws10.gt.0.0)then
            z02=2.0e-6*ws10**2.5
            z02=amax1(z0min,z02)
         else
            z02=z0min
         endif
         z0(i,j)=z02


c ---    if overwater data is missing, assume near-neutral conditions
         if (nowsta.eq.0) go to 1200

c ---    find nearest overwater observation to current grid cell
c ---    where valid dt: nearow
         if(nowsta.eq.1)then
            if(dtow(nowsta).ge.xmissm)then
               nearow=0
               go to 1200
            else
               nearow=1
            endif
         else
            xgdpt=(float(i)-0.5)*dgrid
            ygdpt=(float(j)-0.5)*dgrid
            dmin2=rmax
            nearow=0
c
c ---       loop over overwater stations to find closest one to (i,j)
            do 12 k=1,nowsta
c
c ---          check if data is missing
               if(dtow(k).ge.xmissm)go to 12
c ---          station coordinates are relative to origin (i.e.,
c ---          (xowsta(k),yowsta(k)) of lower left corner of grid = (0.,0.))
               dist2=(xowsta(k)-xgdpt)**2+(yowsta(k)-ygdpt)**2
               if(dist2.lt.dmin2)then
                  dmin2=dist2
                  nearow=k
               endif
12          continue
            if (nearow.eq.0) go to 1200
         endif

         if(nearow.gt.mxows)then
            write(io6,9012)nearow,mxows,i,j
9012        format(//1x,'ERROR in SUBR.WATER-- nearest overwater ',
     1      ' station number is greater than max. array dimension'//
     2      5x,' nearow = ',i5,3x,'mxows = ',i5,3x,' i = ',i5,3x,
     3      ' j = ',i5)
            stop
         endif
c

c ---    050328 (F.Robe). 
c ---    option to use original DeltaT method or COARE algorithm to compute
c        Roughness length (zo), Monin-Obukhov Length (el), 
c        friction velocity (u*),Buoyancy Flux (qb)
c        If DeltaT; compute u*,Zo,Qb,el first then mixing height  
c        if COARE: compute mixing height first (required input to COARE)

c ---    DELTAT METHOD:
         if (icoare.eq.0) then 
c ---       Pass measurement height instead of nearow to deltaT (051113)
            call DELTAT(ws10,zanem(nearow),dthz(nearow),dth10(nearow),
     :                  th10(nearow),th(nearow),z02,
     :                  el(i,j),ustar(i,j),qB)

c ---                   DeltaT actually computes the buoyancy flux QB 
c ---                   (based on virtual pot. temp.)not the sensible 
c                       heat flux QH (based on temp only)
c    :                  el(i,j),ustar(i,j),qh(i,j))

            z0(i,j)=z02

c ---       Buoyancy Flux in terms of <w'Thetav'>
            wt=Qb/rhocp

           go to 1300
         endif

c ---    OVERWATER MIXING HEIGHT (m)
C ---    1/r**2 interpolation of observed mixing heights (if available) 
c ---    Otherwise compute Zi using u*
c
c --     For COARE method, u* is not computed yet so make first guess using
c ---    neutral deltaT equations for u*

1200     continue

c ---    NEUTRAL DELTAT EQUATIONS for u* ,el,wt
         ustar2=vk*ws10/alog(10./z02)
c ---    prevent numerical problems with zero ustar
         ustar(i,j)=amax1(ustar2,1.e-9)
         el(i,j)=9.9e9
         wt=0.

c ---    non neutral EL and QH/wt  are recomputed in COARE
c ---    (if COARE is selected and data available)
     

1300    continue

c       flag for valid Mixing Height observations (0:no - 1:yes)           
        iziobs=0

        if( (nowsta.eq.1). and. (ziow(1).lt.xmissm) )then
c ---      Only one overwater station -- use value if valid
           zi(i,j)=ziow(1)
           iziobs=1
        else if (nowsta.gt.1) then
c ---      1./R**2 weighting
           xsum=0.0
           ysum=0.0
           xgdpt=(float(i)-0.5)*dgrid
           ygdpt=(float(j)-0.5)*dgrid
           do 410 k=1,nowsta
             if(ziow(k).lt.xmissm)then
               r2=(xowsta(k)-xgdpt)**2+(yowsta(k)-ygdpt)**2
c ---          prevent divide by zero errors
               r2=amax1(r2,r2min)
               xsum=xsum+ziow(k)/r2
               ysum=ysum+1./r2
             endif
410        continue
c
           if(xsum.gt.0.)then
             zi(i,j)=xsum/ysum
             iziobs=1
           endif
        endif
        if(iziobs.eq.0) then
c ---      No overwater MixH observations: 
c ---      At this point, only compute the mechanical MixHeight to be used
c ---      in COARE (not a sensitive parameter but needs a value)
c ---      after the COARE computations, compute the convective mix. height
c ---      compute mechanical overwater mixing height (default value: const=0.16)

           zimech=constw*ustar(i,j)/fcori(i,j)
        endif

c frr 050328
C ---   COARE method (if data is not missing)
c ---   Roughness length (z0), Monin-Obukhov Length (el), 
c ---   friction velocity (u*),Sensible Heat Flux (qh), buoyancy flux

        if ( (abs(icoare).ge.10).and. (nearow.ne.0) ) then
c ---       compute air and sea temp in Celsius and positive 
c ---       longitude in East. Hem. at nearest overwater station.
c ---       in real*8 variables
c ---       Use Height of Air temp sensor (not always = anemometer hgt)
            if (ztair(nearow).lt.9998) then
               rzt=ztair(nearow)
            else
               rzt=zanem(nearow)
            endif
            if (tairow(nearow).lt.xmissm) then
               rtairc=tairow(nearow)-273.15
            else
c ---          assume Tair=288.7 i.e. rtairc=15.55
              rtairc=15.55
            endif
            rtsea=rtairc-dtow(nearow)
c ---       make sure SST above -3C:
            rtsea=max(rtsea,-3.D0)
            rrlong =xowlon(nearow)

c ---       Observed dominant wave period and height at nearest station 
c ---       if requested (icoare=-11,-12).  
c ---       find nearest station with valid wave data
            if (icoare.lt.0) then
               now=1
               if(nowsta.gt.1) then
                  xgdpt=(float(i)-0.5)*dgrid
                  ygdpt=(float(j)-0.5)*dgrid
                  dmin2=rmax
c ---             loop over overwater stations to find closest one to (i,j)
                  do 122 k=1,nowsta
c ---                check if wave data is missing
                     if((hwave(k).lt.0.).or.(twave(k).lt.0.))goto 122
c ---                station coordinates are relative to origin (i.e.,
c ---                (xowsta(k),yowsta(k)) of lower left corner of grid = (0.,0.))
                     dist2=(xowsta(k)-xgdpt)**2+(yowsta(k)-ygdpt)**2
                     if(dist2.lt.dmin2)then
                        dmin2=dist2
                        now=k
                     endif
122               continue
               endif
c ---          note: it is okay if all missing wave data (now=1)
               rtwave=twave(now)
               rhwave=hwave(now) 
            endif
c ---       depth of SST sensor - Default: moored NDCB buoy value (0.6m)
            if (zsst(nearow).lt.9998.) then
               rzsst = zsst(nearow)
            else
               rzsst=0.6
            endif

c ---       map other input variables to real*8 variables
            rzu=zu
            rws10=ws10
            if (iziobs.eq.1) then
               rzi=zi(i,j)  
            else
               rzi=zimech
            endif
            rrmm=rmm(i,j)            
            rq=q(nearow)
            rqsw=qsw(i,j)
            rqlw=qlw(i,j)


            call COARE(itimstep,i,j,rzu,rzt,rzsst,rws10,rtairc,rtsea,
     :               rzi,rrmm,rq,rqsW,rqLW,rrlong,jwave,rtwave,rhwave,
     :               nhrz,dshelf,dcoast(i,j),iwarm,icool,rz0,el(i,j),
     :               rustar,rtstar,rqstar,rqh,rqe)
c ---       map output variables to real*4 variables
            z0(i,j)=rz0              
            ustar(i,j)=rustar
c ---       sensible heat flux - no need to assign to qh at this point because
c           QH is really a buoyancy flux array not strictly a sensible heat flux array
c            qh(i,j)=rqh
c ---       latent heat flux (never used so skip)
c           qe(i,j)=rqe

c ---       Surface Buoyancy flux in terms of <w'Thetav'>
            wt=-ustar(i,j)*(rtstar+0.61*rqstar*tair(nearow))

c ---       restrict Monin-Obhukov length near zero (to be consistent with deltaT)
            if(abs(el(i,j)).lt.5.0)then
               if(el(i,j).lt.0)then
                  el(i,j)=-5.0
               else
                 el(i,j)=5.0
               endif
            endif
       endif

c ---  Update mechanical and compute convective OW mixing height if no MixH obs            
       if (iziobs.eq.0)  then

c ---      Mechanical
           zimech=constw*ustar(i,j)/fcori(i,j)

           if (itwprog.eq.0) then
c ---         Use constant lapse rate over mixing height (default or from SEA.DAT)
c ---         (else it will be extracted from the progn. temp. profiles in mixhbg/mixhmc)
              dtdz=tgdefa
              if(nowsta.eq.1)then
c ---             Only one overwater station -- use value if valid 
                  if(tgrada(1).lt.xmissm) dtdz=tgrada(1)
              else if (nowsta.gt.1) then
c ---             1./R**2 weighting
                  xsum=0.0
                  ysum=0.0
                  xgdpt=(float(i)-0.5)*dgrid
                  ygdpt=(float(j)-0.5)*dgrid
                  do 4410 k=1,nowsta
                     if(tgrada(k).lt.xmissm)then
                        r2=(xowsta(k)-xgdpt)**2+(yowsta(k)-ygdpt)**2
c ---                   prevent divide by zero errors
                        r2=amax1(r2,r2min)
                        xsum=xsum+tgrada(k)/r2
                        ysum=ysum+1./r2
                     endif
4410              continue
                  if(xsum.gt.0.)dtdz=xsum/ysum
               endif
c ---          Potential temperature lapse rate
               dthdz=dtdz+0.0098

           endif
c
c ---      make sure initial "old" zi is at least the minimum zi otherwise
c ---      crashed in mixdt2 for itwprog=1 (could be a problem at first
c ---      timestep)
           zi(i,j)=amax1(zi(i,j),ziminw)
c          make sure old convective Zi is not greater than old Zi (in case Zicold 
c          not initialized by computer to 0)(100719)
           zicold(i,j)=amin1(zicold(i,j),zi(i,j))
           zicold(i,j)=amax1(zicold(i,j),ziminw)

           if(imixh.eq.2) then
c             Batchvarova-Gryning convective mixing height 
c             100719 -Pass on old value of Zic not old value of Zi              
              call MIXHBG(nhrz,I,J,WT,DTHDZ,Tairow(nearow),Ilapse,
c     :         THRESHW,ZIMAXW,ZIMINW,USTAR(i,j),EL(i,j),ZI(i,j),ZICONV,
     :         THRESHW,ZIMAXW,ZIMINW,USTAR(i,j),EL(i,j),ZICOLD(i,j),ZICONV,
     :         THT,THTP)               
               Zicold(i,j)=ziconv
           else if (imixh.eq.1) then
c             Carson convective mixing height (similar to MIXHTST/MIXHSTS2)
c             Pass on old value of Zic not old value of Zi              
              call MIXHMC(nhrz,i,j,wt,DTHDZ,ilapse,threshw,
c             110212 - fix typo - use zicold not old zi (as meant to be since v6.229)
     :                    zimaxw,zicold(i,j),ziconv,dptt,THT,THTP)
c     :                    zimaxw,zi(i,j),ziconv,dptt,THT,THTP)
              Zicold(i,j)=ziconv
           else
c             OCD mixing height (mechanical only)
              ziconv=0.
              Zicold(i,j)=ziconv
           endif


           zi(i,j)=amax1(zimech,ziconv)
           zi(i,j)=amax1(ziminw,zi(i,j))
           zi(i,j)=amin1(zimaxw,zi(i,j))


        endif


1600    continue

c ---   OTHER variables ( independent of method)
c
        if (nearow.eq.0) then
           theta=288.7
        else
           theta=th(nearow)
        endif

c ---   convective velocity scale (m/s) 
c --    Must be based on Buoyancy flux QB not sensible heat flux QH (060528)
c ---   (qb=rhocp * wt)
c        if(qh(i,j).gt.0.)then
c          wstar(i,j)=(g*qh(i,j)*zi(i,j)/(theta*rhocp))**0.3333333


        if(wt.gt.0.)then
           if (imixh.lt.0) then 
              wstar(i,j)=(g*wt*zi(i,j)/theta)**0.3333333
           else
c ---         convective velocity scale based on ziconv if computed (070702)
              wstar(i,j)=(g*wt*ziconv/theta)**0.3333333
           endif
        else
           wstar(i,j)=0.0
        endif
c

c ---  So-called "sensible heat flux" output in METGRD.MET (but is truly a buoyancy flux)
       qh(i,j)=wt*rhocp
      
c ---   PGT stability class
        if(abs(el(i,j)).gt.25.)then
           ipgt(i,j)=4
        else if(el(i,j).lt.-10.)then
           ipgt(i,j)=3
        else if(el(i,j).lt.0.)then
           ipgt(i,j)=2
        else if(el(i,j).le.10.)then
           ipgt(i,j)=6
        else if(el(i,j).le.25.)then
           ipgt(i,j)=5
        endif
c
500   continue
c
 
      return
      end

c----------------------------------------------------------------------
      subroutine waterp(u10,v10,imixh,qsw,qlw,dcoast,zu,ilandu,      
     :                 iwat1,iwat2,nx,ny,dgrid,fcori,nhrz,z0)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 100719             WATERP
c ---          F. Robe, Earth Tech
c
c --- PURPOSE:  Compute micrometeorological parameters over water using
c               delta temp. method or the COARE algorithm , and 
c               prognostic overwater temperature variables 
c               (note: wave properties can still be from SEA.DAT)
c
c
c --- UPDATES:
c ---  V6.223 (070702) to v6.229 (100719)(F.Robe)
c      (1) Save Convective mixing height array and pass on old values to
c          MIXHMC and MIXHBG (rather than old values of the mixing height
c          be it mechanical or convective) - Bug fix
c
c --- V6.222 Level 070404 to V6.223 Level 070702 (F.Robe)
c          (1) Pass on correct value of ilapse to MIXHMC and MIXHBG
c              (was not correct when itwprog=2)
c          (2) wstar overwater strictly based on convective mixing height                 
c              if computed (imixh>0)
c
c ---  V6.214 Level 060528 to V6.222 Level 070404(F.Robe)
c          (1) Include internal common to pass value of dptt to MIXHMC
c
c --- Version v6.205 Level 060318 to Version V6.214 Level 060528 (FRR)
c          (1) Convert SST from Kelvins to Celsius to pass to COARE
c          (2) Define w* as a function of the buoyancy flux not sensible heat flux
c              with COARE option
c          (3) Populate QH array stored in METGRD.MET consistently with buoyancy
c              heat fluxes offshore (was sensible heat fluxes with COARE, and 
c              buoyancy fluxes with deltaT)
c          (4) Label buoyancy flux QB instead of QH in deltaT method to avoid 
c              misintrepretation
c          (5) Skip definition of qe as never used
c 
c
c --- Version 5.614 Level 051228 to V6.205 Level 060318
c          (1) Make sure SST passed to COARE are above -3.C
c
c --- Version 5.611 Level 051113 to Version 5.614 Level 051228
c          (1) Add Depth of SST sensor to COARE calling list
c
c --- INPUT:
c       U10(mxnx,mxny) - real array    - Surface U component wind (m/s)
c                                        at height of ZU
c       V10(mxnx,mxny) - real array    - Surface V component wind (m/s)
c                                        at height of ZU
c                  IMIXH - integer    - Method for convective mixing height
c                                       1: Maul Carson overland and overwater
c                                       2: Batchvarova-Gryning overland and OW
c                                      -1: MC overland, OCD mechanical OW
c                                      -2: BG overland, OCD mechanical OW
c       QSW(mxnx,mxny) - real array    - net short wave radiative flux (W/m2)
c                                        at the surface
c       QLW(mxnx,mxny) - real array    - downward long wave radiative flux (W/m2)
c                                        at the surface
c    DCOAST(mxnx,mxny) - real array    - Distance from overwater gridpoint to
c                                        nearest shorec
c                   ZU - real          - height of the lowest CALMET gridpoint
c                                        where the surface winds are computed
c                                        (usually 10m)
c    ILANDU(mxnx,mxny) - integer array - Land use category at each
c                                        grid point
c         IWAT1, IWAT2 - integers      - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c                DGRID - real          - Grid cell size (m)
c     FCORI(mxnx,mxny) - real array    - Absolute value of the Coriolis
c                                        parameter (1/s)
c               NHRZ   - integer       - GMT hour (ending time)
c
c
c
c       Common block /OVRWAT/ variables:
c          NOWSTA, XOWSTA(mxows), YOWSTA(mxows), ZOWSTA(mxows),
c          DTOW(mxows), TAIROW(mxows), RHOW(mxows),
c          ZIOW(mxows), TGRADA(mxows),ZIMINW, ZIMAXW, CONSTW, 
c          ICOARE,JWAVE , dshelf, iwarm,icool
c
c          ICOARE -  Overwater method  -JWAVE: wave method
c                 -  0: original deltaT method (OCD)
c                 - 10: COARE with wave option jwave=0 (Charnock)
c                 - 11: COARE with wave option jwave 1 (Oost et al)
c                 - 12: COARE with wave option 2 (Taylor and Yelland)
c
c       common block /METGRD/ arrays, all dimensioned (mxnx,mxny):
c          RMM (rainfall rate in mm/hr)
c
c       common block /GEN/itimstep
c
c       common block /M3DMET/TAIRP(mxnxp,mxnyp),SSTP(mxnxp,mxnyp),
c                            RHP(mxnxp,mxnyp),Z1P(mxnxp,mxnyp)
c
c       common block /MM4HDO/igrabw(mxnx,mxny),jgrabw(mxnx,mxny),
c                            XLONG4(mxnxp,mxnyp)
cc                 
c       Parameters: MXNX, MXNY, IO6
c
c
c --- OUTPUT:
c        Z0(mxnx,mxny) - real array    - Surface roughness lengths (m)
c 
c       common block /METGRD/ arrays, all dimensioned (mxnx,mxny):
c          IPGT, QH, USTAR, ZI, EL, WSTAR, RMM
c
c --- WATERP called by: COMP
c --- WATERP calls:     ESAT (function), DELTAT, COARE
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real u10(mxnx,mxny),v10(mxnx,mxny),z0(mxnx,mxny)
      real qsw(mxnx,mxny),qlw(mxnx,mxny)
c     real qe(mxnx,mxny)

      real th(mxnxp,mxnyp),dthz(mxnxp,mxnyp),q(mxnxp,mxnyp)
      real dth10(mxnxp,mxnyp),th10(mxnxp,mxnyp)

      integer ilandu(mxnx,mxny)
      real dcoast(mxnx,mxny),fcori(mxnx,mxny)

      real zicold(mxnx,mxny)

c --- COARE input/output real variables are real*8
      real*8 rzu,rzt,rws10,rtairc,rtsea,rzi,rrmm,rq,rqsw,rqlw
      real*8 rrlong,rz0,rustar,rqh,rqe,rtwave,rhwave
      real*8 rtstar,rqstar,rzsst
c

      include 'ovrwat.met'
      include 'gen.met'
      include 'metgrd.met'
      include 'm3dmet.met'
      include 'mm4hdo.met'
c
      data z0min/2.0e-6/,rmax/1.e37/,pres/1000./
      data vk/0.4/,g/9.81/,rhocp/1195.2/
      data nearow/0/
      data  rtwave/-999./,rhwave/-999./

      common /tjump/ dptt(mxnx,mxny)

c     100719 - make sure to retain Zicold values from old timestep
      save zicold


c --- Treat prognostic gridpoints as overwater stations and compute
c --- necessary variables
c --- Loop over 3D.DAT gridcells
      do 50 jp=1,nyp
      do 50 ip=1,nxp
c ---    process only water cells
         if (ilu4(ip,jp).ne.iluoc3d) goto 50 
c
c ---    compute saturation and actual water vapor pressure (mb) at
c ---    measurement height
c ---    (NOTE: ESAT function uses temperature in deg. C)
c ---    (constant 0.01 converts rh from percent to fraction)
         tairc=tairp(ip,jp)-273.15
         es=esat(tairc)
         e=0.01*rhp(ip,jp)*es
c
c ---    compute saturation and actual mixing ratio (g h20/g dry air) at
c ---    measurement height
         ws=0.622*es/(pres-es)
         w=0.622*e/(pres-e)
c ---    specific humidity (g H2O/ KG moist air (!! units))
         q(ip,jp)= w/(1+w)*1000.

c
c ---    compute virtual temperature (deg. K) at measurement height
         tv=tairp(ip,jp)*(1.+0.61*w)
c
c ---    compute virtual potential temperatures (deg. K) at measurement ht
c ---    (potential temp. = temp. + 0.01 (deg. K/m) * height)
         dth=0.01*z1p(ip,jp)
         th(ip,jp)=tv+dth
c
c ---    compute virtual potential temp. (deg. K) at surface -- assume
c ---    surface relative humidity = 100 %
         twaterc=sstp(ip,jp)-273.15
         es=esat(twaterc)
         ws=0.622*es/(pres-es)
         thsurf=sstp(ip,jp)*(1.+0.61*ws)
         dthz(ip,jp)=th(ip,jp)-thsurf
c
c ---    convert measurement ht. - surface delta potential virtual
c ---    temperature to 10 m - surface value
c ---    constant 11.512925 = ln(10 m/z0) with z0=1.e-4 m
c ---    constant 9.2103404 = -ln(z0) with z0=1.e-4 m
         dth10(ip,jp)=dthz(ip,jp)*11.512925/(alog(z1p(ip,jp))+
     1              9.2103404)
         th10(ip,jp)=thsurf+dth10(ip,jp)
50    continue


c --- loop over grid cells
c
      do 500 i=1,nx
      do 500 j=1,ny
c
c ---    process only water cells
         if(ilandu(i,j).lt.iwat1.or.ilandu(i,j).gt.iwat2)go to 500
c
c ---    wind speed at 10 m
         ws10=sqrt(u10(i,j)**2+v10(i,j)**2)

c ---    Roughness length  (Hosker method)
c ---    (is updated in COARE if COARE method selected but initial value
c ---    required in both cases to compute mixing height
         if(ws10.gt.0.0)then
            z02=2.0e-6*ws10**2.5
            z02=amax1(z0min,z02)
         else
            z02=z0min
         endif

c ---    3D.DAT ocean gridpoint nearest to CALMET water cell
         inear=igrabw(i,j)
         jnear=jgrabw(i,j)

c ---    050328 (F.Robe). 
c ---    option to use original DeltaT method or COARE algorithm to compute
c        Roughness length (zo), Monin-Obukhov Length (el), 
c        friction velocity (u*),Buoyancy Flux (qb)
c        If DeltaT; compute u*,Zo,Qh,el first then mixing height  
c        if COARE: compute mixing height first (required input to COARE)

c ---    DELTAT METHOD:
         if (icoare.eq.0) then 
c ---       Pass measurement height instead of nearow to deltaT (051113)
            call DELTAT(ws10,z1p(inear,jnear),dthz(inear,jnear),
     :                  dth10(inear,jnear),th10(inear,jnear),
     :                  th(inear,jnear),z02,el(i,j),ustar(i,j),qb)
            z0(i,j)=z02
c ---       Buoyancy Flux  in terms of <w'Thetav'>
            wt=Qb/rhocp

           go to 1300
         endif

c ---    OVERWATER MIXING HEIGHT (m)
C ---    Compute Zi using u*
c
c --     For COARE method, u* is not computed yet so make first guess using
c ---    neutral deltaT equations for u*


c ---    NEUTRAL DELTAT EQUATIONS for u* ,el,wt
         ustar2=vk*ws10/alog(10./z02)
c ---    prevent numerical problems with zero ustar
         ustar(i,j)=amax1(ustar2,1.e-9)
         el(i,j)=9.9e9
         wt=0.

c ---    non neutral EL and QH are recomputed in COARE
c ---    (if COARE is selected and data available)
     

1300    continue


        
c ---   No overwater MixH in 3D.DAT: 
c ---   At this point, only compute the mechanical MixHeight to be used
c ---   in COARE (not a sensitive parameter but needs a value)
c ---   after the COARE computations, compute the convective mix. height
c ---   compute mechanical overwater mixing height (default value: const=0.16)

        zimech=constw*ustar(i,j)/fcori(i,j)

c frr 050328
C ---   COARE method 
c ---   Roughness length (z0), Monin-Obukhov Length (el), 
c ---   friction velocity (u*),Sensible Heat Flux (qh)

        if ( abs(icoare).ge.10) then
c ---       compute air and sea temp in Celsius and positive 
c ---       longitude  (+ in East. Hem. )at nearest 3D.DAT gridpoint
c ---       in real*8 variables

            rzt=z1p(inear,jnear)
            rtairc=tairp(inear,jnear)-273.15
            rtsea=sstp(inear,jnear)-273.15
c ---       make sure SST above -3C:
            rtsea=max(rtsea,-3.D0)

            rrlong =xlong4(inear,jnear)

c ---       Observed dominant wave period and height at nearest station 
c ---       if requested (icoare=-11,-12).  
c ---       find nearest station with valid wave data
            if (icoare.lt.0) then
               now=1
               if(nowsta.gt.1) then
                  xgdpt=(float(i)-0.5)*dgrid
                  ygdpt=(float(j)-0.5)*dgrid
                  dmin2=rmax
c ---             loop over overwater stations to find closest one to (i,j)
                  do 122 k=1,nowsta
c ---                check if wave data is missing
                     if((hwave(k).lt.0.).or.(twave(k).lt.0.))goto 122
c ---                station coordinates are relative to origin (i.e.,
c ---                (xowsta(k),yowsta(k)) of lower left corner of grid = (0.,0.))
                     dist2=(xowsta(k)-xgdpt)**2+(yowsta(k)-ygdpt)**2
                     if(dist2.lt.dmin2)then
                        dmin2=dist2
                        now=k
                     endif
122               continue
               endif
c ---          note: it is okay if all missing wave data (now=1)
               rtwave=twave(now)
               rhwave=hwave(now) 
            endif

c ---       depth of SST sensor - Default: surface (0.05m)
            rzsst=0.05

c ---       map other input variables to real*8 variables
            rzu=zu
            rws10=ws10
            rzi=zimech
            rrmm=rmm(i,j)            
            rq=q(inear,jnear)
            rqsw=qsw(i,j)
            rqlw=qlw(i,j)

            call COARE(itimstep,i,j,rzu,rzt,rzsst,rws10,rtairc,rtsea,
     :               rzi,rrmm,rq,rqsW,rqLW,rrlong,jwave,rtwave,rhwave,
     :               nhrz,dshelf,dcoast(i,j),iwarm,icool,rz0,el(i,j),
     :               rustar,rtstar,rqstar,rqh,rqe)

c ---       map output variables to real*4 variables
            z0(i,j)=rz0              
            ustar(i,j)=rustar
c ---       sensible heat flux (050628 - the output array QH mislabelled "sensible heat
c           flux", should have buoyancy fluxes in it, not sensible heat flux
c            qh(i,j)=rqh
c ---       latent heat flux (skip - never used)
c           qe(i,j)=rqe

c ---       Surface Buoyancy flux in terms of <w'Thetav'>
            wt=-ustar(i,j)*(rtstar+0.61*rqstar*tairp(inear,jnear))

c ---       restrict Monin-Obhukov length near zero (to be consistent with deltaT)
            if(abs(el(i,j)).lt.5.0)then
               if(el(i,j).lt.0)then
                  el(i,j)=-5.0
               else
                 el(i,j)=5.0
               endif
            endif
       endif

c ---   Update mechanical and compute convective OW mixing height            

c ---   Mechanical
        zimech=constw*ustar(i,j)/fcori(i,j)

c
c ---   make sure initial "old" zi is at least the minimum zi otherwise
c ---   crashed in mixdt2 for itwprog=1 (could be a problem at first
c ---   timestep)
        zi(i,j)=amax1(zi(i,j),ziminw)
c       make sure old convective Zi is not greater than old Zi (in case Zicold 
c       not initialized by computer to 0)(100719)
        zicold(i,j)=amin1(zicold(i,j),zi(i,j))
        zicold(i,j)=amax1(zicold(i,j),ziminw)

        if(imixh.eq.2) then
c ---      Batchvarova-Gryning convective mixing height 
c          100719-Pass on old value of Zic not old value of Zi              
           call MIXHBG(nhrz,I,J,WT,DTHDZ,Tairow(nearow),1,
c     :         THRESHW,ZIMAXW,ZIMINW,USTAR(i,j),EL(i,j),ZI(i,j),ZICONV,
     :         THRESHW,ZIMAXW,ZIMINW,USTAR(i,j),EL(i,j),ZIcold(i,j),ZICONV,
     :         THT,THTP)
           zicold(i,j)=ziconv
        else if (imixh.eq.1) then
c ---      Carson convective mixing height (similar to MIXHTST/MIXHSTS2)
c          100719-Pass on old value of Zic not old value of Zi              
           call MIXHMC(nhrz,i,j,wt,DTHDZ,1,threshw,
c     :                    zimaxw,zi(i,j),ziconv,dptt,THT,THTP)
     :                    zimaxw,zicold(i,j),ziconv,dptt,THT,THTP)
            zicold(i,j)=ziconv
        else
c          OCD mixing height (mechanical only)
            ziconv=0.
            zicold(i,j)=ziconv
        endif

        zi(i,j)=amax1(zimech,ziconv)
        zi(i,j)=amax1(ziminw,zi(i,j))
        zi(i,j)=amin1(zimaxw,zi(i,j))



1600    continue

c ---   OTHER variables ( independent of method)
c
        theta=th(inear,jnear)

c ---   convective velocity scale (m/s)
c ---   Must be based on Buoyancy flux QB not sensible heat flux QH (060528)
c ---   (Qb=rhocp * wt)
c       if(qh(i,j).gt.0.)then
c          wstar(i,j)=(g*qh(i,j)*zi(i,j)/(theta*rhocp))**0.3333333
        if(wt.gt.0.)then
           if (imixh.lt.0) then 
c             OCD mixing height
              wstar(i,j)=(g*wt*zi(i,j)/theta)**0.3333333
           else 
c ---         convective mixing height (070702)
              wstar(i,j)=(g*wt*ziconv/theta)**0.3333333
           endif
        else
           wstar(i,j)=0.0
        endif
c
c ---  So-called "sensible heat flux" array stored in METGRD.MET (but is truly a buoyancy flux)
       qh(i,j)=wt*rhocp


c ---   PGT stability class
        if(abs(el(i,j)).gt.25.)then
           ipgt(i,j)=4
        else if(el(i,j).lt.-10.)then
           ipgt(i,j)=3
        else if(el(i,j).lt.0.)then
           ipgt(i,j)=2
        else if(el(i,j).le.10.)then
           ipgt(i,j)=6
        else if(el(i,j).le.25.)then
           ipgt(i,j)=5
        endif
c
500   continue
c
      return
      end


c----------------------------------------------------------------------
      subroutine DELTAT(ws10,zanem,dthz,dth10,th10,theta,z02,el2,
     :           ustar2,qb)
c----------------------------------------------------------------------
c --- CALMET   Version: 6.4.0     Level: 070717             DELTAT
c ---          F.Robe (Earth Tech) 
c              after pre-050328 CALMET WATER subroutine
c
c --- PURPOSE:  Compute micrometeorological parameters (El,U*,QH)
c               over water using delta temp. method 
c
c --- UPDATES
c --- V6.214 Level 060528 to V6.3 (070717)
c         - Add precision to the product Vk*g by replacing data
c           statement with the explicit product, as done in original
c           code lines from WATER
c         
c --- v5.611 Level 051113 to V6.214 Level 060528(F.Robe)
c         - Rename QH2, QB as the so=called "sensible heat flux" is truly a buoyancy
c           flux overwater, not a sensible heat flux. i.e. it takes into account
c           moisture as well as temperature through the use of virtual potential 
c           temperature 
c --- V5.6 level 050328 to v5.611 Level 051113 (F.Robe)
c         - Add Temp measurement height to calling list so that deltaT is
c           independent of ITWPROG (same subroutines whether SEA.DAT
c           or 3D.DAT is used)
c         - Remove nearow from calling list and "include 'ovrwat.met "
c            (no longer needed)
c
c
c --- INPUT:
c                   WS10 - real    - Wind speed at 10 m
c                  ZANEM - real    - Measurement height (or first 3D.DAT level)
c                  DTHZ   - surface delta potential virtual
c                          temperature to meas.ht - surface value at 
c                          nearest station/3D.DAT gridpoint
c                  DTH10 - surface delta potential virtual
c                          temperature to 10 m - surface value at 
c                          nearest station/3D.DAT gridpoint
c                   TH10 - potential virtual temperature to 10 m at 
c                          nearest station/3D.DAT gridpoint
c                  THETA - surface potential virtual temp. at 
c                          nearest station/3D.DAT gridpoint
c                    Z02 -real - roughness length
c

c --- OUTPUT:
c                   EL2 - real    - Monin-Obukhov length (m)
c                USTAR2 - real    - Friction velocity (m/s)
c                    QB - real    - Buoyancy Flux  (W/m2)
c                                   This quantity used to be labelled "sensible heat flux"
c                                   but has always been the buoyancy flux as it is based
c                                   on the virtual potential temperature 
c                                   (i.e. effects of temp and moisture are included)
c                                  
c
c
c --- DELTAT called by: WATER, WATERP
c --- DELTAT calls:  none

c -------------------------------------------------------------------------
      include 'params.met' 
c      include 'ovrwat.met'

c      data e2/5.096e-3/,vk/0.4/,vkg/3.924/,rhocp/1195.2/
      data e2/5.096e-3/,vk/0.4/,g/9.81/,rhocp/1195.2/

      vkg=vk*g

c --- estimate values of theta* and u* using OCD technique
c
c --- neutral drag coefficient (Garratt, 1977)
      cun=0.75e-3+0.067e-3*ws10
c
      xln10z0=alog(10./z02)
      xlnzz0=alog(zanem/z02)
c
c --- Monin-Obukhov length -- first guess
      if(abs(dth10).gt.1.e-6)then
c ---    constant e2 is 5.096e-3 (Hanna et al., 1985)
         el2=th10*cun**1.5*ws10**2/(e2*dth10)


c ---    if neutral or near-neutral, skip iteration -- use neutral eqns.
         if(abs(el2).gt.9999.)go to 1200
c
c ---    Monin-Obukhov length near zero restricted
         if(abs(el2).lt.5.0)then
            if(el2.lt.0.)then
               el2=-5.0
            else
               el2=5.0
            endif
         endif
      else
c
c ---    neutral conditions
         go to 1200
      endif
c
c --- iterate to refine u* and L estimates
      maxit=3
      elold=el2
      do 200 niter=1,maxit
c
c --- new estimate -- stability correction factors
      z10l=10.0/el2
      ztl=zanem/el2
      if(el2.gt.0.0)then
c
c ---    Monin-Obukhov length is positive -- stable conditions
         psiu=-4.7*z10l
         psit=-4.7*ztl
      else
c
c ---    Monin-Obukhov length is negative -- unstable conditions
         x=(1.0-15.0*z10l)**0.25
         psiu=2.0*alog(0.5*(1.+x))+alog(0.5*(1.+x*x))-
     1    2.0*atan(x)+1.5707963
         y=sqrt(1.-9.*ztl)
c ---    constant 1.48 = 2. * 0.74
         psit=1.48*alog(0.5*(1.+y))
      endif
c
c --- new estimates -- u* and theta*
      ustar2=vk*ws10/(xln10z0-psiu)
c --- prevent numerical problems with zero ustar
      ustar2=amax1(ustar2,1.e-9)
      thstar=vk*dthz/(0.74*xlnzz0-psit)
c
c --- determine new value of Monin-Obukhov length based on u*, theta*
      if(abs(thstar).gt.1.e-6)then
         el2=theta*ustar2**2/(vkg*thstar)
         if(abs(el2).gt.9999.)go to 1200
      else
         go to 1200
      endif
      if(abs(el2).lt.5.0)then
         if(el2.lt.0)then
            el2=-5.0
         else
            el2=5.0
         endif
      endif
c
c --- check for convergence (5% criterion)
      if(abs((el2-elold)/elold).lt.0.05)then
c ---    convergence -- skip out of loop
         go to 400
      else
c ---    perform another iteration (up to maxit)
         elold=el2
      endif
c
200   continue
      go to 400
c
c --- neutral conditions
1200  continue
      ustar2=vk*ws10/alog(10./z02)
c --- prevent numerical problems with zero ustar
      ustar2=amax1(ustar2,1.e-9)
      el2=9.9e9
      thstar=0.0
c
400   continue

c
c --- Buoyancy flux (watts/m**2)
c --- rhocp=1195.2 kg/(m*s**2*deg K)=(1.2 kg/m**3)(996 m**2/(s**2 deg))
      qb=-rhocp*theta*ustar2**3/(vkg*el2)


      RETURN
      END
c----------------------------------------------------------------------
      subroutine water2(us,vs,is,js,ns,zzanem,imixh,fcori,nsurf,zi,
     :                  qsw,qlw,rmm,nhrz,dcoast,ipsifcn)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070717             WATER2
c ---          M. Fernau, Earth Tech after WATER by J. Scire, SRC
c
c --- PURPOSE:  Compute micrometeorological parameters over water using
c               delta temp. or COARE methods so that similarity theory 
c               extrapolation can be done.
c
c --- UPDATES
c ---  V6.223 Level 070702 to v6.3 (070717)
c       - Add IPSIFCN to SIMILT argument list
c
c ---  V6.222 Level 070404 to V6.223 Level 070702(F.Robe)
c          (1) Correct array index of tgrada (nwat instead of ns)
c          (2) Define ws10 also when buoy anemometer height is 10m
c          (3) Define wt(=0) when OW data are missing 
c          (4) Define ilapse and pass on correct value of ilapse 
c              to MIXHMC and MIXHBG if itwprog=2
c
c ---  V6.214 Level 060528 to V6.222 Level 070404(F.Robe)
c          (1) Include internal common to pass value of dptt to MIXHMC
c
c --- V6.205 Level 060318 to V6.214 Level 060528 (F.Robe)
c          (1) Rename qh2 output from deltat qb2 as it is a buoyancy flux not
c              a sensible heat flux
c          (2) compute the buoyancy flux (wt= <w'Thetav'> )for deltaT method
c              so the mixing heights can be correctly computed
c          (3) Skip definition of thstar,qh,qe as not used 
c      
c --- Version 5.614 Level 051228 to V6.205 Level 060318
c          (1) Make sure SST passed to COARE are above -3C
c
c --- V5.613 (051227)to v5.614 (051228)(F.Robe):
c        - Add depth of SST sensor to COARE calling list
c --- V5.611 (051113) to v5.613 (051227)(F.Robe):     
c        - Use actual Tair Sensor height instead of anemometer height
c          if available (SEA.DAT version 2.11+)
c --- V5.6f (050824) to V5.611 (051113) (F.Robe):     
c        - Pass zzanem instead of nwat to deltaT 
c --- V5.6d (050428) to V5.6f (050824) (DGS):     
c        - Check for missing Tair-Tsea before calling COARE 
c --- V5.6c (050419) to V5.6d (050428) (F.Robe):     
c        - Declare rtstar,rqstar as real*8 
c
c --- V5.6 (050328) to V5.6c (050419) (F.Robe):     
c        - Pass iwarm,icool,(is,js) to COARE via calling list
c        - Include gen.met to pass itimstep value to COARE
c
c     Level(950201) to V5.6 Level 050328 (F.Robe)
c        - Allow use of COARE method 
c        - Compute convective mixing height (Batchvarova&Gryning or Maul-Carson)
c        - Use anemometer height not height of first CALMET level as observed
c          surface winds have not been extrapolated yet
c        - Ensure that winds at 10m are used for OCD method
c
c --- INPUT:
c     US(MXNZ,MXWND) - real array - U component of observed winds (for k=1:
c                                   observation is at anemometer height, not
c                                   at first CALMET level
c     VS(MXNZ,MXWND) - real array - V component of observed winds
c            (IS,JS) - integers   - Coordinates (i,j) of the gridcell where the station is located
c                 NS - integer    - Location of station in surface array
c             ZZANEM - real       - Surface (land) station anemometer height
c                                   For overwater station, actual value is
c                                   passed on via common OVRWAT.MET
c                IMIXH - integer  - Method for convective mixing height
c                                    1: Maul Carson overland and overwater
c                                    2: Batchvarova-Gryning overland and OW
c                                   -1: MC overland, OCD mechanical OW
c                                   -2: BG overland, OCD mechanical OW
c                 ZI - real       - previous hour mixing height at gridpoint 
c                                   where station is located
c                QSW - real array - net short wave radiative flux (W/m2)
c                                   at the surface gridpoint where station 
c                                   is located
c                QLW - real       - downward long wave radiative flux (W/m2)
c                                   at the surface gridpoint where station 
c                                   is located
c              FCORI - real       - Absolute value of the Coriolis
c                                   parameter (1/s)  at station gridpoint
c              NSURF - integer    - Total # of surface sites
c               NHRZ - integer    - GMT hour (ending time)
c               RMM  - real       - Rainfall rate (mm/hr) where station is located
c             DCOAST - real       - distance from overwater station to 
c                                   coast (in km)
c            IPSIFCN - integer    - Flag controlling choice of PSI
c                                   stability correction for wind
c                                   profile
c                                  (IPSIFCN=0 use CALMET v5.6;
c                                   IPSIFCN=1 use CALMET v5.53)
c
c       Common block /OVRWAT/ variables:
c          DTOW(mxows), TAIROW(mxows), RHOW(mxows),
c          ZIOW(mxows), ZOWSTA(mxows), ZIMINW, ZIMAXW, CONSTW
c          ICOARE,WAVE, dshelf
c       Parameters: MXNZ, MXWND
c       From TMP.MET: tgdefa
c
c --- OUTPUT:
c         US(MXNZ,MXWND) - real array - U component of observed winds
c         VS(MXNZ,MXWND) - real array - V component of observed winds
c                                       (extrapolated aloft)
c
c --- WATER2 called by: STHEOR
c --- WATER2 calls:     SIMILT, ESAT (function)
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'tmp.met'
      include 'gen.met'
c
      real us(mxnz,mxwnd),vs(mxnz,mxwnd)

c --- double precision variables for COARE (050328)
      real*8 rzu,rzt,rwsz,rzi,rrmm,rq,rqsw,rqlw,rqh,rqe
      real*8 rtairc,rtsea,rrlong,rtwave,rhwave,rz0,rustar
      real*8 rqstar,rtstar,rzsst

c --- Flag for OK SEA.DAT data
      logical lsea

      include 'ovrwat.met'
c
      data z0min/2.0e-6/,xmissm/990./,pres/1000./
      data vk/0.4/,rhocp/1195.2/
c
      common /tjump/ dptt(mxnx,mxny)

c --- If surface wind components missing, don't bother to extrapolate
      if (us(1,ns) .gt. xmissm .or. vs(1,ns) .gt. xmissm) return
c --- Do not extrapolate calm winds
c --- Note (frr 050328):us(1,n),vs(1,n) are winds measured at anemometer height 
c --- not necessarily at 10m 
      wsz = sqrt(us(1,ns) **2 + vs(1,ns) **2)
      if (wsz .lt. 0.0001) return
c

c --- Set lapse rate flag for mixing height subroutine (070702)
      if (itwprog.eq.0) then
          ilapse=0
      else
          ilapse=1
      endif

c --- Find location of station in overwater array
      nsfc = nsurf - nowsta
      nwat = ns - nsfc


c --- Anemometer height
c --- 050328: for sf station (not SEA.dAT), zanem passed through calling list
      if (nwat.gt.0) then
        zzanem = zowsta(nwat)
        zztair = ztair(nwat)
c ---   Assume 10. m anemometer height if missing
        if(zzanem.ge.9998.)zzanem=10.
        if(zztair.ge.9998.)zztair=zzanem
      end if


c --- If station is not a SEA#.DAT station, skip following section
c --- Air-sea temperature difference must be valid to use station
      if (nwat .le. 0 .or. dtow(nwat) .ge. xmissm) goto 51
c
c --- overwater air temp. at measurement ht -- if missing,
c --- assume T=60 F = 288.7 K
      if (tairow(nwat) .ge. xmissm) then
         tair = 288.7
      else
         tair = tairow(nwat)
      endif
c
c --- water temperature -- computed from air temp + air-sea delta temp
      twater = tair - dtow(nwat)
c
c --- relative humidity -- if missing, assume 100 %
      if (rhow(nwat) .ge. xmissm) then
         rh = 100.
      else
         rh = rhow(nwat)
      endif
c
c --- compute saturation and actual water vapor pressure (mb) at
c --- measurement height
c --- (NOTE: ESAT function uses temperature in deg. C)
c --- (constant 0.01 converts rh from percent to fraction)
      tairc = tair - 273.15
      es = esat(tairc)
      e = 0.01 * rh * es
c
c --- compute saturation and actual mixing ratio (g h20/g dry air) at
c --- measurement height
      ws = 0.622 * es / (pres - es)
      w = 0.622 * e / (pres - e)
c --- frr 050328 specific humidity (g H2O/ KG moist air (!! units))
      q= w/(1+w)*1000.
c
c --- compute virtual temperature (deg. K) at measurement height
      tv = tair * (1. + 0.61 * w)
c
c --- compute virtual potential temperatures (deg. K) at measurement ht
c --- (potential temp. = temp. + 0.01 (deg. K/m) * height)
      dth = 0.01 * zowsta(nwat)
      th = tv + dth
c
c --- compute virtual potential temp. (deg. K) at surface -- assume
c --- surface relative humidity = 100 %
      twaterc = twater - 273.15
      es = esat(twaterc)
      ws = 0.622 * es / (pres - es)
      thsurf = twater * (1. + 0.61 * ws)
      dthz = th - thsurf
c
c --- convert measurement ht. - surface delta potential virtual
c --- temperature to 10 m - surface value
c ---   constant 11.512925 = ln(10 m/z0) with z0=1.e-4 m
c ---   constant 9.2103404 = -ln(z0) with z0=1.e-4 m
      dth10 = dthz * 11.512925 / (alog(zowsta(nwat)) +
     &        9.2103404)
      th10 = thsurf + dth10
51    continue
c

c     vkg = vk * g
c

c --- compute overwater surface roughness (Hosker, 1974)
c --- Define ws10 for all cases (070702)
      ws10=wsz
      if(wsz.gt.0.0)then
         zz0 = 2.0e-6 * wsz ** 2.5
         zz0 = amax1(z0min,zz0)
c ---    Adjust wind speed to 10m and recompute z0 (050328-frr)
         if (int(zzanem).ne.10) then
            ws10=wsz*alog(10./zz0)/alog(zzanem/zz0)
            zz0 = 2.0e-6 * ws10 ** 2.5
         endif
      else
         zz0 = z0min
      endif
c
c --- Scale winds to 10m (050328) for OCD method and z0,u*neutral

c --- if overwater data is missing, assume near-neutral conditions
      if (nwat .le. 0 .or. dtow(nwat) .ge. xmissm) goto 1200

c ---    050328 (F.Robe). 
c ---    option to use original DeltaT method or COARE algorithm to compute
c        Roughness length (zo), Monin-Obukhov Length (el), 
c        friction velocity (u*),Buoyancy Flux (qb)
c        If DeltaT; compute u*,Zo,Qb,el first then mixing height  
c        if COARE: compute mixing height first (required input to COARE)

c ---    DELTAT METHOD (OCD)
         if (icoare.eq.0) then
            call DELTAT(ws10,zzanem,dthz,dth10,th10,th,zz0,el2,
     :                  ustar2,qb2)
c ---       Surface Buoyancy flux in terms of <w'Thetav'> (060528)
            wt=qb2/rhocp
            go to 400
         endif

1200  continue
c --- Neutral conditions

      ustar2 = vk * ws10 / alog(10. / zz0)
c --- prevent numerical problems with zero ustar
      ustar2 = amax1(ustar2,1.e-9)
      el2 = 9.9e9
      wt=0.
c --- thstar not used so skip definition
c     thstar = 0.0
c
400   continue

c --- friction velocity (m/s)
      ustar = ustar2
c
c --- Monin-Obukhov length (m)
      el = el2
c
c --- Overwater mixing height (m): observed mixing heights (if available)
      if (nwat .le. 0 .or. ziow(nwat) .ge. xmissm) then
c
c ---    No overwater data -- compute overwater mixing height
c ---    Default values: CONSTW = 0.16, 
        zii = constw * ustar / fcori
        zii = amax1(ziminw,zii)
        zii = amin1(zimaxw,zii)
        iziobs=0
      else
        zii = ziow(nwat)
        iziobs=1
      end if


c --- Adjustment to minimize mixing heights that are bigger than the
c     final gridded mixing height field for current hour
      zii = amin1(zii,zi)
c     make sure however that they are at least = ziminw (for first step, no
c     values yet)  (050328)
      zii = max(zii,ziminw)

c frr 050328
C ---   COARE method (if data is not missing)
c ---   Roughness length (z0), Monin-Obukhov Length (el), 
c ---   friction velocity (u*),Sensible Heat Flux (qh)
c ---   Buoyancy flux (qb)

        lsea=.TRUE.
        if(nwat .LE. 0) then
           lsea=.FALSE.
        elseif(dtow(nwat) .GE. xmissm) then
           lsea=.FALSE.
        endif

        if ( (abs(icoare).ge.10).and. lsea ) then
c ---       compute air and sea temp in Celsius and positive 
c ---       longitude in East. Hem. at nearest overwater station.
c ---       in real*8 variables

            rzt=zztair
            rtairc=tairc
            rtsea=rtairc-dtow(nwat)
c ---       make sure SST above 0C:
            rtsea=max(rtsea,-3.D0)

            rrlong =xowlon(nwat)

c ---       Dominant wave period and height (ok if missing, default in COARE)
            rtwave=twave(nwat)
            rhwave=hwave(nwat) 

c ---       depth of SST sensor - Default: moored NDCB buoy value (0.6m)
            if (zsst(nwat).lt.9998.) then
               rzsst = zsst(nwat)
            else
               rzsst=0.6
            endif


c ---       map other input variables to real*8 variables
c ---       winds are at anemometer height (not zmid(1) - 050328
            rzu=zzanem
            rwsz=wsz
            rzi=zii             
            rrmm=rmm            
            rq=q
            rqsw=qsw 
            rqlw=qlw 

            call COARE(itimstep,is,js,rzu,rzt,rzsst,rwsz,rtairc,rtsea,
     :                rzi,rrmm,rq,rqsW,rqLW,rrlong,jwave,rtwave,rhwave,
     :                nhrz,dshelf,dcoast,iwarm,icool,rz0,el,
     :                rustar,rtstar,rqstar,rqh,rqe)


c ---       map output variables to real*4 variables
            zz0=rz0
            ustar=rustar
c ---       not used so no need to define real*4 var.
c            qh=rqh
c	    qe=rqe

c ---       Surface Buoyancy flux in terms of <w'Thetav'>
            wt=-ustar*(rtstar+0.61*rqstar*tair)

c ---       restrict Monin-Obhukov length near zero (to be consistent with deltaT)
            if(abs(el).lt.5.0)then
               if(el.lt.0)then
                  el=-5.0
               else
                 el=5.0
               endif
            endif

        endif

c ---  Update mechanical and compute convective OW mixing height if no MixH obs.            
       if (iziobs.eq.0)  then

c ---      Mechanical
           zimech=constw*ustar/fcori

           if (itwprog.eq.0) then
c ---         Use constant lapse rate over mixing height (default or from SEA.DAT)
c ---         (else it will be extracted from the progn. temp. profiles in mixhbg/,mixhmc)
c ---          Bug fix (070702): tgrada defined for OW stations only (nwat index)
c              if(tgrada(ns).lt.xmissm) then
c                 dtdz=tgrada(ns)
              if (nwat.gt.0) then
                 if(tgrada(nwat).lt.xmissm) then
                    dtdz=tgrada(nwat)
                 else 
                    dtdz=tgdefa
                 endif
              else 
                 dtdz=tgdefa
              endif
c ---         potential temperature lapse rate
              dthdz=dtdz+0.0098
           endif

           if(imixh.eq.2) then
c             Batchvarova-Gryning convective mixing height 
              call MIXHBG (nhrz,Is,Js,WT,dthdz,Tair,Ilapse,THRESHW,
     :               ZIMAXW,ZIMINW,USTAR,EL,ZIi,ZICONV,THT,THTP)
                        
           else if (imixh.eq.1) then
c             Carson convective mixing height (similar to MIXHTST/MIXHSTS2)
              call MIXHMC (nhrz,is,js,wt,dthdz,ilapse,threshw,
     :                     ZIMAXW,zii,ziconv,dptt,tht,thtp)
           else
c             OCD mixing height (mechanical only)
              ziconv=0.
           endif

           zii=amax1(zimech,ziconv)
           zii=amax1(ziminw,zii)
           zii=amin1(zimaxw,zii)

        endif

c
c --- Call extrapolation routine
      call similt(zzanem,el,zz0,zii,ns,ipsifcn,us,vs,ziminw)
      
      return
      end
c----------------------------------------------------------------------
      subroutine water2p(us,vs,is,js,ns,zzanem,imixh,fcori,nsurf,zi,
     :                  qsw,qlw,rmm,nhrz,dcoast,ipsifcn)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070717            WATER2P
c ---          F.Robe, Earth Tech
c
c --- PURPOSE:  Compute micrometeorological parameters over water using
c               delta temp. or COARE methods so that similarity theory 
c               extrapolation can be done, with prognostic temperature
c               variables.
c
c --- UPDATES:
c ---  V6.223 Level 070702 to v6.3 (070717)
c       - Add IPSIFCN to SIMILT argument list
c
c ---  V6.222 Level 070404to V6.223 Level 070702(F.Robe)
c          (1) Define ws10 also when buoy anemometer (lowest M3d level)
c              height is 10m
c          (2) Pass on correct value of ilapse to MIXHMC and MIXHBG 
c              when itwprog=2
c
c ---  V6.214 Level 060528 to V6.222 Level 070404(F.Robe)
c          (1) Include internal common to pass value of dptt to MIXHMC
c
c --- V6.205 Level 060318 to V6.214 Level 060528
c          (1) Rename QH2 QB2 with deltaT method as this quantity is
c              truly a buoyancy flux, not a sensible heat flux
c          (2) Compute wt for DeltaT method
c          (3) make sure rtwave and rhwave are set to missing values when
c              there are no buoy data (nwat=0)
c          (4) Skip definition of thstar,qh,qe as not used 
c 
c --- Version 5.614 Level 051228 to V6.205 Level 060318
c          (1) Make sure SST passed to COARE are above -3C
c
c --- Version 5.611(051113) to V5.614 (051228)
c         - Add SST sensor depth to COARE calling list
c
c --- INPUT:
c     US(MXNZ,MXWND) - real array - U component of observed winds (for k=1:
c                                   observation is at anemometer height, not
c                                   at first CALMET level
c     VS(MXNZ,MXWND) - real array - V component of observed winds
c            (IS,JS) - integers   - Coordinates (i,j) of the gridcell where the station is located
c                 NS - integer    - Location of station in surface array
c             ZZANEM - real       - Surface (land) station anemometer height
c                                   For overwater station, actual value is
c                                   passed on via common OVRWAT.MET
c                IMIXH - integer  - Method for convective mixing height
c                                    1: Maul Carson overland and overwater
c                                    2: Batchvarova-Gryning overland and OW
c                                   -1: MC overland, OCD mechanical OW
c                                   -2: BG overland, OCD mechanical OW
c                 ZI - real       - previous hour mixing height at gridpoint 
c                                   where station is located
c                QSW - real array - net short wave radiative flux (W/m2)
c                                   at the surface gridpoint where station 
c                                   is located
c                QLW - real       - downward long wave radiative flux (W/m2)
c                                   at the surface gridpoint where station 
c                                   is located
c              FCORI - real       - Absolute value of the Coriolis
c                                   parameter (1/s)  at station gridpoint
c              NSURF - integer    - Total # of surface sites
c               NHRZ - integer    - GMT hour (ending time)
c               RMM  - real       - Rainfall rate (mm/hr) where station is located
c             DCOAST - real       - distance from overwater station to 
c                                   coast (in km)
c            IPSIFCN - integer    - Flag controlling choice of PSI
c                                   stability correction for wind
c                                   profile
c                                  (IPSIFCN=0 use CALMET v5.6;
c                                   IPSIFCN=1 use CALMET v5.53)
c
c       Common block /OVRWAT/ variables:
c          ICOARE,WAVE, dshelf
c        common /MM4HDO/
c        xlong4 (mxnxp,mxnyp),igrabw(mxnx,mxny),jgrabw(mxnx,mxny)
c        common block /M3DMET/
c        TAIRP(mxnxp,mxnyp),RHP(mxnxp,mxnyp),Z1P(mxnxp,mxnyp),SSTP(mxnxp,mxnyp)
c
c       Parameters: MXNZ, MXWND
c
c --- OUTPUT:
c         US(MXNZ,MXWND) - real array - U component of observed winds
c         VS(MXNZ,MXWND) - real array - V component of observed winds
c                                       (extrapolated aloft)
c
c --- WATER2P called by: STHEOR
c --- WATER2P calls:     SIMILT, ESAT (function)
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'gen.met'
      include 'm3dmet.met'
      include 'mm4hdo.met'
c
      real us(mxnz,mxwnd),vs(mxnz,mxwnd)

c --- double precision variables for COARE (050328)
      real*8 rzu,rzt,rwsz,rzi,rrmm,rq,rqsw,rqlw,rqh,rqe
      real*8 rtairc,rtsea,rrlong,rtwave,rhwave,rz0,rustar
      real*8 rqstar,rtstar ,rzsst


      include 'ovrwat.met'
c
      data z0min/2.0e-6/,xmissm/990./,pres/1000./
      data vk/0.4/,rhocp/1195.2/
c
      common /tjump/ dptt(mxnx,mxny)

c --- If surface wind components missing, don't bother to extrapolate
      if (us(1,ns) .gt. xmissm .or. vs(1,ns) .gt. xmissm) return
c --- Do not extrapolate calm winds
c --- Note (frr 050328):us(1,n),vs(1,n) are winds measured at anemometer height 
c --- not necessarily at 10m 
      wsz = sqrt(us(1,ns) **2 + vs(1,ns) **2)
      if (wsz .lt. 0.0001) return
c
c --- Find location of station in overwater array
      nsfc = nsurf - nowsta
      nwat = ns - nsfc


c --- Anemometer height
c --- For sf station (not SEA.dAT), zanem passed through calling list
      if (nwat.gt.0) then
        zzanem = zowsta(nwat)
c ---   Assume 10. m anemometer height if missing
        if(zzanem.ge.9998.)zzanem=10.
      end if

c --- Nearest 3D.DAT gridpoint
      inear=igrabw(is,js)
      jnear=jgrabw(is,js)

c --- Treat prognostic gridpoints as overwater stations and compute
c --- necessary variables 
c
c ---    compute saturation and actual water vapor pressure (mb) at
c ---    measurement height
c ---    (NOTE: ESAT function uses temperature in deg. C)
c ---    (constant 0.01 converts rh from percent to fraction)
         tairc=tairp(inear,jnear)-273.15
         es=esat(tairc)
         e=0.01*rhp(inear,jnear)*es
c
c ---    compute saturation and actual mixing ratio (g h20/g dry air) at
c ---    measurement height
         ws=0.622*es/(pres-es)
         w=0.622*e/(pres-e)
c ---    specific humidity (g H2O/ KG moist air (!! units))
         q= w/(1+w)*1000.

c
c ---    compute virtual temperature (deg. K) at measurement height
         tv=tairp(inear,jnear)*(1.+0.61*w)
c
c ---    compute virtual potential temperatures (deg. K) at measurement ht
c ---    (potential temp. = temp. + 0.01 (deg. K/m) * height)
         dth=0.01*z1p(inear,jnear)
         th =tv+dth
c
c ---    compute virtual potential temp. (deg. K) at surface -- assume
c ---    surface relative humidity = 100 %
         twaterc=sstp(inear,jnear)-273.15
         es=esat(twaterc)
         ws=0.622*es/(pres-es)
         thsurf=sstp(inear,jnear)*(1.+0.61*ws)
         dthz=th-thsurf
c
c ---    convert measurement ht. - surface delta potential virtual
c ---    temperature to 10 m - surface value
c ---    constant 11.512925 = ln(10 m/z0) with z0=1.e-4 m
c ---    constant 9.2103404 = -ln(z0) with z0=1.e-4 m
         dth10=dthz*11.512925/(alog(z1p(inear,jnear))+
     1              9.2103404)
         th10=thsurf+dth10


c     vkg = vk * g
c

c --- compute overwater surface roughness (Hosker, 1974)
      ws10=wsz
      if(wsz.gt.0.0)then
         zz0 = 2.0e-6 * wsz ** 2.5
         zz0 = amax1(z0min,zz0)
c ---    Adjust wind speed to 10m and recompute z0 
c ---    For wind adjustement, use station anenometer height, 
c ---    not height of first 3D.DAT level
         if (int(zzanem).ne.10) then
            ws10=wsz*alog(10./zz0)/alog(zzanem/zz0)
            zz0 = 2.0e-6 * ws10 ** 2.5
         endif
      else
         zz0 = z0min
      endif
c
c --- Scale winds to 10m for OCD method and z0,u*neutral

c ---    option to use original DeltaT method or COARE algorithm to compute
c        Roughness length (zo), Monin-Obukhov Length (el), 
c        friction velocity (u*),Buoyancy Heat Flux (qh)
c        If DeltaT; compute u*,Zo,Qh,el first then mixing height  
c        if COARE: compute mixing height first (required input to COARE)

c ---    DELTAT METHOD (OCD)
         if (icoare.eq.0) then
            call DELTAT(ws10,zzanem,dthz,dth10,th10,th,zz0,el2,
     :                  ustar2,qb2)
c ---       Surface Buoyancy flux in terms of <w'Thetav'> (060528)
            wt=qb2/rhocp
            go to 400
         endif

1200  continue
c --- Neutral conditions

      ustar2 = vk * ws10 / alog(10. / zz0)
c --- prevent numerical problems with zero ustar
      ustar2 = amax1(ustar2,1.e-9)
      el2 = 9.9e9
c     thstar not used so skip
c     thstar = 0.0
c
400   continue

c --- friction velocity (m/s)
      ustar = ustar2
c
c --- Monin-Obukhov length (m)
      el = el2
c
c --- Overwater mixing height (m) 
c ---  Default values: CONSTW = 0.16, 
      zii = constw * ustar / fcori
      zii = amax1(ziminw,zii)
      zii = amin1(zimaxw,zii)


c --- Adjustment to minimize mixing heights that are bigger than the
c     final gridded mixing height field for current hour
      zii = amin1(zii,zi)
c     make sure however that they are at least = ziminw (for first step, no
c     values yet)  (050328)
      zii = max(zii,ziminw)

C ---   COARE method  
c ---   Roughness length (z0), Monin-Obukhov Length (el), 
c ---   friction velocity (u*),Sensible Heat Flux (qh)

        if ( abs(icoare).ge.10 ) then
c ---       compute air and sea temp in Celsius and positive 
c ---       longitude in East. Hem. at nearest overwater station.
c ---       in real*8 variables

c ---      measurement height for temp = 3D.DAT level
            rzt=z1p(inear,jnear)
            rtairc=tairc
            rtsea=twaterc
c ---       make sure SST above 0C:
            rtsea=max(rtsea,-3.D0)
            rrlong=xlong4(inear,jnear)

c ---       Dominant wave period and height (ok if missing, default in COARE)
c ---       Problem when nwat=0 with some compilers- 060528 fix
            if(nwat.gt.0) then 
               rtwave=twave(nwat) 
               rhwave=hwave(nwat) 
            else 
               rtwave = -999. 
               rhwave = -999. 
            end if 

c ---       depth of SST sensor - Default: 0.05m (surface value)
            rzsst=0.05

c ---       map other input variables to real*8 variables
c ---       winds are at anemomenter height (not zmid(1) - 050328
c ---       measurement height for wind = anemometer height
            rzu=zzanem
            rwsz=wsz
            rzi=zii             
            rrmm=rmm            
            rq=q
            rqsw=qsw 
            rqlw=qlw 

            call COARE(itimstep,is,js,rzu,rzt,rzsst,rwsz,rtairc,rtsea,
     :               rzi,rrmm,rq,rqsW,rqLW,rrlong,jwave,rtwave,rhwave,
     :               nhrz,dshelf,dcoast,iwarm,icool,rz0,el,
     :               rustar,rtstar,rqstar,rqh,rqe)


c ---       map output variables to real*4 variables
            zz0=rz0
            ustar=rustar
c ---       qh/qe not used so skip
c           qh=rqh
c	    qe=rqe

c ---       Surface Buoyancy flux in terms of <w'Thetav'>
            wt=-ustar*(rtstar+0.61*rqstar*tair)

c ---       restrict Monin-Obhukov length near zero (to be consistent with deltaT)
            if(abs(el).lt.5.0)then
               if(el.lt.0)then
                  el=-5.0
               else
                 el=5.0
               endif
            endif

        endif

c ---  Update mechanical and compute convective OW mixing height           

c ---      Mechanical
           zimech=constw*ustar/fcori

           if(imixh.eq.2) then
c             Batchvarova-Gryning convective mixing height 
              call MIXHBG (nhrz,Is,Js,WT,dthdz,Tair,1,THRESHW,
     :               ZIMAXW,ZIMINW,USTAR,EL,ZIi,ZICONV,THT,THTP)
                        
           else if (imixh.eq.1) then
c             Carson convective mixing height (similar to MIXHTST/MIXHSTS2)
              call MIXHMC (nhrz,is,js,wt,dthdz,1,threshw,
     :                     ZIMAXW,zii,ziconv,dptt,tht,thtp)
           else
c             OCD mixing height (mechanical only)
              ziconv=0.
           endif

           zii=amax1(zimech,ziconv)
           zii=amax1(ziminw,zii)
           zii=amin1(zimaxw,zii)


c
c --- Call extrapolation routine
      call similt(zzanem,el,zz0,zii,ns,ipsifcn,us,vs,ziminw)
      
      return
      end
c ---------------------------------------------------------------------
       subroutine COARE(itimstep,ix,jx,zu,zt,ts_depth,u,t,ts,zi,rain,
     :                  q,rs,rl,xlon,jwave,twave,hwave,nhrz,dshelfx,
     :                  dcoastx,iwarm,icool,zo,el,ustar,tstar,qstar,qh,
     :                  qe)
c----------------------------------------------------------------------
c --- CALMET   Version: 6.4.0     Level: 051214              COARE
c ---          F.Robe after COARE main program
c
c
c --- PURPOSE: Compute roughness length Zo, Friction velocity u* , 
c              Monin-Obukhov length L  and sensible heat flux
c              overwater using the COARE model
c 
c
c --- UPDATES:
c --- V5.612 (051214)to v5.614 (051228)(F.Robe)
c     (1) Add ts_depth (SST measnt depth) to calling list
c
c --- Version 5.6c Level 050419 to V5.612 (051214)(F.Robe)
c     (1) Restrict the number nits of iterations in ASL subroutine to 1 
c         for all cases because the iteration does not always converge
c
c --- Version 5.6a Level 050331 to Version 5.6c Level 050419 (F.Robe)
c     (1) Warm layer option is applied to each overwater gridpoint
c         independently => create (mxnx,mxny) arrays of bulk variables
c         related to warm layer option (common /OLD/) and include 'params.met'
c     (2) Warm layer computation starts at any time (no 6AM deadline
c         and first day off anylonger - subroutine bulk_flux)
c
c --- Version 5.6 Level 050328  to Version 5.6a Level 050331
c     (1) Fix typo that causes DSHELF variable to be zero in all calls to
c         the COARE module, and correct all references to Charnock
c
C --- NOTES:
c            0) COARE runs the COARE bulk FLux model version 2.6bw
c               (Bradley et al, Fairall et al), straight from original model
c               except for the calling list, input/output files (none)
c               The loop over time is not done internally but as part of the
c               overall CALMET time loop.
c               Modifications to original COARE program are commented with 
c               "c frr" or labelled with 'c frr 050328')
c
c            1) Call to gravity in BULK_FLUX is commented out and gravity constant g
c               is assumed to be constant (=9.81 m/s2=value used throughout CALMET .
c               Saves time (otherwise g is computed at each gridpoint, at each timestep) 
c               If call to gravity is re-instated, the overwater station latitudes
c               xlat must be supplied to COARE. This is the only change made to the
c               6 original COARE subroutines (not including the main COARE pgm)
c 
c            2) The longitude of the nearest overwater station is used (XOWLON)
c               rather than the longitude of the overwater gridpoint itself for the
c               purpose of computing the solar local time. Consider computing the
c               longitude of each gridpoint
c
c            3) The air and sea temperatures are also taken at the nearest overwater
c               station. No spatial interpolation is done - Consider doing it in 
c               subroutine WATEr and transmit via argument list
c
c            4) There are more output data available in COARE than those
c               used in CALMET (see COARE output list below)
c 
c            5) Modification of the original COARE code for shallow waters:
c               A shallow water corrective factor of the Charnock
c               parameter (charn) is introduced to reflect higher
c               values of charn in shallow waters (0.032). A typical
c               lengthscale for the coastal region is introduced (dshelf,
c               reflecting the coastal shelf extent) such that charn varies between
c               the shallow water value and the deep sea values depending
c               on the distance to the nearest coast (DCOAST)
c
c            6) Constants in common /const/ are initialized in bulk_flux
c               rather than asl. Otherwise crash during warm layer calculations
c               
c
c
c--- INPUT:
c             ITIMSTEP - integer - CALMET timestep - indicate if first call to
c                                  COARE- common variable index=itimstep
c              (Ix,Jx) - integer - CALMET gridpoint (i,j)                                      
c                   ZU - real    - height at which winds are either
c                                  measured or computed
c                   ZT - real    - temperature measurement height at buoy
c             TS_DEPTH - real    - SST measurement depth
c                    U - real    - Wind speed at zu
c                    T - real    - Air temperature in Deg. Celsius
c                   TS - real    - Sea temperature (deg. Celsius)
c                   ZI - real    - Mixing height (in meters)
c                 RAIN - real    - Rainfall rate in mm/hr
c                    Q - real    - specific humidity (q/kg)
c                   RS - real    - short wave radiation (W/m2)
c                   RL - real    - Long wave radiation (W/m2)
c                 XLON - real    - Longitude (+tive in Eastern Hem.)
c                JWAVE - integer - Wave parameterization 
c                                    0: none (Charnock)
c                                    1: Oost et al
c                                    2: Taylor and Yelland
c                TWAVE - real    - Dominant wave period (seconds)
c                                  Missing value (-999.)
c                HWAVE - real    - Significant wave height (meters)
c                                  Missing value (-999.)
c                 NHRZ - integer - GMT Time in hours (ending time)
c              dshelfX - real    - Length scale for the coastal region
c                                  used for variable Charnock parameter
c                                  in shallow waters ( in km).
c                                  Default: 0. i.e. deep sea everywhere
c              DCOASTX - real    - distance to the nearest coast (in km)
c                IWARM - integer - Warm layer option - 1: on - 0: off
c                                  must be off if SST measured with
c                                  IR radiomater
c                ICOOL - integer - Cool skin option - 1: on - 0: off
c                                  must be off if SST measured with
c                                  IR radiomater
c
c
c --- OUTPUT:
c                   ZO - real    - Surface roughness length  (m)
c                   EL - real    - Monin-Obukhov length (m)
c                USTAR - real    - Friction velocity (m/s)
c                QSTAR - real    - turbulent moisture flux scale
c                TSTAR - real    - turbulent temperature flux scale
c                   QH - real    - Sensible heat flux (W/m2)                  
c                   QE - real    - Latent heat flux (W/m2)                  
c
c                                       
c
c --- COARE called by: WATER, WATER2  
c --- COARE calls: BULK_FLUX,ASL,HUMIDITY,ZETA,H_ADJUST
c
c --------------------------------------------------------------------------

c    input data - converted for subroutine call because of conflict with COMMON:                                          
c     xtime (COARE convention yymnddhhmmss.ssss GMT)
c     zu (wind measurement height) m  ---
c     zt (T&rh measurement height) m   ----
c     zus (wind standard height) m - changes to different ref. height.   
c     zts (T&rh standard height) m   
c     ts_depth (depth of sst instrument) - positive m - for cool skin/warm layer correction 
c     u (wind speed relative to the sea surface) m/s  --ws10 (although at 10m>)
c     ts (sea surface temp.)  deg. C  - TAIROW-DTOW
c     t (air temperature) deg. C      - TAIROW
c     q (specific humidity) g/kg or qq (RH as decimal) - code works internally in kg/kg!!
c     rs (shortwave radiation) W/m2
c     rl (downwelling longwave) W/m2
c     rain (average rainrate in timestep) mm/hour - RMM
c     p (pressure) mb; use 1008mb if data unavailable
c     zi (boundary-layer depth; use 600m if data unavailable) m - GET from WATEr
c     jcool (=1 for cool skin calculation; =0 if SST measured by IR radiometer)
c     jwarm (=1 for warm layer calculation; =0 if SST measured by IR radiometer)
c     xlat (latitude) degrees  [latitude north +ve, latitude south -ve]
c     xlon (longitude) degrees [Longitude east +ve, longitude west -ve]
c....................................................................
c   AVailable COARE output:
c     QH W/m**2     (Sensible heat flux) - turbulent part only
c     QE W/m**2     (Latent heat flux) - turbulent part only
c     QR W/m**2     (Rainfall heat flux)
c     TAU N /m**2   (wind stress) - turbulent part only
c     Ustar m/s     (velocity scaling parameter - friction velocity)
c     Qstar kg/kg   (humidity scaling parameter)
c     Tstar C       (temperature scaling parameter)
c     CDN - neutral drag coefficient
c     CHN - neutral transfer coefficient for heat
c     CEN - neutral transfer coefficient for moisture
c     RR - Roughness Reynolds number
c     RT - Roughness Reynolds number for temperature
c     RQ - Roughness Reynolds number for moisture
c     ZL - height/L where L is the Obukhov length
c     ZO - roughness length
c     zot - roughness length for temperature
c     zoq - roughness length for humidity
c     dt_wrm - total warm layer temperature difference C
c     tk_pwp - thickness of warm layer
c     dter - cool skin temperature difference C 
c     T0 - skin temperature C (T0 = sst - dter + dt_wrm*ts_depth/tk_pwp)
c     wg - gustiness factor m/s
c     Taur - momentum flux due to rain N/m**2
c     Wbar - Webb mean vertical velocity m/s
c
c frr - get mxnx, mxny to dimension warm layer variables
      include 'params.met'

c frr - program fluxes
      real*8 ws_h,Ta_h,qq_h 
      real*8 zu,zt,zus,zts,u,ts,t,q,p,zi,rain,xlat,xlon
      real*8 QH,QE,TAU,Ustar,Qstar,Tstar
      real*8 rl,rs,QR,T0,ts_depth,wg
      real*8 CDN,CEN,CHN,RR,RT,RQ,ZL
      real*8 Zo,zot,zoq,dt_wrm,dter,S
      real*8 Wbar,Tau_r,xtime,glat

c --- COARE called for each gridpoint i.e. keep track of updates at each
c     gridpoint => real arrays (050419)
c frr real*8 time_old,qcol_ac,tau_ac,tau_old,rf_old,hf_old,ef_old
      real*8 time_old(mxnx,mxny),qcol_ac(mxnx,mxny),tau_ac(mxnx,mxny)
      real*8 tau_old(mxnx,mxny),rf_old(mxnx,mxny),hf_old(mxnx,mxny)
      real*8 ef_old(mxnx,mxny)

      dimension jamset(mxnx,mxny),jump(mxnx,mxny)

cfrr  real*8 intime,sol_time,tk_pwp,fxp
      real*8 intime,sol_time,tk_pwp(mxnx,mxny),fxp(mxnx,mxny)
      real*8 hwave,twave
      integer hh,yy,dd
      character*17 chtime



      logical eoftag
      data eoftag/.FALSE./

      COMMON /old/time_old,qcol_ac,tau_ac,tau_old,rf_old,hf_old,
     &            ef_old,jamset,jump,fxp,tk_pwp,index,i,j   
cfrr &            ef_old,jamset,jump,fxp,tk_pwp,index   

   
c frr 050328 - Length Scale for the coastal region and distance to coast
c              Used to compute variable Charnock coefficient
c              in shallow waters 
      COMMON/charnock/dshelfkm,dcoast         ! pass to ASL

      dshelfkm=dshelfx
      dcoast=dcoastx
      i=ix
      j=jx
      index=itimstep

c initialize variables at first call to COARE only 
      if (index.eq.1) then
        qcol_ac(i,j)=0.
        tau_ac(i,j)=0.
        time_old(i,j)=0.
        tau_old(i,j)=0.
        hf_old(i,j)=0.
        ef_old(i,j)=0.
        rf_old(i,j)=0.
        jamset(i,j)=0
        jump(i,j)=0
      endif

c

c frr 050328 _ no in/out in this subroutine (orginal commented by c frr)
c open input/output files and set up fixed instrument levels
c
c frr    open(unit=3,file='test2_5b.txt')  ! original coare2.5b input data
c frr    open(unit=9,file='Oea2_6aw.out')  ! output Oost et al wave option
c      open(unit=9,file='c:\coare\bulk_alg\Tay2_6aw.out')  ! output Taylor wave option
c      open(unit=10,file='d:\123\bulk2_6\exch2_6c.out') ! CDN,CHN and CEN from this program
c
c frr     write(9,500)
c frr 500   format(1x,'index     xtime       hsb   hlb    tub    ts     HF    
c frr    1 EF     TAU    T0    Wbar  RainF rain dt_cool dt_warm tk_pwp')
c
c      write(10,501)
c501   format(1x,'index    u      Cdn        Chn        Cen')
c

c frr 050328- The winds and temperatures are available in WATER 
c     winds are at cellzc and temperature at zowsta
c frr zu=15.                 !height of wind measurement
c frr zt=15.                 !height of air temp. and RH

      zus=10.                 !10m standard levels
      zts=10.

c      ts_depth=0.05           !Chris Fairall's floating sensor
c      ts_depth=0.45           !from IMET buoy
c      ts_depth=6.0            !Hemantha's 6m data
c
c  default values for pressure and mixed layer height
      p=1008.

c frr 050328 Mixing height supplied via calling list 
c frr zi=600.
c
c initial guesses to the warm layer parameters, these values simulate what is expected
c in early morning:  fxp=0.5 implies a shallow heating layer to start the integration;
c tk_pwp=19.0 implies the thickness is a maximum from the day before and is not meant to
c match this timestep's fxp.
c initialize variables at first call to COARE only (frr -050329)
      if (index.eq.1) then
         fxp(i,j)=0.5       
         tk_pwp(i,j)=19.0  
      endif

c if SST sensed by IR radiometer, jwarm=jcool=0
      jwarm=iwarm
      jcool=icool

c frr 050328 WAve option chosen by user in input file
c frr jwave=1   !0=Charnock,1=Oost et al,2=Taylor and Yelland.
c Also choose output file name
c loop through data
c
c frr      index=0
c      READ(3,505)ADUM            ! skip header line of test data
c      READ(4,505)ADUM            ! skip header line of test output data
505   FORMAT(A1) 
c frr 0404001: no time loop (as COARE is called at each time step.
c frr          time loop in CALMET)
c      do while (.not. eof(3))    !start of loop 
c frr      do while (.not. eoftag)    !start of loop 
c frr      index=index+1              !count data records (hours) 
c      
c read Chris Fairall's Moana Wave data from test file, 116 lines(hours)
c hsb,hlb,tub are bulk fluxes calculated independently by Chris for comparison
c frr 050328: hsb, hlb,tub are useless in CALMET
c HWT=Hemantha's Gregg data at 6m for Ts to demonstrate warm layer calculation
c frr 050328: HWT is useless in CALMET
c ts is Chris' floating temperature sensor at 0.05m depth
c Chris' is used here to compare fluxes with his original HP Basic code
c
c frr 050328 - Input comes from argument list and CALMET common OVRWAT.MET
c              (not from external file)
c frr700   READ(3,705,end=910)xtime,u,ts,t,q,hsb,hlb,tub,
c frr     2 rs,rl,rain,xlat,xlon,HWT                          
c frr705   FORMAT(f12.0,10F6.0,3F9.0)
c
c frr 050328
c     hsb,hlb,tub,HWT are QA variables used by the COARE authors but are
c     meaningless in CALMET 
c     Latitude xlat is not used because call to subroutine gravity is 
c     commented out (frr 050328)
c frr glat=xlat

c default values for wave height and period for equilibrium sea
c if known, add to data and to read statement above, then comment next two lines
c frr 050328 - Use observed wave properties if available (missing values: -999.)
c frr          otherwise use default equilibrium values
      if ((hwave.lt.0).or.(twave.lt.0)) then
         hwave=0.018*u*u*(1+.015*u)
         twave=0.729*u
      endif
c
c check warm layer, cool skin switches
c            
        if(Jwarm.gt.0) then
          if(index.eq.1) then
            Jwarm=2
          else
            Jwarm=1
          endif
        endif
c
c  convert time to decimal hours (e.g. yymnddhhmmss.ssss -> hh.hhhh)
c  skip this part if intime is in this format already
c
c frr 050328: time in hour GMT through calling list (NHRZ)
           intime=float(nhrz)
c frr      intime=xtime                    
c frr      if(intime .gt. 1e9) then                    !eg 921125182900
c frr         write(chtime(1:17),'(f17.4)') intime
c frr         read(chtime,12) yy,mn,dd,hh,mm,ss
c frr12       format(5i2,f7.4)
c frr         intime=(float(hh)+float(mm)/60.+ss/3600.) !eg 18.4833
c frr      endif
c
c and convert to local solar time in seconds
c
c ---    DGS Change for DF compile
c         sol_time=mod(xlon/15+intime+24,24)*3600   !eg 17580
         sol_time=mod(xlon/15.D0+intime+24.D0,24.D0)*3600.D0   !eg 17580
c

c call bulk flux routine. 16/5/01 pass wave parameters also
      call bulk_flux(sol_time,xlat,zu,zt,zus,zts,Jwave,hwave,twave,
     &   u,ts,t,q,ws_h,Ta_h,qq_h,rs,rl,rain,p,zi,Jcool,Jwarm,
     &   QH,QE,QR,TAU,Ustar,Tstar,Qstar,
     &   CDN,CHN,CEN,RR,RT,RQ,ZL,Zo,zot,zoq,S,
     &   dt_wrm,dter,T0,ts_depth,wg,TAU_r,Wbar)

  
c output results

c frr 050328 - Monin-Obukhov Length
    
      If (abs(ZL).Lt.1.e-04) then
         EL=10000.
      else
         EL=zu/ZL
      endif
c     
c frr  write(9,200)index,xtime,hsb,hlb,tub,ts, 
c frr     & QH,QE,TAU,T0,Wbar,QR,rain,dter,dt_wrm,tk_pwp
c frr200   format(i4,f16.0,2f6.0,f7.3,3f7.2,f8.5,f7.2,f8.5,2f6.0,3f7.2)
c
c the following write is useful to monitor various other outputs of interest
c      write(10,202)index,u,cdn,chn,cen !to check with Chris' figures
c202   format(i4,2x,f7.2,3(1pe10.2)) !take care p affects everything following
      
c frr      write(*,*) index
c     
c frr      enddo                !return to beginning of loop
c frr 910   eoftag=.true.   
c
c end of loop
c
c frr      stop
      end
c
c ---------------------------------------------------------------------
      subroutine bulk_flux(sol_time,glat,zux,ztx,zusx,ztsx,Jwave,hwavex,                  
     &twavex,ux,tsx,tx,qx,U_hs,T_hs,Q_hs,rs,rl,rainx,px,zix,Jcool,Jwarm,
     & HF,EF,RF,TAU,Ustar,Tstar,Qstar,
     & CD,CH,CE,RRx,RTx,RQx,ZLx,ZOx,zotx,zoqx,S,
     & dt_wrmx,dterx,T0,ts_depthx,wgx,TAU_r,Wbar)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070404          BULK_FLUX
c
c --- Updates:
c
c --- V5.7 (051230) to V6.222 (070404)
c --- Modified by F. Robe
c         (1) Initialize dt_wrm to avoid execution stop with some
c             compilers when jwarm=0
c
c --- V5.614 (051228) to V5.7 (051230)
c --- Modified by J. Scire
c ---     (1) Minimum stress term of 0.002 N/m2 added to avoid 
c             unrealistic skin temperature increases
c             (STI recommended change)

c frr Need mxnx,mxny to dimension common /old/ variables (050419)
      include 'params.met'

      real*8 zux,ztx,zusx,ztsx,U_hs,T_hs,Q_hs,ts_depthx
      real*8 ZU,ZT,ZQ,ZUs,ZTs,ZQs,glat
      real*8 ux,tsx,tx,qx,rainx,px,zix,wgx
      real*8 U,TS,QS,T,Q,rl,rs,rain,p,zi,QA,S,DU_Wg,Wg,Wbar
      real*8 HF,EF,TAU,RF,Ustar,Qstar,Tstar,TAU_r,ef_webb
      real*8 CD,CE,CH,USR,TSR,QSR
      real*8 Zox,zotx,zoqx,RRx,RTx,RQx,Zlx      
      real*8 ZO,zot,zoq,RR,RT,RQ,RI,zL
      real*8 T0,ee,rns,rnl
c various constants
      real*8 al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,visa
      real*8 visw,von,fdg
c rain heat variables
      real*8 alfac,dqs_dt,dwat,dtmp
c warm layer variables
c --- COARE called for each gridpoint i.e. keep track of updates at each
c     gridpoint => real arrays
c frr real*8 sol_time,newtime,time_old,ctd1,ctd2,rich
      real*8 sol_time,newtime,time_old(mxnx,mxny),ctd1,ctd2,rich
c frr real*8 qcol_ac,tau_ac,tau_old,rf_old,hf_old,ef_old
      real*8 qcol_ac(mxnx,mxny),tau_ac(mxnx,mxny)
      real*8 tau_old(mxnx,mxny),rf_old(mxnx,mxny),hf_old(mxnx,mxny)
      real*8 ef_old(mxnx,mxny)

c frr real*8 fxp,tk_pwp,dsea,dt_wrmx,dterx,qjoule,qr_out,dtime
      real*8 fxp(mxnx,mxny),tk_pwp(mxnx,mxny)
      real*8 dsea,dt_wrmx,dterx,qjoule,qr_out,dtime
      real*8 dt_wrm,dter,dqer,tkt
      real*8 hwave,twave,hwavex,twavex
      dimension jump(mxnx,mxny),jamset(mxnx,mxny)
c
      COMMON /old/time_old,qcol_ac,tau_ac,tau_old,rf_old,hf_old,
     &            ef_old,jamset,jump,fxp,tk_pwp,index,i,j
cfrr &            ef_old,jamset,jump,fxp,tk_pwp,index
      COMMON/PIN/U,T,Q,TS,QS,rns,rnl,ZU,ZT,ZQ,zi,P,ID
      COMMON/POUT/USR,TSR,QSR,ZO,zot,zoq,ZL,RR,RT,RQ,RI,
     &             dter,dqer,tkt,DU_Wg,Wg
      COMMON/const/al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,
     &             visa,visw,von,fdg
      COMMON/wave/hwave,twave       ! pass to ASL
c
c convert back variables that appear in COMMON
c
      ZU=zux       !height of wind measurement
      ZT=ztx       !height of temperature measurement
      ZQ=ztx       !height of water vapor measurement
      ZUs=zusx      !standard height of wind measurement
      ZTs=ztsx     !standard height of temperature measurement
      ZQs=ztsx     !standard height of water vapor measurement
      U=ux         !wind speed m/s
      TS=tsx       !surface temp. Celsius
      T=tx        !air temp. Celsius
      q=qx
      P=px         !pressure mb
      zi=zix       !atmospheric boundary layer depth
      hwave=hwavex
      twave=twavex
c
c frr 050328 - Initialize constants (not later otherwise too late for
c warm layer calculations)
c Constants - Factors in common /const/
      al=2.1e-5*(ts+3.2)**0.79     !water thermal expansion coefft.
      Beta=1.2     !Given as 1.25 in Fairall et al.(1996)
      Cpa=1004.67                 !J/kg/K specific heat of dry air (Businger 1982)
      cpw=4000.                    !J/kg/K specific heat water
      rhow=1022.                   !kg/m3  density water
      Rgas=287.1                  !J/kg/K     gas const. dry air
      toK=273.16   ! Celsius to Kelvin
      visw=1.e-6                   !m2/s kinematic viscosity water
      Von=0.4      ! von Karman's "constant"
c     fdg=1.00     ! Fairall's LKB rr to von karman adjustment
      fdg=1.00     !based on results from Flux workshop August 1995
 
      Rnl= 0.97*(5.67e-8*(TS+toK)**4-rl)    !Net longwave (up = +)
      Rns=0.945*rs                          !Net shortwave (into water)
      rain=rainx                            !rainfall
      ts_depth=ts_depthx                    !depth of sst measurement
c
c frr 050328 - no call to gravity - Rather set constant g to be consistent with
c rest of CALMET model (g=9.81 m/s2)
       grav= 9.81  
c frr       call gravity(glat,grav)
c      grav=9.72    ! gravity equatorial value (ref. IGPP-SIO)
c
c Warm Layer
c     
c --- initialize dt_wrm (070404) to avoid stop in execution with
c --- some compilers if jwarm=0 (no error in results though)
      dt_wrm=0.0
 
      if(Jwarm.ne.0) then    
        newtime=sol_time                    !run time in secs
        if(Jwarm.eq.2) then                    
          jump(i,j)=1
          goto 16                                 !set time_old and pass thru' ASL
c frr -Never too late to start otherwise, simulation is beginning-time
c      dependent (CALMET starts between 0-5AM anyway)
c        elseif(newtime.gt.21600.and.jump(i,j).eq.1) then
c          goto 16                                 !6 am too late to start
        elseif(newtime.lt.time_old(i,j)) then     !reset all var. at midnight
          jump(i,j)=0                                  !test threshold q morning only
          jamset(i,j)=0
          fxp(i,j)=0.5
          tk_pwp(i,j)=19.0
          tau_ac(i,j)=0.0
          qcol_ac(i,j)=0.0
          dt_wrm=0.0
          goto 16
        else
          rich=.65                                    !critical Rich. No.
          ctd1=sqrt(2*rich*cpw/(al*grav*rhow))        !u*^2 integrated so
          ctd2=sqrt(2*al*grav/(rich*rhow))/(cpw**1.5) !has /rhow in both
          dtime=newtime-time_old(i,j)                      !delta time
          qr_out=rnl+hf_old(i,j)+ef_old(i,j)+rf                 !flux out from previous pass
          q_pwp=fxp(i,j)*rns-qr_out                        !effective net warming
          if(q_pwp.lt.50.and.jamset(i,j).eq.0) go to 16    !integration threshold
          jamset(i,j)=1
c
c ***     JSS - Introduce STI changes into warm layer calculation
c ***           Minimum stress to prevent DT_WRM from overflow problems
c ***     tau_ac(i,j)=tau_ac(i,j)+tau_old(i,j)*dtime                 !tau from previous pass
          tau_ac(i,j)=tau_ac(i,j)+(dmax1(tau_old(i,j),0.002d0)*dtime) !tau from previous pass
c
          if(qcol_ac(i,j)+q_pwp*dtime.gt.0) then
            do 10 iter1=1,5                                      !iterate for warm layer thickness
              fxp(i,j)=1.-(0.28*0.014*(1-dexp(-tk_pwp(i,j)/0.014))   
     &            +0.27*0.357*(1-dexp(-tk_pwp(i,j)/0.357))         
     &            +.45*12.82*(1-dexp(-tk_pwp(i,j)/12.82)))/tk_pwp(i,j)     !solar absorb. prof
                  qjoule=(fxp(i,j)*rns-qr_out)*dtime
c ---    DGS Change for DF compile
c              if((qcol_ac(i,j)+qjoule.gt.0.0))
c     &         tk_pwp(i,j)=min(19,ctd1*tau_ac(i,j)/sqrt(qcol_ac(i,j)+
c     &         qjoule))
              if((qcol_ac(i,j)+qjoule.gt.0.0))
     &         tk_pwp(i,j)=min(19.D0,ctd1*tau_ac(i,j)/
     &                         DSQRT(qcol_ac(i,j)+qjoule))
   10       continue
          else
            fxp(i,j)=.76
            tk_pwp(i,j)=19
            qjoule=(fxp(i,j)*rns-qr_out)*dtime  
          endif
c
          qcol_ac(i,j)=qcol_ac(i,j)+qjoule               !integrate heat input
          if(qcol_ac(i,j).gt.0) then
            dt_wrm=ctd2*(qcol_ac(i,j))**1.5/tau_ac(i,j)  !pwp model warming
          else
            dt_wrm=0.
          endif         
        endif
        if(tk_pwp(i,j).lt.ts_depth) then            !sensor deeper than pwp layer
          dsea=dt_wrm                          !all warming must be added to ts
        else                                   !warming deeper than sensor
          dsea=dt_wrm*ts_depth/tk_pwp(i,j)          !assume linear temperature profile
        endif
        ts=ts+dsea                             !add warming above sensor for new ts
   16   time_old(i,j)=newtime
      endif
c
c end of warm layer
c
   15 call humidity(T,P,QA)         !Teten's formula returns sat. air in mb
      if(q.lt.2.) then             !checks whether humidity in g/Kg or RH      
         R=q
         ee=QA*R                    !convert from RH using vapour pressure      
         Q=.62197*(ee/(P-0.378*ee)) !Spec. humidity kg/kg
      else
         Q=q/1000.                 !g/kg to kg/kg
      endif
      QA=.62197*(QA/(P-0.378*QA))   !convert from mb to spec. humidity  kg/kg
      call humidity(TS,P,QS)        !sea QS returned in mb      
      QS=QS*0.98                    !reduced for salinity Kraus 1972 p. 46
      QS=.62197*(QS/(P-0.378*QS))   !convert from mb to spec. humidity  kg/kg
      Rnl= 0.97*(5.67e-8*(TS+toK)**4-rl)  !Recompute net longwave (up = +)
c
c calculate atmospheric surface layer      
c
      call ASL(Jcool,Jwave,IER,index)   ! pass Jwave option

      if(IER.ge.0) then
c
c compute surface stress (TAU), sensible heat flux (HF),  
c latent heat flux (EF) & other parameters
c
       S=sqrt(u*u + wg*wg)           !velocity incl. gustiness param.
       TAU=rhoa*USR*usr*u/S          !kinematic units
       HF=-cpa*rhoa*USR*TSR
       EF=-xlv*rhoa*USR*QSR
       tau_old(i,j)=tau 
       ef_old(i,j)=ef
       hf_old(i,j)=hf
c compute heat flux due to rainfall
       dwat=2.11e-5*((T+toK)/toK)**1.94                    !water vapour diffusivity
       dtmp=(1.+3.309e-3*T-1.44e-6*T*T)*0.02411/(rhoa*cpa) !heat diffusivity
       dqs_dt=QA*xlv/(rgas*(T+toK)**2)                     !Clausius-Clapeyron
       alfac= 1/(1+0.622*(dqs_dt*xlv*dwat)/(cpa*dtmp))     !wet bulb factor
       RF= rain*alfac*cpw*((TS-T-dter*jcool)+(QS-Q-dqer)*xlv/cpa)/3600.
c compute momentum flux due to rainfall
       TAU_r=0.85*rain/3600*u  
c Webb correction to latent heat flux already in EF via zoq/rr function so return Wbar
       Wbar=-1.61*usr*qsr/(1+1.61*q)-usr*tsr/(T+toK)
c compute transfer coefficients
c       CD=(USR/S)**2
c       CH=USR*TSR/(S*(T-TS+.0098*zt+dter*jcool)) !revise 2e to 2f to include '+dter'
c       CE=USR*QSR/(S*(Q-QS+dqer))                                      
c compute neutral transfer coefficients and met variables at standard height
       CD=(0.4/dlog(zus/zo))**2
       CH=0.4*0.4/(dlog(zus/zo)*dlog(zts/zot))
       CE=0.4*0.4/(dlog(zus/zo)*dlog(zqs/zoq))
       T0=ts-dter*jcool
       ihumid=0
c Bypass attempt to accommodate q as RH. Don't have time to fix it. Bradley
c       if(q .lt. 2) ihumid=1
       call h_adjust(ZUs,ZTs,ZQs,U_hs,T_hs,Q_hs,ihumid)
c       ws_h=U_hs
c       Ta_h=T_hs
c       qq_h=Q_hs    
c Convert a few things back to pass through parameter list
       dterx=dter               !cool skin parameters
       tktx=tkt
       dt_wrmx=dt_wrm           !warm layer parameter
       Ustar=USR
c ---  Invert T*,Q* assignments otherwise tstar takes a e+92 value when
c      qstar is assigned. can't find out why (common and declaration apparently
c      match everywhere - I don't get it (F.Robe) 050328
c
       Qstar=QSR
       Tstar=TSR
       RRx=RR
       RTx=RT
       RQx=RQ
       ZLx=ZL
       Zox=Zo
       zotx=zot
       zoqx=zoq
       wgx=wg

      else                           !input parameters out of range
         EF=-999.
         HF=-999.
         TAU=-999.
         TAUr=-999.
         EF_webb=-999.
         Ustar=-999.
         Tstar=-999.
         Qstar=-999.
         RRx=-999.
         RTx=-999.
         RQx=-999.
         ZLx=-999.
         ZOx=-999.
         ws_h=-999.
         Ta_h=-999.
         qq_h=-999.   
         wg=-999.
      endif

      return      !return to main program
      end
c
c ---------------------------------------------------------------------
      subroutine ASL(Jcool,Jwave,IER,index)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060304                ASL
c              (COARE subroutine)
c              (Modified by F. Robe, Earth Tech)
c
c --- Updates:
c
c --- V5.7 Level 051230 to V6.204 Level 060304 (F.Robe)
c           - Convert argument of min function from single to double 
c             precision to avoid compiler warnings in Linux
c
c --- V5.614 (051228) to V5.7 (051230)
c --- Modified by J. Scire
c ---     (1) Net absorption coefficient changed from 0.137 to 0.060
c             (STI recommended change)
c --- 
c
c TO EVALUATE SURFACE FLUXES, SURFACE ROUGHNESS AND STABILITY OF
c THE ATMOSPHERIC SURFACE LAYER FROM BULK PARAMETERS BASED ON
c LIU ET AL. (79) JAS 36 1722-1735 
c    
      real*8 U,T,Q,TS,QS,rns,rnl,ZU,ZT,ZQ,zi,P,DU_Wg,Wg
      real*8 USR,TSR,QSR,Zo,zot,zoq,ZL,RR,RT,RQ,RI,zetu,L10,L,zet
c constants
      real*8 al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,visa
      real*8 visw,von,fdg,charn,psiu,psit
c cool skin quantities
      real*8 wetc,bigc,be,cpv,dq,dt,dter,dqer,tkt,Bf,tcw
      real*8 hsb,hlb,alq,qcol,qout,dels,xlamx,pr,du,ta
c Grachev and Fairall variables
      real*8 u10,zo10,cd10,ch10,ct10,zot10,cd,ct,cc,ribcu,ribu
      real*8 hwave,twave,cwave,lwave,twopi
c
      COMMON/PIN/U,T,Q,TS,QS,rns,rnl,ZU,ZT,ZQ,zi,P,ID
      COMMON/POUT/USR,TSR,QSR,ZO,zot,zoq,ZL,RR,RT,RQ,RI,
     &             dter,dqer,tkt,DU_Wg,Wg     

      COMMON/const/al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,
     &             visa,visw,von,fdg
      COMMON/wave/hwave,twave
c
c frr 050328 - Length scale for coastal region and distance to the coast
c              To compute modified Charnock parameter in shallow water
c              Values of dshelf and dcoast are in kilometers.
c     050331 - Replace DSHELF with DSHELFKM
      COMMON/charnock/dshelfkm,dcoast
c
c
c frr 050328: some constants and factors must be initialized sooner i.e. in
c bulk_flux
c Factors
c frr Beta=1.2     !Given as 1.25 in Fairall et al.(1996)
c frr Von=0.4      ! von Karman's "constant"
c     fdg=1.00     ! Fairall's LKB rr to von karman adjustment
c frr fdg=1.00     !based on results from Flux workshop August 1995
c frr toK=273.16   ! Celsius to Kelvin
      twopi=3.14159*2.
 
c Air constants and coefficients
c frr Rgas=287.1                  !J/kg/K     gas const. dry air
      xlv=(2.501-0.00237*TS)*1e+6  !J/kg  latent heat of vaporization at TS
      Cpa=1004.67                 !J/kg/K specific heat of dry air (Businger 1982)
      Cpv=Cpa*(1+0.84*Q)          !Moist air - currently not used (Businger 1982)
      rhoa=P*100./(Rgas*(T+toK)*(1.+.61*Q)) !kg/m3  Moist air density ( " )
      visa=1.326e-5*(1+6.542e-3*T+8.301e-6*T*T-4.84e-9*T*T*T)   !m2/s
          !Kinematic viscosity of dry air - Andreas (1989) CRREL Rep. 89-11
c                                
c Cool skin constants
c frr (050328): some constants are alread initialized in bulk_flux
c frr al=2.1e-5*(ts+3.2)**0.79     !water thermal expansion coefft.
      be=0.026                     !salinity expansion coefft.
c frr cpw=4000.                    !J/kg/K specific heat water
c frr rhow=1022.                   !kg/m3  density water
c frr visw=1.e-6                   !m2/s kinematic viscosity water
      tcw=0.6                      !W/m/K   Thermal conductivity water
      bigc=16.*grav*cpw*(rhow*visw)**3/(tcw*tcw*rhoa*rhoa)
      wetc=0.622*xlv*QS/(rgas*(TS+toK)**2) !correction for dq;slope of sat. vap.
c 
c Wave parameters
      cwave=grav*twave/twopi
      lwave=cwave*twave
c
c Initial guesses
c
      IER=0
      Dter=0.3*jcool                 !cool skin Dt
      Dqer=0.                        !cool skin Dq
      Zo=0.0001
      Wg=0.5                        !Gustiness factor initial guess
      tkt= 0.001                    ! Cool skin thickness first guess
      DU=U                          !assumes U is measured rel. to current
      DU_Wg=(DU**2.+Wg**2.)**.5     !include gustiness in wind spd. difference
                                    !equivalent to S in definition of fluxes
      DT=Ts-T-0.0098*zt              !potential temperature diff. Changed sign       
      DQ=Qs-Q                        ! from Coar2_5b
c
c **************** neutral coefficients ******************
c
      u10=DU_Wg*dlog(10/Zo)/dlog(zu/Zo)
      usr=0.035*u10
      zo10=0.011*usr*usr/grav+0.11*visa/usr
      Cd10=(von/dlog(10/zo10))**2
      Ch10=0.00115
      Ct10=Ch10/sqrt(Cd10)
      zot10=10/dexp(von/Ct10)
      Cd=(von/dlog(zu/zo10))**2
c      
c ************* Grachev and Fairall (JAM, 1997) **********
c
      Ct=von/dlog(zt/zot10)  ! Temperature transfer coefficient
      CC=von*Ct/Cd           ! z/L vs Rib linear coefficient
      Ribcu=-zu/(zi*0.004*Beta**3)  ! Saturation or plateau Rib 
      TA=T+toK
      Ribu=-grav*zu*((DT-dter)+0.61*TA*DQ)/(TA*DU_Wg**2)
      if (Ribu.lt.0.) then
          zetu=CC*Ribu/(1+Ribu/Ribcu)   ! Unstable G and F
      else
          zetu=CC*Ribu*(1+27/9*Ribu/CC) ! Stable, Chris forgets origin
      endif
      L10=zu/zetu     ! MO length
      thing=psiu(zetu)
c --- frr (051214) only one iteration for all cases because the iterative
c --- process does not always converge 
c
c      if (zetu.gt.50) then
        nits=1
c      else
c        nits=3   ! number of iterations
c      endif
c
c ****** First guess stability dependent scaling params. ******
c
      usr= DU_Wg*von/(dlog(zu/zo10)-psiu(zu/L10))
      tsr=-(DT-dter)*von*fdg/(dlog(zt/zot10)-psit(zt/L10))
      qsr=-(DQ-wetc*dter)*von*fdg/(dlog(zq/zot10)-psit(zq/L10))

c      
      charn=0.011     !then modify Charnock for high wind speeds Chris' data
      if(DU_Wg.gt.10) charn=0.011+(0.018-0.011)*(DU_Wg-10)/(18-10)
      if(DU_Wg.gt.18) charn=0.018
c
c frr 050328 - Adjustment for shallow water - (NOT in original COARE)
c coastal (shallow water) Charnock parameter of 0.032
      if (dshelfkm.lt.0.1) then
         falpha=1.
      else
         falpha=1.-(1.-0.032/charn)*exp(-(dcoast/dshelfkm)**4)
      endif
      charn=charn*falpha
c      
c ******************* bulk loop ************************
c
      do 10 iter=1,nits
      zet= von*grav*zu/ta*(tsr+0.61*ta*qsr)/(usr*usr)
      ZL=zet
      if(Jwave.eq.0) then
       zo=charn*USR*USR/grav + 0.11*visa/usr    !after Smith 1988
      else if(Jwave.eq.1) then
       zo=(50./twopi)*lwave*(usr/cwave)**4.5+0.11*visa/usr !Oost et al.
      else if(Jwave.eq.2) then
       zo=1200.*hwave*(hwave/lwave)**4.5+0.11*visa/usr !Taylor and Yelland 
      endif 
      rr=zo*usr/visa
c
c *** zoq and zot fitted to results from several Chris cruises ************
c
      zoq=min(1.15d-4,5.5d-5/rr**0.6)  !was 0.63, changed 15/05/01
      zot=zoq
c
      L=zu/zet
      psu=psiu(zu/L)
      pst=psit(zt/L)
      usr=DU_Wg*von/(dlog(zu/zo)-psiu(zu/L))
      tsr=-(DT-dter*jcool)*von*fdg/(dlog(zt/zot)-psit(zt/L))
      qsr=-(DQ-wetc*dter*jcool)*von*fdg/(dlog(zq/zoq)-psit(zq/L))

      Bf=-grav/ta*usr*(tsr+0.61*ta*qsr)
      if (Bf.gt.0) then
          Wg=Beta*(Bf*zi)**.333
      else
          Wg=0.2
      endif
c      
c ********** break into coare2.5b code again *************
c
         DU_Wg=sqrt(DU**2.+Wg**2.)        !include gustiness in wind spd.
           hsb=-rhoa*cpa*usr*tsr
           hlb=-rhoa*xlv*usr*qsr
           qout=rnl+hsb+hlb
c
c ***
c ***      JSS - Update constant from 0.137 to 0.06 to reflect STI changes
c ***      dels=rns*(.137+11*tkt-6.6e-5/tkt*(1-dexp(-tkt/8.0e-4))) ! Eq.16 
           dels=rns*(.060+11*tkt-6.6e-5/tkt*(1-dexp(-tkt/8.0e-4))) ! Eq.16
c ***
           qcol=qout-dels
         alq=Al*qcol+be*hlb*cpw/xlv                  !Eq. 7 Buoy flux water
         if(alq.gt.0.) then                          !originally (qcol.gt.0)
           xlamx=6/(1+(bigc*alq/usr**4)**.75)**.333  !Eq 13 Saunders coeff.
         else
           pr=bigc*abs(alq)/usr**4                   !new from Chris
           if(pr.lt.1) then
             xlamx=6/(1-pr**.75)**.333               !Eq 13 Saunders coeff.
           else
             xlamx=6.                 !was 30 - caused excessive warm skins
           endif
         endif
        tkt=xlamx*visw/(sqrt(rhoa/rhow)*usr)      ! Eq.11 Sublayer thickness
        dter=qcol*tkt/tcw                         ! Eq.12 Cool skin


      dqer=wetc*dter
   10 continue            ! end Chris iterations
c
      idum=index          ! avoids warning on compilation


      return              !to main subroutine, bulk_flux
      end
c
c ---------------------------------------------------------------------
      subroutine humidity(T,P,Qsat)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 051230           HUMIDITY
c              (COARE subroutine)                                
c
c Tetens' formula for saturation vp Buck(1981) JAM 20, 1527-1532 
c     
      real*8 T,P,Qsat
c     
      Qsat = (1.0007+3.46e-6*P)*6.1121*dexp(17.502*T/(240.97+T))
      return
      end
c
c ---------------------------------------------------------------------
      function psiu(zL)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 080411               PSIU
c              (COARE subroutine)
c
c psiu and psit evaluate stability function for wind speed and scalars
c matching Kansas and free convection forms with weighting f
c convective form follows Fairall et al (1996) with profile constants
c from Grachev et al (2000) BLM
c stable form from Beljaars and Holtslag (1991)
c
c --- UPDATES:
c --- V6.204 Level 060304 to v6.323 Level 080411(F.Robe)
c           - Remove extraneous 1. multiplication factor and exponent
c             to avoid potential numerical problem
c --- V5.7 Level 051230 to V6.204 Level 060304 (F.Robe)
c           - Convert argument of min function from single to double 
c             precision to avoid compiler warnings in Linux
c -------------------------------------------------------------------

      real*8 zL,x,y,psik,psic,f,psiu,c
      if(zL.lt.0) then
       x=(1-15.*zL)**.25                        !Kansas unstable
       psik=2.*dlog((1.+x)/2.)+dlog((1.+x*x)/2.)-2.*atan(x)+2.*atan(1.)
       y=(1.-10.15*zL)**.3333                   !Convective
       psic=1.5*dlog((1.+y+y*y)/3.)-sqrt(3.)*atan((1.+2.*y)/sqrt(3.))
     &      +4.*atan(1.)/sqrt(3.)
       f=zL*zL/(1.+zL*zL)
       psiu=(1.-f)*psik+f*psic
      else
       c=min(50.d0,0.35d0*zL)                       !Stable
c      psiu=-((1.+1.*zL)**1.+.6667*(zL-14.28)/dexp(c)+8.525) ---080411
       psiu=-((1.+zL)+.6667*(zL-14.28)/dexp(c)+8.525)
      endif
      return
      end

c ---------------------------------------------------------------------  
      function psit(zL)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060304               PSIT
c              (COARE subroutine)
c
c --- UPDATES:
c --- V5.7 Level 051230 to V6.204 Level 060304 (F.Robe)
c           - Convert argument of min function from single to double 
c             precision to avoid compiler warnings in Linux
c -------------------------------------------------------------------

      real*8 zL,x,y,psik,psic,f,psit,c
      if(zL.lt.0) then
       x=(1-15.*zL)**.5                          !Kansas unstable
       psik=2.*dlog((1.+x)/2.)
       y=(1.-34.15*zL)**.3333                    !Convective
       psic=1.5*dlog((1.+y+y*y)/3.)-sqrt(3.)*atan((1.+2.*y)/sqrt(3.))
     &      +4.*atan(1.)/sqrt(3.)
       f=zL*zL/(1.+zL*zL)
       psit=(1.-f)*psik+f*psic
      else
       c=min(50.d0,0.35d0*zL)                        !Stable
       psit=-((1.+2.*zL/3.)**1.5+.6667*(zL-14.28)/dexp(c)+8.525)
      endif
      return
      end
          
c ---------------------------------------------------------------------
      subroutine ZETA(T,Q,USR,TSR,QSR,Z,ZL)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060304               ZETA
c              (COARE subroutine)
C
C TO EVALUATE OBUKHOVS STABILITY PARAMETER Z/L FROM AVERAGE
C TEMP T IN DEG C, AVERAGE HUMIDITY Q IN GM/GM, HEIGHT IN M,
C AND FRICTIONAL VEL,TEMP.,HUM. IN MKS UNITS
C SEE LIU ET AL. (1979)
c
c --- UPDATES:
c --- V5.7 Level 051230 to V6.204 Level 060304 (F.Robe)
c           - Convert argument of sign function from single to double 
c             precision to avoid compiler warnings in Linux
c -------------------------------------------------------------------
C     
      real*8 T,Q,OB,TVSR,TV,TA,sgn
      real*8 USR,TSR,QSR,Z,ZL
      real*8 al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,visa
      real*8 visw,von,fdg
      COMMON/const/al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,
     &             visa,visw,von,fdg
      TA=T+toK
      TV=TA*(1.+0.61*Q)
      TVSR=TSR*(1.+0.61*Q)+0.61*TA*QSR    
      sgn=sign(1.d0,tvsr)               !added this to avoid program
      if(abs(tvsr) .lt. 1.e-3) then   !failure when TVSR is very small
         tvsr=sgn*tvsr
      endif
      OB=TV*USR*USR/(grav*VON*TVSR) 
      ZL=Z/OB                     
c      if(ZL .gt. 1000) ZL=1000.
      goto 99
   10 ZL=0. 
   99 return
      end
       
c----------------------------------------------------------------------
      subroutine H_ADJUST(ZUs,ZTs,ZQs,U_hs,T_hs,Q_hs,IHUMID)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 051230           H_ADJUST
c              (COARE subroutine)
c
c This subroutine adjusts the U,T,Q variables to the specified
c standard height (ZUs,ZTs,ZQs) using the loglayer profiles.
c The DELTA correction (adjustment) is relative to the surface
c measurement. Cronin 4/13/94
c Modified to use new profile relations psiu,psit Bradley 26/10/99
c     
      real*8 ZUs,ZTs,ZQs,U_hs,T_hs,Q_hs,ZUsL,ZTsL,ZQsL
      real*8 U,T,Q,TS,QS,rns,rnl,ZU,ZT,ZQ,zi,P,PUZs,PTZs,PQZs
      real*8 U_wg_hs,Rho_hs,Rho_avg,QA,Rho,P_hs,ee
      real*8 USR,TSR,QSR,ZO,zot,zoq,ZL,RR,RT,RQ,RI,dter,dqer,tkt
      real*8 al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,visa
      real*8 visw,von,fdg,DU_Wg,Wg,S,D,psit,psiu
c      
      COMMON/PIN/U,T,Q,TS,QS,rns,rnl,ZU,ZT,ZQ,zi,P,ID
      COMMON/POUT/USR,TSR,QSR,ZO,zot,zoq,ZL,RR,RT,RQ,RI,
     &            dter,dqer,tkt,DU_Wg,Wg
      COMMON/const/al,beta,cpa,cpw,grav,xlv,rhoa,rhow,rgas,toK,
     &             visa,visw,von,fdg
c
      call ZETA(T,Q,USR,TSR,QSR,ZUs,ZUsL)
      call ZETA(T,Q,USR,TSR,QSR,ZTs,ZTsL)
      call ZETA(T,Q,USR,TSR,QSR,ZQs,ZQsL)
      PUZs= PSIu(ZUsL)
      PTZs= PSIt(ZTsL)
      PQZs= PSIt(ZQsL)
 
      S = (dlog(ZTs/zot)-PTZs)/(von*fdg)
      D = (dlog(ZQs/zoq)-PQZs)/(von*fdg)
      T_hs =TSR*S +TS - dter -.0098*ZTs
      Q_hs =(QSR*D + QS - dqer)*1000
      U_wg_hs = USR*(dlog(ZUs/ZO) - PUZs)/0.4
      if(U_wg_hs.ge.Wg) then
         U_hs = SQRT(U_wg_hs**2 - Wg**2)
      else
         U_hs = U_wg_hs
      endif
c
      if(IHUMID.eq.1) then    ! then need to convert sp hum into rh
         Q_hs = Q_hs/1000     ! sh kg/kg
         RHO=1./(287.*(T+273.16)*(1.+.61*Q))*P*100.
         P_hs = P - (RHO*grav*(ZTs - ZT))/100 !Approx hydrost.Pressure mb
         RHO_hs=1./(287.*(T_hs+273.16)*(1.+.61*Q_hs))*P_hs*100
         RHO_avg = (RHO + RHO_hs)/2
         P_hs = P -(RHO_avg*grav*(ZTs - ZT))/100 !hydrostatic Pressure
         call humidity(T_hs,P_hs,QA)         !Teten's formula for Pvap,sat
         ee=Q_hs*P_hs/(.62197 + .378*Q_hs)   !to get vapor pressure
         Q_hs = ee/QA                        !to get relative humidity
      endif
      return
      end
c----------------------------------------------------------------------      
      Subroutine gravity(lat,g)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 051230            GRAVITY
c              (COARE subroutine)
c
c       calculates g as a funccton of latitude using the 1980 IUGG formula
c         
c       Bulletin Geodesique, Vol 62, No 3, 1988 (Geodesist's Handbook)
c       p 356, 1980 Gravity Formula (IUGG, H. Moritz)
c       units are in m/sec^2 and have a relative precision of 1 part
c       in 10^10 (0.1 microGal)
c       code by M. Zumberge.
c
c       check values are:
c
c        g = 9.780326772 at latitude  0.0
c        g = 9.806199203 at latitude 45.0
c        g = 9.832186368 at latitude 90.0
c
      real*8 gamma, c1, c2, c3, c4, phi, lat, g
      gamma = 9.7803267715
      c1 = 0.0052790414
      c2 = 0.0000232718
      c3 = 0.0000001262
      c4 = 0.0000000007
      phi = lat * 3.14159265358979 / 180.0
      g = gamma * (1.0 
     $ + c1 * ((sin(phi))**2)
     $ + c2 * ((sin(phi))**4)
     $ + c3 * ((sin(phi))**6)
     $ + c4 * ((sin(phi))**8))
c
      return
      end
 
c----------------------------------------------------------------------
      function psiuD(zL)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 080411              PSIUD
c              (COARE subroutine)
c
c PSIUD is similar to COARE PSIU except for a factor 16 instead of 15
c in the Kansas unstable function x (16 should be more correct according
c to Dyer)
c psiu and psit evaluate stability function for wind speed and scalars
c matching Kansas and free convection forms with weighting f
c convective form follows Fairall et al (1996) with profile constants
c from Grachev et al (2000) BLM
c stable form from Beljaars and Holtslag (1991)
c
c --- UPDATES:
c --- V6.204 Level 060304 to v6.323 Level 080411(F.Robe)
c           - Remove extraneous 1. multiplication factor and exponent
c             to avoid potential numerical problem
c --- V5.7 Level 051230 to V6.204 Level 060304 (F.Robe)
c           - Convert argument of min function from single to double 
c             precision to avoid compiler warnings in Linux
c -------------------------------------------------------------------
c
c
      real*8 zL,x,y,psik,psic,f,psiud,c
      if(zL.lt.0) then
c ---  COARE: 15 - Here:16
c      x=(1-15.*zL)**.25                        !Kansas unstable (COARE)
       x=(1-16.*zL)**.25                        !Kansas unstable
       psik=2.*dlog((1.+x)/2.)+dlog((1.+x*x)/2.)-2.*atan(x)+2.*atan(1.)
       y=(1.-10.15*zL)**.3333                   !Convective
       psic=1.5*dlog((1.+y+y*y)/3.)-sqrt(3.)*atan((1.+2.*y)/sqrt(3.))
     &      +4.*atan(1.)/sqrt(3.)
       f=zL*zL/(1.+zL*zL)
       psiud=(1.-f)*psik+f*psic
      else
       c=min(50.d0,0.35d0*zL)                       !Stable
c      psiud=-((1.+1.*zL)**1.+.6667*(zL-14.28)/dexp(c)+8.525) -- 080411
       psiud=-((1.+zL)+.6667*(zL-14.28)/dexp(c)+8.525)
      endif
      return
      end

c----------------------------------------------------------------------  
      function psitD(zL)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060304              PSITD
c              (COARE subroutine)
c
c PSITD is similar to COARE PSIT except for a factor 16 instead of 15
c in the Kansas unstable function x (16 should be more correct according
c to Dyer)
c
c --- UPDATES:
c --- V5.7 Level 051230 to V6.204 Level 060304 (F.Robe)
c           - Convert argument of min function from single to double 
c             precision to avoid compiler warnings in Linux
c -------------------------------------------------------------------


      real*8 zL,x,y,psik,psic,f,psitd,c

      if(zL.lt.0) then
c      x=(1-15.*zL)**.5                          !Kansas unstable (COARE)
       x=(1-16.*zL)**.5                          !Kansas unstable
       psik=2.*dlog((1.+x)/2.)
       y=(1.-34.15*zL)**.3333                    !Convective
       psic=1.5*dlog((1.+y+y*y)/3.)-sqrt(3.)*atan((1.+2.*y)/sqrt(3.))
     &      +4.*atan(1.)/sqrt(3.)
       f=zL*zL/(1.+zL*zL)
       psitd=(1.-f)*psik+f*psic
      else
       c=min(50.d0,0.35d0*zL)                        !Stable
       psitd=-((1.+2.*zL/3.)**1.5+.6667*(zL-14.28)/dexp(c)+8.525)
      endif
      return
      end
          
 
c --------------------------------------------------------------------
ccec101006      subroutine radflx (icloud,iceil,ccgrid,iceilg,tair,irh,qlw)
      subroutine radflx (mcloud,iceil,ccgrid,iceilg,tair,irh,qlw)
c --------------------------------------------------------------------
c --- CALMET    Version: 6.4.0     Level: 101006           RADFLX
c ---           F.Robe
c
c --- PURPOSE:  Compute downward long wave radiative 
c               fluxes at the surface for input to the COARE subroutine
c
c --- UPDATES:
c --- V6.222 (070404) to V6.330 (101006) (CEC)
c         - Change ICLOUD into MCLOUD (and ICLDOUT)
c
c --- V6.216 (061230) to V6.222 (070404)(F. Robe)
c         - Supply observed ceiling height (iceil) and use it in 
c           observation mode (icloud<3) (otherwise ceiling height is 
c           not defined)
c
c --- V6.213 Level 060525 to V6.216 (061230) (F. Robe)
c         - Put  lower and upper bounds on precipitable water (wp) to 
c           ensure that wp is within range of applicability (and remove
c           lower bound on RH)
c
c --- Version 5.6 Level 050328 to V6.213 Level 060525 (D. Strimaitis)
c         - Impose a minimum RH of 1% when computing the precipitable
c           water (wp) in RADFLX.  IRH=0 resulted in wp=0.0, which then
c           makes LOG10(wp) undefined (error stops run).
c
c --- INPUT:  
c             ICEIL(mxss)       - integer - station ceiling height (in
c                                           100's ft) 
c             ICEILG (mxnx,mxny)- integer - ceiling height (in 100's ft)
c             CCGRID(mxnx,mxny) - real    - Fractional Cloud cover
c             ICEILG (mxnx,mxny)- integer - Gridded prognostic ceiling height
c                                           (in 100's ft)
c             TAIR (mxnx,mxny)  - real    - Surface air temperature (K)
c             IRH  (mxnx,mxny)  - integer - Surface relative humidity (%)
c
c                                     
c --- OUTPUT:
c                qLW(mxnx,mxny) - real    - Downward (not net) long wave  
c                                           rad. flux at the surface (W/m2)
c
c
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'grid.met'

      real ccgrid(mxnx,mxny)     
      real qlw(mxnx,mxny),tair(mxnx,mxny)
      integer iceilg(mxnx,mxny),irh(mxnx,mxny)
      integer iceil(mxss)
c

c     
c     DOWNWARD LONG WAVE RADIATIVE FLUX(qLW) 
      do j=1,ny
         do i=1,nx

ccec101006            if (icloud.ge.3) then
            if (mcloud.ge.3) then
                jceil=iceilg(i,j)
            else
                jceil=iceil(nears(i,j))
            endif

c ---       clear sky: QLW=epsa*sigb*Tair**4, with 
c                sigb: Stefan Boltzman constant (5.67 e-8)
c                epsa: atm. longwave emissivity
c                epsa=0.725+0.17log10(wp), 
c                wp: precipitable water in cm, varies between 0.1 and 5 cm
c                see MM5 techincical notes (TN 398-June 1994)
c                precipitable water in cm as a function of Rel Hum (decimal=>rh/100)
c                and air temp (in K)- http://www.uswcl.ars.ag.gov/exper/relhum.htm
            rh=irh(i,j)*0.01

c --- 060525  Place a 1% floor on RH here
c           rh=AMAX1(.01,rh)
c --- 061230  Put bounds on wp to keep wp within range of applicability
c             (0.1< wp < 5cm) rather than putting bound on RH
            wp=0.439*rh*exp(26.23-5416/Tair(i,j))/Tair(i,j)
            wp = max(wp,0.1)
            wp = min(wp,5.)

            qlw(i,j)=(0.725+0.17*log10(wp))*5.67e-8 * Tair(i,j)**4

c  ---      Cloud enhancement factor: Clw
c           clw=c1*n1+c2*n2+c3*n3, (MM5 technical note  TN-398 - June 1994)
c              with ci = enhancement factor for cloud layer i 
c                   ni = cloud fraction of low (below 800mb), 
c                         middle(800-450mb), high level clouds(> 450mb)
c                   ni=function of RH in that layer - Not available (only surface RH)
c                      attribute all the cloud cover (ccgrid) to the layer where the 
c                      ceiling height (jceil) is - jceil is in 100's feet
c                      800mb ~ 1950m ~ 6400ft (ICAO standard Atmosphere) 
c                      450mb ~ 6400m ~ 21000ft
            rn1=0.
            rn2=0.
            rn3=0.
            if (jceil.lt.64 ) then
               rn1=ccgrid(i,j)
            else if (jceil.le.210) then
               rn2=ccgrid(i,j)
            else if (jceil.gt.210  )then
               rn3=ccgrid(i,j)
            endif

            clw=0.26*rn1+0.22*rn2 + 0.006*rn3
            qlw(i,j)=qlw(i,j)*(1+clw)
         end do
      end do


      return
      end
c----------------------------------------------------------------------
      subroutine wind1
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070717              WIND1
c              Earth Tech Inc
c
c                                                    
c --- UPDATES:
c
c --- V6.223 Level 070702 to V6.3 (070717)
c        - Add IPSIFCN to SIMILT argument list
c
c --- V5.6 Level 050328  to V6.223 Level 070702(Frr):
c        - Correct index of xowsta and xusta (results are affected
c          only if barriers) 
c        - only readjust extrapolation weights for valid calm wind data 
c          (results were correct before because no weight was given 
c          to unvalid data but ws10 was not defined in that case which  
c          might cause execution to stop with some compilers)
c        - Update roughness legnth and log profile coefficients for surface
c          stations located on a water gridcell
c
c 
c     V5.55 Level 050217 to V5.6 Level 050328 (Frr):
c        - Extrapolate surface wind measurements from anemometer height
c          to first CALMET level (land and overwater stations) using
c          the user defined extrapolation method (iextrp) or a neutral
c          log profile if iextrp=1 (no vertical extrapolation)
c
c        - Use wind-speed dependent z0 overwater rather than the fixed
c          value set in GEO.DAT 
c
c ---   V5.548a Level 050101 to V5.55 Level 050217 (F.Robe)
c        - Skip call to barier if nbar=0
c
c ---   V5.548 Level 041101 to V5.548a Level 050101 (F.Robe)
c        - Include D3.MET (kbar no longer in wparm.met)
c
c ---   Level 000602 to V5.548 Level 041101 (F.Robe)
c        - Implement barriers up to level k=KBAR
c
c --- Previous Updates:        
c ---          DG Strimaitis, SRC
c ---          M. Fernau, SRC/ETCO added separate land/water sites
c              J. Chang. -- The first-guess wind field is obtained
c                           by straight 1/r^2 interpolation.
c                           profiling is disabled.
c              F.Robe--Vertically varying weights for horizontal
c                      interpolation of vertically extrapolated
c                      surface observations and upper air observed
c                      winds
c              G. Moore--- made sure simult is not called with missing
c                          data, added d4 include and use of editl
c              F. Robe - Use of temporary arrays for the extrapolated
c                        surface winds.
c                      - Option not to extrapolate surface calm winds
c                        aloft
c                      - 7/11/97: bug corrected r2 redefined as xr2 to
c                        avoid conflicts with WPARM
c              J. Scire- Modified 8/25/97 to add anem. ht. fix & checks
c              F. Robe   for missing sounding data
c              J. Scire- Corrects power law extrapolation (6/2000)
c
c --- PURPOSE:  Creates spatially-varying first-guess wind field
c               by interpolating upper air and surface observations
c               (both use 1/r^2 weighting).
c
c --- INPUTS:
c
c     common/GRID/ ---
c                     NX - integer    - No. X grid cells
c                     NY - integer    - No. Y grid cells
c                     NZ - integer    - No. vertical layers
c          ZFACE(MXNZP1) - real array - cell face hts.
c             ZMID(MXNZ) - real array - center cell hts. (m)
c
c    common/WPARM/ ---
c              IEXTRP    - integer    - Flag for vertical interpolation
c             BIAS(mxnz) - real array - Factors modifying weights of
c                                       surface and upper air stations
c                                       (-1 <= BIAS <= +1) -- negative
c                                       BIAS reduces weight of upper air
c                                       stations, zero BIAS leaves
c                                       weights unchanged, positive
c                                       BIAS reduces weights of surface
c                                       stations
c                ICALM - integer      - Flag to vertically extrapolate
c                                       calm winds or not
c              IPSIFCN - integer      - Flag controlling choice of PSI
c                                       stability correction for wind
c                                       profile
c                                      (IPSIFCN=0 use CALMET v5.6;
c                                       IPSIFCN=1 use CALMET v5.53)
c     common /D3/
c                 KBAR - integer      - Level up to which barriers are applied
c
c     common/MET1/ ---
c                    NSSTA - integer    - No. surface landwind stations
c                    NUSTA - integer    - No. upper air wind stations
c XSSTA(mxss), YSSTA(mxss) - real       - Surface station coordinates (m) 
c                                         relative to grid origin
c XUSTA(mxss), YUSTA(mxss) - real       - Upper air station coordinates (m) 
c                                         relative to grid origin
c             ZANEM (MXSS) - real array - Anemometer height at sf stations
c          XORIGR, YORIGR - real        - Reference coordinates (m) 
c                                         of grid origin
c

c     common/OVRWAT/ ---
c                 NOWSTA - integer    - No. over water wind stations
c          ZOWSTA(MXOWS) - real array - Anemometer height (m) of overwater 
c                                       stations
c        ZLOGWSTA(MXOWS) - real array - Adjustement coefficient from anenometer
c                                       Height to 1st CALMET level (neutral
c                                       profile used if abs(iextrp)=1)
c            Z0OW(MXOWS) - real array - overwater roughness length
c
c     common/GEO/ ---
c          z0(mxnx,mxny) - real array - Roughness length
c
c     common/D1/ ---
c         US(MXNZ,MXWND) - real array - U component of observed wind,
c                                       assigned to vertical layers
c         VS(MXNZ,MXWND) - real array - V component of observed wind,
c                                       assigned to vertical layers
c       HTOPO(MXNX,MXNY) - real array - Gridded terrain hts (m) MSL
c 
c           FEXTRP(mxnz) - real array - user input multiplicative factors
c                                       (vertical interpolation)
c
c --- OUTPUT:
c
c     common/D1/ ---
c     UG(MXNX,MXNY,MXNZ) - real array - U component of 1st guess wind,
c                                       assigned to cells
c     VG(MXNX,MXNY,MXNZ) - real array - V component of 1st guess wind,
c                                       assigned to cells
c --- TEMPORARY ARRAYS
c     USTMP(MXNZ,MXWND)  - real array - U component of vertically 
c                                       extrapolated surface obs. or
c                                       upper air obs.
c     VSTMP(MXNZ,MXWND)  - real array - V component of vertically 
c                                       extrapolated surface obs
c                                       upper air obs.
c     WS10(MXWND)        - real array - Surface wind speed
c
c--- CALLS TO SUBROUTINE:
c     
c     SIMILT   - vertical extrapolation of sfc winds using similarity
c                theory
c
c----------------------------------------------------------------------
c
      include 'params.met'
      include 'grid.met'
      include 'wparm.met'
      include 'met1.met'
      include 'd1.met'
      include 'd3.met'
      include 'd4.met'
      include 'ovrwat.met'
      include 'geo.met'

      real rsqwt(mxwnd)
      real ws10(mxwnd)
      real ustmp(mxnz,mxwnd),vstmp(mxnz,mxwnd)
      real zzanem(mxwnd),zlog(mxwnd)
      real xst(mxwnd),yst(mxwnd)

c vertically varying weights
      real vvw(mxnz,mxwnd)

      data z0min/2.0e-6/


c VERTICALLY VARYING BIASES
c  -1<=bias<0: bias towards vertically extrapolated sfc obs. 
c   0<bias<=1: bias toward upper air soundings
c EXAMPLES:    
c     bias= 0.1  : decreases the sfc station weights by 10 %
c     bias= 1.0  : decreases the sfc station weights by 100 %
c                 (i.e. interpolation between upper air stations only)
c     bias=-0.1  : decreases the upper air station weights by 10 %
c     bias=-1.0  : decreases the upper air station weights by 100 %
c                 (i.e. interpolation between sfc stations only)
c     bias= 0.   : no bias; pure 1/R^2 interpolation between vertically
c                  extrapolated sfc and upper air observations

c        --total number of stations (sfc+upper air)
         nstat = nssta + nowsta + nusta

c --- Use temporary arrays for vertically extrapolated winds
c     so as not to carry extrapolated values above the mixing
c     height later on (step 2)
          do l=1,nstat
             do k=1,nz
               ustmp(k,l)=us(k,l)
               vstmp(k,l)=vs(k,l)
             end do
          end do


c --- Update roughness legnth and log profile coefficients for surface
c --- stations located on a water gridcell (070702)
      do L=1,nssta
         Isc = IST(L)
         Jsc = JST(L)

         if(isc.gt.nx)isc=nx
         if(isc.lt.1)isc=1
         if(jsc.gt.ny)jsc=ny
         if(jsc.lt.1)jsc=1

         if (ilandu(isc,jsc).ge.iwat1.and.ilandu(isc,jsc).le.iwat2) then
            if(us(1,l).lt.editl.and.vs(1,l).lt.editl)then
c ---          update z0  
               wsz = sqrt(us(1,L) **2 + vs(1,L) **2) 
c ---          compute overwater surface roughness (Hosker, 1974)
               if(wsz.gt.0.0)then
                  zz0 = 2.0e-6 * wsz ** 2.5
                  z0(isc,jsc) = amax1(z0min,zz0)
               else
                  z0(isc,jsc) = z0min
               endif
c ---          update zlog  
               xlnzo=alog(z0(isc,jsc))
c ---          z1: first CALMET level
               xlnz1=alog(cellzc(1))
c ---          z2: anemometer height
               xlnz2=alog(zanem(l))
c ---          Logarithmic profile scaling factor
c              u(k=1)=zlogsta*u(zanem)
               zlogsta(l)=(xlnz1-xlnzo)/(xlnz2-xlnzo)
            endif
         endif
      enddo
      

c --- Define combined surface+overwater station anemometer height array
c --- and neutral log profile coefficient array
c --- 050328 (frr) define combined arrays for all extrapolation options
c --- as is needed anyway for extrapolation to first CALMET level
c     if(iabs(iextrp).eq.2.or.iabs(iextrp).eq.4)then
c ---    Loop over surface stations first
         do LL=1,nssta
           zzanem(LL)=zanem(LL)
           zlog(ll)=zlogsta(ll)
         enddo
c ---    Add overwater station anem. hts. to end of array
         indx=nssta
         do LL=1,nowsta
            indx=indx+1
            zzanem(indx)=zowsta(LL)
c ---       If overwater anem. height missing, use 10 m
            if(zzanem(indx).ge.9998.)zzanem(indx)=10.
            zlog(indx)=zlogwsta(ll)
         enddo
c     endif
      
c --- Define combined surface+overwater+upper air station 
c     coordinates array, relative relative to grid origin in km 
c     needed for barrier calculation (041101)
      do l=1,nssta
         xst(l)=xssta(l)*0.001
         yst(l)=yssta(l)*0.001
      end do
      do l=nssta+1, nssta+nowsta
c         wrong index (070702)
c         xst(l)= xowsta(l)-xorigr*0.001
c         yst(l)= yowsta(l)-yorigr*0.001
         xst(l)= xowsta(l-nssta)-xorigr*0.001
         yst(l)= yowsta(l-nssta)-yorigr*0.001
      end do
      do l=nssta+nowsta+1, nstat
c         wrong index (070702)
c         xst(l)=xusta(l)*0.001
c         yst(l)=yusta(l)*0.001
         xst(l)=xusta(l-nssta-nowsta)*0.001
         yst(l)=yusta(l-nssta-nowsta)*0.001
      end do

c ---   vertical extrapolation of obs. winds at sfc stations
c       including at the first level (050328)
        do 666 l=1,nssta+nowsta
c
c --- in keeping with original CALMET don't extrapolate if missing data                 
            if(us(1,l).gt.editl.or.vs(1,l).gt.editl)go to 666
c
c ---       If winds are calm, do not call extrapolation subroutines
c ---       Fill with calm winds all the way up 
            ws10(l) = sqrt(us(1,L) **2 + vs(1,L) **2)
            if (ws10(l) .lt. 0.0001) then
             do k=1,nz
               ustmp(k,l)=0.
               vstmp(k,l)=0.
             end do              
             goto 666
            endif
c
c ---       if no extrapolation, still adjust from anemometer height to first
c           calmet level using neutral log profile
            if(iabs(iextrp).eq.1) then
               ustmp(1,l)=ustmp(1,l)*zlog(l)
               vstmp(1,l)=vstmp(1,l)*zlog(l)
            endif   

c ---       power law 
            if(iabs(iextrp).eq.2) then 
              pexp2 = 0.143
c ---         If overwater station, use overwater exponent
              if(L.gt.nssta) pexp2 = 0.286

              do k=2,nz
                km1=k-1
                if(k.eq.2) then
                   padj=(cellzc(k)/zzanem(L))**pexp2
                else
                   padj=(cellzc(k)/cellzc(km1))**pexp2
                endif
                ustmp(k,l)=ustmp(km1,l)*padj
                vstmp(k,l)=vstmp(km1,l)*padj
              end do

c ---         Adjust from anemometer height to first level (050328-frr)
              padj=(zzanem(L)/cellzc(1))**pexp2
              ustmp(1,l)=ustmp(1,l)/padj
              vstmp(1,l)=vstmp(1,l)/padj


            endif

c           --user input multiplicative factors 
            if(iabs(iextrp).eq.3) then
c ---         fextrp: nz values for scaling observations 
c ---        => use the first one for first calmet level (050328-frr)              
c             do k=2,nz
              do k=nz,1,-1
                ustmp(k,l)=ustmp(1,l)*fextrp(k)
                vstmp(k,l)=vstmp(1,l)*fextrp(k)
              end do
            endif
 
c           --similarity theory (assuming neutral conditions
c                                and infinite mixing length)
            if(iabs(iextrp).eq.4)then
c              --assumed Monin-Obukov length (neutral)
               zmo=10000.
c              --assumed mixing length 
               zml=10000.

               if (l.le.nssta) then
c ---             if land station use z0 at gridpoint closest to station
                  isc=ist(l)
                  jsc=jst(l)
                  if(isc.gt.nx)isc=nx
                  if(isc.lt.1)isc=1
                  if(jsc.gt.ny)jsc=ny
                  if(jsc.lt.1)jsc=1
                  zr=z0(isc,jsc)
               else
c ---             overwater station: use current z0 (function of wind speed)
c ---             rather than the fixed constant from GEO.DAT (050328)
                  zr=z0ow(l-nssta)
               endif

               call similt(zzanem(L),zmo,zr,zml,l,ipsifcn,
     &                     ustmp,vstmp,zml)

             endif

666     continue

c          -- done vertically extrapolating sf station winds


c-- Loop over i,j cells in the CALMET grid
c
       dgridi=1.0/dgrid
       do i=1,nx
         do j=1,ny

c          -- compute bulk weights (based on 1/R^2 interpolation)

            xc=FLOAT(i)-0.5
            yc=FLOAT(j)-0.5

c             ---Compute the combined 1/r**2 weights
              sumwt = 0.0
c               --loop over all the stations 
              do l=1,nstat
c                 --land surface stations:
                if (l.le.nssta) then
                    xr2=(xssta(l)*dgridi-xc)**2 + 
     &                  (yssta(l)*dgridi-yc)**2
c                 --water surface stations:
                else if (l.le.(nssta+nowsta)) then
                    xr2=(xowsta(l - nssta)*dgridi-xc)**2 +
     &                  (yowsta(l - nssta)*dgridi-yc)**2
c                 --upper air stations:
                else
                    iu=l-nssta-nowsta
                    xr2=(xusta(iu)*dgridi-xc)**2 +
     &                  (yusta(iu)*dgridi-yc)**2
                endif
                if(xr2 .LT. 1.0) then
                   wgt=1.0
                else
                   wgt=1.0/xr2
                endif

c               --check for valid data (surface)
                if (l.le.(nssta+nowsta))then
                    if((us(1,L).gt.editl).or.(vs(1,L).gt.editl))wgt=0.
                end if

                sumwt=sumwt+wgt
                rsqwt(l)=wgt
              end do
c             --Normalize the weights.
              sumwt=1.0/sumwt
              do l=1,nstat
                rsqwt(l)=rsqwt(l)*sumwt
              end do      
c             --done computing bulk weights 

c VVW         -- vertically varying weights: biased towards 
c             -- vertically interpolated sfc obs. or upper air obs.

c             -- first compute sum of bulk sfc and upper weights
              sumwsfold=0.
              sumwupold=0.
              do l=1,nssta+nowsta
                sumwsfold=sumwsfold+rsqwt(l)
              end do
              do l=nssta+nowsta+1,nstat
                sumwupold=sumwupold+rsqwt(l)
              end do

c             -- loop over nz levels:
              do k=1,nz
c                 -- either bias towards upper air observations (bias>0)
                if(bias(k).ge.0.) then
                  beta=(1.-bias(k))
                  gamma=(bias(k)+(1.-bias(k))*sumwupold)/sumwupold
c                   -- or bias toward vert. extrapolated sfc obs. (bias<0)
                else
                  beta=(-bias(k)+(1.+bias(k))*sumwsfold)/sumwsfold
                  gamma=(1.+bias(k))
                endif

c               --compute the vertically varying weights:
c               ----surface stations:
                do l=1,nssta+nowsta
                  vvw(k,l)=beta*rsqwt(l)
                end do
c               ----upper stations:
                do l=nssta+nowsta+1,nstat
                  vvw(k,l)=gamma*rsqwt(l)
                end do
              end do
c             ---end loop over NZ levels
c

c - If ICALM=0, no weight aloft to vertically extrapolated surface calm winds
c - Readjust the weights for other stations at each level
          IF (ICALM.EQ.0) THEN
            do l=1,nssta+nowsta
c ---        only readjust for valid data (070702) -
             if((us(1,L).lt.editl).and.(vs(1,L).lt.editl)) then
              if (ws10(l).lt.0.0001)then
               do k=2,nz
c               --- if only partial weight of station with calm winds
                if (vvw(k,l).lt.0.9999) then
                  do ll=1,nstat
                    if (ll.ne.l) vvw(k,ll)=vvw(k,ll)/(1.-vvw(k,l))
                  end do
c               --- if full weight (i.e.only surface station with valid data
c               --- interpolate upper air data only (1/R**2)
                else
                   do ll=nssta+nowsta+1,nstat
                      vvw(k,ll)=rsqwt(ll)/(1.-rsqwt(l))
                   end do
                endif
                  vvw(k,l)=0.
               end do
              endif
             endif
             end do
           ENDIF
        
c FRR (8/25/97)
c - If missing value at an upper air station, recompute the weights 
c level by level for the other stations accordingly
c (should occur only at the surface and only if same name for surface and
c upper stations, hence do not throw the whole sounding away)

c - Readjust the weights for other stations at each level
          do 222 k=1,nz
c            --- only if some weight on upper air stations at that level
            if (bias(k).gt.-0.9999) then
               do l=nssta+nowsta+1,nstat
              if ((ustmp(k,l).gt.editl).or.(vstmp(k,l).gt.editl))then
c                  --- stop if only data available at that level (should
c                  --- never happen)
                   if (vvw(k,l).eq.1.)then
                     write(io6,*)'ERROR in SUBR. WIND1'
                     write(io6,*)'No valid observation at level: ', k
                     stop
                   endif
                   do ll=1,nstat
                     if (ll.ne.l) vvw(k,ll)=vvw(k,ll)/(1.-vvw(k,l))
                   end do
                   vvw(k,l)=0.
                 endif
               end do
            endif
222      continue
c FRR -END (8/25/97)  
      
         if(nbar.le.0) goto 91

c ---    Barriers: recompute weights if station shielded by barrier (041101 -FRR)
c ---    Do it for all stations (surface, ovw, upper air)
c ----   First get the gridpoint locations in km, relative to grid origin
         x=(float(i)-0.5)*dgrid*0.001
         y=(float(j)-0.5)*dgrid*0.001


         do  223 l=1,nstat
            ok=1.
            call barier (x,y,xst(l),yst(l),ok) 
            if (ok.le.0) then
c ---           barrier in the way - discard the station for all levels below
c               and up to kbar (041101)
                do k=1,kbar
c ---              stop if only data available at that level 
                   if (vvw(k,l).eq.1.)then
                     write(io6,*)'ERROR in SUBR. WIND1'
                     write(io6,*)'No valid observation at level: ', k
                     write(io6,*)'For gridpoint (i,j)=', i,j
                     write(io6,*)'Check barrier set-up'
                     stop 'STOP in WIND1 - Check list file'
                   endif
                   do ll=1,nstat
                     if (ll.ne.l) vvw(k,ll)=vvw(k,ll)/(1.-vvw(k,l))
                   end do
                   vvw(k,l)=0.
                end do
            endif 
223      continue

91       continue

c     -- done computing the vertically varying weights

c     -- Compute first guess winds at all levels
c
            do k=1,nz
               unext=0.0
               vnext=0.0
               do l=1,nstat
                  unext=unext+vvw(k,l)*ustmp(k,l)
                  vnext=vnext+vvw(k,l)*vstmp(k,l)
               end do
               ug(i,j,k)=unext
               vg(i,j,k)=vnext
            end do
         enddo
      enddo

c-- End loop over i,j cells in the CALMET grid

      return
      end
c----------------------------------------------------------------------
      subroutine windbc(u,v,ub,vb,k)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 940304             WINDBC
c
c --- include parameters
      include 'params.met'
c 
c NEW frr (12/96) D5 replaced by grid.met
      include 'grid.met'
c      COMMON /D5/ NX,NY,NZ,DX,DY,dz(mxnz),NZPRNT
      DIMENSION U(mxnx,mxny,*),V(mxnx,mxny,*)
      DIMENSION UB(mxny,2,*),VB(mxnx,2,*)
C
C     SETS BOUNDARY CONDITIONS FOR WIND FIELDS
C     NO INFLOW - NO OUTFLOW BOUNDARY CONDITIONS ARE USED
C
C     INPUTS:  U (R ARRAY) - GRIDDED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY) - GRIDDED Y-DIRECTION WIND COMPONENTS
C              K (I)       - VERTICAL LEVEL INDEX
c       Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C     OUTPUTS:  UB (R ARRAY) - U-COMPONENT BOUNDARY VALUES
C               VB (R ARRAY) - V-COMPONENT BOUNDARY VALUES
C
C
C     SET BOUNDARY VELOCITIES
C
      DO 100 J=1,NY
      UB(J,1,K)=U(1,J,K)
      UB(J,2,K)=U(NX,J,K)
  100 CONTINUE
      DO 200 I=1,NX
      VB(I,1,K)=V(I,1,K)
      VB(I,2,K)=V(I,NY,K)
  200 CONTINUE
      RETURN
      END
c----------------------------------------------------------------------
      subroutine windpr(u,v,w)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 940304             WINDPR
c
C --- PURPOSE:  PRINT OUT WIND FIELD AT EACH LAYER .
C
c --- UPDATES:
c --- (940304) to V5.6 (050328) (FRR)
c           - explicit common replaced by include d6.met (frr 040630)
c
C     INPUTS:  U (R ARRAY) - GRIDDED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY) - GRIDDED Y-DIRECTION WIND COMPONENTS
C              W (R ARRAY) - GRIDDED VERTICAL WIND COMPONENTS
c        Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
c ---------------------------------------------------------------------
c --- include parameters
      include 'params.met'
c
c NEW frr (12/96) D5 replaced by grid.met
      include 'grid.met'
      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,irdp
      DIMENSION U(mxnx,mxny,*),V(mxnx,mxny,*)
      DIMENSION W(mxnx,mxny,*)
C

      DO 100 K=1,NZ
      IF(K.EQ.1) GO TO 50
      KM = K-1
      if(iwr.gt.0)WRITE(IWR,30) KM,K
      if(iwr.gt.0)WRITE(IWR,12)
      CALL WNDLPT(W(1,1,K))
  50  if(iwr.gt.0)WRITE(IWR,10) K
      if(iwr.gt.0)WRITE(IWR,11)
      CALL WNDLPT(U(1,1,K))
      if(iwr.gt.0)WRITE(IWR,20) K
      if(iwr.gt.0)WRITE(IWR,11)
      CALL WNDLPT(V(1,1,K))
  100 CONTINUE
      RETURN
   10 FORMAT(/,5X,'X-COMPONENT OF WIND (U) AT LEVEL = ',I4,5X,'(M/SEC)')
   11 FORMAT(5X,49('-'))
   12 FORMAT(5X,59('-'))
   20 FORMAT(/,5X,'Y-COMPONENT OF WIND (V) AT LEVEL = ',I4,5X,'(M/SEC)')
   30 FORMAT(/,5X,'Z-COMPONENT OF WIND (W) BETWEEN LEVELS',I4,
     1' & ',I2,5X,'(M/SEC)')
      END
c----------------------------------------------------------------------
      subroutine wndlpt(grid)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328             WNDLPT
c
c
c --- PURPOSE: CREATE A NUMBER MAP OF THE ARRAY 'GRID' SCALED BY FACTOR
c
c --- UPDATES:
c --- V5.6 (050328 - FRR) :xplicit common replaced by include d6.met
c
C
C --- INPUTS:  GRID (R ARRAY) - GRIDDED ARRAY OF SOME VARIABLE
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1
c
c -------------------------------------------------------------------------
c --- include parameters
      include 'params.met'
c
      CHARACTER*1 V
      CHARACTER*3 H
      DIMENSION H(100)
      DIMENSION GRID(mxnx,*)
      COMMON /D2/ MAP(mxnx,mxny), WORK2(3)
      include 'grid.met'
      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,irdp
C
      DATA V/'I'/, ICCM /1/
      DATA H /100*'--+'/
      VMAX = 0.0
      DO 10 J=1,NY
      DO 10 I=1,NX
      VAL = ABS(GRID(I,J))
      VMAX = AMAX1(VAL,VMAX)
   10 CONTINUE
      IF(VMAX.EQ.0..and.iwr.gt.0) WRITE(IWR,995)
      IF(VMAX.EQ.0.) RETURN
      IF(VMAX.LT.10.)  GO TO 30
      IF(VMAX.GE.100.) GO TO 40
      FACTOR = 1.00
      GO TO 50
   30 DO 35 I = 1,20
      FACTOR = 10.**(I)
      IFX = IFIX(FACTOR*VMAX)
      IF(IFX.GE.10 )  GO TO 50
   35 CONTINUE
      RETURN
   40 DO 45 I = 1,20
      FACTOR = 10.**(-I)
      IFX = IFIX(FACTOR*VMAX)
      IF(IFX.LT.100 )   GO TO 50
   45 CONTINUE
      RETURN
   50 CONTINUE
      DO 60 I=1,NX
      DO 60 J=1,NY
      VAL = GRID(I,J)*FACTOR
      IF(VAL.GT.0.)   MAP(I,J) = IFIX( VAL + 0.50)
      IF(VAL.LT.0.)   MAP(I,J) = IFIX( VAL - 0.50)
      IF(VAL.EQ.0.)   MAP(I,J) = 0
   60 CONTINUE
      IL = 1
      IR =  MIN0(NX,36)
      IR = MAX0(IR,1)
      JT = 1
      JB = MIN0(NY,36)
      JB = MAX0(JB,1)
      IRL = IR*ICCM
      if(iwr.gt.0)WRITE(IWR,1000) (I,I=IL,IRL,ICCM)
      if(iwr.gt.0)WRITE(IWR,1002) V, (H(I),I=IL,IR)
      DO 70 J=JT,JB
      K = JB - J + JT
      JRM = (K-1)*ICCM + 1
      if(iwr.gt.0)WRITE(IWR,1003) JRM,V,(MAP(I,K),I=IL,IR)
   70 CONTINUE
      IF (NX .LE. 36) GO TO 80
      IL=37
      IR=MIN0(NX,72)
      JT=1
      JB=MIN0(NY,36)
      JB=MAX0(JB,1)
      IRL=IR*ICCM
      if(iwr.gt.0)WRITE(IWR,1000)(I,I=IL,IRL,ICCM)
      if(iwr.gt.0)WRITE(IWR,1002) V,(H(I),I=IL,IR)
      DO 90 J=JT,JB
      K=JB-J+JT
      JRM=(K-1)*ICCM+1
      if(iwr.gt.0)WRITE(IWR,1003) JRM,V,(MAP(I,K),I=IL,IR)
   90 CONTINUE
   80 CONTINUE
      if(iwr.gt.0)WRITE(IWR,1004) FACTOR
      RETURN
  995 FORMAT(/,9X,'FIELD CONTAINS ALL ZEROS - PRINTING SUPPRESSED')
 1000 FORMAT(/,7X,38I3)
 1002 FORMAT(6X,A1,38A3)
 1003 FORMAT(3X,I2,1X,A1,38I3)
 1004 FORMAT(/,9X,'ARRAY HAS BEEN SCALED BY',E9.1,'  FOR PRINTING')
      END
c----------------------------------------------------------------------
      subroutine wndpr2(u,v)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328             WNDPR2
c
c
c --- PURPOSE: PRINT OUT U & V WIND FIELD AT EACH LAYER
c
c --- UPDATES:
c --- V5.6 (040630 -FRR) :explicit common replaced by include d6.met 
c
C --- INPUTS:  U (R ARRAY) - GRIDDED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY) - GRIDDED Y-DIRECTION WIND COMPONENTS
c        Parameters: MXNX, MXNY, MXNZ, MXNZP1
c
c---------------------------------------------------------------------
c --- include parameters
      include 'params.met'
c
      include 'grid.met'
      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,irdp
      DIMENSION U(mxnx,mxny,*),V(mxnx,mxny,*)
C
      DO 100 K=1,NZ
      if(iwr.gt.0)WRITE(IWR,10) K
      if(iwr.gt.0)WRITE(IWR,11)
      CALL WNDLPT(U(1,1,K))
      if(iwr.gt.0)WRITE(IWR,20) K
      if(iwr.gt.0)WRITE(IWR,11)
      CALL WNDLPT(V(1,1,K))
  100 CONTINUE
      RETURN
   10 FORMAT(//,5X,'X-COMPONENT OF WIND (U) AT LEVEL = ',I4,5X,
     1       '(M/SEC)')
   11 FORMAT(5X,49('-'))
   12 FORMAT(5X,57('-'))
   20 FORMAT(//,5X,'Y-COMPONENT OF WIND (V) AT LEVEL = ',I4,5X,
     1       '(M/SEC)')
      END
c----------------------------------------------------------------------
      subroutine wrt(form1,form2,jj,iout,sign,n,io6)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130                WRT
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write one Y row of gridded data
c
c --- INPUTS:
c              FORM1 - Char.*24    - Format field for Y label and data
c                                    to be printed
c              FORM2 - Char.*21    - Format field for sign of data
c                 JJ - Integer     - Y grid cell number
c            IOUT(N) - Int. array  - Array of data to be printed
c                                    (one Y row)
c            SIGN(N) - Char.*1     - Array containing sign of data
c                                    ('+' or '-')
c                  N - Integer     - Number of cells in this row
c                IO6 - Integer     - Fortran unit no. of output
c
c --- OUTPUT:  none
c
c --- WRT called by:  OUT
c --- WRT calls:      none
c----------------------------------------------------------------------
      integer iout(n)
c
      character*1 sign(n)
      character*24 form1
      character*21 form2
c
      write(io6,form1)jj,iout
      write(io6,form2)sign
c
      return
      end
c----------------------------------------------------------------------
      subroutine wrt2(form,n1,n2,io6)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 901130               WRT2
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write a line labeling grid cell numbers
c
c --- INPUTS:
c               FORM - Char.*18    - Format field of data to be printed
c                 N1 - Integer     - Starting grid cell number
c                 N2 - Integer     - Ending grid cell number
c                IO6 - Integer     - Fortran unit no. of output
c
c --- OUTPUT:  none
c
c --- WRT2 called by:  OUT
c --- WRT2 calls:      none
c----------------------------------------------------------------------
      character*18 form
c
      write(io6,form)(i,i=n1,n2)
      return
      end
c----------------------------------------------------------------------
       subroutine wrti1d(iomet,idat,nwords,clabel,ndathrb,ibsec,
     :                  ndathre,iesec)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060215             WRTI1D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write "NWORDS" of a one-dimensional integer array
c
c --- UPDATES:
c    - 901130 to V6.2 Level 060215 (F.Robe)
c        - Replace hour-ending date by explicit beginning/ending times
c          with seconds

c --- INPUTS:
c         IOMET - integer       - Fortran unit number of output file
c  IDAT(nwords) - integer array - Array to output
c        NWORDS - integer       - Number of words to write
c        CLABEL - character*8   - Variable name
c       NDATHRB - integer       - Beginning Date and time of data
c                                 (YYYYJJJHH) (explicit time)
c         IBSEC - integer       - Beginning Second of data (SSSS)
c       NDATHRE - integer       - Ending Date and time of data 
c                                 (YYYYJJJHH) (explicit time)
c         IESEC - integer       - Ending Second of data (SSSS)
c
c --- OUTPUT:  none
c
c --- WRTI1D called by:  OUTHR
c --- WRTI1D calls:      none
c----------------------------------------------------------------------
      integer idat(nwords)
      character*8 clabel
c
      write(iomet)clabel,ndathrb,ibsec,ndathre,iesec,idat
      return
      end
c----------------------------------------------------------------------
      subroutine wrti2d(iomet,idat,ibuf,mxnx,mxny,nx,ny,clabel,
     :                  ndathrb,ibsec,ndathre,iesec)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060215             WRTI2D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write NX * NY words of a 2-D integer array
c
c --- UPDATES:
c    - 901130 to V6.2 Level 060215 (F.Robe)
c        - Replace hour-ending date by explicit beginning/ending times
c          with seconds
c
c --- INPUTS:
c               IOMET - integer       - Fortran unit number of output file
c     IDAT(mxnx,mxny) - integer array - Array to output
c         IBUF(nx,ny) - integer array - Buffer to hold data for output
c           MXNX,MXNY - integers      - Dimensions of data array
c               NX,NY - integers      - Actual size of grid to output
c              CLABEL - character*8   - Variable name
c             NDATHRB - integer       - Beginning Date and time of data
c                                      (YYYYJJJHH) (explicit time)
c               IBSEC - integer       - Beginning Second of data (SSSS)
c             NDATHRE - integer       - Ending Date and time of data 
c                                       (YYYYJJJHH) (explicit time)
c               IESEC - integer       - Ending Second of data (SSSS)
c
c
c --- OUTPUT:  none
c
c --- WRTI2D called by:  OUTHD, OUTHR
c --- WRTI2D 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 -- write full grid
         write(iomet)clabel,ndathrb,ibsec,ndathre,iesec,idat
      else
c
c ---    only a portion of grid being used -- transfer to buffer
c ---    and write
         do 10 i=1,nx
         do 10 j=1,ny
         ibuf(i,j)=idat(i,j)
10       continue
c
         write(iomet)clabel,ndathrb,ibsec,ndathre,iesec,ibuf
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine wrtr1d(iomet,x,nwords,clabel,
     :                  ndathrb,ibsec,ndathre,iesec)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060215             WRTR1D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write "NWORDS" of a one-dimensional real array
c
c
c --- UPDATES:
c    - 901130 to V6.2 Level 060215 (F.Robe)
c        - Replace hour-ending date by explicit beginning/ending times
c          with seconds
c
c --- INPUTS:
c         IOMET - integer     - Fortran unit number of output file
c     X(nwords) - real array  - Array to output
c        NWORDS - integer     - Number of words to write
c        CLABEL - character*8 - Variable name
c          NDATHRB - integer     - Beginning Date and time of data
c                                  (YYYYJJJHH) (explicit time)
c            IBSEC - integer     - Beginning Second of data (SSSS)
c          NDATHRE - integer     - Ending Date and time of data 
c                                  (YYYYJJJHH) (explicit time)
c            IESEC - integer     - Ending Second of data (SSSS)
c
c --- OUTPUT:  none
c
c --- WRTR1D called by:  OUTHD, OUTHR
c --- WRTR1D calls:      none
c----------------------------------------------------------------------
      real x(nwords)
      character*8 clabel
c
      write(iomet)clabel,ndathrb,ibsec,ndathre,iesec,x
      return
      end
c----------------------------------------------------------------------
      subroutine wrtr2d(iomet,x,xbuf,mxnx,mxny,nx,ny,clabel,
     :                 ndathrb,ibsec,ndathre,iesec)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 060215             WRTR2D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write NX * NY words of a 2-D real array
c
c
c --- UPDATES:
c     - 901130 to V6.2 (060215) (F. Robe)
c           - Hour-ending dates replaced by explicit beginning/ending
c             dates with seconds
c --- INPUTS:
c            IOMET - integer     - Fortran unit number of output file
c     X(mxnx,mxny) - real array  - Array to output
c      XBUF(nx,ny) - real array  - Buffer to hold data for output
c        MXNX,MXNY - integers    - Dimensions of data array
c            NX,NY - integers    - Actual size of grid to output
c           CLABEL - character*8 - Variable name
c          NDATHRB - integer     - Beginning Date and time of data
c                                  (YYYYJJJHH) (explicit time)
c            IBSEC - integer     - Beginning Second of data (SSSS)
c          NDATHRE - integer     - Ending Date and time of data 
c                                  (YYYYJJJHH) (explicit time)
c            IESEC - integer     - Ending Second of data (SSSS)
c
c --- OUTPUT:  none
c
c --- WRTR2D called by:  OUTHD, OUTHR
c --- WRTR2D calls:      none
c----------------------------------------------------------------------
      real x(mxnx,mxny),xbuf(nx,ny)
      character*8 clabel
c
      if(nx.eq.mxnx.and.ny.eq.mxny)then
c
c ---    entire array is being used -- write full grid
         write(iomet)clabel,ndathrb,ibsec,ndathre,iesec,x
      else
c
c ---    only a portion of grid being used -- transfer to buffer
c ---    and write
         do 10 i=1,nx
         do 10 j=1,ny
         xbuf(i,j)=x(i,j)
10       continue
c
         write(iomet)clabel,ndathrb,ibsec,ndathre,iesec,xbuf
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine wstarr(ziconv,qh,temp2d,rho,ilandu,iwat1,iwat2,
     1 nx,ny,wstar)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 050328             WSTARR
c ---          J. Scire, SRC
c              Modified by F.Robe, Earth Tech, for 2D array of rho
c              and prognostic temp (ITPROG)
c
c --- PURPOSE:  Calculate the convective velocity scale, w*, (m/s)
c               at each grid point (LAND CELLS ONLY)
c
c --- UPDATES:
c --- Level 901130  to V5.6 Level 050328 (frr)
c          - Remove NEARS from calling list 
c          - Use gridded surface temperature array (temp2d) rather
c            than tempk,tprog
c
c --- INPUTS:
c    ZICONV(mxnx,mxny) - real array    - Convective mixing height (m)
c        QH(mxnx,mxny) - real array    - Sensible heat flux (W/m**2)
c    TEMP2D(mxnx,mxny) - real array    - Surface air temperature (deg. K)
c       RHO(mxnx,mxny) - real array    - Air density (kg/m**3)
c    ILANDU(mxnx,mxny) - integer array - Land use category at each
c                                        grid point
c         IWAT1, IWAT2 - integers      - Range of land use categories
c                                        defining water (IWAT1 to IWAT2)
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c       Parameters: MXNX, MXNY, MXSS, MXNZ
c
c --- OUTPUT:
c     WSTAR(mxnx,mxny) - real array    - Convective velocity scale (m/s)
c
c --- WSTARR called by:  COMP
c --- WSTARR calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real ziconv(mxnx,mxny),qh(mxnx,mxny),wstar(mxnx,mxny)
      real temp2d(mxnx,mxny),rho(mxnx,mxny)
      integer ilandu(mxnx,mxny)
c
      data cp/996./,g/9.81/
c
      do 100 i=1,nx
      do 100 j=1,ny
c
c --- skip water cells
      if(ilandu(i,j).ge.iwat1.and.ilandu(i,j).le.iwat2)go to 100
c
      if(qh(i,j).le.0.0)then
c
         wstar(i,j)=0.0
      else
         wstar(i,j)=(g*qh(i,j)*ziconv(i,j)/
     :              (temp2d(i,j)*rho(i,j)*cp))**0.3333333
      endif
100   continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine xmit(n,a,b)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 940304               XMIT
C
      DIMENSION A(*),B(*)
C
C     IF N >= 0 XMIT FILLS ARRAY B WITH ARRAY A
C     IF N < 0 XMIT FILLS ARRAY B WITH VALUE A
C
C     INPUT:  A (R ARRAY) - VALUE OR ARRAY OF VALUES USED TO
C                           INITIALIZE ARRAY B
C     OUTPUT: B (R ARRAY) - INITIALIZED ARRAY
C
      IF(N) 100,120,120
  100 K=IABS(N)
      DO 110 I=1,K
      B(I)=A(1)
  110 CONTINUE
      RETURN
  120 DO 130 I=1,N
      B(I)=A(I)
  130 CONTINUE
      RETURN
      END
c----------------------------------------------------------------------
      subroutine outpc1(lecho,nyr,idystr,ihrmax,nssta,nusta,imax,jmax,
     1 ibtz,ilwf,iuwf,dgrid,vk,xscoor,yscoor,xucoor,yucoor,
     2 z0,nears,ilandu)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 941101             OUTPC1
c              J. Scire, SRC
c
c --- PURPOSE:  Write the MESOPAC II header records in the REVISED
c               format
c
c --- INPUTS:
c           LECHO - logical       - Control variable for output of
c                                   header record information
c             NYR - integer       - Year of start of run
c          IDYSTR - integer       - Julian day of start of run
c          IHRMAX - integer       - Number of hours in run
c           NSSTA - integer       - Number of surface met. stations
c           NUSTA - integer       - Number of upper air met. stations
c            IMAX - integer       - Number of grid points in X dir.
c            JMAX - integer       - Number of grid points in Y dir.
c            IBTZ - integer       - Reference time zone
c            ILWF - integer       - Lower-level wind field code
c                                   (2=mixed-layer averaged winds)
c            IUWF - integer       - Upper-level wind field code
c                                   (4=mixed-layer to 700 mb ht. ave.)
c           DGRID - real          - Grid spacing (m)
c              VK - real          - von Karman constant (0.40)
c    XSCOOR(mxss) - real array    - Surface met. station X coordinates
c                                   (met. grid units)
c    YSCOOR(mxss) - real array    - Surface met. station Y coordinates
c                                   (met. grid units)
c    XUCOOR(mxus) - real array    - Upper air station X coordinates
c                                   (met. grid units)
c    YUCOOR(mxus) - real array    - Upper air station Y coordinates
c                                   (met. grid units)
c   Z0(mxnx,mxny) - real array    - Surface roughness lengths (m)
c NEARS(mxnx,mxny)- real array  - Station number of closest surface
c                                 station to each grid point
c ILANDU(mxnx,mxny)-real array  - Land use categories
c
c     Parameters:
c           MXNX, MXNY, IO6, IO7
c
c --- OUTPUT:  None
c
c --- OUTPC1 called by:  SETUP
c --- OUTPC1 calls:      WPCR2D, WPCI2D, OUT
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      real xscoor(nssta),yscoor(nssta),xucoor(nusta),yucoor(nusta)
      real z0(mxnx,mxny),xbuf(mxnx,mxny)
c
      integer nears(mxnx,mxny),ilandu(mxnx,mxny)
      logical lecho,ldate
      character*70 messag
c
      write(io7)nyr,idystr,ihrmax,nssta,nusta,imax,jmax,ibtz,
     1 ilwf,iuwf,dgrid,vk
      write(io7)xscoor,yscoor
      if (nusta .gt. 0) write(io7)xucoor,yucoor
      call wpcr2d(io7,z0,xbuf,mxnx,mxny,imax,jmax)
      call wpci2d(io7,nears,xbuf,mxnx,mxny,imax,jmax)
      call wpci2d(io7,ilandu,xbuf,mxnx,mxny,imax,jmax)
c
      if(lecho)then
         write(io6,1202)
1202     format(//1x,13('----------')//)
         write(io6,*)
         write(io6,*)' Data written to PACOUT meteorological data file'
         write(io6,*)
         write(io6,*)' NYR     = ',nyr
         write(io6,*)' IDYSTR  = ',idystr
         write(io6,*)' IHRMAX  = ',ihrmax
         write(io6,*)' NSSTA   = ',nssta
         write(io6,*)' NUSTA   = ',nusta
         write(io6,*)' IMAX    = ',imax
         write(io6,*)' JMAX    = ',jmax
         write(io6,*)' IBTZ    = ',ibtz
         write(io6,*)' ILWF    = ',ilwf
         write(io6,*)' IUWF    = ',iuwf
         write(io6,*)' DGRID   = ',dgrid
         write(io6,*)' VK      = ',vk
         write(io6,*)' XSCOOR  = ',xscoor
         write(io6,*)' YSCOOR  = ',yscoor
         write(io6,*)' XUCOOR  = ',xucoor
         write(io6,*)' YUCOOR  = ',yucoor
c
         ldate=.false.
         messag='Surface roughness lengths (m)'
         messag(63:64)='Z0'
         call out(z0,idum,1,5,ldate,messag,imax,jmax)
c
         messag='Nearest surface station no. to each grid point'
         messag(63:67)='NEARS'
         call out(xdum,nears,2,5,ldate,messag,imax,jmax)
c
         messag='Land use categories'
         messag(63:68)='ILANDU'
         call out(xdum,ilandu,2,5,ldate,messag,imax,jmax)
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine outpc(lecho,kyr,kjul,khr,ul,vl,uup,vup,htmix,ustar,
     1 wstar,xmonin,ipgt,rmm,avrho,tempk,srad,irh,ipcode,
     2 imax,jmax,nssta)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 030402              OUTPC
c              J. Scire, SRC
c
c --- PURPOSE:  Write the MESOPAC II data records in the REVISED
c               format
c
c --- UPDATE
c --- V5.4 (940419) to V5.5 (030402)  (DGS)
c               - Add list-file unit to GRDAY call
c
c --- INPUTS:
c             LECHO - logical    - Control variable for output of
c                                  header record information
c               KYR - integer    - Year
c              KJUL - integer    - Julian day
c               KHR - integer    - Hour
c     UL(mxnx,mxny) - real array - Lower-layer U wind components (m/s)
c     VL(mxnx,mxny) - real array - Lower-layer V wind components (m/s)
c    UUP(mxnx,mxny) - real array - Upper-layer U wind components (m/s)
c    VUP(mxnx,mxny) - real array - Upper-layer V wind components (m/s)
c  HTMIX(mxnx,mxny) - real array - Mixing heights (m)
c  USTAR(mxnx,mxny) - real array - Surface friction velocities (m/s)
c  WSTAR(mxnx,mxny) - real array - Convective velocity scale (m/s)
c XMONIN(mxnx,mxny) - real array - Monin-Obukhov lengths (m)
c   IPGT(mxnx,mxny) - int. array - Stability class array
c    RMM(mxnx,mxny) - real array - Precipitation rates (mm/hr)
c             AVRHO - real       - Average air density (kg/m**3)
c      TEMPK(nssta) - real array - Air temperature (deg. K)
c       SRAD(nssta) - real array - Solar radiation (W/m**2)
c        IRH(nssta) - int. array - Relative humidity (percent)
c     IPCODE(nssta) - int. array - Precipitation codes at surface met.
c                                  stations
c              IMAX - integer    - Number grid cells in X direction
c              JMAX - integer    - Number grid cells in Y direction
c             NSSTA - integer    - Number of surface met. stations
c     Parameters:
c           MXNX, MXNY, IO6, IO7
c
c --- OUTPUT:  None
c
c --- OUTPC called by:  COMP
c --- OUTPC calls:      WPCR2D, WPCI2D, GRDAY, OUT
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
      real ul(mxnx,mxny),vl(mxnx,mxny),uup(mxnx,mxny),vup(mxnx,mxny)
      real htmix(mxnx,mxny),ustar(mxnx,mxny),wstar(mxnx,mxny)
      real xmonin(mxnx,mxny),rmm(mxnx,mxny)
      real tempk(nssta),srad(nssta)
      real xbuf(mxnx,mxny)
c
      integer ipgt(mxnx,mxny)
      integer irh(nssta),ipcode(nssta)
c
      logical lecho,ldate
      character*70 messag
c
c --- Write a set of revised MESOPAC II data records for one hour
      write(io7)kyr,kjul,khr
c
      call wpcr2d(io7,ul,xbuf,mxnx,mxny,imax,jmax)
      call wpcr2d(io7,vl,xbuf,mxnx,mxny,imax,jmax)
c
      call wpcr2d(io7,uup,xbuf,mxnx,mxny,imax,jmax)
      call wpcr2d(io7,vup,xbuf,mxnx,mxny,imax,jmax)
c
      call wpcr2d(io7,htmix,xbuf,mxnx,mxny,imax,jmax)
      call wpcr2d(io7,ustar,xbuf,mxnx,mxny,imax,jmax)
c
      call wpcr2d(io7,wstar,xbuf,mxnx,mxny,imax,jmax)
      call wpcr2d(io7,xmonin,xbuf,mxnx,mxny,imax,jmax)
c
      call wpci2d(io7,ipgt,xbuf,mxnx,mxny,imax,jmax)
c
      call wpcr2d(io7,rmm,xbuf,mxnx,mxny,imax,jmax)
c
      write(io7)avrho,tempk,srad,irh,ipcode
c
      if(lecho)then
         write(io6,1202)
1202     format(//1x,13('----------')//)
         write(io6,*)
         write(io6,*)' Data written to PACOUT meteorological data file'
         write(io6,*)
         write(io6,*)' KYR     = ',kyr
         write(io6,*)' KJUL    = ',kjul
         write(io6,*)' KHR     = ',khr
c
         ldate=.true.
         call grday(io6,kyr,kjul,kmo,kday)
c
         messag='Lower-layer U winds (m/s)'
         messag(63:64)='UL'
         call out(ul,idum,1,5,ldate,messag,imax,jmax)
c
         messag='Lower-layer V winds (m/s)'
         messag(63:64)='VL'
         call out(vl,idum,1,5,ldate,messag,imax,jmax)
c
         messag='Upper-layer U winds (m/s)'
         messag(63:65)='UUP'
         call out(uup,idum,1,5,ldate,messag,imax,jmax)
c
         messag='Upper-layer V winds (m/s)'
         messag(63:65)='VUP'
         call out(vup,idum,1,5,ldate,messag,imax,jmax)
c
         messag='Mixing heights (m)'
         messag(63:67)='HTMIX'
         call out(htmix,idum,1,5,ldate,messag,imax,jmax)
c
         messag='Friction velocity (m/s)'
         messag(63:67)='USTAR'
         call out(ustar,idum,1,5,ldate,messag,imax,jmax)
c
         messag='Convective velocity scale (m/s)'
         messag(63:67)='WSTAR'
         call out(wstar,idum,1,5,ldate,messag,imax,jmax)
c
         messag='Monin-Obukhov length (m)'
         messag(63:68)='XMONIN'
         call out(xmonin,idum,1,5,ldate,messag,imax,jmax)
c
         messag='Stability class'
         messag(63:66)='IPGT'
         call out(xdum,ipgt,2,2,ldate,messag,imax,jmax)
c
         messag='Precipitation rate (mm/hr)'
         messag(63:65)='RMM'
         call out(rmm,idum,1,5,ldate,messag,imax,jmax)
c
         write(io6,*)
         write(io6,*)' AVRHO (kg/m**3)  = ',avrho
         write(io6,*)' TEMPK (deg. K)   = ',tempk
         write(io6,*)' SRAD  (W/m**2)   = ',srad
         write(io6,*)' IRH   (percent)  = ',irh
         write(io6,*)' IPCODE           = ',ipcode
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine wpcr2d(iomet,x,xbuf,mxnx,mxny,nx,ny)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 930906             WPCR2D
c              J. Scire, SRC
c
c --- PURPOSE:  Write NX * NY words of a 2-D real array
c
c --- INPUTS:
c            IOMET - integer     - Fortran unit number of output file
c     X(mxnx,mxny) - real array  - Array to output
c      XBUF(nx,ny) - real array  - Buffer to hold data for output
c        MXNX,MXNY - integers    - Dimensions of data array
c            NX,NY - integers    - Actual size of grid to output
c
c --- OUTPUT:  none
c
c --- WPCR2D called by:  OUTPC1, OUTPC
c --- WPCR2D calls:      none
c----------------------------------------------------------------------
      integer mxnx,mxny,nx,ny,iomet
      real x(mxnx,mxny),xbuf(nx,ny)
c
      if(nx.eq.mxnx.and.ny.eq.mxny)then
c
c ---    entire array is being used -- write full grid
         write(iomet)x
      else
c
c ---    only a portion of grid being used -- transfer to buffer
c ---    and write
         do 10 i=1,nx
         do 10 j=1,ny
         xbuf(i,j)=x(i,j)
10       continue
c
         write(iomet)xbuf
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine wpci2d(iomet,idat,ibuf,mxnx,mxny,nx,ny)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 930906             WPCI2D
c              J. Scire, SRC
c
c --- PURPOSE:  Write NX * NY words of a 2-D integer array
c
c --- INPUTS:
c               IOMET - integer       - Fortran unit number of output file
c     IDAT(mxnx,mxny) - integer array - Array to output
c         IBUF(nx,ny) - integer array - Buffer to hold data for output
c           MXNX,MXNY - integers      - Dimensions of data array
c               NX,NY - integers      - Actual size of grid to output
c
c --- OUTPUT:  none
c
c --- WPCI2D called by:  OUTPC1, OUTPC
c --- WPCI2D calls:      none
c----------------------------------------------------------------------
      integer idat(mxnx,mxny),ibuf(nx,ny)
c
      if(nx.eq.mxnx.and.ny.eq.mxny)then
c
c ---    entire array is being used -- write full grid
         write(iomet)idat
      else
c
c ---    only a portion of grid being used -- transfer to buffer
c ---    and write
         do 10 i=1,nx
         do 10 j=1,ny
         ibuf(i,j)=idat(i,j)
10       continue
c
         write(iomet)ibuf
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine pacave(u,v,htmix,zface,nx,ny,nz,ztop,zincr,
     1   ul,vl,uup,vup)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 930906             PACAVE
c ---          J. Scire, SRC
c
c --- PURPOSE:  Calculate vertically-averaged winds in two layers:
c                  (1) Ground to mixing height (lower layer)
c                  (2) mixing height to fixed height "ZTOP", or
c                      mixing height + ZINCR, whichever is greater
c
c
c --- INPUTS:
c    U(mxnx,mxny,mxnz) - real array - U wind components (m/s)
c    V(mxnx,mxny,mxnz) - real array - V wind components (m/s)
c     HTMIX(mxnx,mxny) - real array - Mixing heights (m)
c        ZFACE(mxnzp1) - real array - Heights (m) of cell faces
c                   NX - integer    - Number of X grid points
c                   NY - integer    - Number of Y grid points
c                   NZ - integer    - Number of vertical layers
c                 ZTOP - real       - Top of upper layer (m)
c                ZINCR - real       - Increment above mixing height
c                                     defining minimum thickness of
c                                     the upper layer (m)
c
c --- OUTPUT:
c        UL(mxnx,mxny) - real array - Lower-layer vertically averaged
c                                     U wind components (m/s)
c        VL(mxnx,mxny) - real array - Lower-layer vertically averaged
c                                     V wind components (m/s)
c       UUP(mxnx,mxny) - real array - Upper-layer vertically averaged
c                                     U wind components (m/s)
c       VUP(mxnx,mxny) - real array - Upper-layer vertically averaged
c                                     V wind components (m/s)
c
c        Parameters: MXNX, MXNY, MXNZ, MXNZP1, IO6
c
c --- PACAVE called by:  COMP
c --- PACAVE calls:      none
c----------------------------------------------------------------------
c
c --- Include parameters
      include 'params.met'
c
       real u(mxnx,mxny,mxnz),v(mxnx,mxny,mxnz),htmix(mxnx,mxny)
       real zface(mxnzp1),dz(mxnz)
       real ul(mxnx,mxny),vl(mxnx,mxny)
       real uup(mxnx,mxny),vup(mxnx,mxny)
       real worku(mxnz),workv(mxnz)
c
       nzp1=nz+1
c
c --- Compute cell depths
      do 5 k=1,nz
      dz(k)=(zface(k+1)-zface(k))
5     continue
c
c --- LOOP OVER GRID CELLS
      do 100 i=1,nx
      do 100 j=1,ny
c
c --- Define top of lower layer
      zi=amax1(htmix(i,j),10.0)
c
c --- Define top of upper layer
      zztop=amax1(ztop,20.0,htmix(i,j)+zincr)
c
c --- Check for problems with inputs
      if(zztop.gt.zface(nzp1))then
         write(io6,902)
902      format(/1x,'ERROR in Subr. PACAVE -- ZZTOP > top cell ',
     1   'face height')
         write(io6,*)'ZZTOP = ',zztop
         write(io6,*)'ZTOP  = ',ztop,' HTMIX = ',htmix(i,j),' I = ',i,
     1    ' J = ',j,' ZINCR = ',zincr
         write(io6,*)'ZFACE = ',(zface(n),n=1,nzp1)
         stop
      endif
c
c --- Transfer data to work arrays, make all values positive
      do 10 k=1,nz
      worku(k)=u(i,j,k)
      workv(k)=v(i,j,k)
10    continue
c
c --- Compute mixed-layer averaged winds
c ---    NOTE: It is assumed that the CALMET winds are layer-averages
c ---          over the depth of each cell
      sumu=0.0
      sumv=0.0
      sumz=0.0
c
      ksav=0
      do 20 k=1,nz
c
      if(zface(k+1).lt.zi)then
c
c ---    CALMET layer is completely within the mixed-layer
         sumu=sumu+dz(k)*worku(k)
         sumv=sumv+dz(k)*workv(k)
         sumz=sumz+dz(k)
      else
c
c ---    CALMET layer extends to or above mixed-layer
         delz=zi-zface(k)
         sumu=sumu+delz*worku(k)
         sumv=sumv+delz*workv(k)
         sumz=sumz+delz
         ksav=k
         go to 22
      endif
20    continue
c
c --- This should only be reached if ZI > zface(nz+1)
      write(io6,*)'ERROR in Subr. PACAVE -- After 20 continue -- ',
     1   'ZI = ',zi,' ZFACE(nz+1) = ',zface(nz+1),' NZ = ',nz
         stop
22    continue
c
c --- LOWER LAYER WINDS
      ul(i,j)=sumu/sumz
      vl(i,j)=sumv/sumz
c
c --- Compute average winds in layer from mixing height to ZZTOP
      sumu=0.0
      sumv=0.0
      sumz=0.0
c
c --- If mixing ht. > ZZTOP, use CALMET layer above zztop for
c --- upper layer winds
      if(zface(ksav+1).gt.zztop)then
c
c ---    ZI > ZZTOP -- use CALMET winds in layer above ZI
         uup(i,j)=worku(ksav)
         vup(i,j)=workv(ksav)
         go to 100
      else
c
c ---    Average over layers between ZI and ZZTOP
         delz=zface(ksav+1)-zi
         sumu=delz*worku(ksav)
         sumv=delz*workv(ksav)
         sumz=delz
c
         kk=ksav+1
         if(kk.gt.nz)go to 42
         do 40 k=kk,nz
c
         if(zface(k+1).lt.zztop)then
c
c ---       CALMET layer is completely within upper layer
            sumu=sumu+dz(k)*worku(k)
            sumv=sumv+dz(k)*workv(k)
            sumz=sumz+dz(k)
         else
c
c ---       CALMET layer extends to or beyond ZZTOP
            delz=zztop-zface(k)
            sumu=sumu+delz*worku(k)
            sumv=sumv+delz*workv(k)
            sumz=sumz+delz
            go to 42
         endif
40       continue
c
c ---    This section of code should never be reached
         write(io6,*)'ERROR in Subr. PACAVE -- After 20 continue -- ',
     1      'ZI = ',zi,' ZFACE(nz+1) = ',zface(nz+1),' NZ = ',nz
         stop
42       continue
c
c ---    UPPER LAYER WINDS
         uup(i,j)=sumu/sumz
         vup(i,j)=sumv/sumz
      endif
100   continue
c
      return
      end
c----------------------------------------------------------------------
      subroutine readfn(igroup,nusta,nowsta,nm3d,nigf)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 121203             READFN
c              J. Scire, SRC
c
c --- PURPOSE:  Read one or more groups of file names for the
c               input and output files of the run
c
c --- UPDATES
c
c --- v6.205 (060309) to v6.4.0 (121203)
c                  - Allow 999 M3D files (from 99)
c
c --- v5.711 (060106) to v6.205 (060309) (DGS):
c                  - change filenames from c*70 to c*132
c
c --- V5.6 (050328) to v5.711 (060106) (FRR):
c                  - read IGF-CALMET filenames
c
c --- V5.547(041010) to V5.6 (050328) (FRR):
c                  - read distance-to-coast filename
c
c --- V5.1(991104) to V5.547 (041010) (FRR):
c                  - read multiple MM4/MM5 /3D filenames

c
c --- V5.0-V5.1     991104  (JSS): Error messages written to list file
c                                  in addition to screen
c
c --- INPUTS:
c
c           IGROUP - integer    - Group of file to be read -- the 1st
c                                 group includes the CALMET.LST file.
c                                 The other groups are read AFTER the
c                                 control file is read, since the number
c                                 of files read depends on the variables
c                                 NUSTA and NOWSTA
c           NUSTA - integer     - Number of upper air stations (an
c                                 input variable if IGROUP=2)
c          NOWSTA - integer     - Number of overwater stations (an
c                                 input variable if IGROUP=2)
c            nm3d - integer     - Number of MM5 files in 3D.DAT format
c                                 input variable if IGROUP=2)
c            NIGF - integer     - Number of IGF-CALMET files 
c                                 (an input variable if IGROUP=2) 
c
c        Parameters: MXUS, MXOWS, mxm3d, mxigf,IO5, IO6
c
c --- OUTPUT:
c           NUSTA - integer     - Number of upper air stations (an
c                                 output variable if IGROUP=1)
c          NOWSTA - integer     - Number of overwater stations (an
c                                 output variable if IGROUP=1)
c            nm3d - integer     - Number of MM5 files in 3D.DAT format
c                                 input variable if IGROUP=1)
c            nigf - integer     - Number ofIGF-CALMET.DAT files 
c                                 (an input variable if IGROUP=1)
c
c
c
c ---    Common block /FILNAM/ variables:
c           metinp,geodat,srfdat,prcdat,diadat,prgdat,mm4dat,
c           wtdat,updat,seadat,metlst,metdat,pacdat,tstprt,
c           tstout,tstkin,tstfrd,tstslp,lcfiles,clddat,m3ddat,dcstgd
c
c --- READFN called by:  SETUP
c --- READFN calls:      READIN, FILCASE
c----------------------------------------------------------------------
c
c --- Include parameter statements
      include 'params.met'
c
      character*4 ctemp(132,11)
c frr 060106 cvdic (15,6) instead of (14,5) for multiple IGFDAT.DAT
      character*12 cvdic(15,6)
      integer ivleng(15,6),ivtype(15,6)
      logical lecho
c
c --- Include common blocks
      include 'filnam.met'
c
      data lecho/.false./
      data cvdic/'METINP','GEODAT','SRFDAT','PRCDAT','MM4DAT','WTDAT',
     1 'METLST','METDAT','PACDAT','CLDDAT','LCFILES','NUSTA','NOWSTA',
     1 'NM3D','NIGF',
     2 'UPDAT',14*' ',
     3 'SEADAT',14*' ',
     4 'M3DDAT',14*' ',
     5 'IGFDAT',14*' ',
     6 'DIADAT','PRGDAT','TSTPRT','TSTOUT','TSTKIN','TSTFRD',
     6 'TSTSLP','DCSTGD',7*' '/
      data ivleng/10*132,5*1,
     2 132,14*0,
     3 132,14*0,
     4 132,14*0,
     5 132,14*0,
     6 8*132,7*0/
      data ivtype/10*4,3,2,2,2,2,
     2 4,14*0,
     3 4,14*0,
     4 4,14*0,
     5 4,14*0,
     6 8*4,7*0/
c
c --- Read the file names from the data file
c
      if(igroup.eq.1)then
c
c ---    Initialize the UPn.DAT , SEAn.DAT , MM5n.DAT and IGFn.DAT filenames
         do i=1,mxus
            if(i.lt.10)then
               updat(i)='up .dat'
               write(updat(i)(3:3),'(I1)')i
            else if(i.lt.100)then
               updat(i)='up  .dat'
               write(updat(i)(3:4),'(I2)')i
            else
               write(*,*)'ERROR IN SUBR. READFN -- Too many upper ',
     1         'air data files for open format -- i = ',I
               write(io6,*)'ERROR IN SUBR. READFN -- Too many upper ',
     1         'air data files for open format -- i = ',i
               stop
            endif
         enddo
c
         do i=1,mxows
            if(i.lt.10)then
               seadat(i)='sea .dat'
               write(seadat(i)(4:4),'(I1)')i
            else if(i.lt.100)then
               seadat(i)='sea  .dat'
               write(seadat(i)(4:5),'(I2)')i
            else
               write(*,*)'ERROR IN SUBR. READFN -- Too many ',
     1         'overwater data files for open format -- i = ',I
               write(io6,*)'ERROR IN SUBR. READFN -- Too many ',
     1         'overwater data files for open format -- i = ',i
               stop
            endif
         enddo
c
c ---    Multiple MM5 files (041010) - FRR 
         do i=1,mxm3d
            if(i.lt.10)then
               m3ddat(i)='mm5 .dat'
               write(m3ddat(i)(4:4),'(I1)')i
            else if(i.lt.100)then
               m3ddat(i)='mm5  .dat'
               write(m3ddat(i)(4:5),'(I2)')i
c --- v6.4.0, Level 121203
            else if(i.lt.1000)then
               m3ddat(i)='mm5   .dat'
               write(m3ddat(i)(4:6),'(I3)')i
            else
               write(*,*)'ERROR IN SUBR. READFN -- Too many ',
     1         'MM5 files for open format -- i = ',I
               write(io6,*)'ERROR IN SUBR. READFN -- Too many ',
     1         'MM5 files for open format -- i = ',i
               stop
            endif
         enddo

c ---    Multiple IGF files (060106) - FRR 
         do i=1,mxigf
            if(i.lt.10)then
               igfdat(i)='igf .dat'
               write(igfdat(i)(4:4),'(I1)')i
            else if(i.lt.100)then
               igfdat(i)='igf  .dat'
               write(igfdat(i)(4:5),'(I2)')i
            else
               write(*,*)'ERROR IN SUBR. READFN -- Too many ',
     1         'IGF-CALMET files for open format -- i = ',I
               write(io6,*)'ERROR IN SUBR. READFN -- Too many ',
     1         'IGF-CALMET files for open format -- i = ',i
               stop
            endif
         enddo

c ---    Initialize the temporary arrays
         do i=1,10
            do j=1,132
               ctemp(j,i)(1:1)=' '
            enddo
         enddo
c
c ---    Initialize number of MM4-5 files to 0 so it has the correct
c        value if old CALMET.INP file (pre-multiple MM5.DAT ) -041010
         nm3d=0
c ---    Same for IGF-CALMET fiels
         nigf=0
c ---    Read the file names for Group #0(a)
         
         call readin(cvdic(1,1),ivleng(1,1),ivtype(1,1),io5,io6,lecho,
     1   ctemp(1,1),ctemp(1,2),ctemp(1,3),ctemp(1,4),ctemp(1,5),
     2   ctemp(1,6),ctemp(1,7),ctemp(1,8),ctemp(1,9),ctemp(1,10),
     3   lcfiles,nusta,nowsta,nm3d,nigf,
     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)
c
c ---    Prepare filenames that are in I/O file by erasing default
c ---    characters set above
         if(ctemp(1,1)(1:1).ne.' ')metinp=' '
         if(ctemp(1,2)(1:1).ne.' ')geodat=' '
         if(ctemp(1,3)(1:1).ne.' ')srfdat=' '
         if(ctemp(1,4)(1:1).ne.' ')prcdat=' '
         if(ctemp(1,5)(1:1).ne.' ')mm4dat=' '
         if(ctemp(1,6)(1:1).ne.' ')wtdat =' '
         if(ctemp(1,7)(1:1).ne.' ')metlst=' '
         if(ctemp(1,8)(1:1).ne.' ')metdat=' '
         if(ctemp(1,9)(1:1).ne.' ')pacdat=' '
         if(ctemp(1,10)(1:1).ne.' ')clddat=' '
c
c ---    Transfer the char*4 data into the char*132 variables
         do j=1,132
            if(ctemp(j,1)(1:1).ne.' ')metinp(j:j)=ctemp(j,1)(1:1)
            if(ctemp(j,2)(1:1).ne.' ')geodat(j:j)=ctemp(j,2)(1:1)
            if(ctemp(j,3)(1:1).ne.' ')srfdat(j:j)=ctemp(j,3)(1:1)
            if(ctemp(j,4)(1:1).ne.' ')prcdat(j:j)=ctemp(j,4)(1:1)
            if(ctemp(j,5)(1:1).ne.' ')mm4dat(j:j)=ctemp(j,5)(1:1)
            if(ctemp(j,6)(1:1).ne.' ')wtdat (j:j)=ctemp(j,6)(1:1)
            if(ctemp(j,7)(1:1).ne.' ')metlst(j:j)=ctemp(j,7)(1:1)
            if(ctemp(j,8)(1:1).ne.' ')metdat(j:j)=ctemp(j,8)(1:1)
            if(ctemp(j,9)(1:1).ne.' ')pacdat(j:j)=ctemp(j,9)(1:1)
            if(ctemp(j,10)(1:1).ne.' ')clddat(j:j)=ctemp(j,10)(1:1)
         enddo
c
c ---    Convert the file names to the proper case
         call filcase(lcfiles,metinp)
         call filcase(lcfiles,geodat)
         call filcase(lcfiles,srfdat)
         call filcase(lcfiles,prcdat)
         call filcase(lcfiles,mm4dat)
         call filcase(lcfiles,wtdat)
         call filcase(lcfiles,metlst)
         call filcase(lcfiles,metdat)
         call filcase(lcfiles,pacdat)
         call filcase(lcfiles,clddat)

c
      else
c
c ---   Read filename Subgroups 0(b),(c), (d) , (e) & (f)
c
c ---    Upper air stations
         if(nusta.lt.0.or.nusta.gt.mxus)then
            write(io6,*)'ERROR in Subr, READFN -- Invalid value of ',
     1      'NUSTA -- NUSTA = ',nusta,' MXUS = ',MXUS
            stop
         endif
c
         do i=1,nusta
c
c ---       Initialize the temporary arrays
            do j=1,132
               ctemp(j,1)(1:1)=' '
            enddo
c
c ---       Read the file names for Upper air Station "i"
            call readin(cvdic(1,2),ivleng(1,2),ivtype(1,2),io5,io6,
     1      lecho,ctemp(1,1),
     2      idum,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)
c
c ---       Prepare filenames that are in I/O file by erasing default
c ---       characters set above
            if(ctemp(1,1)(1:1).ne.' ')updat(i)=' '
c
c ---       Transfer the char*4 data into the char*132 variables
            do j=1,132
               if(ctemp(j,1)(1:1).ne.' ')updat(i)(j:j)=ctemp(j,1)(1:1)
            enddo
c
c ---       Convert the file names to the proper case
            call filcase(lcfiles,updat(i))
         enddo
c
c ---    Overwater stations
         if(nowsta.lt.0.or.nowsta.gt.mxows)then
            write(io6,*)'ERROR in Subr, READFN -- Invalid value of ',
     1      'NOWSTA -- NOWSTA = ',nowsta,' MXOWS = ',MXOWS
            stop
         endif
c
         do i=1,nowsta
c
c ---       Initialize the temporary arrays
            do j=1,132
               ctemp(j,1)(1:1)=' '
            enddo
c
c ---       Read the file names for Overwater Station "i"
            call readin(cvdic(1,3),ivleng(1,3),ivtype(1,3),io5,io6,
     1      lecho,ctemp(1,1),
     2      idum,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)
c
c ---       Prepare filenames that are in I/O file by erasing default
c ---       characters set above
            if(ctemp(1,1)(1:1).ne.' ')seadat(i)=' '
c
c ---       Transfer the char*4 data into the char*132 variables
            do j=1,132
               if(ctemp(j,1)(1:1).ne.' ')seadat(i)(j:j)=ctemp(j,1)(1:1)
            enddo
c
c ---       Convert the file names to the proper case
            call filcase(lcfiles,seadat(i))
         enddo
c
c ---    Multiple MM4-5 files in 3D.DAT format
         if(nm3d.lt.0.or.nm3d.gt.mxm3d)then
            write(io6,*)'ERROR in Subr, READFN -- Invalid value of ',
     1      'nm3d -- nm3d = ',nm3d,' mxm3d = ',mxm3d
            stop
         endif
c
         do i=1,nm3d
c
c ---       Initialize the temporary arrays
            do j=1,132
               ctemp(j,1)(1:1)=' '
            enddo
c
c ---       Read the file names for MM5 file "i"
            call readin(cvdic(1,4),ivleng(1,4),ivtype(1,4),io5,io6,
     1      lecho,ctemp(1,1),
     2      idum,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)
c
c ---       Prepare filenames that are in I/O file by erasing default
c ---       characters set above
            if(ctemp(1,1)(1:1).ne.' ')m3ddat(i)=' '
c
c ---       Transfer the char*4 data into the char*132 variables
            do j=1,132
               if(ctemp(j,1)(1:1).ne.' ')m3ddat(i)(j:j)=ctemp(j,1)(1:1)
            enddo
c
c ---       Convert the file names to the proper case
            call filcase(lcfiles,m3ddat(i))
         enddo
c
c frr 050328-
c ---    Transfer  MM4DAT to m3ddat(1) if  MM4DAT is defined in old CALMET.INP file
c ---    (pre-multiple MM5.DAT)
         if ((nm3d.eq.0) . and. (mm4dat(1:1).ne.' ')) then
            m3ddat(1)=mm4dat
            nm3d=1
         endif

c ---    060106 (IGF-CALMET fiels)
c ---    Multiple IGF-CALMET files
         if(nigf.lt.0.or.nigf.gt.mxigf)then
            write(io6,*)'ERROR in Subr, READFN -- Invalid value of ',
     1      'nigf -- nigf = ',nigf,' mxigf = ',mxigf
            stop
         endif
c

         do i=1,nigf
c
c ---       Initialize the temporary arrays
            do j=1,132
               ctemp(j,1)(1:1)=' '
            enddo
c
c ---       Read the file names for IGF-CALMET file "i"
            call readin(cvdic(1,5),ivleng(1,5),ivtype(1,5),io5,io6,
     1      lecho,ctemp(1,1),
     2      idum,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)
c
c ---       Prepare filenames that are in I/O file by erasing default
c ---       characters set above
            if(ctemp(1,1)(1:1).ne.' ')igfdat(i)=' '
c
c ---       Transfer the char*4 data into the char*132 variables
            do j=1,132
               if(ctemp(j,1)(1:1).ne.' ')igfdat(i)(j:j)=ctemp(j,1)(1:1)
            enddo
c
c ---       Convert the file names to the proper case
            call filcase(lcfiles,igfdat(i))
         enddo
c


c ---    Filename Subgroup (f)
c
c ---    Initialize the temporary arrays
         do i=1,8
            do j=1,132
               ctemp(j,i)(1:1)=' '
            enddo
         enddo
c
c ---    Read the file names for Subgroup (f)
         call readin(cvdic(1,6),ivleng(1,6),ivtype(1,6),io5,io6,lecho,
     1   ctemp(1,1),ctemp(1,2),ctemp(1,3),ctemp(1,4),ctemp(1,5),
     2   ctemp(1,6),ctemp(1,7),ctemp(1,8),
     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,
     7   idum,idum,idum,idum)
c
c ---    Prepare filenames that are in I/O file by erasing default
c ---    characters set above

         if(ctemp(1,1)(1:1).ne.' ')diadat=' '
         if(ctemp(1,2)(1:1).ne.' ')prgdat=' '
         if(ctemp(1,3)(1:1).ne.' ')tstprt=' '
         if(ctemp(1,4)(1:1).ne.' ')tstout=' '
         if(ctemp(1,5)(1:1).ne.' ')tstkin=' '
         if(ctemp(1,6)(1:1).ne.' ')tstfrd=' '
         if(ctemp(1,7)(1:1).ne.' ')tstslp=' '
         if(ctemp(1,8)(1:1).ne.' ')dcstgd=' '

c
c ---    Transfer the char*4 data into the char*132 variables
         do j=1,132
            if(ctemp(j,1)(1:1).ne.' ')diadat(j:j)=ctemp(j,1)(1:1)
            if(ctemp(j,2)(1:1).ne.' ')prgdat(j:j)=ctemp(j,2)(1:1)
            if(ctemp(j,3)(1:1).ne.' ')tstprt(j:j)=ctemp(j,3)(1:1)
            if(ctemp(j,4)(1:1).ne.' ')tstout(j:j)=ctemp(j,4)(1:1)
            if(ctemp(j,5)(1:1).ne.' ')tstkin(j:j)=ctemp(j,5)(1:1)
            if(ctemp(j,6)(1:1).ne.' ')tstfrd(j:j)=ctemp(j,6)(1:1)
            if(ctemp(j,7)(1:1).ne.' ')tstslp(j:j)=ctemp(j,7)(1:1)
            if(ctemp(j,8)(1:1).ne.' ')dcstgd(j:j)=ctemp(j,8)(1:1)
         enddo

c ---    Convert the file names to the proper case
         call filcase(lcfiles,diadat)
         call filcase(lcfiles,prgdat)
         call filcase(lcfiles,tstprt)
         call filcase(lcfiles,tstout)
         call filcase(lcfiles,tstkin)
         call filcase(lcfiles,tstfrd)
         call filcase(lcfiles,tstslp)
         call filcase(lcfiles,dcstgd)
      endif

c
      return
      end
c----------------------------------------------------------------------
      subroutine wrfiles(nm3d, nigf)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 101006            WRFILES
c              J. Scire, SRC
c
c --- PURPOSE:  Write a table of the input and output file names
c               for the current run
c
c ---  UPDATES
c ---  v6.205 (060309) to v6.330 (101006) (CEC)
c          - Change ICLOUD into MCLOUD (and ICLDOUT)
c ---  v5.711 (060106) to v6.205 (060309) (DGS)
c          - Change filenames from c*70 to c*132
c ---  V5.6 050328 to v5.711 (060106) (F.Robe)
c          - Additional filenames for IGF-CALMET files
c ---  V5.6 050328 (F.Robe): additional filenames (m3ddat,dcstgd)
c
c --- INPUTS:
c       nm3d  - integer  - Number of MM4/MM5 files
c       nigf  - integer  - Number of IGF-CALMET files
c
cc
c       Common block /FILNAM/, /FILLOG/ variables
c           metfil,metinp,geodat,srfdat,prcdat,diadat,prgdat,mm4dat,
c           wtdat,updat(mxus),seadat(mxows),metlst,metdat,pacdat,
c           tstprt,tstout,tstkin,tstfrd,tstslp,lcfiles,clddat,
c           m3ddat(mxm3d),igfdat(mxigf),dcstgd
c       Common block /OUTPT/
c             lsave, iformo
c       Common block /MET1/
c             iforms, iformp, nusta, npsta, noobs, mcloud, icldout
c       Common block /OVRWAT/
c             nowsta
c       Common block /WPARM/
c             ipr0,ipr1,ipr2,ipr3,ipr4,ipr5,ipr6,ipr7,
c             ioutd, idiopt(5), iprog, igfmet
c       Parameters: MXNZ, MXSS, MXUS, MXPS, MXOWS, MXWND, MXBAR,mxm3d
c                   IO2, IO5, IO6, IO8, IO10, IO12, IO18, IO19,
c                   IO20, IO21, IO22, IO23, IO24, IO25, IO26,
c                   IO27,IO30, IO80
c
c --- OUTPUT:  none
c
c --- WRFILES called by:  SETUP
c --- WRFILES calls:      none
c----------------------------------------------------------------------
c
c --- Include parameter statements
      include 'params.met'
c
c --- Include common blocks
      include 'met1.met'
      include 'geo.met'
      include 'outpt.met'
      include 'ovrwat.met'
      include 'wparm.met'
      include 'filnam.met'
c
c --------------------------------------------------
c --- Write the list of INPUT files used in this run
c --------------------------------------------------
      write(io6,10)
10    format(//1x,13('----------')/10x,'INPUT FILES'//
     1 1x,'Default Name',5x,'Unit No.',5x,'File Name and Path'/
     2 1x,'------------',5x,'--------',5x,'------------------')
c --- CALMET.INP
      write(io6,12)'CALMET.INP',io5,metinp
12    format(1x,a12,7x,i3,8x,a132)
c --- GEO.DAT
      write(io6,12)'GEO.DAT',io8,geodat
c --- SURF.DAT
      if(idiopt(4).ne.1)write(io6,12)'SURF.DAT',io10,srfdat
c --- PRECIP.DAT
      if(npsta.gt.0)write(io6,12)'PRECIP.DAT',io12,prcdat
c --- CLOUD.DAT - as INPUT
ccec101006  if(icloud.eq.2)write(io6,12)'CLOUD.DAT',io26,clddat
      if(mcloud.eq.2.and.icldout.eq.0)
     1  write(io6,12)'CLOUD.DAT',io26,clddat
c --- WT.DAT
      if(iprog.EQ.3  .OR. iprog.EQ.5 .OR. 
     :   iprog.EQ.13 .OR. iprog.EQ.15) then
         write(io6,12)'WT.DAT',io19,wtdat
      endif
c --- MM4n.DAT (one file open at a time => same io number)
      if(iprog.eq.3 .or. iprog.eq.4 .or. iprog.eq.5)then
         write(io6,*)
         do 250 i=1,nm3d
            if(i.le.9)then
               write(io6,220)i,io20,m3ddat(i)
220             format(1x,4x,'MM4',i1,'.DAT',7x,i3,8x,a132)
            else
               if(i.ge.10)write(io6,240)i,io20,m3ddat(i)
240             format(1x,3x,'MM4',i2,'.DAT',7x,i3,8x,a132)
            endif
250      continue
      endif
c --- MM5n.DAT (one file open at a time => same io number)
      if(iprog.eq.13 .or. iprog.eq.14 .or. iprog.eq.15)then
         write(io6,*)
         do 350 i=1,nm3d
            if(i.le.9)then
               write(io6,320)i,io20,m3ddat(i)
320             format(1x,4x,'MM5',i1,'.DAT',7x,i3,8x,a132)
            else
               if(i.ge.10)write(io6,340)i,io20,m3ddat(i)
340             format(1x,3x,'MM5',i2,'.DAT',7x,i3,8x,a132)
            endif
350      continue
      endif


c --- MM5n.DAT (one file open at a time => same io number:18)
      if(igfmet.eq.1)then
         write(io6,*)
         do 450 i=1,nigf
            if(i.le.9)then
               write(io6,420)i,io18,igfdat(i)
420             format(1x,4x,'IGF',i1,'.DAT',7x,i3,8x,a132)
            else
               if(i.ge.10)write(io6,440)i,io18,igfdat(i)
440             format(1x,3x,'IGF',i2,'.DAT',7x,i3,8x,a132)
            endif
450      continue
      endif

c --- PROG.DAT
      if(iprog.eq.1 .or. iprog.eq.2)then
         write(io6,12)'PROG.DAT',io20,prgdat
      endif
c --- DIAG.DAT
      do 2 i=1,5
         if(idiopt(i).eq.1)then
            write(io6,12)'DIAG.DAT',io2,diadat
            go to 3
         endif
2     continue
3     continue
c
c --- Upper air station files (UPn.DAT)
c FRR (09/2001) additional option for mm4only
c      if(idiopt(5).eq.1 .or. noobs .eq. 1) go to 29
      if(idiopt(5).eq.1 .or. noobs .ge. 1) go to 29
      write(io6,*)
      do 15 i=1,nusta
         io=io30+i-1
         if(i.le.9)then
            write(io6,14)i,io,updat(i)
14          format(1x,5x,'UP',i1,'.DAT',7x,i3,8x,a132)
         else
            if(i.ge.10)write(io6,16)i,io,updat(i)
16          format(1x,4x,'UP',i2,'.DAT',7x,i3,8x,a132)
         endif
15    continue
29    continue
c
c --- Overwater data files (SEAn.DAT)
      if(nowsta.gt.0)then
         write(io6,*)
         do 25 i=1,nowsta
            io=io80+i-1
            if(i.le.9)then
               write(io6,22)i,io,seadat(i)
22             format(1x,4x,'SEA',i1,'.DAT',7x,i3,8x,a132)
            else
               if(i.ge.10)write(io6,24)i,io,seadat(i)
24             format(1x,3x,'SEA',i2,'.DAT',7x,i3,8x,a132)
            endif
25       continue
      endif
c
c ---------------------------------------------------
c --- Write the list of OUTPUT files used in this run
c ---------------------------------------------------
      write(io6,30)
30    format(//1x,13('----------')/10x,'OUTPUT FILES'//
     1 1x,'Default Name',5x,'Unit No.',5x,'File Name and Path'/
     2 1x,'------------',5x,'--------',5x,'------------------')
c --- CALMET.LST
      write(io6,12)'CALMET.LST',io6,metlst
      if(lsave)then
         if(iformo.eq.1)then
c ---       CALMET.DAT
            write(io6,12)'CALMET.DAT',io7,metdat
         else if(iformo.eq.2)then
c ---       PACOUT.DAT
            write(io6,12)'PACOUT.DAT',io7,pacdat
         endif
      endif
c
c --- CLOUD.DAT - as OUTPUT
ccec101006  if(icloud.eq.1)write(io6,12)'CLOUD.DAT',io26,clddat
      if(icldout.eq.1.and.mcloud.ne.2)write(io6,12)'CLOUD.DAT',io26,
     1  clddat
c
c --- wind field module -- testing & debugging files
      write(io6,*)
      i21=ipr0+ipr1+ipr2+ipr3+ipr4+ipr5+ipr6+ipr7+ipr8
      i22=ipr8+ioutd
      i23=ipr5+ioutd
      i24=ipr6+ioutd
      i25=ipr7+ioutd
c --- TEST.PRT
      if(i21.ge.1)write(io6,12)'TEST.PRT',io21,tstprt
c --- TEST.OUT
      if(i22.eq.2)write(io6,12)'TEST.OUT',io22,tstout
c --- TEST.KIN
      if(i23.eq.2)write(io6,12)'TEST.KIN',io23,tstkin
c --- TEST.FRD
      if(i24.eq.2)write(io6,12)'TEST.FRD',io24,tstfrd
c --- TEST.SLP
      if(i25.eq.2)write(io6,12)'TEST.SLP',io25,tstslp

c --- Distance to the coast gridded output
c --- DCST.GRD
      if(ldbcst)write(io6,12)'DCST.GRD',io27,dcstgd

c
      return
      end
c-----------------------------------------------------------------------
      subroutine rdcld(iformc,nx,ny,ndathr,ccgrid)
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070929               RDCLD
c ---          J. Scire, Earth Tech, Inc.
c
c --- PURPOSE:  Read a gridded fractional cloud cover field from
c               a CLOUD.DAT ile
c
c --- UPDATES:
c --- V6.301 (070927) to v6.302 (070929):
c         - Modify calls to RDR2D to include IO6 in argument list
c         - Update documentation on routines called
c --- v5.711 (060106) to v6.301 (070927): 
c         - added mtver and dummy arguments to rdr2d calling list 
c           (to make compatible with updated RDR2D for MOD5/MOD6)
c
c --- V5.5 (030402) to v5.711 (060106): add ieof to rdr2d calling list
c --- V5.4 (991104) to V5.5 (030402)  (DGS)
c          - Add list-file unit to YR4 call
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c           IFORMC - integer    - Format of CLOUD.DAT file
c                                 (1=unformatted, 2=formatted)
c           NX, NY - integers   - No.  X, Y grid cells
c           NDATHR - integer    - Date and hour (YYYYJJJHH) in LST of
c                                 current hour to be read (explicit beg. time)
c       Parameters: MXNX, MXNY, IO26, IO6
c
c --- OUTPUT:
c           CCGRID(mxnx,mxny) - real array - Gridded cloud cover (fraction)
c
c --- RDCLD called by:  COMP
c --- RDCLD calls:      RDR2D, DEDAT, YR4
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real ccgrid(mxnx,mxny),xbuf(mxnx,mxny)
      character*8 clabel
c
c --- Read the 2-D cloud cover field
      if(iformc.eq.1)then
c
c -----------------------
c ---    Unformatted file
c -----------------------
10       continue
         call rdr2d(io26,0,io6,ccgrid,xbuf,mxnx,mxny,nx,ny,
     1              clabel,idum,idum,idathr,idum,ieof)
         if(clabel.ne.'CLOUDFRA')then
            write(io6,*)'ERROR in Subr. RDCLD -- Incorrect variable ',
     1      'label read from cloud file -- CLABEL = ',clabel,
     2      ' label expected: CLOUDFRA'
            stop
         endif
c ---    Enforce YYYY format for year
         call dedat(idathr,iyr,iday,ihr)
         call YR4(io6,iyr,ierr)
         if(ierr.NE.0) stop 'Halted in RDCLD'
         idathr=iyr*100000+iday*100+ihr

         if(idathr.lt.ndathr)then
c ---       Hour expected not yet reached -- keep reading
            go to 10
         else if(idathr.gt.ndathr)then
c ---       Hour read is past current hour -- error
            write(io6,*)'ERROR in Subr. RDCLD -- Current hour not ',
     1      'found -- current (NDATHR) = ',ndathr,' value read from ',
     2      'cloud file (IDATHR) = ',idathr
            stop
         endif
      else
c
c ---------------------------------------
c ---    Formatted or free-formatted file
c ---------------------------------------
20       continue
         read(io26,*)clabel,idathr,((ccgrid(i,j),i=1,nx),j=1,ny)
         if(clabel.ne.'CLOUDFRA')then
            write(io6,*)'ERROR in Subr. RDCLD -- Incorrect variable ',
     1      'label read from cloud file -- CLABEL = ',clabel,
     2      ' label expected: CLOUDFRA'
            stop
         endif

c ---    Enforce YYYY format for year
         call dedat(idathr,iyr,iday,ihr)
         call YR4(io6,iyr,ierr)
         if(ierr.NE.0) stop 'Halted in RDCLD'
         idathr=iyr*100000+iday*100+ihr

         if(idathr.lt.ndathr)then
c ---       Hour expected not yet reached -- keep reading
            go to 20
         else if(idathr.gt.ndathr)then
c ---       Hour read is past current hour -- error
            write(io6,*)'ERROR in Subr. RDCLD -- Current hour not ',
     1      'found -- current (NDATHR) = ',ndathr,' value read from ',
     2      'cloud file (IDATHR) = ',idathr
            stop
         endif
      endif
c
      return
      end
c-----------------------------------------------------------------------
      subroutine rdcldn(iformc,nx,ny,ndathrb,nsecb,ndathre,nsece,ccgrid)
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 101129              RDCLDN
c ---          J. Scire, Earth Tech, Inc.
c
c --- PURPOSE:  Read a gridded fractional cloud cover field from
c               a CLOUD.DAT file with beginning and ending times
c
c --- UPDATES:
c     FRom RDCL v6.302 (070929) to RDCLN V6.331(101206) (F.Robe)
c         - Reads in CLOUD.DAT with beginning and end ending time 
c         - correct argument list in call to rdr2d

c --- INPUTS:
c           IFORMC - integer    - Format of CLOUD.DAT file
c                                 (1=unformatted, 2=formatted)
c           NX, NY - integers   - No.  X, Y grid cells
c           NDATHRB - integer   - Beginning Date and hour(YYYYJJJHH)
c                                 in LST
c           NSECB   - integer   - Beginning Second in LST
c           NDATHRE - integer   - Ending Date and hour(YYYYJJJHH) in LST
c           NSECE   - integer   - Ending Second in LST
c       Parameters: MXNX, MXNY, IO26, IO6
c
c --- OUTPUT:
c           CCGRID(mxnx,mxny) - real array - Gridded cloud cover (fraction)
c
c --- RDCLDN called by:  COMP
c --- RDCLDN calls:      RDR2D, DEDAT, YR4
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real ccgrid(mxnx,mxny),xbuf(mxnx,mxny)
      character*8 clabel
c
c --- Read the 2-D cloud cover field
      if(iformc.eq.1)then
c
c -----------------------
c ---    Unformatted file
c -----------------------
10       continue
c ---    Calling list with explicit beg/ending times (101206)
         call rdr2d(io26,1,io6,ccgrid,xbuf,mxnx,mxny,nx,ny,
     1              clabel,idathrb,isecb,idathre,isece,ieof)
         if(clabel.ne.'CLOUDFRA')then
            write(io6,*)'ERROR in Subr. RDCLD -- Incorrect variable ',
     1      'label read from cloud file -- CLABEL = ',clabel,
     2      ' label expected: CLOUDFRA'
            stop
         endif

c ---    Enforce YYYY format for year
c ---    Both for beg and end times
         call dedat(idathre,iyre,idaye,ihre)
         call YR4(io6,iyre,ierr)
         call dedat(idathrb,iyrb,idayb,ihrb)
         call YR4(io6,iyrb,ierr)
         if(ierr.NE.0) stop 'Halted in RDCLD'
         idathre=iyre*100000+idaye*100+ihre
         idathrb=iyrb*100000+idayb*100+ihrb


         call deltsec(ndathre,nsece,idathre,isece,ndelsec)

         if (ndelsec.lt.0) then
c         if(idathr.lt.ndathr)then
c ---       Hour expected not yet reached -- keep reading
            go to 10
         else if (ndelsec.gt.0) then
c         else if(idathr.gt.ndathr)then
c ---       Hour read is past current hour -- error
            write(io6,*)'ERROR in Subr. RDCLD -- Current time not ',
     1      'found -- current (NDATHRE, NSECE) = ',ndathre,nsece,
     2      ' value read from cloud file (IDATHRE, ISECE) = ',
     2      idathre,isece
            stop
         endif
      else
c
c ---------------------------------------
c ---    Formatted or free-formatted file
c ---------------------------------------
20       continue
         read(io26,*)clabel,idathrb,isecb,idathre,isece,
     :               ((ccgrid(i,j),i=1,nx),j=1,ny)

         if(clabel.ne.'CLOUDFRA')then
            write(io6,*)'ERROR in Subr. RDCLD -- Incorrect variable ',
     1      'label read from cloud file -- CLABEL = ',clabel,
     2      ' label expected: CLOUDFRA'
            stop
         endif


c ---    Enforce YYYY format for year
c ---    Both for beg and end times
         call dedat(idathre,iyre,idaye,ihre)
         call YR4(io6,iyre,ierr)
         call dedat(idathrb,iyrb,idayb,ihrb)
         call YR4(io6,iyrb,ierr)
         if(ierr.NE.0) stop 'Halted in RDCLD'
         idathre=iyre*100000+idaye*100+ihre
         idathrb=iyrb*100000+idayb*100+ihrb

         call deltsec(ndathre,nsece,idathre,isece,ndelsec)

         if (ndelsec.lt.0) then
c        if(idathr.lt.ndathr)then
c ---       Hour expected not yet reached -- keep reading
            go to 20
         else if (ndelsec.gt.0) then
c         else if(idathr.gt.ndathr)then
c ---       Hour read is past current hour -- error
            write(io6,*)'ERROR in Subr. RDCLD -- Current time not ',
     1      'found -- current (NDATHRE, NSECE) = ',ndathre,nsece,
     2      ' value read from cloud file (IDATHRE, ISECE) = ',
     2      idathre,isece
            stop
         endif
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine outcld(ndathrb,nsecb,ndathre,nsece,nx,ny,nssta,icc,
     :                  nears,iformc,icldout,mcloud,ccgrid)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 101206             OUTCLD
c ---          J. Scire, SRC
c
c --- PURPOSE:  Compute and write a hourly gridded cloud field
c --------------------------------------------------------------
c ---           Assumes missing values of cloud cover array have
c ---           already been filled
c --------------------------------------------------------------
c --- UPDATES:
c --- V6.330 Level 101006 to v6.331 101206 (F.Robe)
c          - Bug fix: pass on beginning /ending time with seconds
c          - output beg/end times with seconds in ascii format too
c            (instead of beginning time without seconds)
c
c --- V6.222 Level 070404 to V6.330 Level 101006 (CEC)
c          - Change ICLOUD into MCLOUD (and ICLDOUT)
c
c --- V6.2 Level 060215 to V6.222 Level 070404 (F.Robe)
c          - Fill in the gridded cloud array ccgrid for
c            also if icloud=0 (additional icloud in calling list)
c
c --- V5 Level 951021 to V6.2 Level 060215 (F.Robe)
c          - Use explicit times in calling list to wrtr2d
c
c --- INPUTS:
c           NDATHRB - integer    - Beginning Date and hour(YYYYJJJHH) in LST
c           NSECB   - integer    - Beginning Second in LST
c           NDATHRE - integer    - Ending Date and hour(YYYYJJJHH) in LST
c           NSECE   - integer    - Ending Second in LST
c           NX, NY - integers   - No.  X, Y grid cells
c            NSSTA - integer    - No. surface stations
c        ICC(mxss) - int. array - Cloud cover (tenths) at each surface
c                                 station
c NEARS(mxnx,mxny) - int. array - Closest surface station to each grid
c                                 point
c           IFORMC - integer    - Format of CLOUD.DAT file
c                                 (1=unformatted, 2=formatted)
c           ICLDOUT - integer   - CLOUD option (write out field if
c                                 ICLDOUT=1)
c           MCLOUD - integer    - CLOUD option (put observations 
c                                 in gridded data if MCLOUD=1)
c       Parameters: MXSS, MXNX, MXNY, IO26
c
c --- OUTPUT:
c CCGRID(mxnx,mxny) - real array - Gridded cloud cover (fraction)
c
c --- OUTCLD called by:  COMP
c --- OUTCLD calls:      WRTR2D
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real ccgrid(mxnx,mxny),xbuf(mxnx,mxny)
      real ccfract(mxss)
      integer icc(nssta),nears(mxnx,mxny)
      character*10 clab2
      character*8 clabel
c
ccec101006 --- limit the assignement of cloud fraction to 
c          each grid cell if clouds come from observations
c          only if mcloud=1
c --- Compute the cloud fraction field

      if(mcloud.eq.1) then
c --- Convert tenths to fraction
      do i=1,nssta
         ccfract(i)=0.1*float(icc(i))
      enddo

c --- Assign cloud cover to each grid cell based on nearest
c --- station method
      do i=1,nx
         do j=1,ny
           ista=nears(i,j)
           ccgrid(i,j)=ccfract(ista)
         enddo
      enddo
      endif
ccec101006 --- end limit assignment of cloud fraction to
c          each grid cell if clouds come from observations
c          only if mcloud=1 
c

c --- Write the 2-D cloud cover field
ccec101006      if(icloud.eq.1) then
      if(icldout.eq.1) then

      if(iformc.eq.1)then
         clabel='CLOUDFRA'
         call wrtr2d(io26,ccgrid,xbuf,mxnx,mxny,nx,ny,clabel,
     :       ndathrb,nsecb,ndathre,nsece)
      else
c ---    Read clab2 as a character*8 in free format ("s used as
c ---    delimiters)
         clab2='"CLOUDFRA"'
c ---     101206 - write out beginning and ending times 
c         write(io26,*)clab2,ndathr,((ccgrid(i,j),i=1,nx),j=1,ny)
         write(io26,*)clab2,ndathrb,nsecb,ndathre,nsece,
     :                ((ccgrid(i,j),i=1,nx),j=1,ny)
      endif

      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine rdi1d(iomet,mtver,io6,idat,nwords,clabel,ndathrb,
     &                 nsecb,ndathre,nsece)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070929              RDI1D
c ---          J. Scire, TRC
c --- Adapted from PRTMET (Version: 4.48, Level: 051012)
c
c --- PURPOSE:  Read "NWORDS" of a one-dimensional integer array
c
c --- UPDATE
c --- V6.301-V6.302 070929 (JSS): Add checks on valid range of MTVER,
c                                 write error message and update 
c                                 documentation
c --- V4.4-V4.41    051012 (DGS): resolve times to the second, and
c     (PRTMET)                    include begin/end times for CALMET
c                                 Version 6 (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) (V5 format)
c                                 1: begin-time/end-time w/ seconds
c                                    (V6 format)
c           IO6 - integer       - Fortran unit number for error messages
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:  RDMET2
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
      else
         write(io6,*)'Error in RDI1D -- Invalid value of MTVER'
         write(io6,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
         write(*,*)'Error in RDI1D -- Invalid value of MTVER'
         write(*,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
         stop
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine rdr1d(iomet,mtver,io6,x,nwords,clabel,
     &                 ndathrb,nsecb,ndathre,nsece)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070929              RDR1D
c ---          J. Scire, TRC
c --- Adapted from PRTMET (Version: 4.48, Level: 051012)
c
c --- PURPOSE:  Read "NWORDS" of a one-dimensional real array
c
c --- UPDATE
c --- V6.301-V6.302 070929 (JSS): Add checks on valid range of MTVER,
c                                 write error message and update 
c                                 documentation
c --- V4.4-V4.41    051012 (DGS): resolve times to the second, and
c     (PRTMET)                    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) (V5 format)
c                               1: begin-time/end-time w/ seconds
c                                  (V6 format)
c           IO6 - integer     - Fortran unit number for error messages
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:  RDHDMET, RDMET2
c --- RDR1D calls:      none
c----------------------------------------------------------------------
c
      real x(nwords)
      character*8 clabel
c
      if(mtver.EQ.1) then
         read(iomet)clabel,ndathrb,nsecb,ndathre,nsece,x
      else if(mtver.EQ.0) then
         read(iomet)clabel,ndathre,x
         nsece=0
         ndathrb=0
         nsecb=0
      else
         write(io6,*)'Error in RDR1D -- Invalid value of MTVER'
         write(io6,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
         write(*,*)'Error in RDR1D -- Invalid value of MTVER'
         write(*,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
         stop
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine rdr2d(iomet,mtver,io6,x,xbuf,mxnx,mxny,nx,ny,
     &                 clabel,ndathrb,nsecb,ndathre,nsece,ieof)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070929              RDR2D
c ---          J. Scire, TRC
c --- Adapted from PRTMET (Version: 4.48, Level: 051012)
c
c --- PURPOSE:  Read NX * NY words of a 2-D real array
c
c --- UPDATE 
c --- V6.301-V6.302 070929 (JSS): Add checks on valid range of MTVER,
c                                 write error message and update 
c                                 documentation
c --- V4.4-V4.41    051012 (DGS): resolve times to the second, and
c     (PRTMET)                    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) (V5 format)
c                                  1: begin-time/end-time w/ seconds
c                                     (V6 format)
c              IO6 - integer     - Fortran unit number for error messages
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:  RDHDMET, RDMET2, RDCLD
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
         else if(mtver.EQ.0) then
            read(iomet,end=999)clabel,ndathre,x
            nsece=0
            ndathrb=0
            nsecb=0
         else
            write(io6,*)'Error in RDR2D -- Invalid value of MTVER'
            write(io6,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
            write(*,*)'Error in RDR2D -- Invalid value of MTVER'
            write(*,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
            stop
         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
         else if(mtver.EQ.0) then
            read(iomet,end=999)clabel,ndathre,xbuf
            nsece=0
            ndathrb=0
            nsecb=0
         else
            write(io6,*)'Error in RDR2D -- Invalid value of MTVER'
            write(io6,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
            write(*,*)'Error in RDR2D -- Invalid value of MTVER'
            write(*,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
            stop
         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 rdi2d(iomet,mtver,io6,idat,ibuf,mxnx,mxny,nx,ny,
     &                 clabel,ndathrb,nsecb,ndathre,nsece)
c-----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070929               RDI2D
c ---          J. Scire, TRC
c --- Adapted from PRTMET (Version: 4.48, Level: 051012)
c
c --- PURPOSE:  Read NX * NY words of a 2-D integer array
c
c --- UPDATE
c --- V6.301-V6.302 070929 (JSS): Add checks on valid range of MTVER,
c                                 write error message and update 
c                                 documentation
c --- V4.4-V4.41    051012 (DGS): resolve times to the second, and
c     (PRTMET)                    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                 IO6 - integer       - Fortran unit number for error 
c                                       messages
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:  RDHDMET, RDMET2
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
         else if(mtver.EQ.0) then
            read(iomet)clabel,ndathre,idat
            nsece=0
            ndathrb=0
            nsecb=0
         else
            write(io6,*)'Error in RDI2D -- Invalid value of MTVER'
            write(io6,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
            write(*,*)'Error in RDI2D -- Invalid value of MTVER'
            write(*,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
            stop
         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
         else if(mtver.EQ.0) then
            read(iomet)clabel,ndathre,ibuf
            nsece=0
            ndathrb=0
            nsecb=0
         else
            write(io6,*)'Error in RDI2D -- Invalid value of MTVER'
            write(io6,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
            write(*,*)'Error in RDI2D -- Invalid value of MTVER'
            write(*,*)'MTVER must be 0 or 1 -- MTVER = ',MTVER
            stop
         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 tfercf
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 090511             TFERCF
c ---          D. Strimaitis
c
c --- PURPOSE: Transfer image of control input file to scratch file
c
c --- UPDATES:
c --- V5.5 (030402) to V6.327 (090511) (DGS)
c     - Reset length of line in control file to 200
c       (store image as 132, splitting lines if needed)
c
c --- INPUTS:
c
c        Common block /QA/
c           ncommout
c        Parameters: mxcol, iox, io5
c
c --- OUTPUT:
c
c        Common block /QA/
c           ncommout
c
c --- TFERCF called by:  SETUP
c --- TFERCF calls:      none
c----------------------------------------------------------------------
c
      include 'params.met'
      include 'params.cal'
      include 'qa.met'

      character*132 aline, blank
      character*200 aline200, blank200
      character*33 blank33

c --- Set blanks
      data blank33/'                                 '/
      blank(1:33)=blank33
      blank(34:66)=blank33
      blank(67:99)=blank33
      blank(100:132)=blank33
      blank200(1:100)=blank(1:100)
      blank200(101:200)=blank(1:100)

c --- Confirm max size of control file record
      if(mxcol.GT.200) then
         write(*,*)'ERROR in TFERCF!'
         write(*,*)'Control file records are assumed to be <= 200'
         write(*,*)'Actual limit is MXCOL = ',mxcol
         write(*,*)'CALMET code needs to be modified'
         stop
      endif      

c --- Reposition input control file
      REWIND(io5)

c --- Open scratch file
      OPEN(iox,status='scratch')

c --- Initialize number of records written to scratch file
      ncommout=0

c --- Transfer control file records
10    aline=blank
      aline200=blank200
      read(io5,'(a200)',end=999) aline200
      write(iox,'(a132)') aline200(1:132)
      ncommout=ncommout+1
      klen=LEN_TRIM(aline200)
      if(klen.GT.132) then
c ---    Line is split
         aline(1:68)=aline200(133:200)
         write(iox,'(a132)') aline
         ncommout=ncommout+1
      endif
      goto 10

c --- Transfer completed
999   close(io5)

      return
      end


c----------------------------------------------------------------------
      subroutine qaplot1(ibtz)
c----------------------------------------------------------------------
c
c --- CALMET     Version: 6.4.0     Level: 060202          QAPLOT1
c                D. Strimaitis,   Earth Tech
c
c --- PURPOSE:  Pass SEA.DAT locations to files for making
c               plots to verify configuration.  Standard filenames
c               and extensions are consistent with defaults used in 
c               the SURFER plotting system.  All locations are in km.
c
c --- INPUTS:
c               IBTZ - integer    - Base time zone for CALMET run
c
c     Common block /OUTPT/ variables:
c        IQAPLOT
c
c     Common block /OVRWAT/ variables:
c        vectiow(9),vectoow(9),
c        nowsta,ioow(mxows),
c        zowsta(mxows),ztair(mxows),zsst(mxows),
c        dtow(mxows),tairow(mxows),rhow(mxows),ziow(mxows),
c        tgrada(mxows),tgradb(mxows),
c        xowlon(mxows),wsow(mxows),wdow(mxows),
c        rverow(mxows),twave(mxows),hwave(mxows),
c        lremap,
c        datumow,cactionow
c      
c     Common block /MAP/ variables:
c        datum
c     
c     Parameters:
c           MXOWS, IO28, IO6
c
c --- OUTPUT:
c
c     Files:
c        QABUOYSTA.DAT - location of SEA.DAT stations
c        
c
c --- QAPLOT1 called by:  SETUP
c --- QAPLOT1 calls:      RDHDOW, GLOBE
c----------------------------------------------------------------------
c --- Include parameter statements
      include 'params.met'

c --- Include common blocks
      include 'ovrwat.met'
      include 'map.met'

      logical lfirst

c --- For coordinate transformations
      character*4 c4hem

c --- Use file index io28 for QA file
      ioqa=io28

c --- SEA.DAT station locations
c -----------------------------

      if (nowsta .gt. 0) then
         open(ioqa,file='qabuoysta.dat',status='unknown')
         write(ioqa,'(a28)') '"Xkm" "Ykm" "Station" "Date"'

c ---    Loop over station-files
         do i = 1,nowsta
            call RDHDOW(i,ibtz)

            io=ioow(i)
            lfirst=.TRUE.
            xsave=0.0
            ysave=0.0

c ---       Read data record
c ---       SEA.DAT version 2.11 and higher:
c           new variables:air temp sensor height (ztair), water temp
c           sensor depth (zsst - positive downward)
100         if (rverow(i).ge.2.10999)then 
               read(io,*,end=900,err=900)xowkm,yowkm,
     &           zowsta(i),ztair(i),zsst(i),i1yr,i1jul,i1hr,
     1           i2yr,i2jul,i2hr,dtow(i),tairow(i),rhow(i),ziow(i),
     2           tgradb(i),tgrada(i),wsow(i),wdow(i),twave(i),hwave(i)

c ---       SEA.DAT version 2.1 and higher: new variables: twave,rwave
c --        Removed: xowlon
            else if (rverow(i).ge.2.099)then
               read(io,*,end=900,err=900)xowkm,yowkm,
     &           zowsta(i),i1yr,i1jul,i1hr,
     1           i2yr,i2jul,i2hr,dtow(i),tairow(i),rhow(i),ziow(i),
     2           tgradb(i),tgrada(i),wsow(i),wdow(i),twave(i),hwave(i)
            else
               read(io,*,end=900,err=900)xowkm,yowkm,xowlon(i),
     &           zowsta(i),i1yr,i1jul,i1hr,
     1           i2yr,i2jul,i2hr,dtow(i),tairow(i),rhow(i),ziow(i),
     2           tgradb(i),tgrada(i),wsow(i),wdow(i)
            endif

            if(LFIRST .OR. xsave.NE.xowkm .OR. ysave.NE.yowkm) then
c ---          Update current location
               xsave=xowkm
               ysave=yowkm
c ---          Remap station (x,y) if needed
               if(LREMAP) then
                  call GLOBE(io6,cactionow,datumow,vectiow,datum,
     &                    vectoow,xowkm,yowkm,xkm,ykm,idum,c4hem)
               else
                  xkm=xowkm
                  ykm=yowkm
               endif
c ---          Write QA record
               write(ioqa,*) xkm,ykm,i,i1yr,i1jul,i1hr
c ---          Reset FIRST flag
               lfirst=.false.
            endif

c ---       Next data record
            goto 100

c ---       End of station i data
900         REWIND(io)
         end do
      end if

      if(nowsta.GT.0) then
         close(ioqa)
      else
         close(ioqa, status='DELETE')
      endif

      return
      end

c -----------------------------------------------------------------------------------------
c----------------------------------------------------------------------
      subroutine airden_ns(pres,tempk,nssta,rho)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070618          AIRDEN_NS
c ---          J. Scire, SRC
c              Modified by F.Robe, Earth Tech, to allow 2D arrays
c
c --- PURPOSE:  Compute the air density (kg/m**3) using the ideal
c               gas law
c
c --- INPUTS:
c           PRES(mxss) - real array    - Surface pressure (mb)
c          TEMPK(mxss) - real array    - Air temperature (deg. K)
c                NSSTA - integer       - Number of surface stations
c        Parameters: MXSS, NEARS,NX,NY
c
c --- OUTPUT:
c            RHO(mxnx,mxny) - real array    - Air density (kg/m**3)
c
c ---  AIRDEN_NS called by:  DIAGNO, COMP
c ---  AIRDEN_NS calls:      none
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
      include 'grid.met'
c
      real pres(mxss),tempk(mxss)
c frr (09/01) 2D rho
c      real rho(mxss)
      real rhos(mxss),rho(mxnx,mxny)
c
c Compute rho at the surface stations
      do 100 i=1,nssta
c
c --- constant 0.3484321 = 100 kg / (m * sec**2) per mb divided by
c --- (287 m**2 / (deg K * sec**2))
      rhos(i)=0.3484321*pres(i)/tempk(i)
100   continue

c 2-D density: take rho at closest station
      do 200 j=1,ny
      do 200 i=1,nx
          nsta = nears(i,j)
          rho(i,j)=rhos(nsta)
200   continue

c
      return
      end
c----------------------------------------------------------------------
      subroutine t2d_nsp(nears,nx,ny,itprog,tprog,tsfnsp)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070618            T2D_NSP
c
c --- PURPOSE:  Fill in 2D temperature field from either the nearest
c               surface station data or prognostic data
c
c --- INPUTS:
c          TEMPK(mxss) - real array    - Air temperature (deg. K)
c     NEARS(mxnx,mxny) - integer array - Station number of surface
c                                        station closest to each grid pt
c                   NX - integer       - Number of grid cells in X
c                                        direction
c                   NY - integer       - Number of grid cells in Y
c                                        direction
c               ITPROG - integer       - Flag indicating if sf temperature
c                                        from prognostic data
c                                        (2 = yes, otherwise, no)
c                TPROG - real array    - 3D prognostic temperature
c
c       Parameters: MXNX, MXNY, MXSS, MXNZ
c       Common /MET2/
c               TEMPK
c
c --- OUTPUT:
c   TSFNSP(mxnx,mxny) - real array    - 2D surface air temperature (K)
c                                       from either surface nearest sfc
c                                       stations or prognostic data
c
c --- T2D_NSP called by:  DIAGNO
c --- T2D_NSP calls:      none
c----------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'met2.met'

      integer nears(mxnx,mxny)
      real tprog(mxnx,mxny,mxnz)
      real tsfnsp(mxnx,mxny)

      do i=1,nx
      do j=1,ny
         if (itprog.lt.2) then
            tsfnsp(i,j)=tempk(nears(i,j))
         else
            tsfnsp(i,j)=tprog(i,j,1)
         endif
      enddo
      enddo

cc --- T2D_NSP DEBUG
c      write(*,*)'T2D_NSP -- ITPROG,nx,ny = ',itprog,nx,ny
c      write(*,*)'(1,1) tempk,tprog,tsfnsp= ',
c     &           tempk(nears(1,1)),tprog(1,1,1),tsfnsp(1,1)

      return
      end
c ---------------------------------------------------------------------
      function psiuc(z,zmol,ifit)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 070618              PSIUC
c
c --- PURPOSE:  Compute surface layer wind speed profile stability 
c               correction using formulas from CALMET v5.53
c
c --- INPUTS:
c                    Z - real          - Height (m)
c                 ZMOL - real          - M-O Length (m)
c                 ifit - integer       - profile fit constant (either
c                                        15.0 or 16.0 are used, so arg
c                                        is either 15 or 16)
c
c --- OUTPUT:
c                psiuc - real          - Wind speed profile stability 
c                                        correction factor
c
c --- PSIUC called by:  ELUSTR, ELUSTR2, SIMILT
c --- PSIUC calls:      none
c----------------------------------------------------------------------
c --- include parameters
      include 'params.met'

c --- Check fit parameter
      if(ifit.EQ.15) then
         rfit=15.0
      elseif(ifit.EQ.16) then
         rfit=16.0
      else
         write(io6,*)'ERROR in PSIUC:  invalid ifit provided'
         write(io6,*)'  Expected ifit = 15 or 16'
         write(io6,*)'     Found ifit = ',ifit
         stop 'ERROR in PSIUC -- see list file'
      endif

      if (zmol.GT.0.0) then
c ---    Stable
         psiuc = -17.*(1.-EXP(-0.29*z/zmol))
      else
c ---    Unstable
         x=(1.-rfit*z/zmol)**0.25
         psiuc=2.0*ALOG(0.5*(1.+x))+ALOG(0.5*(1.+x*x))-
     &         2.0*ATAN(x)+1.5707963
      endif

      return
      end
c----------------------------------------------------------------------
      subroutine surfvar_back(tprog,temp2d,irh2d,ipcode2d)
c----------------------------------------------------------------------
c --- Previous version of SURFVAR dated Level 030119 re-introduced to
c --- obtain consistency with CALMET v5.5 series with ISFCMET=1 option
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 030119            SURFVAR
c ---          F.Robe , Earth Tech
c
c --- PURPOSE:  Fill out 2D arrays of surface temperature,
c               relative humidity, and precipitation code,
c               using surface observations or prognostic data
c    
c --- UPDATES: 
c --- V5.53c (030119) to V6.3 (070717)     
c     - Rename irhprog array to irhpg to be consistent with rest 
c       of the code and avoid conflict with irhprog flag
c      
c --- INPUTS:
c   TPROG(mxnx,mxny,mxnz) - real array - prognostic temperature
c                                        on CALMET grid
c       Common block /GRID/
c          NX,NY,NZ,NEARS(mxnx,mxny)
c       Common block /MET1/
c          ITPROG,noobs,NPSTA
c       Common block /MET2/
c          TEMPK(mxss), IRH(mxss), IPCODE(mxss)
c       Common /SURFPROG/(with rdmm5)
c          IRHPG(mxnx,mxny),IPCODEPG(mxnx,mxny)
c
c --- OUTPUT:
c    TEMP2D(mxnx,mxny) - real array - surface temperature at all gridpoints
c     IRH2D(mxnx,mxny) - int array  - surface relative humidity       
c  IPCODE2D(mxnx,mxny) - int array  - surface precipitation code
c----------------------------------------------------------------------
c
      include 'params.met'
      include 'grid.met'
      include 'met1.met'
      include 'met2.met'

      common /surfprog/irhpg(mxnx,mxny),ipcodepg(mxnx,mxny)
      real temp2d(mxnx,mxny),tprog(mxnx,mxny,mxnz)
      integer irh2d(mxnx,mxny),ipcode2d(mxnx,mxny)

      do 1 j=1,ny
      do 1 i=1,nx
c
c --- first initialize
         temp2d(i,j)= 0.
         irh2d(i,j) = 0
         ipcode2d(i,j) = 0

c ---    Fill-in the 2-D surface arrays

         if (noobs.eq.2) then
c ---       use prognostic data if no observations
            temp2d(i,j)   = tprog(i,j,1)
            irh2d(i,j)    = irhpg(i,j)
            if (npsta.ne.0) ipcode2d(i,j) = ipcodepg(i,j)
         else
c ---       otherwise use values at closest surface station
c ---       (except for Temp if itprog=2 and ipcode if npsta=-1)
            nsta = nears (i,j)
            if (itprog.ne.2)then
               temp2d(i,j)=tempk(nsta)
            else
               temp2d(i,j)=tprog(i,j,1)
            endif
            irh2d(i,j) = irh(nsta)
            if (npsta.gt.0) then
               ipcode2d(i,j) = ipcode(nsta)
            else if (npsta.eq.-1)then
               ipcode2d(i,j) = ipcodepg(i,j)
            endif
         endif

 1    continue

      return
      end
c----------------------------------------------------------------------
      subroutine temp3d_back(nyrze,njulze,nhrze,nsece,tempk,ziconv,
     1              tzgraa,tzgrbb,ztemp,zi,tprog,mnmdav,hafang,u,v)
c----------------------------------------------------------------------
c --- Previous version of TEMP3D dated Level 970825 re-introduced to
c --- obtain consistency with CALMET v5.5 series with ISFCMET=1 option
c --- With modifications for sub-hourly timesteps (explicit beg. times
c --- with seconds)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 090511             TEMP3D
c ---          R. Yamartino, SRC
c ---          Modified by J. Scire to allow for missing data (900810)
c ---          Modified by M. Fernau to allow for 1/Radius weighting
c ---            and different treatment of land vs. water (940912)
c ---          Modified for MM4 data only; no UPn.DAT (941101)
c ---          Modified to have radius of influence and maximum number
c ---            of stations in surface interpolation (950321)
c ---          Modified by F.Robe to get 3D temp from prognostic data
c ---            at upper levels and/or surface (030119)(param:ITPROG)
c
c --- PURPOSE:  Compute a 3-D temperature field
c
c --- NOTE: Currently, if no upper air data exist, then MM4 data are
c           used in place of NWS upper air data.  If any NWS data 
c           exist, only NWS data are used.  This should be modified
c           to allow a weighted use of both.
c           FRR (09/2001): if ITPROG=1 upper air temperature from MM5
c           if ITPROG=2 upper air and surface temperature from MM5
c
c --- UPDATES:
c --- V6.32 Level 080205 to v6.327 Level 090511 (FRR)
c     - Change text and number format in 1089-1090 error write 
c       to reflect time differences in seconds rather than hours 
c
c --- V5.8 Level 070623 to V6.32 Level 080205
c     (1) Back to original end times (explicit with seconds)
c
c --- v5.53 level 970825 to V5.8 Level 070623
c     (1) bug fix: in noobs temp mode, adjust temperatures to adiabatic
c         profile under convective mixing height was done under un-defined
c         variable zic (i.e. 0 or random number depending on compiler)
c
c --- INPUTS:
c                  NYRZE - integer    - Year of current hour (GMT)
c                                       (explicit end time)
c                 NJULZE - integer    - Day of current hour (GMT) 
c                                       (explicit end time)
c                  NHRZE - integer    - Current hour GMT time (0-23)
c                                       (explicit end time)
c                  NSECE - integer    - Current beginning second
c            TEMPK(mxss) - real array - Surface temp. observations
c                                       (deg. K)
c            (this actually is the otempk array w/ missing data)
c      ZICONV(mxnx,mxny) - real array - Convective mixing height (m)
c          ZI(mxnx,mxny) - real array - Mixing height (m)
c    TZGRaa(mxnzp1,mxus) - real array - Grid face temp. interpolations
c                                       for aa GMT sounding (deg. K)
c    TZGRbb(mxnzp1,mxus) - real array - Grid face temp. interpolations
c                                       for bb GMT sounding (deg. K)
c  TPROG(mxnx,mxny,mxnz) - real array - MM4 temperature array on CALMET grid
c           U(mxnx,mxny) - real array - level 1 winds for upwind averaging
c           V(mxnx,mxny) - real array - level 1 winds for upwind averaging
c               MNMDAV - integer      - Max. grid cell search radius
c                                       (outside of HAFANG cone region)
c                                       for mixing depth averaging.
c               HAFANG - real         - Half-angle (degrees) of upwind
c                                       looking cone for averaging.
c        Common block /GRID/
c           nx,ny,nz,nzp1,dgrid,zface,zmid
c        Common block /MET1/
c           nssta,nusta,xssta,yssta,xusta,yusta,noobs,ITPROG
c        Common block /UPMET/
c           justa,justd,ntzaa,ntzbb
c        Common block /TMP/
c           irad,numwb,tgdefb,tgdefa,jwat1,jwat2,trad,numts,iavet
c        Common block /GEO/
c           ilandu,iwat1,iwat2,elev
c        Common block /OVRWAT/
c           tairow,nowsta,tgrada,tgradb 
c        Parameters: mxnx, mxny, mxnz, mxnzp1, mxss,
c                    mxus, mxps, mxlev, mxtmp
c
c --- OUTPUT:
c  ZTEMP(mxnx,mxny,mxnz) - real array - 3-D temperature field (deg. K)
c
c --- TEMP3D_BACK called by:  COMP
c --- TEMP3D_BACK calls:      DEDAT,DELTT
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      real tempk(mxss)
      real zi(mxnx,mxny),ziconv(mxnx,mxny)
      real tzgraa(mxnzp1,mxus),tzgrbb(mxnzp1,mxus)
      real ztemp(mxnx,mxny,mxnz),tprog(mxnx,mxny,mxnz)
      real u(mxnx,mxny),v(mxnx,mxny)
c --- local arrays
      real tzgr(mxnzp1,mxus),tgrdb(mxnx,mxny),tgrda(mxnx,mxny)
      real tzua(mxnzp1)
      real wtus(mxus)
      real tmpwrk(mxtmp),tdist(mxtmp)
      integer stlist(mxtmp)
c
      include 'grid.met'
      include 'met1.met'
      include 'upmet.met'
      include 'tmp.met'
      include 'geo.met'
      include 'ovrwat.met'
c
      data xmiss/9999./
c
c --- If no sf stations and no prognostic data, use default value for ZTEMP
c  FRR (09/2001)
c      if(nssta.le.0 ) return
      if(nssta.le.0 .and. itprog.ne.2) return
c
c --- If no upper air stations, use default value for ZTEMP
c
      if(nusta.le.0 .and. itprog.eq.0 ) return
c
c --- Current timestamp (End GMT time)
      nowtze = nyrze*100000 + njulze*100 + nhrze

c --- Compute time interpolated temperatures for each upper air station.
c     Note that the aa and bb GMT values at each cell face are
c     available in the tzgraa and tzgrbb arrays.
c
c FRR (9/2001) noobs (3 options)
c      if (noobs .eq. 1) goto 6
      if (itprog.ge.1) goto 6
      do 10 iu = 1,nusta
        jorder = justa(iu)
        jdelta = jusdt(iu)
        ntzaas = ntzaa(iu)
        call dedat(ntzaas,jaayr,jaaday,jaahr)
        ntzbbs = ntzbb(iu)
        call dedat(ntzbbs,jbbyr,jbbday,jbbhr)
        ibbsec=jbbsec(iu)
        iaasec=jaasec(iu)


        if (jorder .gt. 0) then
c          call deltt(nyrz,njulz,nhrz,jbbyr,jbbday,jbbhr,jtogo)
c          call deltt(jaayr,jaaday,jaahr,nyrz,njulz,nhrz,jpast)
           call deltsec(nowtze,nsece,ntzbbs,ibbsec,jtogo)
           call deltsec(ntzaas,iaasec,nowtze,nsece,jpast)
        else
c          call deltt(nyrz,njulz,nhrz,jaayr,jaaday,jaahr,jtogo)
c          call deltt(jbbyr,jbbday,jbbhr,nyrz,njulz,nhrz,jpast)
           call deltsec(nowtze,nsece,ntzaas,iaasec,jtogo)
           call deltsec(ntzbbs,ibbsec,nowtze,nsece,jpast)

        end if
c
c --- Check for negative values of jtogo or jpast 
c
        if (jtogo .LT. 0 .OR. jpast .LT. 0) then
c ---     Convert to Gregorian Day for output purposes
          call dedat(nowtze,ioutyz,ioutjz,iouthz) 
          call grday(io6,ioutyz,ioutjz,ioutmz,ioutdz) 
          call dedat(ntzaas,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)
          call dedat(ntzbbs,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)  

            write(io6,1089)iu,
     :        ioutyz,ioutjz,ioutmz,ioutdz,iouthz,nsece,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,iaasec,
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,ibbsec

1089         format(//1x,'ERROR IN SUBR. TEMP3D_BACK -- Upper air ',
     1      'soundings do not straddle current hour'/
     1      2x,'Station no.: ',i5/,
     2   38x,'Year  Julian Day  Month  Day  Hour  Seconds '/,
c             xxxx      xxx       xx    xx   xx    xxxx
     4   '  Current model date/time (UTC-GMT): ',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 1 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 2 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4)
          stop
        end if
c
c --- Double check for upper air data inconsistencies
c
        if ((jpast + jtogo) .ne. jdelta) then

c ---     Convert to Gregorian Day for output purposes
          call dedat(nowtze,ioutyz,ioutjz,iouthz) 
          call grday(io6,ioutyz,ioutjz,ioutmz,ioutdz) 
          call dedat(ntzaas,ioutya,ioutja,ioutha) 
          call grday(io6,ioutya,ioutja,ioutma,ioutda)
          call dedat(ntzbbs,ioutyb,ioutjb,iouthb)     
          call grday(io6,ioutyb,ioutjb,ioutmb,ioutdb)  

            write(io6,1090)iu,
     :        ioutyz,ioutjz,ioutmz,ioutdz,iouthz,nsece,
     :        ioutya,ioutja,ioutma,ioutda,ioutha,iaasec,
     :        ioutyb,ioutjb,ioutmb,ioutdb,iouthb,ibbsec

1090         format(//1x,'ERROR IN SUBR. TEMP3D_BACK -- Inconsistent ',
     1      'upper air times for station ',i3/
     2   38x,'Year  Julian Day  Month  Day  Hour  Seconds '/,
c             xxxx      xxx       xx    xx   xx    xxxx
     4   '  Current model date/time (UTC-GMT): ',
     4    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 1 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4,/,
     5   'Sounding 2 Date/time in UP.DAT file: ',
     5    i5.4,i9.3,i9.2,i6.2,i5.2,i8.4)

          stop
        end if
c
c --- Interpolate in time to current hour and loop over all levels
c
        xfact = float(jtogo) / float(jdelta)
        if (jorder .lt. 0) then
          do 3 k = 2,nzp1
    3     tzgr(k,iu) = tzgraa(k,iu) - (tzgraa(k,iu) - tzgrbb(k,iu))
     &                 * xfact
        else
          do 5 k = 2,nzp1
    5     tzgr(k,iu) = tzgrbb(k,iu) - (tzgrbb(k,iu) - tzgraa(k,iu))
     &                 * xfact
        end if
10    continue
 6    continue
c
      dgridi = 1.0 / dgrid
c

c --- Use Prognostic data for surface temperature if itprog=2
      if (itprog.eq.2) goto 49
         
c
c --- Determine whether overwater vs. land interpolation to be used
c     (assume mxwb is hardwired to 1)
c
c --- Find maximum land use category
c
      maxcat = 0
      do lwi = 1,nlu
        if (ilucat(lwi) .gt. maxcat) maxcat = ilucat(lwi)
      end do
c
c --- If maximum land use category is < jwat1, use all sites
c     in the interpolation
c
      ldwat = 1
      if (maxcat .lt. jwat1(mxwb)) ldwat = 0
c
c --- Set LNDWAT = 0 so won't be undefined
c
      lndwat = 0
c
c --- Load surface temperature working array
c
      nstat = nssta + nowsta
      if ((nstat) .gt. mxtmp) then
        write(io6,*) ' too many combined surface stations!'
        write(io6,*) ' mxtmp = ',mxtmp,' nssta & nowsta = ',
     &                 nssta,nowsta
        stop
      end if
      do mstat = 1,nstat
        if (mstat .le. nssta) then
          tmpwrk(mstat) = tempk(mstat)
        else
          tmpwrk(mstat) = tairow(mstat - nssta)
        end if
      end do
c
c --- Reduce the missing value indicator by a small amount to allow
c     for machine roundoff
c
      xmissm=xmiss-0.01
c
49    continue

c --- Loop over grid cells
c
      do 50 i = 1,nx
c
c --- Note,(xssta,yssta) are relative to the SW corner of grid pt (1,1)
c
      xc = float(i) - 0.5
c
      do 50 j = 1,ny
        yc = float(j) - 0.5
c
c FRR (9/2001) - surface temp from prognostic model 
        if ( itprog .eq. 2 ) then
           ztemp(i,j,1) = tprog(i,j,1)
           goto 50
        endif

c --- Compute the weights for the surface met stations
c     and compute the average surface temperature
c     and average temperature gradients
c     (irad = 1 = 1/R; irad = 2 = 1/R**2)
c
c----------------------------------------------------------------
c...multiple water body capability commented out for now (9/94)
c
c --- If using land/water interpolation, determine in which water
c     body, if any, the grid cell is located
c
c.wb    jwb = 0
c.wb    if (numwb .gt. 0) then
c.wb      do iwb = 1,numwb
c.wb        if (ilandu(i,j) .ge. jwat1(iwb) .and.
c.wb &          ilandu(i,j) .le. jwat2(iwb)) then
c
c --- Grid cell land use places it in water body iwb
c
c.wb          jwb = iwb
c.wb          goto 27
c.wb        end if
c.wb      end do
c
c --- Grid cell not in any water body of interest, call it land
c     (jwb = 0)
c.wb
c.wb    end if
c27     continue
c--------------------------------------------------------------------
c  FRR (09/2001) May want an option for observed water temp rather than
c                prognostic temp in the future 

c --- If using land/water interpolation, determine whether water
c     or land (assume mxwb is hardwired to 1)
c
        if (ldwat .eq. 1) then
          lndwat = 0
          if (ilandu(i,j) .ge. jwat1(mxwb) .and.
     &        ilandu(i,j) .le. jwat2(mxwb)) lndwat = 1
        end if
c
c --- Find valid stations
c
        numsta = 0
        do 30 is = 1,nstat
c
c --- Skip this station if the temperature data is missing
c
          if (tmpwrk(is) .ge. xmissm) goto 30
c
c --- If not using L/W interpolation, skip this part and use all
c     stations
c
          if (ldwat .eq. 1) then
c
c --- Skip this station if using L/W interpolation, cell is water,
c     and station is land
c
            if (lndwat .eq. 1 .and. is .le. nssta) goto 30
c
c --- Skip this station if using L/W interpolation, cell is land,
c     and station is water
c
            if (lndwat .eq. 0 .and. is .gt. nssta) goto 30
          end if
c
c---------------------------------------------------------------------
c...multiple water body capability commented out for now (9/94)
c
c --- If number of water bodies to be interpolated = 0 then
c     include all nonmissing stations (numwb = 0).
c --- If using water/land interpolation (numwb > 0), discard
c     station if not located in interpolation area that corresponds
c     to land use range for that water body/land.
c
c.wb      if (numwb .gt. 0 .and. jwb .ne. jlandu(is)) goto 30
c----------------------------------------------------------------------
c
          numsta = numsta + 1
          if (is .le. nssta) then
            xxx = xssta(is)
            yyy = yssta(is)
          else
            xxx = xowsta(is - nssta)
            yyy = yowsta(is - nssta)
          end if
          r2 = (xxx * dgridi - xc)**2 +
     &         (yyy * dgridi - yc)**2
c
c --- Valid station, store distance and site number
c
          tdist(numsta) = sqrt(r2)
          stlist(numsta) = is
   30   continue
c
c --- Sort list of eligible stations
c
        if (numsta .gt. 1) then
          do ii = 1,numsta-1
          do jj = ii+1,numsta
            if (tdist(ii).gt.tdist(jj)) then
              tmpvar = tdist(ii)
              tdist(ii) = tdist(jj)
              tdist(jj) = tmpvar
              itmpvar = stlist(ii)
              stlist(ii) = stlist(jj)
              stlist(jj) = itmpvar
            end if
          end do
          end do
        end if
        if (numsta .eq. 0) then
c
c --- No valid sites, stop program
c
          write(io6,*) ' grid cell ',i,j,' has no valid sites for'
          write(io6,*) ' interpolation.  If it is a water body and'
          write(io6,*) ' you are using land/water interpolation,'
          write(io6,*) ' you must have at least 1 sea#.dat file!'
c
c------------------------------------------------------------------
c...commented out because no multiple water bodies and no JLANDU
c
c.wb      write(io6,*) ' you must assign it a real or pseudo'
c.wb      write(io6,*) ' station in input group 7!'
c-------------------------------------------------------------------
c
          stop
        end if
        sumwt = 0.0
        tsurf = 0.0
        tgrda(i,j) = 0.0
        tgrdb(i,j) = 0.0
        sumwt2 = 0.0
        sumwt3 = 0.0
c
c --- Calculate average temperature and TGRADs
c
        if (tdist(1) .gt. trad) then
c
c --- No stations within radius of influence, take nearest one
c
          tsurf = tmpwrk(stlist(1))
          if (lndwat .eq. 1) then
c
c --- If LNDWAT  = 1 then STLIST(1) always > NSSTA)
c
            if (tgradb(stlist(1) - nssta) .lt. xmissm) then
c
c --- Use observed TGRAD
c
              tgrdb(i,j) = tgradb(stlist(1) - nssta)
            else
c
c --- Use default TGRAD
c
c ***         if (i .eq. 1 .and. j .eq. 1) then
c ***           write(io6,*) ' No TGRADB info in sea#.dat files!'
c ***           write(io6,*) ' Default lapse rate used'
c ***         end if
              tgrdb(i,j) = tgdefb
            end if
            if (tgrada(stlist(1) - nssta) .lt. xmissm) then
c
c --- Use observed TGRAD
c
              tgrda(i,j) = tgrada(stlist(1) - nssta)
            else
c
c --- Use default TGRAD
c
c ***         if (i .eq. 1 .and. j .eq. 1) then
c ***           write(io6,*) ' No TGRADA info in sea#.dat files!'
c ***           write(io6,*) ' Default lapse rate used'
c ***         end if
              tgrda(i,j) = tgdefa
            end if
          end if
        else
c
c --- Some stations within radius, use up to NUMTS of them
c
          do 888 is = 1,numsta
            if (tdist(is) .gt. trad) goto 889
            if (is .gt. numts) goto 889
            if (irad .eq. 2) tdist(is) = tdist(is) * tdist(is)
            if (tdist(is) .lt. 1.0) then
              wt = 1.0
            else
              wt = 1.0 / tdist(is)
            endif
            sumwt = sumwt + wt
            tsurf = tsurf + wt*tmpwrk(stlist(is))
            if (lndwat .eq. 1) then
c
c --- If LNDWAT  = 1 then STLIST(IS) always > NSSTA)
c
              if (tgradb(stlist(is) - nssta) .lt. xmissm) then
                sumwt2 = sumwt2 + wt
                tgrdb(i,j) = tgrdb(i,j) +
     &                       wt * tgradb(stlist(is) - nssta)
              end if
              if (tgrada(stlist(is) - nssta) .lt. xmissm) then
                sumwt3 = sumwt3 + wt
                tgrda(i,j) = tgrda(i,j) +
     &                       wt * tgrada(stlist(is) - nssta)
              end if
            end if
 888      continue
 889      tsurf = tsurf / sumwt
          if (lndwat .eq. 1) then
            if (sumwt2 .gt. 0.) then
c
c --- Use observed TGRAD
c
              tgrdb(i,j) = tgrdb(i,j) / sumwt2
            else
c
c --- Use default TGRAD
c
c ***         if (i .eq. 1 .and. j .eq. 1) then
c ***           write(io6,*) ' No TGRADB info in sea#.dat files!'
c ***           write(io6,*) ' Default lapse rate used'
c ***         end if
              tgrdb(i,j) = tgdefb
            end if
            if (sumwt3 .gt. 0.) then
c
c --- Use observed TGRAD
c
              tgrda(i,j) = tgrda(i,j) / sumwt3
            else
c
c --- Use default TGRAD
c
c ***         if (i. eq. 1 .and. j .eq. 1) then
c ***           write(io6,*) ' No TGRADA info in sea#.dat files!'
c ***           write(io6,*) ' Default lapse rate used'
c ***         end if
              tgrda(i,j) = tgdefa
            end if
          end if
        end if
c
c --- Always use the surface determined temperature for the lowest cell
c
        ztemp(i,j,1) = tsurf
   50 continue
c
51    continue

c --- Spatially average surface temperature
c --- (currently uses mixing height variables)
c
      if (iavet.eq.1) call avetmp(nx,ny,mnmdav,hafang,dgrid,
     &                            u,v,ztemp(1,1,1))
c
c --- Load the 3-d temp array:
c
      do 150 i = 1,nx
c
c --- Note,(xusta,yusta) are relative to the SW corner of grid pt (1,1)
c
      xc = float(i) - 0.5
c
      do 150 j = 1,ny
c
c --- If using MM4/MM5 only aloft (no observations) just use TPROG as the
c     temperature field aloft
c
c FRR(09/2001) - flag itprog for prognostic temperature
c        if (noobs .eq. 1) then
        if (itprog .ge. 1) then
          do k = 2,nz
            ztemp(i,j,k) = tprog(i,j,k)
c frr (09/01)
c ---       Below convective mixing height, use dry adiabatic lapse rate
c ---       this is needed because of the spatial and temporal interpolation
c ---       performed on the prognostic data in RDMM5
c ---       bug fix: zic is not defined in noobs, use convective mixing height
c           if (zmid(k).le.zic)
            if (zmid(k).le.ziconv(i,j))
     &          ztemp(i,j,k) = ztemp(i,j,1)-0.0098*(zmid(k)-zmid(1))
          enddo
          go to 150
        endif
c
        yc = float(j) - 0.5
c
c --- Compute the weights for the upper air stations
c       (irad = 1 = 1/R; irad = 2 = 1/R**2)
c
        sumwt = 0.0
        do 115 iu = 1,nusta
          wtus(iu) = 0.0
          r2 = (xusta(iu) * dgridi - xc)**2 +
     &         (yusta(iu) * dgridi - yc)**2
          if (irad .eq. 1) r2 = sqrt(r2)
          if (r2 .lt. 1.0) then
            wt = 1.0
          else
            wt = 1.0 / r2
          endif
          sumwt = sumwt + wt
          wtus(iu) = wt
  115   continue
c
c --- Normalize the weights
c
        sumwt = 1.0 / sumwt
        do 117 iu = 1,nusta
  117     wtus(iu) = wtus(iu) * sumwt
c
c --- Load the upper air determined temperatures into tzua
c
        do 125 k = 2,nzp1
          tzuas = 0.0
          do 120 iu = 1,nusta
  120       tzuas = tzuas  +  wtus(iu) * tzgr(k,iu)
          tzua(k) = tzuas
  125   continue
c
c --- If using land/water interpolation, determine whether water 
c     or land (assume mxwb is hardwired to 1)
c
        if (ldwat .eq. 1) then
          lndwat = 0
          if (ilandu(i,j) .ge. jwat1(mxwb) .and.
     &        ilandu(i,j) .le. jwat2(mxwb)) lndwat = 1
        end if
        if (ldwat .eq. 0 .or. lndwat .eq. 0) then
c
c --- Use convective mixing height, adiabatic lapse rate, upper air
c     data method if not using L/W interpolation or if grid cell is
c     on land
c
c --- Fetch the convective mixing height
c
          zic = ziconv(i,j)
c
          do 145 k=2,nz
            kp1 = k + 1
            zlow = zface( k )
            tlow = tzua( k )
            zhgh = zface(kp1)
            thgh = tzua(kp1)
c
c --- Entire layer above convective mixing height, use average of
c     sounding levels
c
            if (zlow .gt. zic) ztemp(i,j,k) = 0.5 * (tlow + thgh)
c
c --- Entire layer below convective mixing height, use adiabatic
c     lapse rate
c
            if (zhgh .le. zic) ztemp(i,j,k) = ztemp(i,j,1) - 0.0098
     &                           * 0.5 * (zlow + zhgh)

            if (zlow .le. zic .and. zhgh .gt. zic) then
c
c --- Convective mixing height located in layer, use 3-point thickness
c     weighted average of temperature at the two cell faces and at
c     the CMH
c
              tlow = ztemp(i,j,1) - 0.0098 * zlow
              tmid = ztemp(i,j,1) - 0.0098 * zic
              ztemp(i,j,k) = 0.5 * ((tlow + tmid) * (zic - zlow) +
     &              (tmid + thgh) * (zhgh - zic)) / (zhgh - zlow)
            endif
  145     continue
        else
c
c --- Over water use user-determined TGRAD
c
c --- Substitute regular mixing height for convective MH
c
          zic = zi(i,j)
          do 146 k = 2,nz
            kp1 = k + 1
            zlow = zface(k)
            zhgh = zface(kp1)
            if (zhgh .le. zic) then
c
c --- Entire layer below the mixing height, use tgrad below
c
              ztemp(i,j,k) = ztemp(i,j,1) + tgrdb(i,j) * zmid(k)
            else if (zlow .gt. zic) then
c
c --- Entire layer above the mixing height, use tgrad above for
c     portion above the mixing height
c
              ztemp(i,j,k) = ztemp(i,j,1) + tgrdb(i,j) * zic +
     &                       tgrda(i,j) * (zmid(k) - zic)
            else if (zlow .le. zic .and. zhgh .gt. zic) then
c
c --- Mixing height is located in layer, use thickness weighted
c     3-point average
c
              tlow = ztemp(i,j,1) + tgrdb(i,j) * zlow
              tmid = ztemp(i,j,1) + tgrdb(i,j) * zic
              thgh = ztemp(i,j,1) + tgrdb(i,j) * zic +
     &               tgrda(i,j) * (zhgh - zic)
              ztemp(i,j,k) = 0.5 * ((tlow + tmid) * (zic - zlow) +
     &              (tmid + thgh) * (zhgh - zic)) / (zhgh - zlow)
            endif
  146     continue
        end if
  150 continue
      return
      end


c------------------------------------------------------------------------------
         subroutine inout(xx,yy,iflag,xb,yb,nbpts)
c------------------------------------------------------------------------------
c
c --- CALMET   Version: 6.4.0     Level: 090511               INOUT
c ---          Based on BOUND_2.FOR, V2.0, J. Scire
c
c --- PURPOSE:  performs in/out test on single point (xx,yy) for boundary 
c               defined by xb,yb and returns in/out/on flag
c
c
c --- UPDATES:
c --- Bound_2.for v2.0 (2000-01-11) to V6.327 Level 090511 (F.Robe):
c          - Adapted to CALMET (variable definitions, conventions, 
c            error messages,number of boundaries limited to 1 )  
c
c --- INPUT:
c                 xx, YY - real*8     - coordinates of CALMET gridpoint (km)
c   XB (mxb3d),YB(mxb3d) - real*8     - Coordinates defining the boundary 
c                                       the boundary must be closed (start
c                                       point=end point)       
c
c        via PARAMS.MET: io6,mxb3d (number of MM4/MM5 boundary points)
c
c                  NBPTS - integer    - Number of points defining the boundary
c --- OUTPUT:
c                  IFLAG - integer    - IN/OUT/ON flag
c                                      = 0: CALMET gridpoint OUTside of boundaries
c                                      = 1: CALMET gridpoint INside of boundaries 
c                                      =-1: CALMET gridpoint ON boundaries
c
c --- INOUT called by: RDHD4, RDHD5
c --- INOUT calls: -
c
c -------------------------------------------------------------------------
      include 'params.met'

c --- CALMET gridpoint (dubbed "receptor" in the subroutine)
      real*8 xx,yy

c --- boundary information
      real*8 xb(mxb3d),yb(mxb3d)

      real*8 small
      parameter(small=1.0d-3)  !tolerance for being on boundary

c --- test on boundary
      real*8 xs,ys,xp,yp,xe,ye,d2,ds,dc,small2

c --- work array with segment no. of all segments intersecting Y coordinate
c --- of receptor
      integer ibsave(mxb3d)

      small2 = small*small


c -----------------------------------------------
c --- STEP 1 - Find all boundary segments which
c ---          cross Y of the receptor
c -----------------------------------------------
      nseg=0

c --- Start and end indices of boundary points
      ns = 1
      ne = nbpts

c set nflag = 1 if we're starting above the line, =-1 if below
c (do loop necessary if boundary is on y = yy)
         do j = ne,ns,-1
            if (yb(j).gt.yy) then
               nflag = 1
               goto 100
            elseif (yb(j).lt.yy) then
               nflag = -1
               goto 100
            endif
c if boundary is a straight line on yy, nflag = -1
            nflag = -1
         enddo
 100     continue

c for each boundary, make list of segments intersecting Y coordinate
         do j = ns+1,ne
            if(nflag.eq.1.and.yb(j).lt.yy) then
               nseg = nseg + 1
               ibsave(nseg) = j
               nflag = -1
            elseif(nflag.eq.-1.and.yb(j).gt.yy) then
               nseg = nseg + 1
               ibsave(nseg) = j
               nflag = 1
            endif
c check if point is within 'small' of the boundary
c boundary segment vector:
            xs = xb(j)-xb(j-1)
            ys = yb(j)-yb(j-1)
            ds = (xs*xs+ys*ys) !boundary segment length
            if (ds.ne.0.0) then
c quietly ignore zero length segments
c receptor vector:
            xp = xx-xb(j-1)
            yp = yy-yb(j-1)
c perpendicular vector from boundary segment to receptor:
            xe = (xp - ((xs*xp+ys*yp)/ds)*xs)
            ye = (yp - ((xs*xp+ys*yp)/ds)*ys)
            d2 = (xe*xe+ye*ye) !perpendicular distance squared to receptor
c projected position of perpendicular on segment:
            dc = (xs*xp+ys*yp)
            if (d2.lt.small2.and.dc.ge.(0.0-small2).and.
     &           dc.le.(ds+small2)) then
               iflag = -1
               goto 101
c               return
            endif
            endif
         enddo

c --- The number of segments intersecting y=yy must be zero or
c --- an even number
      if(mod(nseg,2).ne.0)then
         write(  6,*)'ERROR -- STOP in subroutine INOUT'
         write(io6,*)'ERROR -- STOP in subroutine INOUT'
         write(io6,*)'Number of segments intersecting yy ',
     1   'must be zero or an even number -- NSEG = ',nseg
         write(io6,*)'CALMET coordinates x,y:',xx,yy
         write(io6,*)'IBSAVE = ',(ibsave(n),n=1,nseg)
         stop
      endif
c
c --- If no boundary segments intersect yy, receptor must be OUTSIDE
c --- of the boundary
      if(nseg.eq.0) then
         iflag = 0
         goto 101
      endif
c
c ---------------------------------------------------
c --- STEP 2 - count no. of segments on either side of xx
c ---          even -> out
c ---          odd  -> in
c ---          <> nseg -> boundary
c ---------------------------------------------------
c
      nlow = 0
      nhigh = 0
      do i = 1,nseg
         i1 = ibsave(i)-1
         i2 = ibsave(i)
         xint = xb(i2)-(xb(i2)-xb(i1))*(yb(i2)-yy)
     &        /(yb(i2)-yb(i1))
         if (abs(xint-xx).lt.small) then
c boundary:
            iflag = -1
            goto 101
c            return
         elseif (xint.gt.xx) then
            nhigh = nhigh + 1
         elseif (xint.lt.xx) then
            nlow = nlow + 1
         endif
      enddo

      if ((nhigh+nlow).eq.nseg) then
         if (mod(nhigh,2).eq.0) then
c out:
            iflag  = 0
         else
c in:
            iflag  = 1
         endif
      else
c boundary:
         iflag  = -1
      endif

 101  continue

      return
      end
c ---------------------------------------------------------------------