c ---------------------------------------------------------------------
      program calmet
c ---------------------------------------------------------------------
c --- CALMET -- Diagnostic meteorological model for the CALPUFF,
c ---           CALGRID, and MESOPUFF-II models
c----------------------------------------------------------------------
c
c     Copyright (c) 1998-2013 by TRC Environmental Corporation
c
c --- CALMET   Version: 5.8.4      Level: 130731                 MAIN
c
c --- CALMET MOD5- Developed by:
c                  Joe Scire, Francoise Robe, and Mark Fernau
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 no changes
C                                                       MCB-G (130104)
c----------------------------------------------------------------------
c
c     TRC Version 5.8, Level 070623 to Version 5.8.4, Level 130731
c
c     Associated with MCB G
c
c     (1) Bug Fix: When using multiple multi-hourly M3D files with
c         overlapping times CALMET simulation stopped sooner than the
c         requested end time. The fix does not affect results.
c         Modified: RDMM5
c  
c     (2) Bug Fix: When using convective overwater mixing height options 
c         (IMIXH>0) the overwater convective mixing height grows from 
c         the previous hour mixing height, not from the previous hour  
c         convective mixing height. This affects the values of overwater 
c         mixing heights overwater if conditions switch from stable/neutral
c         to convective overwater during the simulation.
c         Modified: WATER,WATERP
c
c     (3) Bug Fix: At night when CALMET temperatures are computed from  
c         3D.DAT temperatures (ITPROG>0) and CALMET lower level(s) are   
c         below the lowest 3D.DAT level, CALMET lowest temperature (s), 
c         which in that case are based on  vertical extrapolation of the  
c         lowest 3D.DAT temperatures, assumed radiative cooling even in  
c         (rare) cases of nightime warming (e.g. passage of a warm front)
c         Modified: STULL
c
c     (4) Bug Fix: In case of several upper air stations, the upper air 
c         station selected for the computation of the lapse rate (IUPT)  
c         was not necessarily used for the computation of the lapse rate
c         at the top of the boundary layer or the computation of the 
c         Batchvarova/Gryning mixing height 
c         (the closest station was, whether IUPT or not)
c         Modified: MIXHT, MIXHTST
c
c     (5) Bug Fix: There is no check to make sure that the CALMET grid is
c         located within the prognostic grid, thus possibly using far away
c         and irrelevant prognostic gridpoints to initialize CALMET variables
c         Modified: RDHD4, RDHD5, PARAMS.MET, READCF, INOUT (new)
c
c     (6) Bug Fix: For precipitation interpolated from prognostic 
c         precipitation (NPSTA=-1), the user-defined SIGMAP is not checked 
c         against the prgnostic gridsize thus allowing more than the 4 
c         nearest prognostic gridpoints to be used for the interpolation
c         onto the CALMET grid.
c         Modified: RDHD4, RDHD5, READHD
c
c     Associated with MCB E
c
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).
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 (flagged by Bruno Santos)
c
c 
c     (1) Bug fix: check values of prognostic ceiling heights at both  
c         times t1 and t2 before performing a time interpolation.
c         Affects runs with MM5 prognostic clouds (ICLOUD=3,4; IPROG>5)
c         and MM5 timestep longer than CALMET timestep
c         Modified: RDMM5
c     (2) Bug Fix: check precip. station IDs based on LCFPRC not LCFSFC.
c         Modified: READHD
c     (3) 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
c 
c     (1) Bug fix in RDMM5 when the run ends on the first hour of a  
c         new year (longer than 1 hour run). Enforce bounds on dtinc
c         Modified: RDMM5
c     (2) 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     (3) 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     (4) 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). 
c         Modified: SURFVAR
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) 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     (7) Base value check of ISURFT and IUPT on ITPROG and do not 
c         allow negative values of ISURFT and IUPT even in noobs mode,  
c         because the meaning of such values in MOD6 is important 
c         whereas it is not in MOD5 (thus preventing CALMEt.INP with
c         such values to be used with different meanings, in MOD5 and
c         MOD6 without warning to the users)
c         Modified: READCF     
c
c --- V5.731 Level 070619 to v5.8      Level 070623
c --- Changes to create EPA regulatory option to replicate results
c --- from CALMET v5.53c Level 070501, as modified by MCB-D updates
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         This switch, MREG, becomes a mandatory input
c         Reset default buoyancy flux over land to 0.0 W/m3
c         Modified: BLOCK DATA, READCF
c
c
c
c --- V5.730 Level 070128 to V5.731 Level 070619
c     Modifications by F. Robe
c     (1) Modify computation of RHOP in RDMM5 such that it is
c         properly (re)initialized at each timestep and is always
c         computed at the surface. The non-initialization of RHOP
c         could produce wrong values with some compilers (e.g. PGI
c         in Linux) (Modifications suggested by B. Brashers)
c     (2) Add ldbhr to OUTPT.MET  and include OUTPT.MET
c         in mixhtst and mixht2st (Was not defined in those
c         subroutines earlier on)
c         Modified: COMP, ELUSTR2,MIXHTST, MIXHT2ST, OUTPT.MET
c     (3) Supply ceiling height values to RADFLX subroutine in
c         mode (otherwise wrong long wave flux passed on to COARE if
c         COARE observation option selected)- Modified: COMP, DIAGNO,
c     (4) Fill in gridded cloud array with observations for icloud=0,1
c         RADFLX to provide correct cloud data to RADFLX (otherwise
c         wrong long wave flux passed on to COARE if COARE option
c         selected) - Modified: COMP, OUTCLD
c     (5) 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     (6) Initialize the following variables (non-initialization of
c         these variables do not affect results but may cause execution
c         to stop with some compilers):
c            - nlevag1,TZ,ZL, TZ1,ZL1,TZ2,ZL2 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     (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     (8) 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
c           DATA
c     (9) CALUTILS from v2.53 Level 060626 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'-  Modified:  UTCBASR, BASRUTC
c         - Allow negative increments in INCRS (V2.54 Level 061020)
c    (10) Correct array index of tgrada (nwat instead of ns) in WATER2
c    (11) Correct array index of xowsta and xusta in WIND1
c         (only a pb if barriers are used)
c    (12) Initialize ldwat sooner in the code to avoid non-initialization
c         if no water stations (with water temp results depending on
c         default value assigned to ldwat by compiler)
c         Modified: TEMP3D
c    (13) 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    (14) Update roughness legnth and log profile coefficients for
c         surface stations located on a water gridcell
c         Modified: WIND1
c    (15) assign z0 value sooner in the code so that filled in even when
c         no valid overwater stations - Modified: WATER
c    (16) 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. Also affects runs
c         with ITWPROG=2 and ICOARE=10 when lowest M3D level is at 10m
c         Modified: WATER2,WATER2P
c    (17) Set buoyancy flux to 0 when missing OW data (neutral)
c         Modified: WATER2
c    (18) 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    (19) 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    (20) Read the MM5 land use into ILU4 array in RDHD51 and RDHD52.
c         This is already done in RDHD53.
c    (21) Allow initial HTOLD convective mixing height to be less than
c         ZIMIN in MIXHT2 and MIXHT2ST
c    (22) Convective velocity (wstar) overwater strictly based on convective
c         mixing height if ziconv is computed
c         Modified: WATER, WATERP
c    (23) Echo all input parameter values, even those not listed in input file
c         (for which default values are then used)
c         Modified: READCF
c    (24) 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    (25) Make sure vertical extrapolation is not done for iextrp=1
c         Modifed: DIAGNO
c    (26) Include grid.met in MIXHST to ensure nx and ny are available for debug
c         output option (and change nearu variable name to avoid conflict)
c         Modifed: MIXHTST
c    (27) Default value for THRESHL reset to 0 for consistency with older
c         CALMET versions and regulatory assumptions
c         Modified: READCF
c
c --- V5.729 Level 070115 to V5.730 Level 070128
c     Modifications by F. Robe and J. Scire
c     (1) Accept both midnight conventions for CSUMM time (Hr 0 or Hr 24)
c         (Subr. PROGRD)  (F. Robe)
c     (2) When ITWPROG=2, compute the nearest 3D.DAT 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 (F. Robe)
c     (3) Define LCALGRIDI as logical and perform tests on False/true
c         rather than 0/1 in RDHDMET (relevant for IGF-CALMET runs)
c         (F. Robe)
c     (4) Allow more than 99 layers in UP.DAT format (change format for
c         number of stations from i2 to i5 in Subr. RDUP.  (J. Scire)
c
c --- V5.728 Level 061230 to V5.729 Level 070115
c --- Modifications by J. Scire
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         Subr. modified:  RDHD51, RDHD52, RDHD53
c
c --- V5.727 Level 061206 to V5.728 Level 061230
c --- Modifications by F. Robe
c     (1) Ensure that precipitable water remains within algorithm range
c         of applicability (RADFLX subroutine)
c
c --- V5.726 Level 060801 to V5.727 Level 061206
c --- Modifications by F. Robe
c     (1) Bug fix in ELUSTR2: update gridded prognostic cloud cover in
c         the computation of u*,Lmo, Mixing Height, under stable
c         conditions when ICLOUD=3 (cloud cover based on MM5 rel.hum.)
c
c --- v5.725 Level 060525 to v5.726 Level 060801
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
c          data - 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 --- Modifications by D. Strimaitis
c     (1) CALUTILS from v2.51 Level 051019 to v2.53 Level 060626
c         Modify search for '=' to allow blanks (internal blanks are not
c         removed after V2.2); move GLOBE1
c         Modified:  READIN
c         Removed:   GLOBE1
c     (2) 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 --- v5.724 Level 060414 to v5.725 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.MET to MIXHT2ST for debug output call to OUT
c         (Change contributed by Bart Brashers, Geomatrix Consultants)
c         Modified:  MIXHT2ST
c
c --- v5.723 Level 060411 to v5.724 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 --- v5.722 Level 060322 to v5.723 Level 060411
c --- Modifications by DGS
c     (1) Revise check for missing SST in RDMM5.  Current range of
c         260-320K is not large enough since land cells are also given
c         an SST.  Range is revised to 150-350K, as expected missing
c         values are either 0, large negative, or large postitve.
c         Modified:  RDMM5
c
c --- v5.721 Level 060318 to v5.722 Level 060322
c --- Modifications by F.Robe
c     (1) Add check for negative log arguments in MIXHBG
c
c
c --- v5.720 Level 060315 to v5.721 Level 060318
c --- Modifications by F.Robe
c     (1) CALUTILS from v2.2 Level 030528 to v2.51 Level 051019
c     (2) Filnames changed from c*70 to c*132 (for CALUTILS V2.3
c         and later)
c         Modified:  FILNAM.MET , READFN, WRFILES
c
c --- v5.719 Level 060314 to v5.720 Level 060315
c --- Modifications by F.Robe
c     (1) Change minimum SST to -3.0C (WATER,WATER2,WATERP,WATERP2)
c     (2) Remove internal debug write(66,*) statements (DIAGNO)
c     (3) Set default prognostic ocean land use category ILUOC3D=16,
c         corresponding to MM5 ocean LU cat (BLOCK DATA)
c     (4) 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)
c     (5) Fill in values of ILU4(mxnxp,mxnyp) no matter ITWPROG value
c         (RDHD53)
c     (6) Assign ocean LU to zero elevation MM5 gridpoints for old
c         format files from which prognostic landuse is not read in
c         (RDHD52)
c     (7) Add a check for missing Tairow before call to COARE and
c         replace by default Tair if missing (WATER)
c
c
c --- v5.718 Level 060305 to v5.719 Level 060314
c --- Modifications by D.Strimaitis
c     (1) 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.
c         Modified: WATER
c --- Modifications by F. Robe
c     (1) Fixed same typo as above in WATER2
c     (2) Allow for round-off error when checking for missing ZOWSTA (WATER)
c     (3) Make sure SST is above freezing temp (WATER/WATER2/WATERP/WATERP2)
c
c --- v5.717 Level 060304 Level 060301 to v5.718 Level 060305
c --- Modifications by F.Robe
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
c --- v5.716 Level 060301 to v5.717 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 --- v5.715 Level 060218 to v5.716 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
c         Modified: MIXHBG
c         New: function FBG
c     (2) Check whether to compute mixing height growth based on net
c         buoyancy flux (i.e. take threshold into account) (MIXHMC)
c     (3) Compute tht,thtp (ilapse=1) for all cases in MIXHBG and MIXHMC
c
c --- v5.714 Level 060217 to v5.715 Level 060218
c --- Modifications by F.Robe
c     (1) 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 --- v5.713 Level 060215 to v5.714 Level 060217
c --- Modifications by D. Strimaitis
c     [Repeats changes from v5.7 to v5.71 dated 060202]
c     (1) Add QA output file of SEA.DAT station locations
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
c         Modified: RDHDOW
c
c --- version 5.712 Level 060213 to v5.713 Level 060215
c --- Modifications by F.Robe
c     (1) Bug fix: shift sinalp time index by 1 in RDMM4/RDMM5 (array index
c         from 1-24 for hour-ending 0-23).
c
c --- version 5.711 Level 060106 to V5.712 Level 060213
c --- Modifications by F.Robe
c     (1) 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) - Nearest CALMET neighbor computed in RDHD4/RDHD5
c
c --- version 5.7 Level 051230 to Version 5.711 Level 060106
c --- Modifications by F.Robe
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='5.8.4'
      level='130731'
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: 5.812      Level: 080512             BLOCK DATA
c ---          J. Scire, Earth Tech, Inc.
c ---          modified by M. Fernau, J. Scire , F.Robe
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'

      common /tjump/ dptt(mxnx,mxny)
      data dptt/mxxy*0./
c
c --- GEN common block
c frr (09/01)
c     data irtype/1/,lcalgrd/.true./
      data irtype/1/,lcalgrd/.true./,nendhr/0/
      data mreg/-1/
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
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 --- 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
c frr (09/01)
      data itprog /0/
      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/
c FRR (09/2001) - 030119  bug - itprog assigned twice (same value but still)
c      data itprog /0/
      data icloud/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----------------------------------------------------------------------
      subroutine adjust(u,v,phi,htopo,hbar,ub,vb)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8        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: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8         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,k,zi)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 030119                CINTERP
c              F.Robe, Earth Tech
c              After R2INTERP subroutine (M.Fernau, Earth Tech)
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 --- 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 --- 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,mxnz)

      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),k)
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),k) * 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: 5.8         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(nyrz,njulz,nhrz,iupt,zupt,ziconv,gamma)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 991104                  CGAMMA
c ---          J. Scire, SRC
c
c --- PURPOSE:  Compute the average temperature lapse rate in a layer
c               up to the height "ZUPT"
c
c --- UPDATE
c --- V5.0-V5.1     991104  (DGS): YYYY format for year
c
c --- INPUTS:
c
c                 NYRZ - integer    - Year of current hour (GMT)
c                NJULZ - integer    - Day of current hour (GMT)
c                 NHRZ - integer    - Current Hour (GMT)
c                 IUPT - integer    - Station number of the upper air
c                                     sounding to use
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 --- OUTPUT:
c                GAMMA - real       - Average temperature lapse rate
c                                     (deg. K/m) in the layer up to
c                                     height "ZUPT"
c
c --- CGAMMA called by:  PREPDI
c --- CGAMMA calls:      INTP, DELTT
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      include 'upmet.met'
c
      data nconv/9999/,xmiss/999.9/
c
      if(ziconv.ge.zupt)then
c
c ---    layer within convective mixing height
c ---    assume dry adiabatic lapse rate
         gamma=-0.0098
c ---    save hour -- last convective hr of day is used in time interp
         nconv=nhrz
         go to 300
      endif
c
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)
c**** Modified by EMI -- 4/26/94
      if(jorder.gt.0) then
         call deltt(nyrz,njulz,nhrz,jbbyr,jbbday,jbbhr,jtogo)
         call deltt(jaayr,jaaday,jaahr,nyrz,njulz,nhrz,jpast)
      else
         call deltt(nyrz,njulz,nhrz,jaayr,jaaday,jaahr,jtogo)
         call deltt(jbbyr,jbbday,jbbhr,nyrz,njulz,nhrz,jpast)
      endif
c     check for negative values of jtogo or jpast
      if(jtogo.LT.0 .OR. jpast.LT.0)then
        write(io6,1089) iupt,nyrz,njulz,nhrz,jpast,jtogo,jdelta,
     1                  ntzaas,ntzbbs
1089    format(//1x,'ERROR IN SUBR. CGAMMA -- Upper air soundings',
     1      ' do not straddle current hour for station ',i3/
     2      5x,'Current YYYYDDDHH (GMT)  ',i4,i3,i2,/
     3      5x,'GMT hours past and before soundings ',2i4/
     4      5x,'GMT hours between these soundings ',i4/
     5      5x,'GMT YYYYDDDHH codes for these soundings ',2i11)
        stop
      endif
c     double check for upper air data inconsistencies.
      if((jpast+jtogo).ne.jdelta) then
         write(io6,1090) iupt,nyrz,njulz,nhrz,jpast,jtogo,jdelta,
     1                   ntzaas,ntzbbs
1090     format(//1x,'ERROR IN SUBR. CGAMMA -- Inconsistent ',
     1   'upper air times for station ',i3/
     2   5x,'Current YYYYDDDHH (GMT) ',i4,i3,i2,/
     3   5x,'GMT hours past and before soundings ',2i4/
     4   5x,'GMT hours between these soundings ',i4/
     5   5x,'GMT YYYYDDDHH codes for these soundings ',2i11)
         stop
         endif
c**** End of EMI Modifications -- 4/26/94
c
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)
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 time=nhrz
      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 time=nhrz
      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 NCONV undefined.
      if(nconv.gt.998) go to 300
c --- Also, this additional information is only useful if NCONV
c     lies between the two current soundings.
      if(jorder.gt.0) then
                      jtogoc = jbbhr - nconv
                      jpastc = nconv - jaahr
                      else
                      jtogoc = jaahr - nconv
                      jpastc = nconv - jbbhr
                      endif
      if(jtogoc.lt. 0) jtogoc = jtogoc + 24
      if(jtogoc.gt.23) jtogoc = jtogoc - 24
      if(jpastc.lt. 0) jpastc = jpastc + 24
      if(jpastc.gt.23) jpastc = jpastc - 24
c --- Check that NCONV lies between JaaHR and JbbHR.  In order 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) go to 300
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) go to 300
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) go to 300
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 time NHRZ.
      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 time=NHRZ.
      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
  300 return
      end
c----------------------------------------------------------------------
      subroutine cgamma2(tprog,ziconv,gamma,itprog)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 941101                 CGAMMA2
c ---          J. Scire, SRC
c
c --- PURPOSE:  Compute the average temperature lapse rate in a layer
c               up to the height "ZUPT" using MM4 prognostic data
c               if ITPROG>=1
c               Compute a domain representative temperature TINF
c               if ITPROG=2
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               ITPROG - integer     - Flag for use of prognostic temperature
c                                      =1 : use upper air prognostic temp.
c                                      =2 : use sf. and upper air progn. temp.
c
c        Parameters: MXNX,MXNY,MXNZ, IO6
c
c --- OUTPUT:
c                GAMMA - real       - Average temperature lapse rate
c                                     (deg. K/m) in the layer up to
c                                     height "ZUPT"
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)
c
      avgamma = 0.
c frr (09/01) initialize tinf
      if (itprog.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
        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
        end if
c frr (09/01)
c ---   Compute domain representative surface temperature TINF
        if (itprog.eq.2) tinf=tinf+tprog(i,j,1)
      end do
      end do
      gamma = avgamma / (nx * ny)
c frr (09/01)
      if (itprog.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: 5.8         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: 5.8         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: 5.8         Level: 070623                  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 --- V5.731 (070619) to v5.8      (070623)
c        - Add IPSIFCN to ELUSTR argument list
c        - Add ISFCMET option for 2D surface temperatures and density
c
c --- v5.611 (051113) to V5.731 (070619) (F.Robe)
c        - Save ldbhr in OUTPT.MET and do not declare it in COMP anylonger
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
c --- V5.6 (050328) to v5.611 (051113) (F.Robe)
c        - Allow option to use prgnostic 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----------------------------------------------------------------------
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
      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
      if(lmesg)then
         write(iomesg,*)'ENTERING COMPUTATIONAL PHASE'
         write(iomesg,*)
      endif

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 --- 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(ibyr,4).eq.0)then
         mxdays=366
      else
         mxdays=365
      endif
      nyr=ibyr
      njul=ibjul-1
      nhr=ibhr-1
c
c --- Begin DAY loop
      do 1000 idy=1,idays
c
c --- increment date/time
      njul=njul+1
      if(njul.gt.mxdays)then
         nyr=nyr+1
         njul=1
         if(mod(nyr,4).eq.0)then
            mxdays=366
         else
            mxdays=365
         endif
      endif
      call grday(io6,nyr,njul,nmo,nday)

c --- compute sin(solar elevation angles) at all gridpoints
c --- for 24 hours
      call solar (njul,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 --- frr (09/2001)
c --- flag last hour of run
      if (nh.eq.irlg) nendhr =1

      if(nh.gt.irlg)go to 1001
      nhr=nhr+1
      if(nhr.gt.23)then
         nhr=-1
         nh=nh-1
         go to 1000
      endif
c --- nhrind is hour variable ranging from 1-24 instead of 0-23
      nhrind=nhr+1
c
      if(lmesg)print 788,nyr,njul,nhr
788   format('+','Processing Year, Day, Hour: ',i4,1x,i3,1x,i2)

c
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)
      nhrz = nhr
      njulz = njul
      nyrz = nyr
      call indecr(io6,nyrz,njulz,nhrz,ibtz,0,23)
      nowtz = nyrz*100000 + njulz*100 + nhrz

c --- set print variables for this hour
      if(lprint.and.mod(nh,iprinf).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 --- compute date/hour variable (YYYYJJJHH)
      ndathr=nyr*100000+njul*100+nhr
c
c --- write sine (solar elev. angle) if LDB switch is on
      if(ldbhr)then
         write(io6,95)nyr,njul,nhr,sinalp(1,1,nhrind)
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
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
      call rds(iforms,nssta,ispack,ios,0,ibuf,iyr,ijul,ihr,ws,wd,
     1 iceil,icc,tempk,irh,pres,ipcode)
c
      idathr=iyr*100000+ijul*100+ihr
      if(idathr.ne.ndathr)then
         write(io6,102)ndathr,idathr
102      format(//1x,'ERROR IN SUBR. COMP -- 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
c
c --- echo back surface met. data if "debug write" option is on
c --- (BEFORE missing data is replaced)
      if(ldbhr)then
         write(io6,108)iyr,ijul,ihr
108      format(/1x,'SURFACE MET. INPUT DATA -- Year: ',i4,3x,
     1   'Julian day: ',i3,3x,'Hour: ',i2/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 --- 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
      if(icloud.eq.2)then
         call rdcld(iformc,nx,ny,ndathr,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 (070619)
c --- And must be done for icloud=0 as well otherwise no
c --- gridded cloud data when observations
c --- Compute and output gridded cloud data
      if(icloud.le.1)call outcld(ndathrb,nx,ny,nssta,icc,nears,
     1  iformc,icloud,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 hour
      if(npsta.gt.0)then
         call rdp(iformp,npsta,ippack,iop,0,iyr,ijul,ihr,xprecp)
c
         idathr=iyr*100000+ijul*100+ihr
         if(idathr.ne.ndathr)then
            write(io6,112)ndathr,idathr
112         format(//1x,'ERROR IN SUBR. COMP -- Expected date/hour ',
     1      'does 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
c
c ---    echo back precip. input data if "debug write" option is on
         if(ldbhr)then
            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(ndathr)
         if(ldbhr)then
            write(io6,128)iyr,ijul,ihr
128         format(/1x,'OVERWATER INPUT DATA -- Year: ',i4,3x,
     1      'Julian day: ',i3,3x,'Hour: ',i2/1x,'Station No',3x,
     2      'Rel. X',4x,'Rel. Y',6x,'Z',4x,'Beg. Time',3x,'End. Time',
     3      3x,'Delta T',3x,'Air T',3x,'Rel Hum',3x,'Mix Ht'/16x,
     4      '(m)',6x,'(m)',7x,'(m)',1x,'(YYYYJJJHH)',1x,'(YYYYJJJHH)',
     5      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
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     if(justas.eq.+1 .and. nowtz.lt.ntzaas) stop -- have read too far
      if(justas.eq.+1 .and. nowtz.ge.ntzbbs) go to 138
c     if(justas.eq.-1 .and. nowtz.lt.ntzbbs) stop -- have read too far
      if(justas.eq.-1 .and. nowtz.ge.ntzaas) 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
      if(((ntzaas-nowtz)*(ntzbbs-nowtz)) .gt. 0) then
c     the two upper air times do not straddle the current time
            ntzlow = min0(ntzaas,ntzbbs)
            ntzhgh = max0(ntzaas,ntzbbs)
            write(io6,1311)iu,nowtz,ntzlow,ntzhgh
1311        format(//1x,'ERROR IN SUBR. COMP -- Required dates/hours'/
     1      5x,'do not match values read from UPPER AIR STATION no.',i3/
     2      5x,'Current year, Julian day, GMT hour = ',i9,'  but'/
     3      5x,'Last two upper air records are for = ',i9,'  and  ',i9/
     4      5x,'expressed as YYYYDDDHH.  Therefore STOP!')
            stop
         endif
c
c --- Test for excessive time separation of the soundings.
c *** rjy modified the following on 1/30/90 ******************
      jdelta = jusdt(iu)
      if(jdelta.gt.maxsep) then
c --- The two upper air times are more than "maxsep" hours apart.
            ntzlow = min0(ntzaas,ntzbbs)
            ntzhgh = max0(ntzaas,ntzbbs)
            write(io6,1312)maxsep,iu,nowtz,ntzlow,ntzhgh,jdelta
1312        format(//1x,'ERROR IN SUBR. COMP -- Missing upper air data'/
     1      5x,'or record gap > ',i2,' hours for UPPER AIR STATION no.',
     2      i3/5x,'Current year, Julian day, GMT hour = ',i9,'  but'/
     3      5x,'Last two upper air records are for = ',i9,'  and  ',i9/
     4      5x,'for a spacing of ',i4,' hours.  Therefore STOP!')
            stop
         endif
c ************************************************************
c
c --- Current upper air soundings acceptable; thus, proceed.
      go to 140
c
  132 call rdup(iu,io,1,iconvrt,jbbhr,jbbday,jbbyr)
      ntzbbs = jbbyr*100000 + jbbday*100 + jbbhr
      ntzbb(iu) = ntzbbs
      justa(iu) = +1
c
c --- Compute the time separation 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)
         call dedat(ntzaas,jaayr,jaaday,jaahr)
         call deltt(jaayr,jaaday,jaahr,jbbyr,jbbday,jbbhr,jdelta)
         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 call rdup(iu,io,-1,iconvrt,jaahr,jaaday,jaayr)
      ntzaas = jaayr*100000 + jaaday*100 + jaahr
      ntzaa(iu) = ntzaas
      justa(iu) = -1
c
c --- Compute the time separation of the two upper air soundings.
c *** rjy addition of the following on 1/30/90 ***************
      ntzbbs = ntzbb(iu)
      if(ntzbbs.gt.0) then
         call dedat(ntzbbs,jbbyr,jbbday,jbbhr)
         call deltt(jaayr,jaaday,jaahr,jbbyr,jbbday,jbbhr,jdelta)
         jdelta = iabs(jdelta)
         jusdt(iu) = jdelta
      endif
c ************************************************************
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
      if (noobs.ne.2)then
         call prepdi(ws,wd,tempk,uaveaa,uavebb,vaveaa,vavebb,nssta,
c****1   nusta,nz,nhr,ibtz,ziconv,gamma,beta2,um,vm,wt,us,vs)
     1   nusta,nz,nhr,nyrz,njulz,nhrz,ziconv,gamma,beta2,um,vm,
     2   wt,us,vs,nowsta,wsow,wdow,noobs)
c
         if(ldbhr)then
           if (noobs .eq. 0) then
            write(io6,152)nyr,njul,nhr,gamma,tinf,um,vm
152         format(/2x,'Diagnostic wind field data -- Year: ',i4,3x,
     1      'Julian day: ',i3,3x,'Hour: ',i2/
     1           2x,'Domain-scale temp. lapse rate (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
153         format(/2x,'Diagnostic wind field data -- Year: ',i4,3x,
     1      'Julian day: ',i3,3x,'Hour: ',i2/
     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)nyr,njul,nhr
154        format(/2x,'Surface station data for wind field module -- ',
     1     'Year: ',i4,3x,'Julian day: ',i3,3x,'Hour: ',i2/5x,
     2     'Station',2x,'Station',4x,'U-CMPT',4x,'V-CMPT'/6x,'Name',
     3     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,nyr,njul,nhr
158           format(/2x,'Upper air station: ',a4,3x,'Number: ',i4,3x,
     1        'Year: ',i4,3x,'Julian day: ',i3,3x,'Hour: ',i2/8x,
     2        'Level',3x,'U-CMPT',3x,'V-cmpt'/17x,'(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
         sinalp2(i,j) = sinalp(i,j,nhrind)
      end do
      end do
      ihr2gmt=nhr+ibtz

c --- compute diagnostic winds
c --- also return the array of surface temperatures using nearest
c --- surface station or prognostic data for later use (ISFCMET)
      call diagno(nhrz,nhrind,gamma,beta2,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(sinalp(1,1,nhrind),nears,temp2d,icc,ilandu,iwat1,
     1               iwat2,nx,ny,icloud,ccgrid,qh,qsw)
      elseif(isfcmet.EQ.1) then
c ---    Use 2D temperature array of either nearest station temperature
c ---    or prognostic temperature
         call heatfx(sinalp(1,1,nhrind),nears,tsfnsp,icc,ilandu,iwat1,
     1               iwat2,nx,ny,icloud,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
         call radflx(icloud,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
      if (itwprog.eq.2) then
         call waterp(u,v,imixh,qsw,qlw,dcoast,zmid(1),ilandu,iwat1,
     &           iwat2,nx,ny,dgrid,fcori,nhrz,z0)
      else
         call water(u,v,imixh,qsw,qlw,dcoast,zmid(1),ilandu,iwat1,iwat2,
     &           nx,ny,dgrid,fcori,nhrz,z0)
      endif
c
c --- compute PGT stability class  *** LAND CELLS ***
      call pgtstb(u,v,nears,icc,iceil,sinalp(1,1,nhrind),ilandu,
     1 iwat1,iwat2,nx,ny,icloud,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)nyr,njul,nhr,rho(1,1),qsw(1,1)
172      format(/2x,'Computed surface parameters -- Year: ',i2,3x,
     1   'Julian day: ',i3,3x,'Hour: ',i2,3x,'At point (1,1):',
     2   /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,
     1    iwat1,iwat2,nx,ny,icloud,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,
     1    iwat1,iwat2,nx,ny,icloud,ccgrid,ipsifcn,qh,ustar,el)
      endif
c
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)
      ihrgmt=nhr+ibtz
      if (itprog .eq. 0) then
        call mixht(el,ustar,qh,nx,ny,rho,ihrgmt,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,ihrgmt,
     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
             call temp3d(nyrz,njulz,nhrz,temp2d,ziconv,
     &                   tzgraa,tzgrbb,ztemp,zi,tprog)
          elseif(isfcmet.EQ.1) then
             call temp3d_back(nyrz,njulz,nhrz,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
            call outhr(ndathr,nx,ny,nz,npsta,irtype,rho,qsw,
     1                 iomet,lcalgrd,temp2d,irh2d,ipcode2d)
         else if(iformo.eq.2)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 (070619)
c      if(icloud.eq.1)call outcld(ndathr,nx,ny,nssta,icc,nears,
c     1  iformc,ccgrid)
800   continue
c
900   continue
c
c --- set hour for next pass through day loop
      nhr=-1
1000  continue
c
1001  continue
      return
      end
c----------------------------------------------------------------------
      subroutine diag2(nssta,nowsta,chowsta,xowsta,yowsta)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         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: 5.8         Level: 050328                  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.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
c
c --- DIAGI  called by:  SETUP
c --- DIAGI  calls:      TERSET
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
c frr(12/96)      real zface(nz2+1),zmid(nz2)
      real elev(mxnx,mxny),z0(mxnx,mxny)
c      real xssta(mxss),yssta(mxss),xusta(mxss),yusta(mxss)
c      character*4 csnam(mxss),cunam(mxss)
      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
c ---    factor of 1 convert to array index, 0.5 rounds to nearest pt
         iiupt=xusta(iupt)/dgrid+1.5
         jjupt=yusta(iupt)/dgrid+1.5
c
         if(iiupt.lt.1)iiupt=1
         if(iiupt.gt.nx)iiupt=nx
         if(jjupt.lt.1)jjupt=1
         if(jjupt.gt.ny)jjupt=ny
      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,beta2,um,vm,nowsta,zowsta,
     &        itwprog,zlogwsta,ziconv,tsfnsp,tprog,vptprog,
     &        ccgrid,iceilg,rho)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070623               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 --- v5.731 Level 070619 to v5.8      Level 070623
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 --- v5.720 Level 060315 to v5.731 Level 070619(F.Robe)
c        - Pass on observed ceiling height iceil(mxss) and icloud
c          to RADFLX
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 --- V5.711 Level 060106 to v5.720 Level 060315(F.Robe)
c     -  Remove internal debug write(66,*) statements
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   : sinalp,nhrind
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)

      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 --- BEGIN SIMULATION
c --- 070619- 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
      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)
      elseif(iprog.eq.4)then
         call rdmm4(cellzc,udat,vdat,uprog,vprog,
     1              mhr,mjul,myr,tprog,vptprog,
c frr 030119: NOOBS - MM4
     2              icloud,ccgrid,iceilg,rho,npsta)

c --- Must define GAMMA and BETA2 if using only MM4 data or if using prog T
c     (currently an average over whole domain)
c *** NOTE: in future, this may be replaced with forced read to DIAG.DAT
c FRR (9/2001) additional option for noobs and itprog
c         if (noobs .eq. 1) then
         if (itprog.ge.1) then
c frr (09.01)
c           call cgamma2(tprog,ziconv,gamma)
           call cgamma2(tprog,ziconv,gamma,itprog)
c --- Store the sign of GAMMA in BETA2
           IF (GAMMA .LT. 0.) BETA2 = 1.
           IF (GAMMA .EQ. 0.) BETA2 = 0.
           IF (GAMMA .GT. 0.) BETA2 = -1.
         end if
      elseif(iprog.eq.14)then
c frr (09/01) prognostic air density (rho),precip flag(npsta),cloud
c        call rdmm5(cellzc,udat,vdat,uprog,vprog,
c    1              mhr,mjul,myr,tprog,vptprog)

         call rdmm5(cellzc,udat,vdat,uprog,vprog,mhr,mjul,myr,
     1              tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta,
     2              itwprog)

c --- Must define GAMMA and BETA2 if using prog T
c     (currently an average over whole domain)
c *** NOTE: in future, this may be replaced with forced read to DIAG.DAT
c FRR (9/2001) additional option for noobs and TINf from MM5
c         if (noobs .eq. 1) then
         if (itprog .ge. 1) then
c           call cgamma2(tprog,ziconv,gamma)
           call cgamma2(tprog,ziconv,gamma,itprog)
c --- Store the sign of GAMMA in BETA2
           IF (GAMMA .LT. 0.) BETA2 = 1.
           IF (GAMMA .EQ. 0.) BETA2 = 0.
           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 ---- 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,TINF,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,TINF,CRITFN,
     1                   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 --- 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 --- Fill in 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 --- 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(sinalp(1,1,nhrind),nears,temp2d,icc,ilandu,iwat1,
     1               iwat2,nx,ny,icloud,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,
     2               nx,ny,icloud,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(sinalp(1,1,nhrind),nears,tsfnsp,icc,ilandu,iwat1,
     1               iwat2,nx,ny,icloud,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,
     2               nx,ny,icloud,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
C frr (5/97): option to turn off the slope flows
      if (ISLOPE.EQ.1)CALL SLOPE(USLOPE,VSLOPE,HTOPO,TINF,HMAX)
c -frr(12/96)--  CALL SLOPE(USLOPE,VSLOPE,HTOPO,BETA2,TINF,
c    1           HMAX,GAMMA)
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 iextrp=4 otherwise also done for iextrp=1 (070619)
      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
           call radflx(icloud,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
c
        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,
     &                icloud,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,
     &                icloud,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)
      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)
         call rdmm4(cellzc,udat,vdat,uprog,vprog,
     1              mhr,mjul,myr,tprog,vptprog,
c frr 030119: NOOBS - MM4
     2              icloud,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 frr (09/01) prognostic air density (rho),precip flag,cloud
c        call rdmm5(cellzc,udat,vdat,uprog,vprog,
c     1              mhr,mjul,myr,tprog,vptprog)
         call rdmm5(cellzc,udat,vdat,uprog,vprog,mhr,mjul,myr,
     1              tprog,vptprog,icloud,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)
         call rdmm4(cellzc,udat,vdat,uprog,vprog,
     1              mhr,mjul,myr,tprog,vptprog,
c frr 030119: NOOBS - MM4
     2              icloud,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 frr (09/01)prognostic air density (rho),precip flag,cloud
c        call rdmm5(cellzc,udat,vdat,uprog,vprog,
c     1              mhr,mjul,myr,tprog,vptprog)
         call rdmm5(cellzc,udat,vdat,uprog,vprog,mhr,mjul,myr,
     1              tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta
     2              ,itwprog)
      endif

      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
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: 5.8         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: 5.8         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,
     1 iwat1,iwat2,nx,ny,icloud,ccgrid,ipsifcn,qh,ustar,el)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070623                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   - v5.612 (051214) to v5.8      (070623)
c          - add new control variable IPSIFCN to select call to PSIU
c            functions
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               ICLOUD - 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 ICLOUD=2,3)
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
c frr (01/09) new option icloud=3
c      if(icloud.eq.2)then
      if(icloud.eq.2 .or. icloud.eq.3)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,
     &     icc,iupt,icloud,itprog,ccgrid,zi,temp,rho,ipsifcn)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070623               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 --- V5.731 (070619) to v5.8      (070623)
c            - add new control variable IPSIFCN to select call to PSIU
c              functions
c
c --- V5.727 (061206) to V5.731 (070619)(F.Robe)
c            - Remove ldbhr from calling lists to MIXHTST and MIXHST2
c              (was not defined)
c
c --- V5.612 (051214) to V5.727 (061206) (F.Robe)
c            - Bug fix: properly update gridded cloud cover when icloud=3
c              under stable conditions (Affect the computation of
c              u*,el,Zi, etc)
c
c --- V5.6 (040830) to V5.612 (051214) (DGS)
c            - Use double precision argument for PSIUD
c
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                 ICLOUD - integer    - Flag indicating if gridded
c                                       cloud data are available
c                                       (2,3=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 ICLOUD=2,3)
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               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
c frr (09/01) new option icloud=3
c      if(icloud.eq.2)then
      if(icloud.eq.2 .or. icloud.eq.3)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 --- bug fix (061206)
c      if(icloud.eq.2)then
      if(icloud.eq.2 .or.icloud.eq.3)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: 5.8         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: 5.8         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: 5.8         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: 5.8         Level: 030402                     FIN
c ---          J. Scire, Earth Tech, Inc.
c
c --- PURPOSE:  Run termination routine -- compute runtime,
c               write last day processed
c
c --- UPDATE
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----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
      character*8 rtime2
      character*10 rdate2
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(nhr.EQ.-1)then
            nhr=0
            call indecr(io6,nyr,njul,nhr,-1,0,23)
            call grday(io6,nyr,njul,nmo,nday)
         endif
c
         write(io6,5)nyr,nmo,nday,njul,nhr
5        format(//2x,'LAST DAY/HOUR PROCESSED:'/5x,'Year: ',i4,2x,
     1   'Month: ',i2,3x,'Day: ',i2,3x,'Julian day: ',i3,3x,'Hour: ',
     2   i2)
      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
      write(io6,1402)rtime2,rdate2,delt,rcpu
1402  format(//2x,'End of run -- Clock time: ',a8/
     1         2x,'                    Date: ',a10//
     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: 5.8         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,tinf,critfn,cellzb,
     1                  hmax)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 970825                   FRADJ
c              S.DOUGLAS, SAI
c              Modified by J. Scire
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'
c --- explicit d6 common replaced by include 'd6.met'
      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,irdp
      DIMENSION U(mxnx,mxny,*), V(mxnx,mxny,*),
     1          HTOPO(mxnx,*), HMAX(mxnx,*), CELLZB(mxnzp1)
C
C     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     TOWRD THE OBSTACLE, THE U AND V WIND COMPONENTS ARE
C     ADJUSTED.
C
C     INPUT:  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)       - TEMPERATURE LAPSE RATES
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     OUTPUT:  U (R ARRAY) - ADJUSTED X-DIRECTION WIND COMPONENTS
C              V (R ARRAY) - ADJUSTED Y-DIRECTION WIND COMPONENTS
C
C     COMPUTE THE STABILITY PARAMETER
C
      TAU=-0.01
      GAMMA2=GAMMA - TAU
C
C     MELSAR FROUDE NUMBER ADJUSTMENT
C
      RPD=0.017453
      DPR=57.296
      DO 100 J=1,NY
      DO 100 I=1,NX
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
      IF (ABS(DELHI) .LT. 0.00015 .AND. ABS(DELHJ) .LT. 0.00015) THEN
        DELHI = 0.
        DELHJ = 0.
      ENDIF
C
      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/TINF)**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: 5.8         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: 5.8          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 Z04,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,
     1                  nx,ny,icloud,ccgrid,qh,qsw)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 951021                  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: 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               ICLOUD - 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 ICLOUD=2,3 )
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
         if(icloud.eq.2 .or. icloud.eq.3)then
c ---       use gridded cloud data (2:from cloud.dat - 3: 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

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: 5.8         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: 5.8          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: 5.8         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: 5.8         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: 5.8         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: 5.8         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
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         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 --- V5.6 (050328) to v5.715 (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 --- 000602b to V5.6 (050328) - F.Robe
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)

      twodte=7200.*conste
      onedte=3600.*(1.+conste)
c
      return
      end
c----------------------------------------------------------------------
      subroutine minim(u,v,w,ub,vb,div,niter,divlim)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 050328                   MINIM
c ---          S.DOUGLAS, SAI
C
c
c --- UPDATES:
c --- V5.6 (050328)- explicit common replaced by include 'd6.met'
c
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: 5.8         Level:  050328                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---  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),icloud
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
      if(iceil(i).ge.imiss. and. icloud.ne.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
      if(icc(i).ge.imiss .and. icloud.ne.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: 5.8         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: 5.8         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)
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

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: 5.8.4       Level: 130731                 MIXHT
c              EPA
c
c ---          Version: 5.8         Level: 051113                  
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     v5.611 (051113) to V5.8.4 Level 130731 (EPA)
c        - Corrected an error in cases where are several upper air 
c          stations, the station selected for the computation of the
c          lapse rate (IUPT) was not necessarily the used to compute the
c          lapse rate at the top of the boundary layer or the computation
c          of the Batchvarova-Gryning mixing height
c     V5.6 (050328) to v5.611 (051113)- (FRR)
c        - Remove zimin from calling list to MIXHMC
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)
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
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.
      jorder = justa(iupt)
      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 hour's convective mixing ht.
      htold=ziconv(i,j)
      nlev=nlbb(iupt)
      call mixdt(ihrgmt,i,j,iupt,htold,nlev,zlbb,tzbb,dptmin,dzzi,
     1    tht,thtp,dtheta)

      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height
         call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzbb(iupt,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)
      nlev=nlaa(iupt)
      call mixdt(ihrgmt,i,j,iupt,htold,nlev,zlaa,tzaa,dptmin,dzzi,
     1 tht,thtp,dtheta)

      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height
         call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzaa(iupt,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: 5.8.4       Level: 130731               MIXHTST
c              EPA
c
c ---          Version: 5.8         Level: 070619             
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     v5.611 (051113) to V5.8.4 Level 130731 (EPA)
c        - Corrected an error in cases where are several upper air 
c          stations, the station selected for the computation of the
c          lapse rate (IUPT) was not necessarily the used to compute the
c          lapse rate at the top of the boundary layer or the computation
c          of the Batchvarova-Gryning mixing height
c --- v5.611 (051113) to V5.731 (070619)- (FRR)
c        - Remove ldbhr from calling list (was not defined) and include
c          outpt.met where ldbhr is now defined
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
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                 IUPT - integer  - Upper air station to use for
c                                        computing the domain-scale
c                                        lapse rate
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,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 - 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'
      include 'outpt.met'
      include 'grid.met'
c
      character*70 messag
      logical ldate
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.
      jorder = justa(iupt)
      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
      nlev=nlbb(iupt)
      call mixdt(ihrgmt,i,j,iupt,htold,nlev,zlbb,tzbb,dptmin,dzzi,
     1 tht,thtp,dtheta)

      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height
         call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzbb(iupt,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
      nlev=nlaa(iupt)
      call mixdt(ihrgmt,i,j,iupt,htold,nlev,zlaa,tzaa,dptmin,dzzi,
     1 tht,thtp,dtheta)
c

      if(abs(imixh).eq.2) then
c ---    Batchvarova-Gryning convective mixing height
         call MIXHBG (ihrgmt,I,J,WT,DTHETA,tzaa(iupt,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: 5.8         Level: 070619              MIXHT2
c ---
c               F.Robe (09/2001)
c               Based on MIXHT (J. Scire, SRC)
c
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 v5.731 (070619)
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)  - 070619
      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 --- 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: 5.8         Level: 070619            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 --- v5.725 (060525) to V5.731 (070619)- (FRR)
c        - Remove ldbhr from calling list (was not defined) and include
c          outpt.met where ldbhr is now defined
c        - HTOLD uses last zi even if less than zimin
c
c --- v5.6 (050328) to v5.725 (060525) - (DGS)
c             - Add GRID.MET to provide nx,ny for OUT call
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               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'
      include 'grid.met'
      include 'outpt.met'
c
      character*70 messag
      logical 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 --- 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 hour convective mixing height
c     htold=max(ziconv,zimin)  --- 070619
      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: 5.8         Level: 060305                     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 --- UPDATES
c --- v5.718 Level 060305 to v5.722 Level 060322
c --- Modifications by F.Robe
c          (1) Add check for negative log arguments and replace zeta2 estimate
c              by average value if necessary
c
c --- V5.716 Level 060301 to v5.718 Level 060305(F.Robe)
c          (1) Replace Tk by dummy variable tsf in call do mixdt2 otherwise
c              mixdt2 overwrites Tk with MM5 surface temperature (not ok for
c              all options e.g. overwater)
c --- V5.6 Level 050328 to V5.716 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          (2) Make sure to compute tht,thtp (ilapse=1) even if no mixing
c              height growth.
c
c --- INPUTS:
c               IHRGMT - real     - GMT hour
c              (IS,JS) - integer  - CALMET gridpoints
c
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) (must be an input as only
c                                   overland value zimax stored in ziparm.met and mixhbg
c                                   can also be called overwater)
c                ZIMN - REAL      - Minimum mixing height (m) (must be an input as only
c                                   overland value zimin stored in ziparm.met and mixhbg
c                                   can also be called overwater)
c                USTAR - REAL     - Ustar (m/s)
c                   EL - REAL     - Monin-Obuknov length (m)
c             ZICBGOLD - real     - Previous hour mixing height (mechanical or
c                                   convective overwater, convective overland)
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
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'

      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 --- 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

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=3600.
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

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)
        write(6,*)'neg2',zeta2,zetap2
        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,
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: 5.8         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: 5.8        Level: 060301                 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 --- V5.7 (051230) to V5.716 (060301) - F.Robe
c        - Check whether to compute mixing height growth based on net
c          buoyancy flux (i.e. take threshold into account)
c        - Compute tht,thtp (ilapse=1) for all cases (needed later)
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 mixing height (convective
c                                   overland, conv. or mech. overwater) (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
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'

      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 --- Only compute if net positive buoyancy flux
      if ((wt-wto).le.0) then
         zic=0.
         return
      endif

c --- Constant twodte is 2.*dt*conste, where dt=3600. seconds
      twodte=2.*3600.*conste
      unsqrt=gamma*twodte*(wt-wto)
      unsqrt=amax1(unsqrt,0.0)
      dpttp1=sqrt(unsqrt)

c --- Constant onedte is dt*(1.+conste), where dt=3600. seconds
      onedte=3600.*(1+conste)
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: 5.8         Level: 041010                  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 --- 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
c       Common block /MET1/
c             iforms, iformp, nusta, npsta, noobs, icloud, 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')
         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)
      if(icloud.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
      else if(icloud.eq.2)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: 5.8         Level: 991104                     OUT
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write a gridded field of real or integer numbers
c
c --- UPDATE
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:
c          NYR, NMO, NDAY, NJUL, NHR  - (Used only if LDATE=.true.)
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
      if(ldate)write(io6,94)messag,nyr,nmo,nday,njul,nhr
      if(.not.ldate)write(io6,95)messag
      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
      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/)
      if(.not.ldate)write(io6,95)messag
95    format(/1x,a70/)
      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
      if(ldate)write(io6,94)messag,nyr,nmo,nday,njul,nhr
      if(.not.ldate)write(io6,95)messag
      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: 5.8         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: 5.8         Level: 050128                   OUTHD
c ---          J. Scire, Earth Tech, Inc.
c
c --- PURPOSE:  Write header records to CALMET output file
c
c --- UPDATES:
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         ibyr,ibmo,ibdy,ibhr,ibtz,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.0'/
      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
      do i=1,8
         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
      CLOSE(iox)
c
c --- record #NCOM+3 - run control parameters -- 37 words
      write(iomet) ibyr,ibmo,ibdy,ibhr,ibtz,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)
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)
         clabel='YSSTA'
         call wrtr1d(iomet,yssta,nssta,clabel,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)
         clabel='YUSTA'
         call wrtr1d(iomet,yusta,nusta,clabel,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)
         clabel='YPSTA'
         call wrtr1d(iomet,ypsta,npsta,clabel,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)
c
c --- record #NCOM+12 - land use categories (NX * NY words)
      clabel='ILANDU'
      call wrti2d(iomet,ilandu,xbuf,mxnx,mxny,nx,ny,clabel,idum)
c
c --- record #NCOM+13 - elevations (NX * NY words)
      clabel='ELEV'
      call wrtr2d(iomet,elev,xbuf,mxnx,mxny,nx,ny,clabel,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)
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)
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine surfvar(u,v,tprog,temp2d,irh2d,ipcode2d,iall)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8.4       Level: 130731               SURFVAR
c              EPA
c
c ---          Version: 5.8         Level: 070619      
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
c --- UPDATES:
c      V5.731 (070619) to v5.8.4 (130731) (EPA)
c       - Set overwater RH default to 100% when there is no sea.dat
c         file (MCB-E)
c       - In NOOBS mode and temperature mode = 2, define variables to
c         initialize surface temperatures at the first timestep (MCB-E)
c      V5.6b Level 050412 to V5.731 (070619)(F.Robe)
c       - Add option iall=2 to skip temperature averaging
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
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          IRHPROG(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/irhprog(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
        if ( itprog .eq. 2 ) then
           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 noobs=2
      if (noobs.eq.2) then
         do i=1,nx
            do j=1,ny
               irh2d(i,j)    = irhprog(i,j)
               if (npsta.ne.0) ipcode2d(i,j) = ipcodepg(i,j)
            end do
         end do
         goto 999
      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
c ---      80% overland and 100% overwater
           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
c

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

999   return
      end

c----------------------------------------------------------------------
      subroutine outhr(ndathr,nx,ny,nz,npsta,irtype,rho,qsw,
     1                 iomet,lcalgrd,temp2d,irh2d,ipcode2d)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 901130                   OUTHR
c ---          J. Scire, SRC
c              modified by F.Robe, Earth Tech
c             (2D RHO,QSW,IPCODE,RH,TEMP)
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 --- INPUTS:
c        NDATHR - integer     - Date and hour (YYYYJJJHH) in LST
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:      WRTI1D, WRTI2D, WRTR1D, WRTR2D
c----------------------------------------------------------------------
c
c --- include parameters
      include 'params.met'
c
c frr (09/01) - 2D arrays of RHO, QSW, IPCODE, RH, SF TEMP
c     real rho(mxss),qsw(mxss),xbuf(mxnx,mxny)
      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'
c  frr (09/01) no need for common block MET2 as 2D values of T,RH,IPCODE
c      include 'met2.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,ndathr)
c
      clabel(1:1)='V'
      call wrtr2d(iomet,v(1,1,i),xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
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,
     1   ndathr)
      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,
     1   ndathr)
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,ndathr)
c
      clabel='USTAR'
      call wrtr2d(iomet,ustar,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
c
      clabel='ZI'
      call wrtr2d(iomet,zi,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
c
      clabel='EL'
      call wrtr2d(iomet,el,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
c
      clabel='WSTAR'
      call wrtr2d(iomet,wstar,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
c
      clabel='RMM'
c frr (09/01)- rmm if npsta=-1 (MM5 data)
c      if(npsta.gt.0)call wrtr2d(iomet,rmm,xbuf,mxnx,mxny,nx,ny,
c     1 clabel,ndathr)
      if(npsta.ne.0 )
     : call wrtr2d(iomet,rmm,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)

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,ndathr)
c
      clabel='RHO'
      call wrtr2d(iomet,rho,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
c
      clabel='QSW'
      call wrtr2d(iomet,qsw,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
c
      clabel='IRH'
      call wrti2d(iomet,irh2d,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
c
      clabel='IPCODE'
c      if(npsta.gt.0)
c     :  call wrti2d(iomet,ipcode2d,mxnx,mxny,nx,ny,clabel,ndathr)
cBUG FIX 07/10/02      if(npsta.ne.0)
c     :  call wrti2d(iomet,ipcode2d,xubf,mxnx,mxny,nx,ny,clabel,ndathr)
      if(npsta.ne.0)
     :  call wrti2d(iomet,ipcode2d,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)

cc --- write 1-D meteorological fields -- Air temp. (deg. K),
cc       Air density (kg/m**3), Short-wave solar radiation (W/m**2),
cc       Relative humidity (percent), Precipitation code
c      if(nssta.ge.1)then
c         clabel='TEMPK'
c         call wrtr1d(iomet,tempk,nssta,clabel,ndathr)
cc
c         clabel='RHO'
c         call wrtr1d(iomet,rho,nssta,clabel,ndathr)
cc
c         clabel='QSW'
c         call wrtr1d(iomet,qsw,nssta,clabel,ndathr)
cc
c         clabel='IRH'
c         call wrti1d(iomet,irh,nssta,clabel,ndathr)
cc
cc ---    NOTE: ipcode is dimensioned NSSTA not NPSTA
c         clabel='IPCODE'
c         if(npsta.gt.0)call wrti1d(iomet,ipcode,nssta,clabel,ndathr)
c      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine pack(nvals,xdata,nwords,xbuf)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         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,
     1 iwat1,iwat2,nx,ny,icloud,ccgrid,iceilg,ipgt)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 951021                  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 --- 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               ICLOUD - 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 ICLOUD=2,3)
c    ICEILG(mxnx,mxny) - int array     - Gridded ceiling height
c                                        (Used only if ICLOUD=3)
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
      if (icloud.eq.3) then
         jceil=iceilg(i,j)
      else
         jceil=iceil(nsta)
      endif

c --- calculate insolation category & pgt stability class
c frr (09/01)
c      if(icloud.eq.2)then
      if( icloud.eq.2 .or. icloud.eq.3 )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,nssta,
     1 nusta,nz,nhr,nyrz,njulz,nhrz,ziconv,gamma,beta2,um,vm,wt,
     2 us,vs,nowsta,wsow,wdow,noobs)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070619                 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
c --- V5.6 (050328) to V5,731 (070619) (F.Robe)
c     - Initialize um,vm
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                NSSTA - integer    - Number of surface land stations
c                NUSTA - integer    - Number of upper air stations
c               NOWSTA - integer    - Number of over water stations
c                   NZ - integer    - Number of vertical grid layers
c                  NHR - integer    - Hour (LST) in "IBTZ" time zone
c                 NYRZ - integer    - Year of current hour (GMT)
c                NJULZ - integer    - Day of current hour (GMT)
c                 NHRZ - integer    - Current Hour (GMT)
c    ZICONV(mxnx,mxny) - real array - Convective mixing heights (m)
c              noobs - integer    - Flag for no NWS upper air data
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
c --- OUTPUT:
c            **  GAMMA - real       - Domain-scale temperature lapse
c                                     rate (deg. K/m)
c            **  BETA2 - real       - Flag indicating sign of GAMMA
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)
c
      CHARACTER*4 namst,LAST,IBLANK,NAM
c
      include 'd4.met'
      include 'd6.met'
c      COMMON /D4/ EDIT, EDITL, IEDIT, IEDITL
c      COMMON /D6/  IRD, IWR, IFILE, irdp
      include 'upmet.met'
      include 'wparm.met'
c
      DATA ZERO /0./, LAST /'LAST'/, IBLANK /'    '/
c
      htfac=1.0
      um=0.
      vm=0.
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
      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
c
c --- set domain-scale temperature lapse rate
      if (noobs .eq. 0) then
        if(idiopt(2).eq.0)then
c
c ---   use lapse rate from upper air station "iupt"
c**** Modified by EMI -- 4/26/94
          call cgamma(nyrz,njulz,nhrz,iupt,zupt,
     &                ziconv(iiupt,jjupt),gamma)
        else
c
c ---    read lapse rate (deg. K/km) from diagnostic data file
           READ(IRD,1030)GAMMA
1030       FORMAT(10X,8F5.1)
c
c ---    convert to deg. K/m
           GAMMA = GAMMA/1000.
        endif
C
C --- STORE THE SIGN OF GAMMA IN BETA2 ARRAY
        IF (GAMMA .LT. 0.) BETA2 = 1.
        IF (GAMMA .EQ. 0.) BETA2 = 0.
        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**** Modified by EMI -- 4/26/94
            if(jorder.gt.0) then
              call deltt(nyrz,njulz,nhrz,jbbyr,jbbday,jbbhr,jtogo)
              call deltt(jaayr,jaaday,jaahr,nyrz,njulz,nhrz,jpast)
            else
              call deltt(nyrz,njulz,nhrz,jaayr,jaaday,jaahr,jtogo)
              call deltt(jbbyr,jbbday,jbbhr,nyrz,njulz,nhrz,jpast)
            endif
c           check for negative values of jtogo or jpast
            if(jtogo.LT.0 .OR. jpast.LT.0)then
              write(io6,1089) iupwnd,nyrz,njulz,nhrz,jpast,
     1                        jtogo,jdelta,ntzaas,ntzbbs
1089         format(//1x,'ERROR IN SUBR. PREPDI -- Upper air ',
     1      'soundings do not straddle current hour for station ',i3/
     2        5x,'Current YYYYDDDHH (GMT)  ',i4,i3,i2,/
     3        5x,'GMT hours past and before soundings ',2i4/
     4        5x,'GMT hours between these soundings ',i4/
     5        5x,'GMT YYYYDDDHH codes for these soundings ',2i11)
              stop
            endif
c           double check for upper air data inconsistencies.
            if((jpast+jtogo).ne.jdelta) then
              write(io6,1090) iupwnd,nyrz,njulz,nhrz,jpast,
     1                        jtogo,jdelta,ntzaas,ntzbbs
1090        format(//1x,'ERROR IN SUBR. PREPDI -- Inconsistent ',
     1      'upper air times for station ',i3/
     2        5x,'Current YYYYDDDHH (GMT)  ',i4,i3,i2,/
     3        5x,'GMT hours past and before soundings ',2i4/
     4        5x,'GMT hours between these soundings ',i4/
     5        5x,'GMT YYYYDDDHH codes for these soundings ',2i11)
              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**** Modified by EMI -- 4/26/94
      if(jorder.gt.0) then
         call deltt(nyrz,njulz,nhrz,jbbyr,jbbday,jbbhr,jtogo)
         call deltt(jaayr,jaaday,jaahr,nyrz,njulz,nhrz,jpast)
      else
         call deltt(nyrz,njulz,nhrz,jaayr,jaaday,jaahr,jtogo)
         call deltt(jbbyr,jbbday,jbbhr,nyrz,njulz,nhrz,jpast)
      endif
c     check for negative values of jtogo or jpast
      if(jtogo.LT.0 .OR. jpast.LT.0)then
        write(io6,1089) iupwnd,nyrz,njulz,nhrz,jpast,jtogo,jdelta,
     1                  ntzaas,ntzbbs
        stop
      endif
c     double check for upper air data inconsistencies.
      if((jpast+jtogo).ne.jdelta) then
         write(io6,1090) j,nyrz,njulz,nhrz,jpast,jtogo,jdelta,
     1                   ntzaas,ntzbbs
         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.  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=nhr
      if(iwr.gt.0)then
         WRITE(IWR,2240) TIME, nhr
 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)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070128                PROGRD
c              S.DOUGLAS, SAI
c ---          Modified by J. Scire 9/30/90
c
c --- UPDATES:
c
c --- V5.729 (050328) to V5.730 (070128) (FRR)
c     - Accept both midnight conventions for CSUMM time (Hour 0 or Hour 24)
c
c --- V5.6 (050328-FRR) explicit common replaced by include d4/d6.met
c
c
c --- include parameters
      include 'params.met'
      include 'grid.met'
      include 'd4.met'
      include 'd6.met'

      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
c --- Minimum distance (km) in 1/r**2 interpolation
      data rmin/0.001/
c ***
c *      character*70 messag
c *      logical ldate
c ***
C
C
C     THIS SUBROUTINE READS AND INTERPOLATES THE PROGNOSTIC MODEL
C     OUTPUT TO THE DIAGNOSTIC MODEL GRID
C
C     INPUTS:   UP (R ARRAY)   - U-COMPONENT OF THE PROGNOSTIC WIND FIELD
C               VP (R ARRAY)   - V-COMPONENT OF THE PROGNOSTIC WIND FIELD
C               NXP (I)        - NO. OF PROGNOSTIC MODEL GRID POINTS IN THE
C                                X-DIRECTION
C               NYP (I)        - NO. OF PROGNOSTIC MODEL GRID POINTS IN THE
C                                Y-DIRECTION
C               NZP (I)        - NO. OF PROGNOSTIC MODEL LEVELS
C               DXKP (R)       - PROGNOSTIC MODEL GRID SPACING
C               UTMXOP (R)     - UTM_EASTING ORIGIN OF THE PROGNOSTIC MODEL
C                                GRID
C               UTMYOP (R)     - UTM_NORTHING ORIGIN OF THE PROGNOSTIC
C                                MODEL GRID
C               CELLZC(R ARRAY)- DIAGNOSTIC WIND MODEL CELL-CENTER HEIGHTS
C               TIME (R)       - SIMULATION TIME
C               IRDP (I)       - UNIT NUMBER FOR PROGNOSTIC MODEL OUTPUT
c        Parameters: MXNX, MXNY, MXNZ, MXNXP, MXNYP, MXNZP, IO6
C
C     OUTPUTS:  UPROG (R ARRAY)- INTERPOLATED U-COMPONENT OF THE PROGNOSTIC
C                                WIND FIELD
C               VPROG (R ARRAY)- INTERPOLATED V-COMPONENT OF THE PROGNOSTIC
C                                WIND FIELD
C
C     READ PROGNOSTIC MODEL OUTPUT
C
   30 READ(IRDP) TIMEH
c *     write(io6,*)
c *     write(io6,*)'TIMEH = ',timeh
      ITIME = TIMEH * 100

c --- 070128: CALMET midnight convention: hour 0 - original CSUMM midnight: hour 24
c --- For time comparison furtherdown, use CSUMM midnight =0 if not already the case
c
      If (itime.eq.2400) itime=0

      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

      IT = TIME

c     write(6,*)'CALMET: ',it,' - CSUMM:',itime

      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
  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)
c ---------------------------------------------------------------------
c
c       Sorts an aray ARR of length N into ascending numerical order using
c       Quicksort algorithm.  N is input; ARR is replaced on output by its
c       sorted rearrangement.
c -----------------------------------------------------------------
c       Modified to sort 3 arrays   EMI  9/11/92
c       Modified to sort 5 arrays   MEF 11/01/94
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)
      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)
          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)
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
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)
        ARR(IQ)=ARR(L)
        arr2(IQ)=arr2(L)
        arr3(IQ)=arr3(L)
        arr4(IQ)=arr4(L)
        arr5(IQ)=arr5(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
            GO TO 30
          ENDIF
          ARR(I)=ARR(J)
          arr2(I)=arr2(J)
          arr3(I)=arr3(J)
          arr4(I)=arr4(J)
          arr5(I)=arr5(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
            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)
          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,ibyr,ibjul,ibhr,ieyr,iejul,iehr,ibtz,
     1                nsta,ipack,idsta,anem,cname,rnlat,relon,maxs,
     2                clat,clon,datum,lstnloc)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 031215                    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 --- UPDATE
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              IBYR - integer    - Beginning year of data (4 digits)
c             IBJUL - integer    - Beginning Julian day number
c              IBHR - integer    - Beginning hour
c              IEYR - integer    - Ending year of data (4 digits)
c             IEJUL - integer    - Ending Julian day number
c              IEHR - integer    - Ending hour
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       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
      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
            read(io) ibeg,iend,ibtz,nsta,ipack
            read(io) (idsta(n),n=1,nsta)
            write(io6,*)ibeg,iend,ibtz,nsta,ipack
            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) xyunit
            read(io) ibeg,iend,ibtz,nsta,ipack
            write(io6,'(a8,a10)') datum,daten
            write(io6,'(a4)') xyunit
            write(io6,'(2i12,i4,i12,i4)')ibeg,iend,ibtz,nsta,ipack
c ---       To scratch file
            write(iox,'(a8,a10)') datum,daten
            write(iox,'(a4)') xyunit
            write(iox,'(2i12,i4,i12,i4)')ibeg,iend,ibtz,nsta,ipack
            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 starting and ending dates
         call dedat(ibeg,ibyr,ibjul,ibhr)
         call dedat(iend,ieyr,iejul,iehr)
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
            read(io,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,ibtz,nsta
            read(io,*)(idsta(n),n=1,nsta)
            write(io6,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,ibtz,nsta
            write(io6,*)(idsta(n),n=1,nsta)
c ---       To scratch file
            write(iox,'(7i5,i12)')ibyr,ibjul,ibhr,ieyr,iejul,iehr,
     &                            ibtz,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
            read(io,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,ibtz,nsta
            write(io6,'(a8,a10)') datum,daten
            write(io6,'(a4)') xyunit
            write(io6,*)ibyr,ibjul,ibhr,ieyr,iejul,iehr,ibtz,nsta
c ---       To scratch file
            write(iox,'(a8,a10)') datum,daten
            write(iox,'(a4)') xyunit
            write(iox,'(7i5,i12)')ibyr,ibjul,ibhr,ieyr,iejul,iehr,
     &                            ibtz,nsta
            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

      call YR4(io6,ibyr,ierrb)
      call YR4(io6,ieyr,ierre)
      if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in RDHD'

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,ibyru,ibjulu,ibhru,ieyru,iejulu,
     1                 iehru,ptop,jdat,ifmt,lht,ltemp,lwd,lws,
     2                 idstn,cname,rnlat,relon,elevm,datum,
     3                 lstnloc)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 031215                   RDHDU
c ---          J. Scire, SRC
c
c --- PURPOSE:  Read a set of upper air header records
c
c --- UPDATE
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                IBYRU - integer    - Beginning year of data (GMT)
c               IBJULU - integer    - Beginning Julian day of data (GMT)
c                IBHRU - integer    - Beginning hour of data (GMT)
c                IEYRU - integer    - Ending year of data (GMT)
c               IEJULU - integer    - Ending Julian day of data (GMT)
c                IEHRU - integer    - Ending hour of data (GMT)
c                 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                 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
      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
            read(io,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
            read(io,124)lht,ltemp,lwd,lws
            write(iolst,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
            write(iolst,124)lht,ltemp,lwd,lws
c ---       To scratch file
            write(iox,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                    ptop,jdat,ifmt
            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
            read(io,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
            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,'(a8,a10)') datum,daten
            write(iolst,'(a4)') xyunit
            write(iolst,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                  ptop,jdat,ifmt
            write(iolst,124)lht,ltemp,lwd,lws
            write(iolst,*) idstn,cname,clat,clon,ielevm
c ---       To scratch file
            write(iox,'(a8,a10)') datum,daten
            write(iox,'(a4)') xyunit
            write(iox,122)ibyru,ibjulu,ibhru,ieyru,iejulu,iehru,
     &                    ptop,jdat,ifmt
            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 --- Check year format
      call YR4(iolst,ibyru,ierrb)
      call YR4(iolst,ieyru,ierre)
      if(ierrb.NE.0 .OR. ierre.NE.0) stop 'Halted in RDHDU'

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)
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: 5.8       Level: 060202                 RDHDOW
c ---          D. Strimaitis, Earth Tech, Inc.
c
c --- PURPOSE:  Read a set of overwater header records
c
c --- UPDATES:
c
c --- v5.614 (051228) to v5.71 (060202)
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: 5.8.4       Level: 130731                 RDHD4
c              EPA
c
c ---          Version: 5.8         Level: 060213                
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 --- V5.712 (060213) to V5.8.4 Level 130731 (EPA)
c        - Added check to make sure the CALMET grid is located within the
c          prognostic grid (MCB-G)
C        - When precipitation is interpolated from prognostic precipitation,
c          added code for the user-defined SIGMAP to be checked against 
c          the prognostic gridsize (MCB-G)
c
c --- V5.547 (041010) to V5.712 (060213)(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
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        Common PROGSTEP variables (to RDMM4)
c            ifirstpg,nfm3d
c
c --- RDHD4 called by:  READHD
c --- RDHD4 calls:      JULDAY, INCR, YR4, GLOBE1, GLOBE
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'
c --- explicit common replace by include d6.met
      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,IRDP
c
      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 (110421)
      real*8 xc(4),yc(4)

c --- MM4 corner points (defining MM4 boundary)(110421)
      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 (110421)
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 ----------------------------------------------------------------
      delg = dgrid * .001
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(icloud,itwprog,dxmm5)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8.4       Level: 130731                 RDHD5
c              EPA
c
c ---          Version: 5.8         Level: 070128                 
c              F.Robe
c              Modified by J. Scire (1/99), Zhong Wu (11/00)
c                          F.Robe (09/01)
c
c --- PURPOSE: Read the header records from a MM5.DAT or 3D.DAT file
c
c --- UPDATES:
c --- V5.730 (070128) to V5.8.4 Level 130731 (EPA)
c        - Added check to make sure the CALMET grid is located within the
c          prognostic grid (MCB-G)
C        - When precipitation is interpolated from prognostic precipitation,
c          added code for the user-defined SIGMAP to be checked against 
c          the prognostic gridsize (MCB-G)
c
c --- V5.729 (060213) to V5.730 (070128)(F.Robe)
c        - Compute 4 closest ocean 3D.DAT gridpoint to ALL CALMET
c          gridpoints (not just offshore gridpoints)
c
c --- v5.56h (051113)to V5.712 (060213)(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              ICLOUD  INT     - CLOUD FLAG - IF ICLOUD=3, 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
c        Parameters:
c            MXNXP, MXNYP, MXNZP, IO6, IO20, MXNX, MXNY
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
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 (110421)
      real*8 xc(4),yc(4)

c --- MM5 corner points (defining MM5 boundary)(110421)
      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.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
         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)then
c
c ---    Data is in new 3D.DAT format (dataset version 2.0 or
c ---    later)
         call rdhd53(nfm3d,itwprog)

      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 --------------------------------------------------------
c --- Print first and last lat/lon values to the list file
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
c ----------------------------------------------------------------------
c --- Ensure that the CALMET domain is within the M3D sub-domain (110421)
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 ---------------------------------------------------------------
      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
        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-------------------------------------------------------------------
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 (070128)
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

      if ( icloud.eq.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,*)'ICLOUD  = ',icloud
        write(io6,*)'ioutmm5 = ',ioutmm5
        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 )

      return
      end
c----------------------------------------------------------------------
      subroutine rdhd51(nfm3d)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070619               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
c --- V5.729 (070115) to V5.731 (070619) (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.728 (041010) to V5.729 (070115) (J. Scire)
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
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            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, 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 ------------------------------------------------------------------

      if(nfm3d.gt.1) then
         close(io20)
         open(io20,file=m3ddat(nfm3d),status='old')
c ---    V5.729 change (J. Scire) - do NOT skip header records
c
         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
c ----------------------------------------------------
      do 50 j=1,nyp
      do 50 i=1,nxp
c ---    Land use is in fact recorded in MM5.DAT so read it (070507)
        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
      return
      end

c----------------------------------------------------------------------
      subroutine rdhd52(nfm3d)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070619               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 --- V5.729 (070115) to V5.731 (070619) (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.728 (060318) to V5.729 (070115) (J. Scire)
c         - Read header records on 2nd, 3rd, ... 3D.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
c --- V5.6 (041010) to V5.720 (060315)(F.Robe)
c               - Assign ocean LU to zero elevation gridpoints (no land use
c                 is read from MM5 records in this format so subsitute)
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 3D.DAT 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 3D.DAT and open next 3D.DAT-
c ------------------------------------------------------------------
      if(nfm3d.gt.1) then
         close(io20)
         open(io20,file=m3ddat(nfm3d),status='old')
c
c ---    V5.729 change (J. Scire) - 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 ---    Land use is in fact recorded in MM5.DAT so read it (070507)
         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. 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
      return
      end
c----------------------------------------------------------------------
      subroutine rdhd53(nfm3d,itwprog)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070115                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.0 or later)
c
c --- UPDATES:
c
c --- V5.728 (060318) to V5.729 (070115) (J. Scire)
c         - Read header records on 2nd, 3rd, ... 3D.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
c --- V5.611 (051113) to V5.720 (060315)(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        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
      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 --- 041010 - Multiple 3D.DAT files  (Frr)-
c ------------------------------------------------------------------------
c --- Close current 3D.DAT and open next 3D.DAT-
c ------------------------------------------------------------------------
      if(nfm3d.gt.1) then
         close(io20)
         open(io20,file=m3ddat(nfm3d),status='old')
c
c ---    V5.729 change (J. Scire) - 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 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 ------------------------------------------------------------------
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 --------------------------------------
      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)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
      call incr(io6,ieyrm,iejulm,iehrm,nhrsmm5)
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)

         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, 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
      return
      end

c ---------------------------------------------------------------------
      subroutine rdhdmet
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8      Level: 070128                  RDHDMET
c              F.Robe
c
c --- PURPOSE: Read the header records from an IGF-CALMET.DAT file.
c              Check that the map projection/datum are identical
c              in IGF and current CALMET grids (no coordinate
c              transformation)
c
c --- UPDATES:
c --- v5.729 (060414) to V5.730 (070128) (FRR)
c          - Define LCALGRIDI as logical and perform tests on False/true
c            rather than 0/1.
c
c --- V5.711 (060106) to v5.724 (060414) (DGS)
c          - DATENI was not declared
c          - I2DMET was not assigned (remained at 0)
c
c
c --- INPUT:
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,DGRID,XORIGR,YORIGR
c
c --- OUTPUT:
c
c        common block /IGF/nfigf,Nigf, CELLZCi(mxnzi),
c                     IBYRi, IBJULi, IBHRi, IEYRi, IEJULi, IEHRi,
c                     NEARSi(mxnxi,mxnyi),NSSTAi,NPSTAi,JBTZi,
c                     xigf(mxnxi,mxnyi),yigf(mxnxi,mxnyi)
c                     z0i(mxnxi,mxnyi),
c                     igrabi(mxnx,mxny,4), jgrabi(mxnx,nxny4),
c                     I2DMET
c
c --- RDHDMET called by:  READHD, RDMET2
c --- RDHDMET calls: JULDAY, INCR, RDR1D, RDR2D, RDI2D
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 caction,dateni
      character*4 cigfhem
      real*8 vecti(9),vecto(9)

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

      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

      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
        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,iutmzni,
     4   rnlat0i,relon0i,xlat1i,xlat2i

      endif
c
      if(ifilver.EQ.0) then
c ---   Assign 2D flag (2D vars are NOT in this file version)
        i2dmet=0
c
c ---   Read older CALMET header records
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 ---   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:
          if ( (pmapi.ne.pmap) .or. (datumi.ne.datum)) then
              write(io6,*)' STOP in RDHDMET '
              write(io6,*)' IGF Datum and map projection do not match'
              write(io6,*)' Current datum:',datum,
     :                    ' and map projection:',pmap
              write(io6,*)' IGF datum:    ',datumi,
     :                    ' and map projection:',pmapi

             STOP' STOP in RDHDMET - Datum/map projection do not match '
          endif

c --- Convert time to beginning and ending julian dates
      call julday(io6,ibyri,ibmoi,ibdyi,ibjuli)

      ieyri=ibyri
      iejuli=ibjuli
      iehri=ibhri
      call incr(io,ieyri,iejuli,iehri,irlgi)

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,zfacei,nzi1,clabel,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,xsstai,nsstai,clabxs,idum)
      call rdr1d(io18,ysstai,nsstai,clabys,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,xustai,nustai,clabxu,idum)
      call rdr1d(io18,yustai,nustai,clabyu,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,xpstai,npstai,clabxi,idum)
      call rdr1d(io18,ypstai,npstai,clabyi,idum)
      endif
c
c --- record #11 - surface roughness lengths (NX * NY words)
      call rdr2d(io18,z0i,xbuf,mxnxi,mxnyi,nxi,nyi,clabz0,idum,ieof)
c
c --- record #12 - land use categories (NX * NY words)
      call rdi2d(io18,ilui,xbuf,mxnxi,mxnyi,nxi,nyi,clablu,idum)
c
c --- record #13 - elevations (NX * NY words)
      call rdr2d(io18,elevi,xbuf,mxnxi,mxnyi,nxi,nyi,clabte,idum,ieof)

c --- record #14 - leaf area index (NX * NY words)
      call rdr2d(io18,xlaii,xbuf,mxnxi,mxnyi,nxi,nyi,clablai,idum,ieof)
c
c --- record #15 - nearest surface station to each grid point
c                  (NX * NY words)
      if(nsstai.ge.1)then
         call rdi2d(io18,nearsi,xbuf,mxnxi,mxnyi,nxi,nyi,clabnss,idum)
      endif

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 - IGF- LCALGRDI = ',lcalgrdi
         write(io6,*)' STOP in RDHDMET'
         STOP 'STOP IN RDHDMET - Check list file'
      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
104        format(1x,'CALMET Version: ',a8,3x,'Level: ',a8)
        else
           write(io6,'(a80)') doc1
        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,*)' 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 ---   Compute IGF-CALMET (x,y) in km
c ---   Assume same projection and datum!!!

      do 50 j=1,nyi
      do 50 i=1,nxi
        xigf(i,j) = (xorigri + (i-0.5)*dgridi)*0.001
        yigf(i,j) = (yorigri + (j-0.5)*dgridi)*0.001
50    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
        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,nxi
          do jj = 1,nyi
            pdist = sqrt ((xigf(ii,jj) - xx) ** 2 +
     &                    (yigf(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
            igrabi(i,j,k) = neari(k)
            jgrabi(i,j,k) = nearj(k)
          enddo
        enddo
      enddo
      return
      end
c

c
c ---------------------------------------------------------------------
      subroutine RDCALMET(cellzc,uigf,vigf)
c ---------------------------------------------------------------------
C
c --- CALMET   Version: 5.8       Level: 060106                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 --- 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
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
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 ---   Read in IGF-CALMET data
        call rdmet2(ndathr,ibtz,up,vp)

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
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

         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,x,y,udat,k,uigf(i,j,k))
          call r2interpi(i,j,x,y,vdat,k,vigf(i,j,k))


 121     continue



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


      return
      end


c----------------------------------------------------------------------
      subroutine rdmet2(idathr,ibtz,umet,vmet)
c----------------------------------------------------------------------
c
c --- CALMET    Version: 5.8        Level: 060106                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 --- INPUTS:
c        IDATHR - integer       - Date & hour of required data
c                                 (YYYYJJJHH) in current CALMET
c                                 timezone
c         IBTZ - integer        - Current CALMET base time zone
c
c    Common block /IGFMET/ variables:
c         NXi, NYi, NZi, NEARSi, NSSTAi, NPSTAi, I2DMET,JBTZi
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,
c                        DEDAT, INCR
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 --- Express requested time in IGF-CALMET base time zone (jbtzi)
      jdathr=idathr
      call dedat(jdathr,jyr,jjul,jhr)
      idtz=ibtz-jbtzi
      call incr(io6,jyr,jjul,jhr,idtz)
      jdathr=jyr*100000+jjul*100+jhr

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

c
c --- read the U, V wind components
      kdathr=0
      do 10 iz=1,nzi
      call rdr2d(io18,umet(1,1,iz),wrk1,mxnxi,mxnyi,nxi,nyi,clabel,
     1 ndathrp1,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,umet(1,1,iz),wrk1,mxnxi,mxnyi,nxi,nyi,clabel,
     1   ndathrp1,ieof)
      endif
c
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,vmet(1,1,iz),wrk1,mxnxi,mxnyi,nxi,nyi,clabel,
     1 ndathrp2,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,wdiv(1,1,iz),wrk1,mxnxi,mxnyi,nxi,nyi,clabel,
     1              ndathrp3,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(ndathrp2.ne.ndathrp3)go to 2999
c      endif
c

c --- Check for consistency of date/time
      if(ndathrp1.ne.ndathrp2)go to 2999
      if(kdathr.eq.0)then
c ---    first vertical level
         kdathr=ndathrp1
      else if(ndathrp1.ne.kdathr)then
c ---    date/time does not match value for previous layer
         ndathrp=ndathrp1
         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,tmet(1,1,iz),wrk1,mxnxi,mxnyi,nxi,nyi,clabel,
     1    ndathrp,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(ndathrp.ne.kdathr)go to 3999
12       continue
c      endif
c

c --- read other 2-D meteorological fields
c
c --- PGT stability class
      call rdi2d(io18,ipgti,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp)
      clabexp='IPGT'
      if(clabel.ne.clabexp)go to 999
      if(ndathrp.ne.kdathr)go to 3999
c
c --- FRICTION VELOCITY
      call rdr2d(io18,ustari,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp,
     :          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(ndathrp.ne.kdathr)go to 3999
c
c --- MIXING HEIGHT
      call rdr2d(io18,zii,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp,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(ndathrp.ne.kdathr)go to 3999
c
c --- MONIN-OBUKHOV LENGTH
      call rdr2d(io18,eli,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp,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(ndathrp.ne.kdathr)go to 3999
c
c --- CONVECTIVE VELOCITY SCALE
      call rdr2d(io18,wstari,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp,
     :   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(ndathrp.ne.kdathr)go to 3999
c
c --- PRECIPITATION DATA
      if(npstai.ne.0)then
         call rdr2d(io18,rmm,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp,
     :    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,temp2d,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp,
     :          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(ndathrp.ne.kdathr)go to 3999
c
        call rdr2d(io18,rho2d,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp,
     :   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(ndathrp.ne.kdathr)go to 3999
c
        call rdr2d(io18,qsw2d,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp,
     :   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(ndathrp.ne.kdathr)go to 3999
c
        call rdi2d(io18,irh2d,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,ndathrp)
        clabexp='IRH'
        if(ieof.EQ.1) then
           write(*,*)
           stop 'RDMET2: Unexpected EOF in CALMET records'
        endif
        if(clabel.ne.clabexp)go to 999
        if(ndathrp.ne.kdathr)go to 3999
c
c ---   Precipitation code at surface stations

        if(npstai.ne.0)then
          call rdi2d(io18,ipcode2d,wrk1,mxnxi,mxnyi,nxi,nyi,clabel,
     :     ndathrp)
          clabexp='IPCODE'
          if(clabel.ne.clabexp)go to 999
          if(ndathrp.ne.kdathr)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,tempss,nsstai,clabel,ndathrp)
         clabexp='TEMPK'
         if(clabel.ne.clabexp)go to 999
         if(ndathrp.ne.kdathr)go to 3999
c
         call rdr1d(io18,rhoss,nsstai,clabel,ndathrp)
         clabexp='RHO'
         if(clabel.ne.clabexp)go to 999
         if(ndathrp.ne.kdathr)go to 3999
c
         call rdr1d(io18,qswss,nsstai,clabel,ndathrp)
         clabexp='QSW'
         if(clabel.ne.clabexp)go to 999
         if(ndathrp.ne.kdathr)go to 3999
c
         call rdi1d(io18,irhss,nsstai,clabel,ndathrp)
         clabexp='IRH'
         if(clabel.ne.clabexp)go to 999
         if(ndathrp.ne.kdathr)go to 3999
c
c ---    Precipitation code at surface stations
         if(npstai.gt.0)then
            call rdi1d(io18,ipcode,nsstai,clabel,ndathrp)
            clabexp='IPCODE'
            if(clabel.ne.clabexp)go to 999
            if(ndathrp.ne.kdathr)go to 3999
         endif

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

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

c --- Check to see if required date-time has been read
      if(kdathr.lt.jdathr)then
c ---    Obtain next time period in MET file
         go to 1
      elseif(kdathr.gt.jdathr)then
         write(io6,*)'ERROR in subr. RDMET2 -- current hour not found ',
     1   'in the MET data file -- Current date/hour = ',jdathr,
     2   ' Last date/hour read = ',kdathr
         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 -- ndathrp1 = ',ndathrp1,' ndathrp2 = ',ndathrp2,
     2 ' ndathrp3 = ',ndathrp3
      write(*,*)
      stop 'Halted in RDMET2 -- see list file.'
3999  continue
      write(io6,*)'ERROR in subr. RDMET2 -- date/time variables ',
     1 'do not match -- ndathrp = ',ndathrp,' KDATHR = ',kdathr
      write(*,*)
      stop 'Halted in RDMET2 -- see list file.'
      end


c----------------------------------------------------------------------
      subroutine rdmm4(cellzc,udat,vdat,uprog,vprog,mhr,mjul,myr,
     1 tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8.4       Level: 130731                 RDMM4
c              EPA
c
c ---          Version: 5.8         Level: 060215                  
c              E. Insley, Earth Tech, Inc.
c ---          Modified by M. Fernau, J. Scire, F. Robe (Earth Tech)
c              Modified by F. Robe, TRC
c
c --- UPDATES:
c --- v5.731 (070619) to V5.8.4 (130731) (EPA)
c      - In NOOBS mode if the simulation starts during convective
c        conditions, initialize prognostic sounding to compute the
c        convective mixing height growth (MCB-E)

c --- v5.720 (060315) to V5.731 (070619) (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 --- V5.713 (060215) to v5.720 (060315) (F.Robe)
c          - Do not use Stull night cooling overwater but extrapolate
c            down from first 2 MM4 levels
c
c --- V5.712 (060213) to V5.713 (060215)(F.Robe)
c         - Bug fix: shift sinalp time index by 1 (array index from 1-24 for
c           hour-ending 0-23)
c --- v5.611 Level 051113 to V5.712 (060213)(F.Robe)
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
c
c --- V5.6 Level 050328 to v5.611 Level 051113
c --- Modified by F.Robe
c               - Use index1 instead index+1 in call to STULL
c --- Version V5.548b Level 050113 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 --- 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               MHR   INT      - HOUR OF PROGNOSTIC DATA (LST)
C               MJUL  INT      - JULIAN DAY OF PROGNOSTIC DATA (LST)
C               MYR   INT      - YEAR OF PROGNOSTIC DATA
C
c             CCGRID  R-ARRAY  - Gridded cloud cover computed with MM4
c                                Relative humidity (if icloud=3)
c              ICEIL  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             iRHPROG 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'
c      COMMON /D4/ EDIT,EDITL,IEDIT,IEDITL
c      COMMON /D6/ IRD,IWR,IFILE,IRDP
      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/irhprog(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),
     &          rhprog(mxnx,mxny),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
c --- Initialize constants
      deg2rad=0.0174533

c --- Initialize variables (070619)
      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 --- 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
        if (mdathr .gt. ndathr) then
          write(6,*) 'MM4 data record is beyond CALMET time step-STOP'
          write(io6,*) ' MM4 data record is beyond CALMET time step: '
          write(io6,*) myr,mjul,mhr,nyr,njul,nhr,i,j,ix,jx
          stop
        endif
c
c ---   Check whether need to skip a record
        iskip = 0
        if (mdathr .lt. ndathr) 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,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 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.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) ** 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 - 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 RHand rho
            if (n.eq.1) then
              rh(i,j)=rh1
              rhop(i,j)= 0.3484321*press/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)


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)
                 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
          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
              if(LLCC)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)
            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 ---      Bug fix (060213) Use nearest CALMET gridpoint (i,j loop are on
c ---      MM4 grid at this point and sinalp is defined on CALMET grid)
c ---      Bug fix (060215) array timeindex for sinalp goes from 1-24
c ---      for hour-ending 0-23. Shift by 1 (as in CALMET)
c            if (mhr.eq.0)then
c                sina=sinalp(inearg(i,j),jnearg(i,j),24)
c             else
c                sina=sinalp(inearg(i,j),jnearg(i,j),mhr)
c             endif
           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 extrapoltion 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 ---       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 (except overwater)
              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=(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
      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
           call r2interp(i,j,x,y,rhop,1,rho(i,j))

c          Surface RH
           call r2interp(i,j,x,y,rh,1,rhprog(i,j))
           irhprog(i,j) = int(rhprog(i,j))

c          RH at 850 mb
           call r2interp(i,j,x,y,rh850,1,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 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
           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 and ceiling height
      if (icloud.eq.3) then

c ---   cloud cover from prognostic relative humidity at 850 mb
        call cloud(nx,ny,rh850pg,ccgrid)


c ---   set constant ceiling height at 8000ft
        do 138 j=1,ny
        do 138 i=1,nx
           iceilg(i,j) = 80
138     continue

      endif



      return
      end
c----------------------------------------------------------------------
      subroutine rdmm5(cellzc,udat,vdat,uprog,vprog,mhr,mjul,myr,
     1                 tprog,vptprog,icloud,ccgrid,iceilg,rho,npsta,
     2                 itwprog)
c----------------------------------------------------------------------
C
c --- CALMET   Version: 5.8.4         Level: 130731               RDMM5
c              EPA
c
c ---          Version: 5.8           Level: 070619
c              F.Robe
c ---          Modified by M. Fernau (2/99), F.Robe (09/01)
c ---          Modified by J. Scire (5/03)
c
c --- UPDATES:
c --- v5.731 Level 070619 to v5.8.4 Level 130731 (EPA)
c      - Corrected error when using multiple multi-hourly M3D files with
c        overlapping times, a simulation stopped sooner than requested
c        end time (MCB-G)
c      - Correct date test for a simulation ending on the first year
c        following a leap year and the computation of dtinc for a run
c        ending on the first hour of a new year (MCB-E)
c      - Correct error that stopped searching for a first valid MM5
c        record after reading the first MM5 file even if more than one
c        MM5 file was specified (MCB-E)
c      - Correctly interpolate prognostic ceiling heights (ICLOUD=3) to
c        CALMET grid points (MCB-E)
c      - When ITWPROG=2 with prognostic temperatures overwater, interpolate
c        between SST and lowest 3D.DAT level temperature (MCB-E)
c
c --- V5.723 Level 060411 to v5.731 Level 070619(F. Robe)
c      - Initialize nlevag1,TZ1,ZL1,TZ2,ZL2 at fist call to subroutine
c        (does not affect results but can stop execution with some
c        compilers)
c      - Modification 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      - Only fill in indx array when valid records (not when skipping)
c        (useless and besides, index not definied when skipping records)
c
c --- V5.720 Level 060315 to V5.723 Level 060411 (DGS)
c         - Revise check for missing SST.  Current range of 260-320K
c           is not large enough since land cells are also given
c           an SST.  Range is revised to 150-350K, as expected missing
c           values are either 0, large negative, or large postitve.
c
c --- V5.713 (060215)to V5.720 Level 060315(F.Robe)
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 --- V5.712 (060213) to V5.713 (060215)(F.Robe)
c         - Bug fix: shift sinalp time index by 1 (array index from 1-24
c           for hour-ending 0-23)
c
c --- v5.611 Level 051113 to V5.712 (060213)(F.Robe)
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
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              ICLOUD  INT     - CLOUD FLAG - IF ICLOUD=3, compute cloud cover
C                                from MM5 relative humidity (Teixeira, 2001)
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
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               MHR   INT      - HOUR OF PROGNOSTIC DATA (LST)
C               MJUL  INT      - JULIAN DAY OF PROGNOSTIC DATA (LST)
C               MYR   INT      - YEAR OF PROGNOSTIC DATA
c             CCGRID  R-ARRAY  - Gridded cloud cover computed with MM%
c                                Relative humidity (if icloud=3)
c              ICEIL  I-ARRAY  - ceiling height (lowest MM5 level)
c                                with non zero qc (for ioutmm5>82 and icloud=3)
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                 ZL1 R-ARRAY  - ELEVATION ABOVE GROUND OF MM5 LEVELS AT
C                                MM5 GRIDPOINT CLOSEST TO GIVEN CALMET
C                                GRIDPOINT. Artificial zl=0 level added
c                 TZ1 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             iRHPROG 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     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/irhprog(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),
     &        ceilprog(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),
     &         zl2(mxnx,mxny,mxnzp+1),tz2(mxnx,mxny,mxnzp+1),
c frr  040225
     &         zl1(mxnx,mxny,mxnzp+1),tz1(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 --- Make sure to keep it1,it2 in memory for next time step (050125)
      save it1,it2

c --- Initialise variables at first access to MM5 data records
c ---     (flag initialized in rdhd5)
      if (ifirstpg.eq.0) then
         it1=0
         it2=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
              qcprog2(i,j)=0.
              iceilg2(i,j)=0
              irhprog2(i,j)=0
              rho2(i,j) = 0.
              rmm2(i,j) = 0.
              rh850pg2(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

      endif

c frr 040225
c last available temperature profile for use in MIXDT2 (Mix.H. growth)
      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
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 -

c frr bug  Fix for end of the day
c frr 030526 - fix so that okay for turn of the year (365 or 366 days as well
c     ndathr=iyr*100000+jul*100+nhr
c     if ( (ndathr-it1) .ne. isteppg .and. it1 .ne. 0)then
c     if (((ndathr-it1).ne.isteppg).and.((ndathr-100+24-it1).ne.isteppg)

      if (((ndathr-it1).ne.isteppg).and.((ndathr-100+24-it1).ne.isteppg)
     :     .and. ((ndathr-100000+364*100+24-it1).ne.isteppg)
     :     .and. ((ndathr-100000+365*100+24-it1).ne.isteppg)
     :     .and. it1 .ne. 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 ---  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

c ---    Read date record of data portion
         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)
         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 260< sst< 320
c ---   REVISED                   => 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
         mdathr=myr*100000+mjul*100+mhr

c        Compute current time+ MM5 timestep in yyyyjulhr format
         nsyr=nyr
         nsjul=njul
         nshr=nhr
         call indecr(io6,nsyr,nsjul,nshr,isteppg,0,23)
         nsdathr=nsyr*100000+nsjul*100+nshr

         if (mdathr .gt. nsdathr ) then
           write(io6,*)
           write(io6,*) ' ERROR - in Subroutine RDMM5'
           write(io6,*) ' MM5 data record is beyond CALMET time step: '
           write(io6,*) ' Gap in MM5 record > MM5 timestep'
           write(io6,*) ' Current LST TIME (yyyyjulhr): ',ndathr
           write(io6,*) ' STOP'
           write(6,*)   ' Gap in MM5 record - STOP - Check LST file'
           stop
         endif
c
c ---    Check whether need to skip a record
         iskip = 0

c ---    initialize surface density (070619-BAB)
         rhop(i,j)=0.
         irho=0

c ---    Always read in the next MM5 record, except for first valid record
         if (mdathr .le. (ndathr-isteppg+1) ) iskip = 1
c         if(mdathr.eq. (ndathr-isteppg+1) .and. ifirstpg.eq.1) iskip=0
         if(mdathr.eq. (ndathr-isteppg+1) .and. ifirstpg.le.1) iskip=0
c ---    Make sure to read next record if overlapping files and multihourly
c ---    M3D timesteps (080710)
         if(mdathr.eq.ndathr.and. nfm3d.gt.1) iskip=1

c ---    Need something extra if run starts early on one day and the latest MM5
c         MM5 data is on the previous day (because ndathr=..jul*100+nhr)
         if( ((njul-mjul).eq.1).and.((nhr+24-mhr).lt.isteppg)) iskip=0

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
                if (cver3d.eq.'2.1') then
                   read(io20,830) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr
                else
                   read(io20,83) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr
                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
                if (cver3d.eq.'2.1') then
                   read(io20,840) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr,qi,qs
                else
                   read(io20,84) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr,qi,qs
                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
                if (cver3d.eq.'2.1') then
                   read(io20,850) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr,qi,qs,qg
                else
                   read(io20,85) ipress,iz,t(n),iwd,ws(n),
     :                        irh,q,qc,qr,qi,qs,qg
                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
                if(cver3d.eq.'2.1') then
                   read(buff,930) ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,fcomp
                else
                   read(buff,93) ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,fcomp
                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
                      if (cver3d.eq.'2.1') then
                         read(buff,930)ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr
                      else
                         read(buff,93)ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr
                      endif
                   else if (ioutmm5.eq.94) then
                      if (cver3d.eq.'2.1') then
                         read(buff,940)ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr,qi,qs
                      else
                         read(buff,94)ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr,qi,qs
                      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
                      if (cver3d.eq.'2.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
                      else
                         read(buff,95) ipress,iz,t(n),iwd,ws(n),w,
     :                        irh,q,qc,qr,qi,qs,qg
                      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 frr (0 9/01)
c ---        find cloud ceiling (in meters)
             if ( ceil(i,j).eq.0. .and. qc.gt.1.e-09 ) then
                  ceil(i,j)=z(n)
             endif


c frr (09 /01)
c ---        integrate cloud water content over vertical (in g/kg)
             qctot (i,j)= qctot(i,j) + 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 - 070619)
             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 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
c ---      Sort arrays by ascending height (useless with CALMM5)
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
               if(LLCC)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 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 ---       Bug fix (060213) use sinalp at nearest CALMET gridpoint
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           if (mhr.eq.0)then
c              sina=sinalp(inearg(i,j),jnearg(i,j),24)
c           else
c              sina=sinalp(inearg(i,j),jnearg(i,j),mhr)
c           endif
c ---       Bug fix (060215) array time-index for sinalp goes from 1-24
c ---       for hour-ending 0-23. Shift by 1 (as in CALMET)
            sina=sinalp(inearg(i,j),jnearg(i,j),mhr+1)

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            060213: sinalp computed before k loop
c
c            First record pot.temp before sunset for extrapoltion 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)
             if (sina.gt.0)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 (060315-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 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 (060315-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 done when valid data)
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
c frr (09/01)
c ---    update time stamps for linear interpolation
         it1 = it2
         it2 = mdathr
         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
       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)
       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) call rdhd53(nfm3d,itwprog)
           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...'
            write(io6,*) 'On (yyyyjulhr): ',ndathr
         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))
c         call r2interp(i,j,x,y,udat,k,uprog(i,j,k))
c         call r2interp(i,j,x,y,vdat,k,vprog(i,j,k))
c          call r2interp(i,j,x,y,tmm4,k,tprog(i,j,k))
c          call r2interp(i,j,x,y,vptdat,k,vptprog(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 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)
         call r2interp(i,j,x,y,rh850,1,rh850pg2(i,j))


 125    continue

c ---   if qc data available, compute ceiling height and accumulated
c ---   cloud water content
        if (icloud.eq.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 to calmet grid
               call cinterp(i,j,x,y,ceil,1,ceilprog(i,j))
c ---          convert ceiling height from meters to hundreds of feet
               iceilg1(i,j)=iceilg2(i,j)
               iceilg2(i,j)= int ( ceilprog(i,j)/30.28 )
c ---          Vertically integrated cloud water
               qcprog1(i,j)=qcprog2(i,j)
               call r2interp(i,j,x,y,qctot,1,qcprog2(i,j))
127         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
c frr (02/10/22) check works also for consecutive days
         if (ifirstpg.eq.2) then
             istepmm5 = it2-it1
c frr (02/10/23) stop if check not ok except if Jan1 (previous step could
c be year before and it is okay => won't catch actual pb on Jan 1)
c frr (02/10/28)if ( (istepmm5.ne.isteppg).or.
             if ( (istepmm5.ne.isteppg).and.
     :           ((istepmm5-100+24).ne.isteppg).and.(mjul.ne.1))then

                 write(io6,9010)isteppg,it2,it1
9010       format(//1x,'WARNING- Possible error ',
     &     /1x,'Check actual prognostic time step in MM5.DAT ',
     &     /1x,' User input is: ISTEPPG = ',i7,
     &     /1x,'it1=',i10,' it2=',i10)

                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)
228          continue

c frr 040225
c set up temperature profile for use in MIXDT2 (Mix.H. growth)
c big fix - 050328 - tz1,zl1 all zeroes at this point, use tz2,zl2 instead
             nlevag0= nlevag1
             do 1321 i = 1,nx
             do 1321 j = 1,ny
                do 1322 k = 1,mxnzp+1
c                   tz0(i,j,k) = tz1(i,j,k)
c                   zl0(i,j,k) = zl1(i,j,k)
                   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)
      call deltsec(it1,0,ndathr,0,incsec)
      dtinc=incsec/(isteppg*3600.)
c --- Enforce bounds
      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): ',ndathr
         write(io6,*)'Current M3D times in memory (LST): ',it1,it2
         write(io6,*)'Value of dtinc: ',dtinc
         STOP
      endif

      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

      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))
       irhprog(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))

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)
      if (icloud.eq.3) then

c ---   cloud cover from prognostic relative humidity
        call cloud(nx,ny,rh850pg,ccgrid)

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
            if ( iceilg1(i,j).ne.0 .and. iceilg1(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

        else

          do 138 j=1,ny
          do 138 i=1,nx
            iceilg(i,j) = 80
138       continue

        endif

      endif
      return
      end
c----------------------------------------------------------------------
      subroutine STULL (z2,t2,t20,z3,t3,t30,z1,t1)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8.4       Level: 130731                 STULL
c              EPA
c
c ---          Version: 5.8         Level: 040612
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.8.4 Level 130731 (EPA)
c      - Corrected error that assumed radiative cooling even in (rare)
c        cases of nightime warming whenever CALMET temperatures are
c        computed from 3D.DAT temperatures and CALMET lower level(s)
c        are below the lowest 3D.DAT level  (MCB-G)
c
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     allow CALMET surface temp to warm up if prognostic near surface temp warm 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: 5.8         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: 5.8         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(idathr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 051227                  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 --- 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       IDATHR - integer      - Current date and hour (YYYYJJJHH where
c                               YYYY=year, JJJ=Julian day,
c                               HH=hour (00-23)
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       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
      if(idathr.gt.iowend(i))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
         if(idathr.lt.iowbeg(i))then
            write(io6,22)i,io,idathr,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
         if(idathr.gt.iowend(i))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 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
         if(LLCC) 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

      else if(idathr.lt.iowbeg(i))then
c
c ---    date/hr requested is out of range of stored data
         write(io6,112)i,io,idathr,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 = ',i9,5x,
     4   'Range read from file -- Beginning date/hour = ',i9,3x,
     5   'Ending date/hour = ',i9)
         stop
      endif
      go to 100
c
c --- end-of-file reached before date/hour found
999   continue
      write(io6,122)i,io,idathr
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: 5.8         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 rds(iforms,nssta,ispack,io,iskip,ibuf,iyr,ijul,ihr,
     1 ws,wd,iceil,icc,tempk,irh,pres,ipcode)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 030402                     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 --- 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
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
      if(LLCC)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 rdup(iup,iunit,iflag,iconvrt,jhrz,jjul,jyr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070128                  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 --- V5.729 (030402) to V5.730 (070128) (J. Scire)
c               - Allow more than 99 levels of data by changing format for
c                 number of levels from i2 to i5
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        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
      if(LLCC .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
      if(LLCC .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 rdwt(noobs,iprog,cellzc)
c---------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         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: 5.8.4        Level:  130731              READCF
c              EPA
c
c ---          Version: 5.8          Level:  070623             
c ---          J. Scire, R. Mentzer, SRC
c              Modified by M. Fernau, J. Scire , F.Robe
c              Earth Tech, Inc.
c
c --- PURPOSE:  Read CALMET control file inputs
c
c --- UPDATES:
c --- V5.8 (070623) to V5.8.4 Level 130731 (EPA)
c        - Added check to make sure the CALMET grid is located within the
c          prognostic grid (MCB-G)
c        - Correct error in coordinates for precipitation stations
c          when no upper air observations are used (MCB-E)
c
c --- v5.731 (070619) to V5.8      (070623)
c               - Read new input parameter MREG for screening
c                 regulatory settings
c               - Set configuration switches ISFCMET and IPSIFCN from
c                 value of ICOARE
c
c --- V5.711 (060106) to v5.731 (070619)
c               - Echo all input parameters, even those not listed in the
c                 user's input file (for which default values are assigned)
c               - Default value for THRESHL reset to 0 for consistency
c                 CALMET versions and regulatory assumptions
c
c --- v5.7 (051230) to V5.711 (060106)
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
      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 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','IBTZ','IRLG','IRTYPE',
     1 'LCALGRD','ITEST','MREG',50*' ',
     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','IFORMC',53*' ',
     5 'IWFCOD','IFRADJ','IKINE','IOBR','IEXTRP','RMIN2',
     5 'FEXTR2','IPROG','ISTEPPG','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',4*' ',
     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  17*' ',
     7  60*' ',60*' ',60*' '/
c

c --- Variable dimension (1: scalar)
      data ivleng/10*1, 50*0,
     2   2*8,4*1,4*16,6*1,mxnzp1, 43*0,
     3   3*1, 3*mxnz, 24*1, 30*0,
     4   7*1, 53*0,
     5   6*1, mxnz, 14*1, 2*mxnz, 3*1, 4*mxbar, 10*1, 2,
     5   2*1, 9*mxbox, mxbxwnd, mxnz, 2*1,4*0,
     6   22*1, 2*mxwb, 19*1, 17*0,
     7   60*0,
     8   60*0,
     9   60*0/
c
C     Data types: 1: real - 2: integer - 3: logical
      data ivtype/7*2,3,2,2,50*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 7*2, 53*0,
     5 5*2, 2*1, 3*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, 4*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, 2*2, 17*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 --- Read title (First 3 lines of the control file)
      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
1400  format(40x,'CALMET',3x,'Version: ',a8,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'/
     2   5x,'    Model Code - Version: ',a8,' Level: ',a8/
     3   5x,'Parameter File - Version: ',a8,' 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 --------------------------------------------

      call readin(cvdic(1,1),ivleng(1,1),ivtype(1,1),io5,io6,lecho,
     1 IBYR,IBMO,IBDY,IBHR,IBTZ,IRLG,IRTYPE,LCALGRD,ITEST,MREG,
     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)

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,
     1 noobs,NSSTA,NPSTA,IFORMS,IFORMP,ICLOUD,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,idum,idum)

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 --- 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

      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 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,idum)

c --- set other variable name to pass through calling list
      igfflag=igfmet

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  --- reset 070619
      threshl=0.0

      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,idum,idum,idum,idum,idum,idum,idum,idum,idum,idum,
     6 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 --- 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
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'
         write(io6,*) 'Invalid beginning hr:    IBHR = ',ibhr
         write(io6,*) 'Run must start on or 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
      else
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 2'
         write(io6,*) 'Unacceptable PMAP             = ',pmap
         write(io6,*) 'PMAP must be UTM,LCC,TTM'
         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
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.3)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 or 3'
         lerrcf=.TRUE.
      endif
c frr (09/01) ICLOUD must be = 2 or 3 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 or 3 if NOOBS = 2'
         lerrcf=.TRUE.
      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 --- 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 --- FRR (09/2001) - New parameter for 3D temp (ITPROG)
      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 (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 --- 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
      if (isteppg.gt.12) 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 (isteppg.gt.1 .and. iprog.lt.13 ) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Prognostic timestep           = ',isteppg
         write(io6,*) 'Maximum timestep allowed for MM4 is 1 hour'
         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.lt.1.or.isurft.gt.nssta)) then
         write(io6,*)
         write(io6,*) 'READCF:  Error in Input Group 5'
         write(io6,*) 'Invalid sfc station    ISURFT =',isurft
         write(io6,*) 'Number must be 1 to ',nssta
         lerrcf=.TRUE.
      endif
c
c frr (09/01) perform QA checks only if matters (i.e. not in noobs mode)
      if(noobs .eq. 0) then

        if(idiopt(2).eq.0 .AND. (iupt.lt.1.or.iupt.gt.nusta))then
          write(io6,*)
          write(io6,*) 'READCF:  Error in Input Group 5'
          write(io6,*) 'Invalid upper station    IUPT =',iupt
          write(io6,*) 'Number must be 1 to ',nusta
          lerrcf=.TRUE.
        endif
c
        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
      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 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 --- 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
        if(LLCC)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
        if(LLCC)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
      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] (110421)
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)ibyr,ibmo,ibdy,ibjul,ibhr,ibtz,irlg,irtype,
     1 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,'              Base time zone: ',i4//
     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
      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 prognostic RH at 850mb)')
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)isteppg
1477    format(/5x,'Prognostic model output timestep (hours):',i4)

       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: ',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
c FRR (noobs option)
      if(idiopt(2).eq.0)then
c
         write(io6,*)
         if (noobs.eq.0) then
           write(io6,*)'     Upper air station no. used for domain-',
     1     'averaged temp. lapse rate (IUPT): ',iupt
         else
           write(io6,*)'     Prognostic data used for domain-',
     1     'averaged temp. lapse rate  '
         endif
         write(io6,*)'     Depth through which domain-averaged temp. ',
     1   'lapse rate 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)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,1488)constb,conste,constn,constw,fcoriol,dptmin,
     &                  dzzi,nflagp,sigmap,cutp
1488  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)
c

         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,/)

         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(/
     :   5('-'),'Temperature parameters',5('-'),//
     1   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: 5.8         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: 5.8        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,ibtz,irlg,ldb,idiopt,iprog,
     :   igfmet)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8.4       Level: 130731                READHD
c              EPA
c
c ---          Version: 5.8         Level: 060106        
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 --- v5.711 (060106) to v5.8.4 (130731) (EPA)
c               - If precip data observations are used, match precip
c                 station coordinates in control file to those in precip
c                 file (MCB-E)
C               - When precipitation is interpolated from prognostic
c                 precipitation, added code for the user-defined SIGMAP 
c                 to be checked against the prognostic gridsize (MCB-G)
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               IBTZ - integer    - Base time zone
c               IRLG - integer    - Length of run (hours)
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         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       Common block /OVRWAT/ variables:
c         IOOW,NOWSTA
c        Parameters: MXSS, MXUS, MXPS
c
c --- OUTPUT:
c       Common block /MET1/ variables:
c         IPPACK, ISPACK, ZANEM, ...
c       Common block /OVRWAT/ variables:
c         CHOWSTA,IDOWSTA
c       Common block /IGF/nfigf
c
c --- READHD called by:  SETUP
c --- READHD calls:      RDHD, DELTT, RDS, RDP, RDHDU, RDUP, RDHD4,
c                        INDECR, RDHD5, RDHDOW,
c                        GLOBE1, GLOBE, RDHDMET
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

      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,jeyr,jejul,jehr,jbtz,jssta,
     1          ispack,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
            if(LLCC) 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)then
         write(io6,125)nskip,ibyr,ibjul,ibhr,jbyr,jbjul,jbhr
125      format(//2x,'ERROR IN SUBR. READHD -- Surface data does not ',
     1   'cover time period in run'/5x,'nskip = ',i10/
     2   5x,'Run starting date/hr: ibyr, ibjul, ibhr = ',3i10/
     3   5x,'     Date/hr in file: jbyr, jbjul, jbhr = ',3i10)
         lfatal=.TRUE.
      endif
c
c --- check time from beg. of run to end of surface data file
      call deltt(ibyr,ibjul,ibhr,jeyr,jejul,jehr,jleng)
c --- no. hours data = delta time + one hour
      jleng=jleng+1
      if(jleng.lt.irlg)then
         write(io6,130)irlg,jleng
130      format(//2x,'ERROR IN SUBR. READHD -- Surface data does not ',
     1   'cover time period in run'/5x,'irlg = ',i10,5x,'jleng = ',i10)
         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 --- Skip to proper starting point in surface data file
      iskip=1
      do i=1,nskip
        call rds(iforms,nssta,ispack,ios,iskip,ibuf,iyr,ijul,ihr,
     1           ws,wd,iceil,icc,tempk,irh,pres,ipcode)
      enddo

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,jeyr,jejul,jehr,jbtz,jpsta,
     1          ippack,idprec,dumprec,cpnam,xplat,xplon,mxps,
     2          clatp,clonp,datumi,lstnloc)
c
c --- write data from precipitation header records
      write(io6,10)iformp,ippack,jbtz,jpsta,jbyr,jbjul,jbhr,
     1 jeyr,jejul,jehr
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//
     8 5x,'      Ending year: ',i5/
     9 5x,'       Julian day: ',i5/
     a 5x,'             hour: ',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
      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 precip. 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)then
         write(io6,25)nskip,ibyr,ibjul,ibhr,jbyr,jbjul,jbhr
25       format(//2x,'ERROR IN SUBR. READHD -- Precip. data does not ',
     1   'cover time period in run'/5x,'nskip = ',i10/
     2   5x,'Run starting date/hr: ibyr, ibjul, ibhr = ',3i10/
     3   5x,'     Date/hr in file: jbyr, jbjul, jbhr = ',3i10)
       lfatal=.TRUE.
      endif
c
c --- check time from beg. of run to end of precip. file
      call deltt(ibyr,ibjul,ibhr,jeyr,jejul,jehr,jleng)
c --- no. hours data = delta time + one hour
      jleng=jleng+1
      if(jleng.lt.irlg)then
         write(io6,30)irlg,jleng
30       format(//2x,'ERROR IN SUBR. READHD -- Precip. data does not ',
     1   'cover time period in run'/5x,'irlg = ',i10,5x,'jleng = ',i10)
      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
         call rdp(iformp,npsta,ippack,iop,iskip,iyr,ijul,ihr,xprecp)
      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
c --- read header records -- upper air data
      io=io+1
      call RDHDU(io,io6,iox,ibyru,ibjulu,ibhru,ieyru,iejulu,
     1           iehru,ptop,jdat,ifmtu(i),lht,ltemp,lwd,lws,
     2           idusta(i),cunam(i),xulat(i),xulon(i),uelev(i),
     3           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
c --- check that upper air file begin. time <= run begin. time
      if(ibyru.gt.ibyr)then
         write(io6,75)i,ibyr,ibjul,ibhr,ibyru,ibjulu,ibhru
75       format(//2x,'ERROR IN SUBR. READHD -- Upper air data does ',
     1   'not cover time period in run'/5x,'Station no.: ',i5/
     2   5x,'Run starting date/hr: ibyr,  ibjul,  ibhr  = ',3i10,
     2   ' (LST)'/
     3   5x,'     Date/hr in file: ibyru, ibjulu, ibhru = ',3i10,
     3   ' (GMT)')
         lfatal=.TRUE.
      else if(ibyru.eq.ibyr.and.ibjulu.gt.ibjul)then
         write(io6,75)i,ibyr,ibjul,ibhr,ibyru,ibjulu,ibhru
         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) stop 'Halted in READHD --- See list file'
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
            if(LLCC) 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 --- 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. RDCALMET
c
      endif

c
c --- Read header records from MM5 data file
c ------------------------------------------
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
         call rdhd5 (icloud,itwprog,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
        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
        if(ibyrm.gt.ibyr)then
           write(io6,275) ibyr,ibjul,ibhr,ibyrm,ibjulm,ibhrm
275        format(//2x,'ERROR IN SUBR. READHD -- MM5 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
        else if(ibyrm.eq.ibyr.and.ibjulm.gt.ibjul)then
           write(io6,275) ibyr,ibjul,ibhr,ibyrm,ibjulm,ibhrm
           stop
        else if(ibyrm.EQ.ibyr.and.ibjulm.EQ.ibjul.and.ibhrm.GT.ibhr)then
           write(io6,275) ibyr,ibjul,ibhr,ibyrm,ibjulm,ibhrm
           stop
        endif
c
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
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)
        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
        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
        else if(ibyrm.eq.ibyr.and.ibjulm.gt.ibjul)then
           write(io6,175) ibyr,ibjul,ibhr,ibyrm,ibjulm,ibhrm
           stop
        else if(ibyrm.EQ.ibyr.and.ibjulm.EQ.ibjul.and.ibhrm.GT.ibhr)then
           write(io6,175) ibyr,ibjul,ibhr,ibyrm,ibjulm,ibhrm
           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: 5.8         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: 5.8         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: 5.8         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: 5.8         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(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: 5.8         Level: 060217                   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 --- V5.711 (060106)  to V5.714 (060202/060217)  (DGS)
c               - add QA plot file subroutine
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----------------------------------------------------------------------
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)
      call readhd(ibyr,ibjul,ibhr,ibtz,irlg,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
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
        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: 5.8         Level: 070623               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 v5.8      (070623)
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            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     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,tinf,hmax)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 050328                   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-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             TINF (R)        - DOMAIN REPRESENTATIVE 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 --- 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'
c      COMMON /D6/ IRD,IWR,IFILE,irdp
      COMMON /S1/ USFC(mxnx,mxny),VSFC(mxnx,mxny)


      DIMENSION USLOPE(mxnx,mxny,mxnz), VSLOPE(mxnx,mxny,mxnz),
     1          HTOPO(mxnx,mxny), HMAX(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

      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/tinf)*abs(qh(i,j))*dcrest/rhocp/cdk)
     1              **(1./3.)*(1-exp(tempmef))**(1./3.)
          else
c ---  Upslope
             UVALLY=((9.81/tinf)*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: 5.8         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 cloud(nx,ny,rh,ccgrid)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 030119                   CLOUD
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 solar(njul,ibtz,sinalp)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 050328                  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
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              ITIMSTEP - integer    - Timestep number
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
c --- OUTPUT:
c       SINALP(MXNX,MXNY,24) - 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

      real sinalp(mxnx,mxny,24)
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 previous so 1-24
c --- actually represent 23:30 previous day through 22:30 current day.
c
c --- zero negative values; these occur before sunrise or after sunset
        do 30 ihr = 1,24
          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)
          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,
     &    itwprog,iicloud,ccgrid, rho, temp2d,rmm,qsw,qlw,
     &    ipsifcn,isfcmet)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070623                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     v5.612 (051214) to v5.8      (070623)
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
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
c      ZICONV(mxnx,mxny) - real array - Convective mixing heights (m)
c                                       of previous hour
c          ZI(mxnx,mxny) - real array - Previous hour 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                   IUPT - integer    - Upper air station to use for
c                                       computing the domain-scale
c                                       lapse rate
c                IICLOUD - 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 IICLOUD=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        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, WATER2P
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,
     1   iicloud,itprog,ccgrid,zi,temp,rho(is,js),ipsifcn)
      end if
      return
      end
c----------------------------------------------------------------------
      subroutine temp3d(nyrz,njulz,nhrz,temp2d,ziconv,tzgraa,tzgrbb,
     1                  ztemp,zi,tprog)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070619                 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 --- v5.6 level 050328 to V5.731 Level 070619(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     (2) initialize ldwat sooner in the code to avoid non-initialization
c         if no water stations (with water temp results depending on default
c         valueassigned to ldwat by compiler)
c
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                   NYRZ - integer    - Year of current hour (GMT)
c                  NJULZ - integer    - Day of current hour (GMT)
c                   NHRZ - integer    - Current hour GMT time (0-23)
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 --- 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)
c**** Modified by EMI -- 4/26/94
        if (jorder .gt. 0) then
          call deltt(nyrz,njulz,nhrz,jbbyr,jbbday,jbbhr,jtogo)
          call deltt(jaayr,jaaday,jaahr,nyrz,njulz,nhrz,jpast)
        else
          call deltt(nyrz,njulz,nhrz,jaayr,jaaday,jaahr,jtogo)
          call deltt(jbbyr,jbbday,jbbhr,nyrz,njulz,nhrz,jpast)
        end if
c
c --- Check for negative values of jtogo or jpast
c
        if (jtogo .LT. 0 .OR. jpast .LT. 0) then
          write(io6,1089) iu,nyrz,njulz,nhrz,jpast,jtogo,jdelta,
     1                    ntzaas,ntzbbs
1089      format(//1x,'ERROR IN SUBR. TEMP3D -- Upper air',
     1    ' soundings do not straddle current hour for station ',i3/
     2    5x,'Current YYDDDHH (GMT)  ',i2,i3,i2,/
     3    5x,'GMT hours past and before soundings ',2i4/
     4    5x,'GMT hours between these soundings ',i4/
     5    5x,'GMT YYDDDHH codes for these soundings ',2i9)
          stop
        end if
c
c --- Double check for upper air data inconsistencies
c
        if ((jpast + jtogo) .ne. jdelta) then
          write(io6,1090) iu,nyrz,njulz,nhrz,jpast,jtogo,jdelta,
     &                    ntzaas,ntzbbs
1090      format(//1x,'ERROR IN SUBR. TEMP3D -- Inconsistent ',
     1    'upper air times for station ',i3/
     2    5x,'Current YYDDDHH (GMT) ',i2,i3,i2,/
     3    5x,'GMT hours past and before soundings ',2i4/
     4    5x,'GMT hours between these soundings ',i4/
     5    5x,'GMT YYDDDHH codes for these soundings ',2i9)
          stop
        end if
c****  End of EMI modifications -- 4/26/94
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 --- must initialize ldwat sooner or can be undefined (070619)
      ldwat = 0


c --- Determine whether overwater vs. land interpolation to be used
c     (assume mxwb is hardwired to 1)
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 (070619)
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: 5.8         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: 5.8         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,
     1                  gamma,tinf,alpha)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 050328                  TOPOF2
c              S.DOUGLAS, SAI
c
c
c --- UPDATES:
c
c --- V5.6 (050328- FRR): explicit common replaced by include d6.met
c
c --- Modified 3/98 by J. Scire to prevent numerical problems
c             when WS = 0.0
c
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 -------------------------------------------------------------------
c --- include parameters
      include 'params.met'
      include 'grid.met'
      include 'd6.met'
c      COMMON /D6/ IRD,IWR,IFILE,irdp
      COMMON /T1/ W1(mxnx,mxny,mxnzp1)
      DIMENSION U(mxnx,mxny,*), V(mxnx,mxny,*),
     1          W(mxnx,mxny,*), HTOPO(mxnx,*), CELLZB(mxnzp1)
C
C     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
C     INPUT:  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)        - TEMPERATURE LAPSE RATES (HOURLY)
C             TINF (R)         - DOMAIN REPRESENTATIVE TEMPERATURE
C             ALPHA (R)        - EMPIRICAL COEFFICIENT FOR
C                                TOPOGRAPHIC EFFECTS
c         Parameters: MXNX, MXNY, MXNZ, MXNZP1
C
C     OUTPUT:  W (R ARRAY) - TERRAIN INDUCED VERTICAL VELOCITY
C
C     CALCULATE THE STABILITY PARAMETER, S
C
      TAU=-0.01
      GAMMA2=GAMMA-TAU
      IF (GAMMA2 .LT. 0.) S=-1.0
      IF (GAMMA2 .GE. 0.) S=(9.8*GAMMA2/TINF)**0.5
C
C     CALCULATE THE VERTICAL VELOCITY
C
      DO 100 J=1,NY
      DO 100 I=1,NX
C
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: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8.4       Level: 130731                WATER
c              EPA
c
c ---          Version: 5.8         Level: 070619
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 --- V5.731 (070619) to V5.8.4, Level 130731 (EPA)
c      -  When using convective overwater mixing height options (IMIXH>0)
c         the overwater convective mixing height grew from the previous
c         hour mixing height, not from the previous hour convective
c         mixing height (MCB-G)
c
c --- V5.726 (060801) to V5.731 (070619)(F.Robe):
c     (1) Include internal common to pass value of dptt to MIXHMC
c     (2) assign z0 value sooner in the code so that filled in even when
c         no valid overwater stations
c     (3) Define ilapse and pass on correct value of ilapse to MIXHMC and
c         MIXHBG if itwprog=2
c     (4) wstar overwater strictly based on convective mixing height
c         if computed (imixh>0)
c
c --- V5.620 (060315) to V5.726 (060801) (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.619 (060314) to V5.620 (060315)(FRR):
c     (1) Change minimum SST to -3.0C
c     (2) Add a check for missing Tairow before call to COARE and
c         replace by default Tair if missing
c
c --- V5.614 (051228) to V5.619 (060314)(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 0C
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 meansuremnt 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 Ocean 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
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)
      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)
      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 (070619)
      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)
           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
              call MIXHBG(ihrgmt,I,J,WT,DTHDZ,Tairow(nearow),Ilapse,
     :         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)
              call MIXHMC(ihrgmt,i,j,wt,DTHDZ,ilapse,threshw,
     :                    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))


        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 (070619)
              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: 5.8.4       Level: 130731               WATERP
c              EPA
c
c ---          Version: 5.8         Level: 070619
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 --- V5.731 (070619) to V5.8.4, Level 130731 (EPA)
c      -  When using convective overwater mixing height options (IMIXH>0)
c         the overwater convective mixing height grew from the previous
c         hour mixing height, not from the previous hour convective
c         mixing height (MCB-G)
c
c --- V5.726 (060801) to V5.731 (070619)(F.Robe):
c          (1) Include internal common to pass value of dptt to MIXHMC
c          (2) Pass on correct value of ilapse to MIXHMC and MIXHBG
c              (was not correct when itwprog=2)
c          (3) wstar overwater strictly based on convective mixing height
c              if computed (imixh>0)
c
c --- Version 5.620 (060315) to Version 5.726 Level 060801 (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 --- V5.619 (060314) to V5.620 (060315)(DGS):
c     (1) Change minimum SST to -3.0C
c
c --- Version 5.614 Level 051228 to V5.719 Level 060314
c          (1) Make sure SST passed to COARE are above 0C
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
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)
      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,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,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)
        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
           call MIXHBG(ihrgmt,I,J,WT,DTHDZ,Tairow(nearow),1,
     :         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)
           call MIXHMC(ihrgmt,i,j,wt,DTHDZ,1,threshw,
     :                    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 (070619)
              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: 5.8         Level: 070623                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 --- V5.726 Level 060801 to V5.8      Level 070623
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 --- v5.611 Level 051113 to V5.726 Level 060801(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: 5.8         Level: 070623               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 --- V5.731 (070619) to v5.8      Level 070623
c       - Add IPSIFCN to SIMILT argument list
c
c --- V5.726 (060801) to V5.731 (070619)(F.Robe):
c          (1) Include internal common to pass value of dptt to MIXHMC
c          (2) Correct index of tgrada (nwat instead of ns)
c          (3) Define ws10 also when buoy anemometer height is 10m
c          (4) Define wt(=0) when OW data are missing
c          (5) Define ilapse and pass on correct value of ilapse
c              to MIXHMC and MIXHBG if itwprog=2
c
c --- V5.620 Level 060318 to V5.726 Level 060801 (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 --- V5.619 (060314) to V5.620 (060315)(DGS):
c     (1) Change minimum SST to -3.0C
c
c --- V5.614 (051228) to V5.619 (060314)(FRR):
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) Make sure SST passed to COARE are above 0C
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
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 (070619)
      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 (070619)
      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 (070619) tgrada is defined for OW stations
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 (ihrgmt,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 (ihrgmt,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: 5.8         Level: 070623              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 --- V5.731 (070619) to v5.8      Level 070623
c       - Add IPSIFCN to SIMILT argument list
c
c --- V5.726 (060801) to V5.731 (070619)(F.Robe):
c          (1) Include internal common to pass value of dptt to MIXHMC
c          (2) Define ws10 also when buoy anemometer (lowest M3d level)
c              height is 10m
c          (3) Pass on correct value of ilapse to MIXHMC and MIXHBG
c              when itwprog=2
c
c --- V5.620 Level 060315 to V5.726 Level 060801
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 --- V5.619 (060314) to V5.620 (060315)(DGS):
c     (1) Change minimum SST to -3.0C
c
c --- V5.614 (051228) to V5.619 (060314)(FRR):
c     (1) Make sure SST passed to COARE are above 0C
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
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

      common /tjump/ dptt(mxnx,mxny)

      include 'ovrwat.met'
c
      data z0min/2.0e-6/,xmissm/990./,pres/1000./
      data vk/0.4/,rhocp/1195.2/
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 --- 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 (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
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 (ihrgmt,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 (ihrgmt,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: 5.8         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
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: 5.8         Level: 070619              BULK_FLUX
c
c --- Updates:
c
c --- V5.7 (051230) to V5.731 (070619) (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 --- initialize dt_wrm (070619) 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: 5.8         Level: 060304                     ASL
c              (COARE subroutine)
c              (Modified by F. Robe, Earth Tech)
c
c --- Updates:
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 --- V5.7 Level 051230 to V5.717 Level 060304 (F.Robe)
c           - Convert argument of min function from single to double
c             precision to avoid compiler warnings in Linux
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: 5.8         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: 5.8         Level: 051230                    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
      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
       psiu=-((1.+1.*zL)**1.+.6667*(zL-14.28)/dexp(c)+8.525)
      endif
      return
      end

c ---------------------------------------------------------------------
      function psit(zL)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 060304                    PSIT
c              (COARE subroutine)
c --- UPDATES:
c --- Level 051230 to V5.717 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: 5.8         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 --- Level 051230 to V5.717 Level 060304 (F.Robe)
c           - Convert argument of sign function from single to double
c             precision to avoid compiler warnings in Linux
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: 5.8         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: 5.8         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: 5.8         Level: 060304                   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 --- Level 051230 to V5.717 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,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
       psiud=-((1.+1.*zL)**1.+.6667*(zL-14.28)/dexp(c)+8.525)
      endif
      return
      end

c----------------------------------------------------------------------
      function psitD(zL)
c ---------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         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 --- Level 051230 to V5.717 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 --------------------------------------------------------------------
      subroutine radflx (icloud,iceil,ccgrid,iceilg,tair,irh,qlw)
c --------------------------------------------------------------------
c --- CALMET    Version: 5.8         Level: 070619              RADLFX
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 --- V5.728 (061230) to V5.731 (070619)(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 --- Version V5.727 (060525) to V5.728 (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 V5.725 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             ICLOUD            - integer - cloud option flag
c             ICEIL(mxss)       - integer - observed ceiling heights
c                                           (in 100's ft)
c   CCGRID(mxnx,mxny) - real    - Fractional Cloud cover
c             ICEILG (mxnx,mxny)- integer - 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

            if (icloud.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)
            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: 5.8         Level: 070623                 WIND1
c              Earth Tech Inc
c
c
c --- UPDATES:
c
c --- V5.731 Level 070619 to v5.8      Level 070623
c        - Add IPSIFCN to SIMILT argument list
c
c --- V5.6 Level 050328  to V5.731 Level 070619(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 length and log profile coefficients for surface
c --- stations located on a water gridcell (070619)
      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 (070619)
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 (070619)
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 (070619) -
             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: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8         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,ndathr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 901130                  WRTI1D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write "NWORDS" of a one-dimensional integer array
c
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        NDATHR - integer       - Date and time of data (YYYYJJJHH)
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,ndathr,idat
      return
      end
c----------------------------------------------------------------------
      subroutine wrti2d(iomet,idat,ibuf,mxnx,mxny,nx,ny,clabel,ndathr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 901130                  WRTI2D
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              CLABEL - character*8   - Variable name
c              NDATHR - integer       - Date and time of data (YYYYJJJHH)
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,ndathr,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,ndathr,ibuf
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine wrtr1d(iomet,x,nwords,clabel,ndathr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 901130                  WRTR1D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Write "NWORDS" of a one-dimensional real array
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        NDATHR - integer     - Date and time of data (YYYYJJJHH)
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,ndathr,x
      return
      end
c----------------------------------------------------------------------
      subroutine wrtr2d(iomet,x,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 901130                  WRTR2D
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           CLABEL - character*8 - Variable name
c           NDATHR - integer     - Date and time of data (YYYYJJJHH)
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,ndathr,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,ndathr,xbuf
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine wstarr(ziconv,qh,temp2d,rho,ilandu,iwat1,iwat2,
     1 nx,ny,wstar)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8         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: 5.8         Level: 060106                 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 --- v5.711 (060106) to v6.205 (060318) (FRR):
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
            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: 5.8         Level: 060318                 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 ---  v5.711 (060106) to v6.205 (060318) (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, icloud
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
      if(icloud.eq.2)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
      if(icloud.eq.1)write(io6,12)'CLOUD.DAT',io26,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: 5.8         Level: 060106                   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 --- UPDATE
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
c       Parameters: MXNX, MXNY, IO26
c
c --- OUTPUT:
c CCGRID(mxnx,mxny) - real array - Gridded cloud cover (fraction)
c
c --- RDCLD called by:  COMP
c --- RDCLD calls:      RDR2D, 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,ccgrid,xbuf,mxnx,mxny,nx,ny,clabel,idathr,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 outcld(ndathr,nx,ny,nssta,icc,nears,iformc,icloud,
     :                  ccgrid)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 070619                 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
c --- UPDATES:
c --- Level 95 to V5.731 Level 070619(F.Robe)
c          - Fill in the gridded cloud array ccgrid
c            also if icloud=0 (additional icloud in calling list)
c
c --- INPUTS:
c           NDATHR - integer    - Date and hour (YYYYJJJHH) 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           ICLOUD - integer    - CLOUD option (write out field if
c                                 ICLOUD=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
c --- Compute the cloud fraction field

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
c
c --- Write the 2-D cloud cover field if icloud=1
      if(icloud.eq.1) then
         if(iformc.eq.1)then
            clabel='CLOUDFRA'
            call wrtr2d(io26,ccgrid,xbuf,mxnx,mxny,nx,ny,clabel,ndathr)
         else
c ---       Read clab2 as a character*8 in free format ("s used as
c ---       delimiters)
            clab2='"CLOUDFRA"'
            write(io26,*)clab2,ndathr,((ccgrid(i,j),i=1,nx),j=1,ny)
         endif
      endif
c
      return
      end
c----------------------------------------------------------------------
      subroutine rdi1d(iomet,idat,nwords,clabel,ndathr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8       Level: 940830                   RDI1D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Read "NWORDS" of a one-dimensional integer array
c
c --- INPUTS:
c         IOMET - integer       - Fortran unit number of input file
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        NDATHR - integer       - Date and time of data (YYJJJHH
c                                                   or YYYYJJJHH)
c
c --- RDI1D called by:  MAIN
c --- RDI1D calls:      none
c----------------------------------------------------------------------
c
      integer idat(nwords)
      character*8 clabel
c
      read(iomet)clabel,ndathr,idat
      return
      end
c----------------------------------------------------------------------
      subroutine rdr1d(iomet,x,nwords,clabel,ndathr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8       Level: 940830                   RDR1D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Read "NWORDS" of a one-dimensional real array
c
c --- INPUTS:
c         IOMET - integer     - Fortran unit number of input file
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        NDATHR - integer     - Date and time of data (YYJJJHH
c                                                 or YYYYJJJHH)
c
c --- RDR1D called by:  MAIN
c --- RDR1D calls:      none
c----------------------------------------------------------------------
      real x(nwords)
      character*8 clabel
c
      read(iomet)clabel,ndathr,x
      return
      end
c----------------------------------------------------------------------
      subroutine rdi2d(iomet,idat,ibuf,mxnx,mxny,nx,ny,clabel,ndathr)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8       Level: 940830                   RDI2D
c ---          J. Scire, SRC
c
c --- PURPOSE:  Read NX * NY words of a 2-D integer array
c
c --- INPUTS:
c               IOMET - integer       - Fortran unit number of input
c                                       file
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              NDATHR - integer       - Date and time of data (YYJJJHH
c                                                         or YYYYJJJHH)
c
c --- RDI2D called by:  MAIN
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
      read(iomet)clabel,ndathr,idat
      else
c
c ---    only a portion of grid being used -- read and
c ---    transfer from buffer
c
      read(iomet)clabel,ndathr,ibuf
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 rdr2d(iomet,x,xbuf,mxnx,mxny,nx,ny,clabel,ndathr,ieof)
c----------------------------------------------------------------------
c
c
c --- CALMET   Version: 5.8         Level: 060106                   RDR2D
c              J. Scire, SRC
c
c
c --- PURPOSE:  Read NX * NY words of a 2-D real array
c
c --- UPDATE
c --- 951021 to V5.711 (060106(DGS): add IEOF to recover from end-of-file
c     (taken from PRTMET.FOR)
c
c --- INPUTS:
c            IOMET - integer     - Fortran unit number of input file
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           CLABEL - character*8 - Variable name
c           NDATHR - integer     - Date and time of data (YYJJJHH
c                                                    or YYYYJJJHH)
c
c --- OUTPUT:
c     X(mxnx,mxny) - real array  - Input data array (padded if nec.)
c             IEOF - integer     - End-of-File status
c                                  0 = pointer within file
c                                  1 = EOF reached on read
c
c --- RDR2D called by:  RDCLD, RDHDMET,RDMET2
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
         read(iomet,end=999)clabel,ndathr,x
      else
c
c ---    only a portion of grid being used -- read and
c ---    transfer from buffer
         read(iomet,end=999)clabel,ndathr,xbuf
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 tfercf
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8         Level: 030402                  TFERCF
c ---          D. Strimaitis,    Earth Tech, Inc.
c
c --- PURPOSE: Transfer image of control input file to scratch file
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*33 blank33

c --- Set blanks
      data blank33/'                                 '/
      blank(1:33)=blank33
      blank(34:66)=blank33
      blank(67:99)=blank33
      blank(100:132)=blank33

c --- Confirm max size of control file record
      if(mxcol.GT.132) then
         write(*,*)'ERROR in TFERCF!'
         write(*,*)'Control file records are assumed to be <= 132'
         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
      read(io5,'(a132)',end=999) aline
      write(iox,'(a132)') aline
      ncommout=ncommout+1
      goto 10

c --- Transfer completed
999   close(io5)

      return
      end

c----------------------------------------------------------------------
      subroutine qaplot1(ibtz)
c----------------------------------------------------------------------
c
c --- CALMET     Version: 5.8      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----------------------------------------------------------------------
      subroutine airden_ns(pres,tempk,nssta,rho)
c----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8       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: 5.8         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: 5.8         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: 5.53c     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
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          IRHPROG(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/irhprog(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)    = irhprog(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(nyrz,njulz,nhrz,tempk,ziconv,tzgraa,
     1                  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----------------------------------------------------------------------
c
c --- CALMET   Version: 5.8       Level: 070623                  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 --- 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                   NYRZ - integer    - Year of current hour (GMT)
c                  NJULZ - integer    - Day of current hour (GMT)
c                   NHRZ - integer    - Current hour GMT time (0-23)
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 called by:  COMP
c --- TEMP3D 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 --- 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)
c**** Modified by EMI -- 4/26/94
        if (jorder .gt. 0) then
          call deltt(nyrz,njulz,nhrz,jbbyr,jbbday,jbbhr,jtogo)
          call deltt(jaayr,jaaday,jaahr,nyrz,njulz,nhrz,jpast)
        else
          call deltt(nyrz,njulz,nhrz,jaayr,jaaday,jaahr,jtogo)
          call deltt(jbbyr,jbbday,jbbhr,nyrz,njulz,nhrz,jpast)
        end if
c
c --- Check for negative values of jtogo or jpast
c
        if (jtogo .LT. 0 .OR. jpast .LT. 0) then
          write(io6,1089) iu,nyrz,njulz,nhrz,jpast,jtogo,jdelta,
     1                    ntzaas,ntzbbs
1089      format(//1x,'ERROR IN SUBR. TEMP3D -- Upper air',
     1    ' soundings do not straddle current hour for station ',i3/
     2    5x,'Current YYDDDHH (GMT)  ',i2,i3,i2,/
     3    5x,'GMT hours past and before soundings ',2i4/
     4    5x,'GMT hours between these soundings ',i4/
     5    5x,'GMT YYDDDHH codes for these soundings ',2i9)
          stop
        end if
c
c --- Double check for upper air data inconsistencies
c
        if ((jpast + jtogo) .ne. jdelta) then
          write(io6,1090) iu,nyrz,njulz,nhrz,jpast,jtogo,jdelta,
     &                    ntzaas,ntzbbs
1090      format(//1x,'ERROR IN SUBR. TEMP3D -- Inconsistent ',
     1    'upper air times for station ',i3/
     2    5x,'Current YYDDDHH (GMT) ',i2,i3,i2,/
     3    5x,'GMT hours past and before soundings ',2i4/
     4    5x,'GMT hours between these soundings ',i4/
     5    5x,'GMT YYDDDHH codes for these soundings ',2i9)
          stop
        end if
c****  End of EMI modifications -- 4/26/94
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: 5.8.4        Level: 130731                INOUT
c              EPA
c
c ---          Version: 5.815        Level: 110421               
c ---          Copied from V6.327 Level 090511 (F.Robe)
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 --- V5.730 (070128) to V5.8.4 Level 130731 (EPA)
c        - Added check to make sure the CALMET grid is located within the
c          prognostic grid (MCB-G)
c
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
