United States Meterological Data: Daily and Hourly Files to Support Predictive Exposure Modeling


vxEPA
United States
Environmental Protection
Agency
 United States Meteorological
 Data: Daily and Hourly Files to
 Support Predictive Exposure
           Modeling
      RESEARCH AND DEVELOPMENT

-------
                                                         EPA/600/R- 07/053
                                                                 May 2007
           United States Meteorological Data
Daily and Hourly Files to Support Predictive Exposure Modeling
                                By

                       Lawrence A. Burns, Ph.D.
                Ecologist, Ecosystems Research Division
                 U.S. Environmental Protection Agency
                       960 College Station Road
                        Athens, Georgia 30605

                        Luis A. Suarez, Ph.D.
            Pharmacokineticist, Ecosystems Research Division
                 U.S. Environmental Protection Agency
                       960 College Station Road
                        Athens, Georgia 30605

                        Lourdes M. Prieto, B.S.
          Environmental Scientist, Ecosystems Research Division
                 U.S. Environmental Protection Agency
                       960 College Station Road
                        Athens, Georgia 30605
                 U.S. Environmental Protection Agency
                  Office of Research and Development
                        Washington, DC 20460

-------
Notice

The U. S. Environmental Protection Agency through its Office of Research and Development funded
and managed the research described here under GPRA Goal 4, Preventing Pollution and Reducing
Risk in Communities, Homes, Workplaces and Ecosystems., Objective 4.3, Safe Handling and Use
of Commercial Chemicals andMicroorganisms, Sub obj ecti ve 4.3.4, Human Health and Ecosystem s,
Task 6519, Advanced Pesticide Risk Assessment Technology. It has been subjected to the Agency's
peer and administrative review and approved for publication as an EPA document. Mention of trade
names or commercial products does not constitute endorsement or recommendation for use.
Abstract

ORD numerical models for pesticide exposure include a model of spray drift (AgDisp), a cropland
pesticide persistence model (PRZM), a surface water exposure model (EXAMS), and a model offish
bioaccumulation (BASS). A unified climatological database for these models has been assembled
from several National Weather Service (NWS) datasets, including Solar and Meteorological Surface
Observation Network (SAMSON) data for 1961-1990 (versions 1.0 and 1.1), combined with NWS
precipitation and evaporation data. Together these NWS products provide coordinated access to solar
radiation, sky cover, temperature, relative humidity, station atmospheric pressure, wind direction and
speed, and precipitation. The resulting hourly and daily weather parameters provide a unified dataset
for use in coordinated exposure modeling. The data files, which include some derived data of use
to exposure modeling (e.g., short-grass crop standard evapotranspiration ET0) are publicly available
(gratis) on EPA's Center for Exposure Assessment Modeling (CEAM) web site at
http://www.epa.gov/ceampubl/tools/metdata/index.htm. By using observational data for models,
"trace-matching" Monte Carlo simulation studies can transmit the effects of environmental
variability directly to exposure metrics, by-passing issues of correlation (covariance) among external
driving forces.

This report covers a period from May 2, 2001 to December 27, 2004 and work was completed as
of December 27, 2004.

-------
                                       Foreword

Environmental protection efforts are increasingly directed toward preventing adverse health and
ecological effects associated with specific chemical compounds of natural or human origin. As part
of the Ecosystems Research Division's research  on the occurrence, movement, transformation,
impact, and control of environmental contaminants, the Ecosystems Assessment Branch studies
complexes of environmental processes that control the transport, transformation, degradation, fate,
and impact of pollutants or other materials in soil and water and develops models for assessing the
risks associated with exposures to chemical contaminants.

                                               Eric Weber, Director
                                               Ecosystems  Research Division
                                               Athens, Georgia
                                           11

-------
                                List of Symbols [units]


a      surface albedo or canopy reflection coefficient [dimensionless]. Standardized at 0.23 for
       the FAO hypothetical grass reference crop (Allen et al. 1998:23). The albedo of water
       surfaces for atmospheric radiation is 0.03, and for direct sunlight, 0.06 (Kohler and
       Parmele 1967).

A      slope of saturation vapor-pressure curve at temperature T [kPa °C"1];


            4G9S[Q.61GS exp(-£££r)l    [2503exp(-££
       A =	l-	\ 'J;"1'J = ±	-^4
                   (7* +237.3)'              (J +237.3)'

       For T in °F, A [inches Hg °F1] is (Lamoreux 1962)

                7182.6         /1c^a        -7482.6
       A =	— exp( 15,674 jexp
                                   ,
                 39836)-                    (T + 3 98.36)
a      solar declination [radians]

a      psychrometric coefficient [kPa °C"1] = 6.65* W~4P

       ais weakly dependent on temperature as well, a can alternatively be calculated from
              •Y=CpP/A£

       (Burman and Pochop 1994:28). In this equation, cp, the specific heat at constant pressure
       of naturally occurring moist air, can be taken as 1.013 kJ kg"1 K"1 (ASCE 1996:128), 4 the
       ratio of the mole weight of water to air, is 0.622, P is station barometric pressure [kPa],
       and e [kJ/kg] is calculated (following Harrison 1963) from dew-point temperature
       (Burman and Pochop 1994, ASCE 1996):  A = 25Q1 -2361'T^
dp      psychrometric coefficient for Class A evaporation pan [kPa °C ] = 0.001568/1

a      emissivity

e      latent heat (enthalpy) of vaporization (= 2.45 MJ kg"1 in FAO standard (Allen et al.
       1998:31)), calculated from dew-point temperature via /- = 2501-23617^,

o      angle of the sun above the horizon [radians]


                                          iii

-------
cp      latitude [radians]

u      solar time angle at midpoint of hourly period [radians]

6      Stefan-Boltzmann constant
       = 7.88 x 10"11 equivalent inches of evaporation cm"2 K"4 day"1 (using FAO standard
       enthalpy of vaporization of water of 585 cal/g)

e      water vapor pressure [kPa]

ea      atmospheric water vapor pressure, actual water vapor pressure [kPa] (= ed = 0.01 e  Rff)

es      saturation water vapor pressure [kPa] at temperature T [°C];
                            1727T
       e,(T) = 0.6108exp 	:
        "   '            *tr +237.

e-ea   vapor pressure deficit

ed      saturation water vapor pressure [kPa] at dew-point temperature Td(= ea)

Ea     aerodynamic function in Penman equation [mm day"1]

EL     evaporation from  small lake or pond [mm day"1]

Ep     pan evaporation [mm day"1]

ET0    reference or potential daily evapotranspiration for standard short-grass crop (FAO
       standard method)  [mm day"1]

ET0(hr)  reference or potential hourly evapotranspiration for standard short-grass crop (FAO
       standard method)  [mm hour"1]

G      soil heat flux density [MJ m"2 hour"1]

J      day of the year (on January 1, J=l; on December 31, J=365; 366 in leap years)

P      atmospheric pressure [kPa]

RH    relative humidity (%) = 100 x ejes

Ra     solar radiation received on a horizontal surface at the top of the atmosphere

Rn     net broad-band radiation in units of equivalent depth of water evaporated [mm day"1]
                                            IV

-------
Rn(hr)   net broad-band hourly radiation at the FAO reference short-grass surface [MJ m"2 hour"1]

Rs     global (direct + diffuse) solar radiation received on a horizontal surface [J cm"2 day"1]

Rso    short-wave radiation received on a horizontal surface on a clear-sky day [J cm"2 day"1]

T     temperature [°C]

Thr    mean hourly air temperature [°C]

Ta     mean daily air temperature, dry-bulb temperature [°C]

Tdp    dew-point temperature [°C]

T0     water-surface temperature [°C]

u2     average hourly wind speed at 2 meter height [m s"1]

u4     average hourly wind speed at 4 meter height [m s"1]

ua6    Class A evaporation pan wind speed at 0.6 m height (about 2 feet; 6 inches above rim of
       pan) [m s"1]

up     daily wind movement at Class A pan [km day"1] (at 0.6 m height)

u4d    daily wind movement over open water at 4 m height [km day"1]

uw    wind speed at  10 meter height [m s"1]

uai    wind speed at 0.1 meter height over open water [m s"1]

W     precipitable water in the atmosphere [mm]

[ ]     dimensionless units for variable

-------
                                       Contents


Notice	i

Abstract	i

Foreword	  ii

List of Symbols	iii

Introduction	j_

Data Sources	2

File and Data Formats	3_
       Daily Data Files	.3
       Hourly Data Files	3_

Data Assembly and Processing	6
       Assembly of Evaporation Data	6
       Assembly of Precipitation Data	7
       Estimation of standard crop potential evapotranspiration (reference evapotranspiration
             ET0)	7
       Estimation of Pan Evaporation and Free Water Surface Evaporation	j_j_
             Pond and Lake Evaporation	JJ
       Conversion of wind speeds to standard heights	j_5

Processing Sequence  for Production of Daily Values Files (*.dvf)	19_
       Notes and Irregularities	22

Fortran Processing Code	26
       BinaryTree	26
       dump	29
       dumpmet	49
       EtO	62
       Evap	90
       Fix_Data	99
       Gaps	103
       global	122
       LinkedList	134
       Make_RO	140
       Precip	142
                                           VI

-------
       raw_data	220
       read_info	231
       Red_Black	242
       samson	259
       setup	277
       Stats	291
       UtilsO	297
       Utilsl	300
       Utils2	324
       Utils3	357
       Utils4	363
       UtilsS	371

Test Data for Laramie, Wyoming: average values for August 1987	376

SAMSON Station Locations	377

References	386
                                         vn

-------
Introduction

Exposure models (e.g., EXAMS (Burns 2000), PRZM (Carousel et al. 2005)) used in EPA chemical
exposure assessments number weather data among their required input parameters. Although
"weather generator" software (e.g., Hanson et al. 1993, 1994, Nicks and Gander 1994) is available
and has been used for water resource and climate studies, it has been observed that the weather
sequences thus generated are weak in their ability to capture the extreme events that are usually of
greatest importance in exposure and risk assessments. For example, in a study (Johnson et al. 1996)
of the USCLIMATE (Hanson et al. 1993, 1994) and CLIGEN (Nicks and Gander 1994) models, the
authors remark that "[a]nnual and monthly precipitation statistics (means, standard deviations, and
extremes) were adequately replicated by both models, but daily amounts, particularly typical extreme
amounts in any given year, were not entirely satisfactorily modeled by either model. USCLIMATE
consistently underestimated extreme daily amounts, by as much as 50%." In a study (Semenov et al.
1998) of WGEN (Richardson and Wright 1984) (itself an element of USCLIMATE) and LARS-WG
(Semenov and Barrow 1997) at 18 climatologically diverse sites in the USA, Europe, and Asia, the
authors concluded that the Gamma distribution used in WGEN "probably tends to overestimate the
probability of larger values" of rainfall. This result, although opposite in tendency to that of Johnson
et al. (1996), is no less undesirable. Both models had a lower inter-annual variance in monthly mean
precipitation than that seen in the ob served data, and neither weather generator "performed uniformly
well in simulating the daily variances of the climate variables." Semenov et al. (1998) concluded that
failures to represent variance in LARS-WG and WGEN were "likely to be due to the observed data
containing many periods in which successive values are highly correlated..."

The problem of accurately preserving parameter variability, and covariance among parameters, can
be bypassed by using observed synoptic data, and the pitfall of generating impossible input scenarios
(e.g., days of heavy rainfall coupled with maximum drying potential) can be avoided, given accurate
input datasets. Weather generator software can be problematic in this regard. For example, CLIGEN
generates temperature, solar radiation, and precipitation independently of one another, so the
covariance structure of daily sequences need not be preserved in the model outputs.

Here we report on the production of long-term (30-year) observed weather sequences for use in
ecological exposure modeling. The Weather Station Data Files (available at
http://www.epa.gov/ceampubl/tools/metdata/index.htm) contain weather data for 23 7 meteorological
stations for the (nominal) period 1961-1990. Two types of files were generated: "*.dvf for daily
values file, and "*.hww" for hourly values file. The daily weather files are used by the current
versions of PRZM and EXAMS; they also include values potentially useful for modeling of spray drift
of pesticides. The hourly data files serve as both source for the daily files and as a detailed data set
publicly available for inclusion in simulation models. The name of each file is of the form "wnnnnn",
where "nnnnn" represents the WBAN (Weather Bureau Army Navy) identification number of the
weather station. Daily files are of file type ".dvf' and "««" denotes the last two digits of the year for

-------
each hourly file. For example, w25501 .h65 contains 1965 hourly data for WBAN 25501 located in
Kodiak, AK. More information on WBAN numbers is available at
http://lwf.ncdc.noaa.gov/oa/climate/stationlocator.html
Data Sources

The following sources provided data for the generation of the hourly files:

4 Solar and Meteorological Surface Observation Network (SAMSON) 1961 -1990 data sets, Version
1.0, Sept. 1993.

4 National Solar Radiation Data base (NSRDB) version 1.1; NSRDB Hourly Data Files Text files
downloaded from http://rredc.nrel.gov/solar/old data/nsrdb/hourly/. These files provided updated
solar radiation parameters for the SAMSON database.

4 Earthlnfo NCDC Summary of the Day and Surface Airways, 2001. Provided daily and hourly
values for precipitation, and daily evaporation. Missing evaporation was calculated using the
Kohler-Nordenson-Fox (Kohler et al. 1955, Burman andPochop 1994) Class-A Evaporation Pan
version of the Penman-Monteith equations.
SAMSON (Solar and Meteorological Surface Observation Network) data were obtained from NOAA
(http://nndc.noaa.gov/onlinestore.html) as athree-volume CD-ROM disk set containing observational
and modeled meteorological and solar radiation data for the period 1961-1990. SAMSON
encompasses 237 NWS (National Weather Service) stations in the United States, plus offices in
Guam and Puerto Rico. An additional five years of data (1991-1995) were acquired on CD from
NCDC (National Climatic Data Center) as the HUSWO (Hourly United States Weather Observations)
product. (HUSWO is nominally an update to the SAMSON files.) Combined data were then available
for 234 stations over 1961-1995. Weather stations used to deveop these data files are tabulated
according to their standard WBAN (Weather Bureau Army Navy) number, along with station location
(City, State), geographic (latitude and longitude) coordinates, and station elevation (m), later in this
document.

The hourly SAMSON solar elements comprise extraterrestrial horizontal and extraterrestrial direct
normal radiation; and global, diffuse, and direct normal radiation. Meteorological elements comprise
total and opaque sky cover, temperature and dew point, relative humidity, station pressure, wind
direction and speed, visibility, ceiling height, present weather, precipitable water, aerosol optical
depth, snow depth, days since last snowfall, and hourly precipitation. Weather elements in the
HUSWO files include total and opaque sky cover; temperature and dew point; relative humidity;
station pressure; wind direction and speed; visibility; ceiling height; present weather; ASOS
(Automated Surface Observing System) cloud layer data; snow depth; and hourly precipitation for
most stations. Stations for which hourly precipitation was not available are italicized in the station
tabulation.

-------
The original intent for this project was to develop a data base encompassing the entire 1961-1995
period. However, the HUSWO CD-ROM, albeit formatted the same as SAMSON, was discovered to lack
solar radiation data, i.e., the fields are present but marked as "missing data." The published EPA
dataset was therefore restricted to the period 1961-1990.
                               File and Data Formats

Daily Data Files

The daily values were obtained by computing the mean over 24 hours, or by adding the values over
one day, as appropriate, from the completed hourly values data files. "Daily Values File" data files
(*.dvf) have the following format:

Field  Columns   Description            Units                     Type        Format
1
2
3
4
5
6
7
8
9

10

11

12
13

14

15


02
08
18
28
38
48
58
64

74

78

81
91

97

103

1
- 07
- 17
- 27
- 37
- 47
- 57
- 63
- 73

- 77

- 80

- 90
- 96

-102

-106

blank
Date
Precipitation
Pan Evaporation
Temperature (mean)
Wind Speed @10 meter
Solar Radiation
FAO Short Grass Eto
Daylight Station
Pressure
Daylight Relative
Humidity
Daylight Opague
Sky Cover
Daylight Temperature
Daylight Broadband
Aerosol
Daylight Prevailing
Wind Speed @10 meter
Daylight Prevailing
Wind Direction
N/A
mmddyy
cm/ day
cm/ day
degrees Centigrade
cm/ second
Langleys/day
mm/ day
kiloPascal

percent

tenths of sky covered

degrees Centigrade
optical depth

meter/second

degrees (N=0, E=90, .

                                                                  Character   Ix
                                                                  Integer     3i2
                                                                  Real        flO.2
                                                                  Real        flO.2
                                                                  Real        flO.l
                                                                  Real        flO.l
                                                                  Real        flO.l
                                                                  Real        £6.1
                                                                  Real        flO.l

                                                                  Integer     i4

                                                                  Integer     i3

                                                                  Real        flO.l
                                                                  Real        £6.3

                                                                  Real        £6.1

                                                                  Integer     i4
                             :tion

Daily values Fortran file format:
            (Ix,3i2, t8,f!0.2, tl8,f!0.2, t28,fl0.1, t38,f!0.1, &
               t48,f!0.1, t58,f6.1, t64,f!0.1, t74,i4, t78,i3, &
               t81,f!0.1, t91,f6.3, t97,f6.1, U03,i4)


Fields 03 - 08 are daily totals or mean values (i.e., mean Wind Speed and mean Temperature)
Fields 03 - 07 units preserved from earlier PRZM meteorological files for compatibility
Fields 09-15 are mean values over daylight hours only (to support photochemical and spray drift
algorithms)
Hourly Data Files

Hourly values files (*.hnn) contain hourly data for the year 19nn. For example, w25501 .h65 contains
1965 hourly data for Kodiak, AK. The hourly values file has a header containing identifying
information.

-------
Example header record:
Header field description:



Field  Columns  Description
Type
            Format
1
2
3

4

5
6




7




8
9





1
02 -
08 -

39 -

42 -
47 -
47 -

48 -
53 -
57 -
57 -

58 -
63 -
67 -
74 -





blank
06 WBAM id
37 City where the
station is located.
40 State where the
station is located.
44 Time Zone
54 Latitude of the station
47 N: North of the Equator
S : South
51 Degrees
54 Minutes
64 Longitude of the station
57 W: West
E: East
61 Degrees
64 Minutes
70 Station Elevation (meter)
92 Generation date of the
file, i.e, yyyy-mm-dd hh:
where
yyyy: year
mm: month
dd: day of the month
Character
Character
Character

Character

Character

Character

Integer
Integer

Character

Integer
Integer
Integer
Character
:mm: ss




Ix
a5
a30

a2

a3

al

14
12

al

14
12
14
a!9





hh: hour (24-hour clock)


Header



Hourly
Field
1
2
3
4


5


mm: minutes
ss: seconds
format: (Ix, a5, Ix, a30, Ix, a2 ,



data
2x, al, 14, Ix, 12, &
2x, al, 14, Ix, 12, &
2x, 14, 3x, a!9)
fields:
Columns Description

002
012
016


023
1 blank
- Oil Date
- 014 *Hour of the day
- 021 Extraterrestrial
Horizontal
Radiation (Ra)
- 028 Extraterrestrial


Ix, a3, &




Units
N/A
yyyy-mm-dd
Hour
*Wh/m2


Wh/m2















Direct Normal Radiation
6

7

8

9
10
11
030

039

048

057
061
065
- 037 Global Horizontal
Radiation (Rs)
-046 Direct Normal
Radiation
- 055 Diffuse Horizontal
Radiation
- 059 Total Sky Cover
- 063 Opague Sky Cover
- 070 Dry Bulb Temperature
Wh/m2

Wh/m2

Wh/m2

tenths of
tenths of






sky cove
sky cove
degrees Centigrade
                                                                Type
                                                                             Format
Character
Integer
Integer
Integer
Integer
Integer
Integer
Integer
Integer
Integer
Real
Ix
14 , Ix, 12, 1
13
15, al
15, al
15, a3
15, a3
15, a3
12, al
12, al
f5.1,al

-------
 12    072 - 077  Dew Point Temperature  degrees Centigrade     Real         f5.1,al
 13    079 - 082  Relative_Humidity      percent                Integer      13,al
 14    084 - 089  Station_Pressure       *kPa                   Real         f5.1,al
 15    091 - 094  Wind_Direction         degrees(N=0,E=90,...)  Integer      13,al
 16    096 - 101  Wind_Speed @10meter    m/s                    Real         f5.1,al
 17    103 - 109  Horizontal Visibility  km                     Real         f6.1,al
 18    111 - 117  Ceiling Height         m                      Integer      16,al
 19    119 - 120  Observation Indicator  N/A                    Integer      11,al
 20    122 - 131  Present_weather        N/A                    Character    a9,al
 21    133 - 136  Precipitable Water     mm                     Integer      13,al
 22    138 - 144  Broadband Aerosol      Optical_Depth          Real         f6.3,al
 23    146 - 150  Snow Depth             cm                     Integer      14,al
 24    152 - 155  Days since last        day                    Integer      13,al
                   Snowfall
 25    157 - 164  Hourly Precipitation   cm                     Real         f6.2,a2
 26    166 - 172  Eto, FAO Short Grass   mm/day                 Real         f6.2,al
 27    174 - 180  Ep, Class A pan        mm/day                 Real         f6.2,al
                    Evaporation

*Hour of the day: The range of the hour of the day is Ih to 25h:
   lh-24h: line contains data for the hour
   25h: line contains daily values

*Wh/m2: Watt hour meter"2
   Watt hour meter"2 is equivalent to 3.6e-3 MJoule meter"2
   Watt hour meter"2 is equivalent to 8.59845e-02 Langley

*kPa: kiloPascal (1 kiloPascal is equivalent to 10 millibar)

Fields 26 and 27 represent daily totals. These fields are populated only when the hour of the day
(field 3) is 25.

Generally, each value has one or more character flags associated with it. When possible, the flags
associated with the original datum are transferred to the Hourly Values File (*.hnn).

  "W"  = Measured value (SAMSON flag)
  "B"  = Calibrated (SAMSON flag)
  "D"  = Deleted (SAMSON flag)
  "E"  = Estimated
        = Missing value
  "R"  = Datum from Earthlnfo data 2001
  "S"  = Datum from SAMSON version 1.0
  "T"  = Datum from SAMSON version 1.1
  "U"  = Unlimited in Visibility or Ceiling Height, or short-gap interpolation with either of the
          endpoints being Unlimited or Cirriform.
  "Z"  = Cirriform in Ceiling Height data
  "?"   = Value is undefined, given the context,  e.g., Dew point is undefined if the Relative
          Humidity is zero.
  "#"   =If the station is above the Arctic Circle (Latitude 66.5 degrees North), then the region
          will be in darkness for a period  of the year. This prevents the computation of, e.g.,
          Daylight value  of Global Horizontal Radiation and Reference Crop Evapotranspiration
          (Et0)

-------
"A" = Accumulation (SAMSON flag). The precipitation is distributed in the observation interval.

Missing values are denoted by "— "in the numeric value field and flag value of"- "

Hourly values Fortran file format:
(Ix,i4,lx,i2,lx,i2,13, t!6,i5,al, t23,i5,al, &
t30,i5,a3, t39,i5,a3, t48,i5,a3, &
t57,i2,al, t61,i2,al, t65,f5.1,al, t72,f5.1,al, &
t79,i3,al, t84,f5.1,al, t91,i3,al, t96,f5.1,al, &
U03,f6.1,al, tlll,i6,al, tl!9,il,al, t!22,a9,al, &
U33,i3,al, U38,f6.3,al, U46,i4,al, U52,i3,al, &
t!57,f6.2,a2, t!66,f6.2,al, t!74,f6.2,al)
Data Assembly and Processing

Assembly of Evaporation Data

GIS software (Arclnfo) was used to facilitate station identification and data assembly. GIS
evaporation coverages for Alaska, Hawaii, Guam and Puerto Rico were created by extracting from
the 2001 NCDC Summary of the Day Earthinfo CD-ROMS the coordinates of the stations that had
evaporation data for each pertinent state or region. An evaporation coverage for the conterminous
United States was created by extracting from the 1998 NCDC Summary of the Day Earthinfo CD-
ROMS the coordinates of the stations that had evaporation data.

To obtain evaporation data for the SAMSON stations in the conterminous U.S. the following
guidelines were used:

- when available, data were taken from the cooperative network reporting station that corresponded
to the SAMSON station of interest
- when the corresponding station was not available or had no data for the period of interest, a
nearby station was chosen according the following criteria:
- The station had to be located in the same climate region as the SAMSON station in question. To
determine the climate region, an image of the map: "Land Resource and Climate Regions of the
United States for EPA - Pesticide Study," provided by EPA's Office of Pesticide Programs, was
used. This map was developed for the U.S. Environmental Protection Agency, Office of Pesticide
Programs, Environmental Fate and Effects Division under a contract with Oak Ridge National Lab
in 1999-2000. ORNL subcontracted to USDA/NRCS through the Conservation Technology
Information Center (CTIC) at Purdue. The work was carried out by NRCS staff Glenn Weesies
(West Lafayette, IN), Dave Lightle (Lincoln, NE) and Ken Pfeiffer (Portland, OR). The
EFED/ORNL proj ect was entitled: "C-factor zone map of the U. S. to localize RUSLE applications
for various crops developed and supporting database completed which includes RUSLE crop,
climate, field operation, and C-factors."
- Out of the stations located in the same climate region, we picked the closest one that had an
station elevation difference with the SAMSON station of interest of no more than 500 feet.

-------
 - If the station chosen fell within 20 km of the SAMSON station, the station was considered to be "on
 target". Stations that were more than 20  km away were considered to be "not on target". The
 maximum allowable distance for "not on target" stations was 200 km.

To obtain evaporation data for the SAMSON stations located in Alaska, Hawaii, Guam and Puerto
Rico the above guidelines were followed except that the station chosen had to be located in the same
Major Land Resource Area (MLRA) as the SAMSON station in question, since no corresponding
climate  region map was available for these  areas.
Assembly of Precipitation Data

Daily precipitation files were created by extracting data for each station from the 2001 NCDC
Summary of the Day Earthinfo CD-ROMS.

Hourly precipitation files were created by extracting hourly data for each station from the 2001
NCDC Hourly Precipitation Earthinfo CD-ROMS.
Estimation of standard crop potential evapotranspiration (reference evapotranspiration ET0)

The FAO Penman-Monteith equation for hourly time steps (Allen et al. 1998:74) is:
                 C('r>                  A+/(1+G34M,)
where  ET0(hr) is hourly reference evapotranspiration [ mm hour"1]
 Rn(hr)  is hourly net radiation at the grass surface [MJ m"2 hour"1]
 G  is soil heat flux density [MJ m"2 hour"1]
 Tte is mean hourly air temperature [°C]
 A is slope of the saturation vapor pressure curve at Thr [kPa °C"1];
                                     (4. + 2373)'
 a  is the psychometric constant [kPa °C"1]. The SAMSON data files report station barometric
    pressure in millibars (ImB = 0.1 kPa); after conversion to kPa, a=6.65xlO~4 x P (Allen et al.
    1998:32).
 es(T^r)  is the saturation vapor pressure at Thr
 ea is average hourly actual vapor pressure [kPa]
 u2 average hourly wind speed at 2 m height [m s"1]

-------
This reference is accessible online at http://www.fao.org/docrep/X0490E/x0490eOO. htm .

From the relative humidity measurements reported in the SAMSON data files, actual vapor pressure
e was calculated as
                                    '    :kr   100

where RHhr is hourly relative humidity [%], and es(Tht), the saturation vapor pressure at temperature
Thn is calculated from (Allen et al. 1998:36)
                                                .^+2373.
Net radiation Rn(hr) is the difference between net shortwave radiation R^ and the net longwave
radiation Rnl at the hourly time steps:

                                    K-n(hr) = ^ns ~ ^nl

The SAMSON data files report hourly values of global horizontal radiation^ [Wh m"2]. Net hourly
shortwave radiation Rm [MJ m"2 hour"1] is the balance between incoming and  reflected  solar
radiation, given by

                  RK = 3.60 x 1Q~3 (1 - a}R. = 3.60 x 1Q~3 (1 - 0.23)J2.

The factor 3.60 x 10"3 converts from [Wh m"2] to [MJ m"2]; the albedo of the standard short-grass crop
is 0.23 (Allen etal. 1998:23).

Net longwave radiation Rnl was calculated as
                        ^ +27315]4(034- 0,14
135 ^--035
in which the Stefan-Boltzman constant 6 has the value 2.043><10~10 MJ m"2 hour"1. The ratioR/RSO,
the ratio of actual global horizontal radiation to the equivalent (theoretical) clear-sky shortwave
radiation, represents the effect of cloud cover and atmospheric aerosol. For calculation ofRnl for
hourly periods during nighttime hours, the ratio R/RSO is set equal to R/RSO calculated for a time 2-3
hours before sunset, before the sun angle becomes small. The hourly period 2-3 hours before sunset
was identified in the SAMSON files from positive (non-zero) values in the global horizontal radiation
field.

-------
For the calculation of Rso (short-wave radiation on a clear-sky day),
where the factor 3.60* 10~3 converts Ra from [Wh m"2] to [MJ m"2], and
KB = the clearness index for direct beam radiation []
KD = the corresponding index for diffuse radiation []
Ra = extraterrestrial radiation on a horizontal surface, reported in SAMSON in [Wh m"2]

The clearness index KB was calculated from

                                                                   0.4 ~
                 Ks = 0,98 exp
                                   -O.G0146P    „     f   W
- 0.075
where
P = atmospheric pressure [kPa]; P converted to [kPa] from SAMSON file hourly values [millibars]
W = precipitable water in the atmosphere [mm], hourly values read from SAMSON files
Kt is a turbidity coefficient [], 0 sin $ + cos (p cost? cos m
where
 d = solar declination [radians]
 cp = station latitude [radians]
 it = solar time angle at midpoint of hourly period [radians]

The solar declination d is calculated from
                                           i' ~*           ""S
                            £ = 0.409 sinl —.7-1.391
                                           V365         )
where J is the day of the year.

The solar time angle u at the midpoint of the period is

                   to = -^ [r + G.G6667(I7 - Iw) + Sc - 12]

where
 t = standard clock time at the midpoint of the hour [hours, based on 24-hour clock]

-------
 Lz = longitude of the center of the local time zone [degrees west of Greenwich] (see Table 1)
 Lm = longitude of the measurement site [degrees west of Greenwich]
 Sc = seasonal correction for local solar time [hour]

                           Table  1. Standard U.S. Time Zones

                           Time   Letter   U.S. Name    Central
                           Zone                        Meridian
+4
+5
+6
+7
+8
+9
+10
+11
-10
Q
R
S
T
U
V
w
X
K
Atlantic
Eastern
Central
Mountain
Pacific
Alaska
Hawaii-
Aleutian
Samoa
Chamorro
(proposed)
60W
75W
90W
105W
120W
135W
150W
165W
150E
                           "Time Zone" indicates hours to be added to local standard
                           time to arrive at Universal Time, Coordinated (UTC).
                           Time zones in the USA are defined in the U.S. Code, Title
                           15, Chapter 6, Subchapter IX - Standard Time. The U.S.
                           Department of Transportation is responsible for time zone
                           boundaries.
The seasonal correction for local time Sc is (Allen et al. 1998:48)

                     5;  = 01645sin(2£)- 0.1255cos(&)- 0.025sin(6)

                     b = ^—	
                             364

where/is the day of the year. Jean be determined (Allen 1996) by
                             J = int
275—-30 +D|-2
      9           )
whereMis month number (1-12) and D is day in month; with the proviso that ifM<3, J=J+2, and
during leap years, if M>2, J=J+l. Alternatively, Jean be determined from (Allen 2000)
                                             10

-------
9) \.M + V UQQ 4 }

where
DM is the day of the month (1 - 31)
M is the number of the month (1-12)
7 is the year (e.g., 1990)

The diffuse radiation index KD was then calculated from KB (Allen et al. 1998:227):

KD = 0.35 - 036KB forKB >0.15 (parameters altered per (Allen 2000))
KD = Q.IS + Q.S2KB forKB<0.\5.

Soil heat flux G is important for hourly calculations. Hourly G during daylight periods is
approximated as Ghr = 0.1 Rn, and during nighttime periods as Ghr = 0.5 Rn (Allen et al. 1998:55).
The coefficients in these equations assume a constant surface resistance rs of 70 s/m during all
periods. This may cause some under-prediction of ET0 during some daytime periods and over-
prediction ofET0 during evening hours. Precise estimates ofET0 for specific hourly periods would
require the use of aerodynamic stability functions and estimation of rs as a function of radiation,
humidity, and temperature. When hourly values are summed to 24-hour totals, however, these hourly
differences compensate for one another (Allen et al. 1998). Such functions were therefore not used
in assembling this dataset.
Estimation of Pan Evaporation and Free Water Surface Evaporation

Evaporation from the standard Class A pan is measured at numerous Weather Bureau stations. These
pans provide a measure of the integrated effect of radiation, temperature, humidity, and wind on
evaporation from an open water surface. The pans are, however, subject to some systematic
differences in their behavior from that of natural water bodies or crops. These differences include
energy exchange with the pan ambient environment through the pan walls, the differing albedo of
water and cropped agricultural surfaces, heat storage and thermal inertia differences between lakes,
crop lands, and evaporation pans, and differences in aerodynamic properties of the air immediately
above the respective surfaces. Adjustment of observed pan evaporation to estimate lake evaporation
and crop water use remains a useful and common procedure, however, and Field 4 of the database
retains measured/modeled pan evaporation in cm/day.

Observations of water lost from Class A pans are commonly suspended during Winter months, and
are subject to errors during rainfall events due to splash-out even when the pans are meticulously
maintained. For this project, the Kohler-Nordenson-Fox equation (Kohler et al. 1955, Burman and
Pochop 1994) was used to estimate pan evaporation from meteorological data. Where possible, the
estimates were correlated with observed pan evaporation on rain-free days at the station, from which
monthly correction/calibration factors were developed. Database field 4 (daily pan evaporation, cm)
was filled with observed data where possible, supplemented with modeled data (corrected by month-
specific calibration factors) to fill in missing values.

-------
The underlying equation is an adaptation of the Penman (Penman 1948, 1963) equation to the task
of estimating Class A pan evaporation E [mm day"1], as
                                 EP =
                                            + Yp
In (Kohler et al. 1955), a psychometric coefficient ap specific to the Class A pan was created by
inclusion of an empirical adjustment that accounts for sensible heat conducted through the sides and
bottom of the pan. The psychometric coefficient is calculated from mean daily station barometric
pressure [kPa] via ^Q.001568/1; the values calculated with this relationship exceed theoretical
values of a as a consequence of the incorporated heat transfer component.

The  aerodynamic  function Ea [mm day"1] in the  Penman equation, specific  to Class A pan
evaporation, was developed by Kohler et al. (1955) from data at four locations representing a variety
of climatic regimes (Vicksburg, Mississippi; Silver Hill, Maryland; Boulder City, Nevada; Lake
Hefner, Oklahoma). For this project, Ea [mm day"1] was thus calculated as
Ea = 25.4{0.295(es  - ej}°'ss(0.37
                                             °'ss

where
 e-ea  is the mean daily vapor pressure deficit [kPa] computed from hourly values of relative
       humidity RHhr and air temperature Thr
 up is daily wind movement [km day"1] calculated from hourly wind speeds at 0.6 m height

Effective net radiation for the Class A pan (the termARn) is given by (Lamoreux 1962, Burman and
Pochop 1994:185)

     ( AJ? J = 154.8 exp[(1.8Ja - 180)(0 1024 -0.01 066 ln(0.086J?J)]- 0.0 1548
where
 Rs is global horizontal radiation [Wh m"2 day"1], derived from SAMSON by summation over the day,
    and
 Ta is mean daily air temperature [°C]

Here A [kPa/°C], the slope of the saturation vapor pressure versus temperature curve, was calculated
by the method recommended at (Burman and Pochop 1994:24):
                                2503
                      A =	 exp
                                     1121T
                                             i*
                                       +2373
                                          12

-------
Pond and Lake Evaporation

Although based on limited data, the ratio of annual Class A pan evaporation to evaporation from
natural water bodies (e.g., small ponds) can be taken as 0.70, provided (Kohler et al. 1955)

1. Any net energy advection into the pond is balanced by the change in energy storage
2. air temperature adequately represents surface water temperature, and, if an observation pan is the
data source (rather than a computed value as EP)
3. The net transfer of sensible heat through the observing pan is negligible.
4. The observing pan exposure is representative of pond conditions.

To account for the third point above, a "theoretical" pan (i.e., one not subject to sensible heat
transfer through its walls) is constructed by replacing the pan-specific coefficient ap with a standard
psychometric coefficient a calculated as o=0.000665/> (Allen et al. 1998:32), giving
A +;/

where ARn and Ea are calculated as for pan evaporation above.

Evaporation calculated by this equation is generally designated "free water surface" (FWS)
evaporation in order to emphasize its somewhat theoretical nature, i.e., it can only apply in its
uncorrected form to small ponds meeting the four requirements listed above. This equation was used
in the production of the NWS Evaporation Atlas for the Contiguous 48 United States (Farnsworth
etal. 1982).

As might be expected from the admixture of a generalized annual coefficient (0.70) with shorter-
term calculations, the pan coefficient, i.e., the ratio EFWSIEP, can vary considerably from month to
month. The value of the pan coefficient depends on climatic conditions in the area affecting thermal
properties of the exposed evaporation pan. Pan coefficients in the contiguous 48 United States were
observed to vary from 0.64 to 0.88 for the period May through October (Farnsworth et al. 1982:5).
Pan coefficients for colder months (November through April) were usually smaller than those of
warmer months. Coastal southern California offers an "extreme" example, in which pan coefficient
values range from 0.88 for the warmer months to 0.64-0.68 for the colder months.

The assumptions of the equations for free water surface evaporation (Penman 1948, Kohler et al.
1955, Penman 1963) were reexamined by Kohler and Parmele (Kohler and Parmele 1967). Because
several empirical factors were inferred from data, the units in use at the time were maintained for
this analysis. Their modified equation for evaporation EFWS [mm day"1] from a free water surface
(FWS) is
13

-------
                                                       •y + •
                                                                    oo
              = ?S 4	
                                             4OT(7;+27315)i
                                       1 f            s* -  .

where
 EFWS  is free-water-surface evaporation in mm day"1 (converted via 25.4 mm/inch)
 a  is the broad-band emissivity of the water surface (-0.97 (Kohler et al. 1955:11))
 6  is the Stefan-Boltzmann constant in units of equivalent depth of evaporation, here with a value
    of 7.87x 10"11 [inches cm"2 K"4 day"1] (Kohler and Parmele 1967) using the FAO standard value
    of e of 2.45 MJ/kg = 585 cal/g
 Rn is daily broad-band net radiation, expressed as [inches cm"2 day"1] of equivalent evaporation. The
    SAMSON data files include hourly global horizontal radiation (Rs, [Wh m"2]), and hourly diffuse
    horizontal radiation (Rdifi [Wh m"2]). Taking the albedo of atmospheric radiation as 0.03 and the
    albedo of incident direct solar radiation as 0.06 (Kohler and Parmele 1967), net radiation is
    (0.97 Rdif+ 0.94(^ - R^). Daily net radiation is then the sum of the  hourly values, converted
    to Langleys (cal/cm2), divided by the enthalpy of vaporization (585 cal/g), and converted  to
    equivalent inches of water evaporated (Ig water /cm2 = 0.3937 inches of evaporated water):

                          Q.97JU-.+ 0.94(5. -£.„,)
      A, = 0.086 x 0.3937 x	^	—	^- = 5.79 x 10~S(057JZ,V + 0.94(5, - J?,,r»
       •"                            585                      N     •"•'       ^  J    -^

 Ta is mean daily air temperature [°C]
 f(u) is the wind function in the aerodynamic equation i.e., E2 - f(u^e, - ea]
   The wind function f(u), in which u4d is daily wind movement at 4 meter height [km day"1],  is
 e-ea  is the mean daily vapor pressure deficit [inches of Hg] computed from hourly values of
       relative humidity RHhr and air temperature Thr. This quantity can also be calculated from
       (Lamoreux 1962):
          e -e  = 6.4133x10
                                          - 7482.6             - 7482.6
exp	exp
                                     '  1.87; + 430.36      '1.87;+ 43036
  Td mean daily dewpoint temperature [°C]
  u4d is daily wind run [km day"1] calculated from hourly wind speeds at 4 m height
  a  is the psychometric coefficient, taken as a constant 0.0105 [inches of Hg °F"1], or calculated
    from mean daily station barometric pressure [kPa] via a= 0.000108/1.
  A  is the slope of the saturation vapor pressure versus temperature curve, here in units of [inches
    of Hg °F1]

Evaporation from ponds and lakes of any considerable size will  vary significantly from FWS
evaporation. This can be appreciated by noting that larger lakes remain noticeably cooler than small
ponds for an extended period early in the year, and remain noticeably warmer for an extended period
during the Fall. Maximum lake evaporation can thus lag maximum pond or pan evaporation by
several months. The Lake Hefner study ((Harbeck and Kennon 1954), cited from (Merkel  1988))

                                           14

-------
reported one to three years of evaporation data for four lakes, from which monthly multipliers for
EFWS can be deduced. The lakes are

• Lake Okeechobee, Florida (maximum depth 5.2 m, mean depth 2.7 m, volume 57.6x 107 m3)
• Lake Hefner, Oklahoma (maximum depth 29 m, mean depth 8.8 m, volume 9.2x 107 m3)
• Fort Collins Reservoir, Colorado (maximum depth about 26 m), and
• Lake Elsinore, California (mean depth 7.5 m, volume 10.7><107 m3)

Monthly factors for these four lakes are given in Table 2 (Merkel 1988).
Table 2. Monthly factors for conversion of
free water surface evaporation EFWS to large
lake evaporation
Month Factor Month
Factor
January 0.986

February 0.857

March 0.821

April 0.821

May 0.871

June 0.937
July 1.014

August 1.079

September 1.129

October 1.166

November 1.179

December 1.143
These factors are recommended (Merkel 1988) for use with lakes similar to the four lakes from
which the data were derived. (Merkel (1988) does not report variances associated with these
estimates.) Few data are available for larger or smaller lakes.
Conversion of wind speeds to standard heights

Wind speeds u reported by the NWS and incorporated into SAMSON do not include a correction for
the height of the anemometer above the ground surface, which in many cases has varied significantly
over the history of the observing station. These histories were assembled using data at
http://lwf.ncdc.noaa.gov/oa/climate/surfaceinventories.html.

For this project, extrapolation of observed wind speeds to several standard heights was required:

1. The international standard height of 10 meters was used for wind speed data entered in Field 6
of the database (http://wwwl .ncdc.noaa.gov/pub/data/documentlibrary/tddoc/td6421 .pdf).
2. Standardization to 2 meter height was required for calculation of FAO standard potential
evapotranspiration ET0.
3. Standardization to 0.6 meters ("nearly 2 feet above the ground level" (Farnsworth et al. 1982:3))
was required for calculation of pan evaporation and free water surface (FWS) evaporation by the
15

-------
methods of Kohler et al. (1955), based on the standard Class A evaporation pan anemometer.
4. Standardization to 4 m height under meteorological station conditions was required for
calculation of free water surface (FWS) evaporation by the method of Kohler and Parmele
(1967).

These corrections are usually made, in the absence of available detailed studies of the wind profile
at a site, by translation of observed wind speeds u at heights z1 and z2 along a logarithmic wind
profile defined by the equations (Brutsaert 1982:58):
for z » z0m, where the subscripts refer to two levels in the wind profile, z0m is the momentum
roughness parameter, u* is the friction velocity, and k is von Karman's constant.

For rough surfaces (most natural surfaces) the momentum roughness is commonly written as z0m=z0
where z0 is referred to as surface roughness length or roughness height (Brutsaert 1982). Proper
placement of the reference height d0 (at which z=0) is somewhat uncertain for rough surfaces. For
densely placed somewhat permeable obstructions, which describes most crops, the reference level
d0 (the zero plane displacement) is somewhere between the ground level and the crop height h; in
the FAO standard methodology d0 is taken as 2/2/3. More generally, then
Thus, to calculate the wind profile, the value of two parameters must be established: the zero-plane
displacement height d0 and the roughness height z0, of both the observing instrument and the target
profile. The windspeed uc at a height zc above a surface with a zero-plane displacement of dc and
roughness height z0c is then conventionally calculated from the observed windspeed u1 at height z;,
zero-plane displacement d, and roughness height z01, from the relationship:
kr z,. -dr.
^
IL = M,
16

-------
The FAO reference surface is a hypothetical grass reference crop with an assumed crop height h of
0.12 m, a fixed surface resistance of 70 s ~l and an albedo of 0.23 (Allen et al.  1998:23). For such
a crop, the zero plane displacement height d0 (m) and the roughness length governing momentum
transfer z0m are estimated as d0 = (2/3 )/z  = 0.08m, and z0m = 0.123 h = 0.01476m. The calculation of
d as (2/z/3) is fairly representative (Brutsaert 1982), although d/h doubtless varies as a function of
the density of the planting. However, as Jappears in (z-d), the profile functions are not very sensitive
to its exact value, so long as z » z0. In what follows, u10 designates wind speed at 10 m height, u4
wind speed at 4 m height, u2 wind speed at 2 m height, and u06 wind speed at 0.6 m (~2 foot) height.

Table 3 gives momentum surface roughness and zero-plane displacements for selected surfaces.
 Table 3. Aerodynamic parameters for wind speed computations
Surface
Open Flat Terrain (Used for
Meteorological Stations)
Class A Pan
Anemometer

Roughness
Length z0 (m)
0.03
0.01476

Zero Plane Dis-
placement d0 (m)
0.0 (none; few
isolated obstacles)
0.08

Reference
(EPA 2000)
Assumed approx.
same as FAO Short
Grass
 FAO Reference
 Short-Grass Crop

 Open sea, fetch > 5km

 Large Water Surfaces
   0.01476              0.08
   0.0002       Depends on sea state

0.0001-0.0006   Depends on sea state
  0.000228
(Allen etal. 1998)


(EPA 2000)

(Brutsaert 1982)
For wind speeds at 10 m height derived from SAMSON observations, extrapolation along an observing
station site logarithmic wind profile was accomplished by taking dc = dj = Om, and z0c = z01 = 0.03m.
Inserting these numerical values in the equation for calculated wind speed uc at 10 meter height (i.e.,
calculating u10 from SAMSON observations of meteorological observing station (airport) wind speed
ua at anemometer height za [m]) yields
                               in/io.o-o.o\
                               m\   0.03  )
                            5.81
                                             =  ur
                                                   ln(za / 0.03)
                                           17

-------
Similarly, for wind speed at 2 meter height above the FAO reference short-grass crop surface u2,
              2.00-0.08
                                           \
                                           )
              . 0.01476  .
77   zn  77  	:	— = 1J
Lt-i      a      '    "" "•     '  '
                                                        ra / 0.03)
For computation of meteorological station wind speed at 4 m height (for use in calculation of free
water surface evaporation by the Kohler-Parmele equation (Kohler and Parmele 1967)),
                    "  —
                                  M'4.00-0.0 \
                                  .0.000228)
For wind speed at the Class A pan anemometer height of 0.6 m (~2 feet) z/06,

                                    0.6-0.08 \
                   M0.6 -
                                    0 .01476
For EXAMS, the meteorological station wind speeds at 10 m height must be translated to a height of
O.lm above an open water surface. This transformation is executed automatically by EXAMS during
the course of reading the meteorological data file:

                                           ).l0-0.0 \
                             _           0.000228
                        )-10      '10  1   /IOQ_Q Q
                                            0.03
                                           18

-------
Processing Sequence for Production of Daily Values Files (*.dvf)

The program "make_rO" generates all dvf files. The data structures are defined in GLOBAL.F90.
The derived type for each datum contains the source of the item, any flags associated with the
item, and its value.

Subroutine DriverO (in file RAW_DATA.F90) reads several files containing general information
pertaining to each weather station.
• "SAMSON STATIONNOTES.TXT" : Contains, for each weather station: the name of
the station, its WBAN number, location (State), latitude and longitude
(degrees and minutes), elevation (meters), and time zone.
• "ANEMOMETER HEIGHTS.PRN" : Contains, for each station, the height of the
anemometer (feet) during a given period (yyyy-mm-dd). The data were
collected from http://lwf.ncdc.noaa.gov/oa/climate/surfaceinventories.html.
Example:
03103 30 1950-01-12

20 1965-10-07
For weather station 03103 (Flagstaff, AZ), the height of the anemometer was
30 feet during the period Jan 1, 1950 to October 6, 1965, and 20 feet from
October 7, 1965 to present date. The elevation data is used to normalize the
SAMSON Wind_Speed value to 10 meters. If no instrument height was
available, assume the measurement was made at 30 feet (9.1 meter). A
reference height of 10 meters or about 3 0 feet is internationally recommended
as the standard, and anemometers are usually mounted as close to this height
as is practical. Station histories were not available for 24 stations; these (24)
instruments were assumed to be sited at a standard height to minimize
changes to the observed data.
• DriverO calls an "internal standard" module (Internal_Standard, file
RAW_DATA.F90), to verify that certain parts of the program are behaving
correctly.
• Finally, DriverO calls Read_RO_List, which reads the list of stations to be processed
(contained in LSAMSON.LIST.TXT) and calls Process_One_WBAN_Station
to process each station.

Process_One_WBAN_Station (in RAW_DATA.F90)

Subroutine Station_With_Missing_Data: determines the completeness of the precipitation data.
The SAMSON format document (file samson_format.txt) identifies some stations as " Stations with
Little or No Hourly Precipitation Data ".
19

-------
Subroutine Read_SAMSON_vlx reads and stores each SAMSON data file (versions 1.0 and 1.1).
The module verifies that the values read are within the range described in the SAMSON format
document (file samson_format.txt). The source of the datum and any associated flags are stored.
Values outside the prescribed range are considered missing. Any errors detected are issued to the
log file.
• Unit conversion is performed (e.g., hourly precipitation: from hundredths of an inch
to cm; station pressure: from mbar to kPa; wind speed normalized to a height
of 10 meters.
• The module also determines the maximum Ceiling Height and the maximum
Horizontal Visibility (over all years, nominally 1961-1990). (See
Process_Set, vide infra)
• The undocumented value "990" was sometimes present for Wind_Direction (valid
range 0-360; missing value flag: 999). The observation was considered
missing.

Subroutine Issue_Years: determines which years will be output based on the precipitation record.
If the hourly precipitation was be incomplete (or missing), the daily precipitation record
Earthlnfo NCDC Summary of the Day and Surface Airways, 2001 was examined to determine
which years had complete daily records. The year ranges present in the subroutine were arrived
"by hand": a previous run of "make_rO" would show incomplete hourly precipitation for a
particular station. For that station, the NCDC Summary of the day would be examined and if
complete, the records would be exported so that "make_rO" would supplement the precipitation
on subsequent executions.

Subroutine Process_Set:
• Replaces the radiation data from SAMSON v 1.0 with version 1.1.
• Read hourly and daily precipitation from Earthlnfo CD.
• Coordinates the output of other processing modules.
• Horizontal Visibility field nominal range: 0.0-160.9 (kilometers). SAMSON used the
value "777.7" to denote unlimited visibility. The flag value was replaced with
110% of the maximum unlimited visibility observed during the nominal
period 1961-1990. The datum was flagged with "U".
• Ceiling Height field nominal range: 0-30450 (meters). The value "77777" denoted
unlimited ceiling height; "88888" denoted cirroform.. The flag values were
replaced with 110% of the maximum ceiling height observed during the
nominal period 1961-1990. The datum was flagged with "U" (unlimited) or
"Z" (cirroform).
• Gaps in the hourly data record were filled according to methods described in
National Solar Radiation Data Base User's Manual (1961-1990), NSRDB
Volume 1, September 1991, Section 5.2.1. The document may be
downloaded from
http://rredc.nrel.gov/solar/pubs/NSRDB/NSRDB index.html. In general:
• Gaps of less than 6 hours were filled by linear interpolation between points
at both sides of the gap.
• Gaps of 6 hours to 49 hours were filled by copying data from the previous
(or following) day.

-------
Longer gaps of 50 hours to 8784 hours (one leap year) were filled by
copying data for the same period from some other year.
Standardize_ppt - 'D' (deleted) points are flagged "missing"; periods of missing data are
identified and all intervening hours are flagged missing. Accumulation periods, i.e., periods in
which only the total accumulation is known (e.g., 0.12 cm fell over five hours) are recorded for
later processing.

Process_BAOD (Broadband aerosol optical_depth (broadband turbidity))-BAOD is not present
during nighttime. See fragment file below (13 893_61.txt). To generate nighttime values: starting
at 1 h, find the first non-missing BAOD value, call it "rv". Replace all missing values during that
day with "rv". For the example, all missing values (99999.) for 1961-01-01 will be replaced with
0.034.
! hours 2-6
! hours 9-16
! hours 19-6
! etc.

4 Process_Days_since_last_Snowfall - The SAMSON value of (DSLS was sometimes missing or not
consistent with fields 4 and 5 of the Present_Weather flag. Algorithm: accept non-missing values
of DSLS, otherwise utilize field 4 (Occurrence of Snow, Snow Pellets, or Ice Crystals) or field
5 (Occurrence of Snow Showers, or Snow Squalls) to determine if snow occurred during the 24
hour period.

4 Daylight Prevailing wind direction: indicates the most frequent wind direction observed during
the daylight hours of a given day. (Wind direction indicates where the wind is coming from.).

Algorithm: First, determine the most frequent quadrant, which is defined as the quadrant with the
most observations. If there is a tie, among the tied quadrants select the quadrant with the largest wind
speed. If tied, select the quadrant where the maximum wind speed falls closest to noon. The
prevailing wind direction is the median of the wind directions that fell in the most frequent quadrant.
The prevailing wind speed is the mean of the wind speeds that fell in the most frequent quadrant. See
subroutine DAYLIGHT_PREVAILING_WIND for complete details.
yy
61
61
61
61
61
61
61
61
61
61
61
mm
1
1
1
1
1
1
1
1
1
1
1
dd
1
1
1
1
1
1
1
1
2
2
2
hh
1

7
8

17
18

7
8
9
BAOD
99999.
99999.
99999.
.034
.034
.034
99999.
99999.
99999.
.104
.104
21

-------
Notes and Irregularities

Unless stated otherwise, these comments pertain to the SAMSON CDs.

1 Two files (years) missing from the SAMSON CDs: Burns, OR (94185): 1989, and Miles City, MT
(24037) 1990. In addition, the SAMSON CDs also contained empty data files.

2 The files for WB AN Station Number 14847 (SAULT STE. MARIE, MI) were duplicated in two
CDs: 1961-1990: Z:\nrel0001\data\14847, Z:\nrel0002\data\14847. The files were identical: same
date & size; A file by file comparison using cmp showed both sets were identical. All other "MI"
stations were present only in "nre!0002". So, the files in Z:\nrel0001\data\14847 were ignored.

3 Some SAMSON/HUSWO data files contained the undocumented value "E" (estimated) for the
precipitation flag. The SAMSON present weather flag had values not described in the SAMSON
document. These flags are described in Appendix C (Pages 48-49) of Database Guide for
Earthlnfo CDA2 NCDC Surface Airways. The SAMSON document was augmented to include the
missing flags.

4 Expected number of observations: 8760 (365*24) or 8784 (Leap year). Some HUSWO stations
are missing the observation for 1995-12-31 24h.

5 For some years, observations were taken every three hours.

6 SAMSON v 1.0 files. The last fields (Hourly precipitation and Hourly precipitation flag) are not
written in the original SAMSON file unless the fields are different from zero. For example
1961010101 ...(other parameters)... 10
1961010102 .. .(other parameters)...
e.g., it rained 10/100 inches during the first hour; no rain (implicit 0) during the second hour.

7 Wind Speed daily value == (Sum V_i) / 24

8 Evaporation formula: wind run == Sum V_i

9 If the station is above the Arctic Circle (Latitude 66.5 degrees North), then the region will be in
darkness for a period of the year, preventing the computation of, e.g., daylight value of Global
Horizontal Radiation, and Reference Crop Evapotranspiration (Eto)

10 Evaporation files from Earthlnfo. Determine the associated Cooperative Station for a given
WBAN number (http://lwf.ncdc.noaa.gov/oa/climate/stati onlocator.htmQF or the continental
USA:

11 Cooperative Stations Index: http://lwf.ncdc.noaa.gov/oa/climate/surfaceinventories.html
http://lwf.ncdc.noaa.gov/oa/climate/stationlocator.html
ftp://ftp.ncdc.noaa.gov/pub/data/inventories/COOP.TXT Historical cooperative station index.
Cooperative stations are U.S. stations operated by local observers which generally report max/min
temperatures and precipitation. National Weather Service (NWS) data are also included in this

-------
dataset. The data receive extensive automated + manual quality control. The index includes a county
location cross-reference. Over 8000 stations are currently active across the country.

12  All  stations: http://lwf.ncdc.noaa.gov/oa/climate/stationlocator.html
#24. Longer Gaps. 
   See 

#25. 14 Feb 2002 4:34 pm.  
   See 
   See 
   See 
   24013 !!!Minot,ND;
   Minot is missing years 1989 and 1990.
   We will copy
     -> 24013_89.txt
     -> 24013_90.txt
   Run make_rO, and manually delete those missing years
   from the rO directory, and eliminate those years from
   the MET file.

   * 15 Feb 20025:02 pm; I modified make_rO to
    #1. determine missing files (on the fly)
    #2. fill missing block of data
    #3. not to produce the rO file associated with the missing year(s)
    #4. not to generate the MET records for the missing year(s)

#26.  
   Dew Point.
   See 

#27.  
   Accumulation flag in hourly precipitation field —
   The description and example presented in
     
   is different to the actual usage in the SAMSON files.
   See 

#28. Hourly Precipitation: Cut Bank, MT (WBAN:  24137)
   26 Mar 2002 10:02 am.
   Relevant SAMSON entries:
     1983-12-09 1 Ih OM ! Begin missing run
     1983-12-23 12h OM ! End missing run
     1983-12-30 9h 22A  ! End accumulation run
   The SAMSON file contains a terminating accumulation run flag without the concomitant starting

                                         23

-------
flag.
   The Earthlnfo record for that period —
                                     HOURLY
Station
PO Code
Station  ID
County
         CUT BANK  FCWOS
         MT
         2173
         GLACIER
12/09/1983
12/23/1983
12/30/1983
        0100
        0700
        1300
        1900
        0100
        0700
        1300
        1900
        0100
        0700
        1300
        1900
                    + 000
   Latitude     N48:36:30
   Longitude   ¥112:22:34
   Elevation         3838
	 Prep  (in.)  	
 +100      +200      +300       +400
% Coverage       90
Begin M/Yr  07/1948
End M/Yr    12/2000
# Record  Years  53
                                                                          + 500
                                          0.22 A
   i.e, 1983-12-09 11 h begins the missing run (m).
        There is no terminating M for this run.
      1983-12-23 12 h begins the accumulation run (a), which terminates
        on 1983-12-30 9h (A)

   So we will edit the  SAMSON file Z:\nrel0003\data\24137\24137_83.z
   to read:
     1983-12-09 llh  OM  ! Begin missing run (entry unchanged)
                         I *** new entry: End missing run.
                          *** altered entry: Begin accumulation run
                         End accumulation run (entry unchanged)
1983-12-23 llh  OM
1983-12-23 12h  OA
1983-12-30 9h22A
   WIN> ! File extracted using WinZip
   DOS> mkszip -v 24137_83.txt! Compress file, output to 24137_83.txt.gz
      ! Rename 24137_83.txt.gz -> 24137_83.z
#29. Hourly Precipitation: Williamsport, PA (WBAN: 14778)
   27 Mar 2002 8:55 am
   Relevant SAMSON entries:
     1984-04-21 lOh 99999A  ! Begin accumulation run
                            ! many intervening Begin/End Missing data pairs
     1986-07-31 24h 99999M  ! End missing run - correctly paired.
     End-of-data reached (1990) without matching the "Begin accumulation run"
        of 1984-04-21 lOh
                                         24

-------
The SAMSON file contains a terminating accumulation run flag without the concomitant starting flag.
The Earthlnfo precipitation files show no hourly data, only monthly data.

   So we will edit the last record of the SAMSON file
   Z:\nrel0001\data\14778\14778_90.z to read:
     90 12 3124 .9999999   01A

   This will fix the missing matching "A".

   An accumulation value of Zero will cause problems, therefore we will
   use 1, i.e., 1/100 inch. The precipitation data will be compared with
   the Earthlnfo hourly and daily precipitation, and fixed when necessary.

   WIN> ! File extracted using WinZip
   DOS>mkszip -v 14778_90.txt! Compress file, output to 14778_90.txt.gz
      ! Rename 14778_90.txt.gz -> 14778_90.z

#30.  
   From: Prieto.Lourdes@epamail.epa.gov
   Subject: Metadata for weather station data files
   To: Suarez.Luis@epamail.epa.gov
   DeliveredDate:  07/01/2002 12:12:26 PM

   For anemometer heights:
     http://lwf.ncdc.noaa.gov/oa/climate/surfaceinventories.html

     National Weather Service Station Histories - file "station-hist.zip" at
     ftp://ftp.ncdc.noaa.gov/pub/data/inventories
     Zip-archival version of the NWS station histories file.

   To check lat/long and station elevation, checked individual stations here:
     http://lwf.ncdc.noaa.gov/oa/climate/stationlocator.html
                                           25

-------
                                                   Fortran Processing Code

BinaryTree
   Use Global_Variables
   Use Linked_List
   Use Red Black Binary  Tree
   !  Store info in a binary tree  since we want sorted output.

   !  []  Cooper Redwine.  1995.  Upgrading to  Fortran 90.
   !     Springer Verlag;  ISBN:  0387979956;  pages 333-343.
Contains
   Subroutine Initialize  Binary  Tree(Xstations)

      Implicit None
      Type(Site_Info),  Pointer  :: Xstations   ! Pointer to root of tree

      Nullify(Xstations)  !  Disassociate pointer to root node of tree
   End Subroutine Initialize_Binary_Tree
   Subroutine Get Node(Xroot,  WBAN  id, Node Was New, Xnew)

      !  *** []  Robin A.  Vowels.  1998. Algorithms and data
      !  ***    structures  in  F and  Fortran. Pages 98-130.
      !  ***    ISBN:  0-9640135-4-1
      I  * * *
      !  ***    Figure 3.14  Algorithm for manipulating a
      !  ***                Red-Black binary tree
      !  This procedure  either:
      !  #1.  Creates  and inserts  a  new node  (Xnew) for the given WBAN number,  or
      !  #2.  Points Xnew to  an  existing node in Xroot with the WBAN number.
      !  On output Xnew  points  to the node containing the WBAn number.

      Implicit None
      Type (Site Info) ,      Pointer :: Xroot
                                                                 26

-------
Character(Len=*), Intent(In)
Logical,         Intent(Out)
Type(Site Info),      Pointer
  WBAN_id
  Node_Was_New
  Xnew   !  Intent (Out
!  Binary tree initialization.
Xnew%Color = Red
Xnew%WBAN = WBAN_id
Nullify(Xnew%Parent)
Nullify(Xnew%pLeft)
Nullify(Xnew%pRight)

Call Insert In Tree(Xroot, Xnew, Node Was New)
If  (Node_Was_New) Then
   Call Initialize_Node(Xnew, WBAN_id)
End If
                  !  Insert or point to WBAN
!  Sanity Check.
If
Implicit None
Type(Site Info),   Pointer    ::  Xnew
Character(Len=*), Intent(In) ::  WBAN id
            !  Intent(InOut)
Xnew%WBAN = WBAN_id
Xnew%State = ''
Xnew%Text = ''
Xnew%Lat = Coords(''
Xnew%Lon = Coords(''
!  Latitude  '
!  Longitude
 in  radians;  e.g.,  N 40 1
1  in radians;  e.g.,  W 105 IE
                                                             27

-------
      Xnew%Nelev = 0





   End Subroutine Initialize Node





End Module Binary_Tree
                                                                  28

-------
dump
Module Dump RO
                    1
                2- 11
                   12
               13- 14
                       hvf_Cols
                       Extraterrestrial Horizontal Radiation
                       Extraterrestrial Direct Normal Radiation
                       Global Horizontal Radiation
                       Direct Normal Radiation
                       Diffuse Horizontal Radiation
                       Total Sky_Cover
                       Opaque Sky_Cover
                       Dry Bulb Temperature
                       Dew Point Temperature
                       Relative Humidity
                       Station Pressure
                       Wind Direction
                       Wind Speed
                       Visibility
                       Ceiling Height
                       Observation Indicator
                       Present weather
                       Precipitable Water
                       Broadband Aerosol Optical_Depth
                       Snow_Depth
                       Days Since Last Snowfall
                       Hourly Precipitation
                       FAO Short Grass PET
                       Pan Evaporation
                       K-P FWS Evaporation
      3 Binary_Tree
      3 FileStuff
      3 GetNumbers
      3 Linked List
      3 Read_Info
      3 SAMSON
      3 Strings
      3 UtilsO
      3 Utilsl
       Date_Module
       Global Variables
                                                                   29

-------
Use loSubs
Use Utils2
Use UtilsS
Use Winteracter
Implicit None
                 first time = .True.
   !  This routine dumps previously generated data
   !  All fields will have a flag.
   !  The format statement has to changed by hand.
   !  Look for all instances of "NNtext".
   !  a30 below == a == a
   Integer,  Parameter ::  NNtext = 30    ! Maximum Text Length
   Character(Len=30)   ::  fl = '	   '  ! value with one flag
   Character(Len=30)   ::  f2 = '	  '  ! value with two flag pc
   Character(Len=30)   ::  f3 = '	'  ! value with three flag
   Character(Len=MaxNamLen)  :: rO_file, vO_file
   Character(Len=NNtext)  ::  qtext
   Character(Len=250) ::  tbuf, qObuf
   Integer    Out_rO, In_vO, Out_vO
   Integer    kO, kl, klbase, j , jpar,  ierr, n missing
   Integer    tlen, iipar,  LenF
   Logical    is_a_number
   Integer    nbase,  iv,  doy
   Integer    YYVYr mmr  dd,  hh
   Integer    jd begin,  jd end,  jd today   ! Julian days
   Logical    xok, qdebug,  wO, one_file, cols_now
   Integer,  Dimension(0:f end) :: id of missing
   qdebug = .True.
   !one_file = .True.
   one_file = .False.
   Select Case(y4)
      Case(1961,  1962, 1964, 1965, 1990)  ! Fargo
   Case(1968,  1987)  ! Memphis
      wO = .True.
   Case Default
      wO = .False.
                                                                30

-------
End Select
wO = (qdebug .And. wO)   .And.  (.False.)

If (wO) Then
   Call Decompress_and_Open_File(In_vO, Year_Names(y4)%Samson_vlO)
   ICall lORead(In_vO,  Year_Names(y4)%Samson_vll)
   If  (one_file) Then
       ! Do nothing
   Else
      Write  (vO_file,  '(3a,"_",12.2,".vlO")')  &
             '.',  '/', Trim(pWBAN%WBAN), Modulo(y4,100)

      Call lOWrite(Out_vO, vO_file)
   End If
End If
rO file = name rO(y4)
Call lOWrite(Out_rO, rO_file, Ok=xok)
If (.Not. xok) Then
   Write  (ULog, *)  '?? Could not open rO  file  ', Trim(rO_flie)
   Errors Detected = .True.
   Return
End If
!  Trim(pWBAN%WBAN), Trim(pWBAN%Text)
j  = Index(pWBAN%Text,  ',', Back=.True.)
kO = j - 1    !  City
kl = j + 2    !  State
qtext = pWBAN%Text(l:kO)
If (kO > NNtext) Stop  '?? Stopping  in  Dump_RO_One_Year:  Len(Text)  >  NNtext'
If (kO > Maximum Text Length) Stop  '?? Stopping  in  Dump  RO  One  Year:  Len(Text)  > Maximum Text Length1

                        ) - 1

Write (Out_rO,  9130) &
      Trim(pWBAN%WBAN),             qtext, pWBAN%Text(kl:kl+1),  &
      pWBAN%TZ(1:j ) , &
      pWBAN%Lat%Letter, pWBAN%Lat%degrees, pWBAN%Lat%minutes,    &
      pWBAN%Lon%Letter, pWBAN%Lon%degrees, pWBAN%Lon%minutes,    &
      Nint(pWBAN%Elev), &
      Trim(TimeStamp)
                                                             31

-------
9130  Format (&
            Ix, a5, Ix, a30, Ix, a2,  &
            Ix, a3, &
            2x, al, 14, Ix, 12,  &
            2x, al, 14, Ix, 12,  &
            2x, 14, &
            3x, a)

      If (wO)  Then
         Read(In_vO,  '(a)') qObuf
         If (one_file) Then
            Write(Out_rO,  '(a,a)')  'vO>',  Trim(qObuf)
         Else
            Write(Out_vO,  '(a,a)')  Trim(qObuf)
         End If
      End If
      jd_begin = Jd(y4, 01, 01)
      jd_end = Jd(y4, 12, 31)
      jd_today = jd_begin
      n missing = 0
                                             24      25    Nhours = 2J
                                                                    32

-------
!  The 24-hour data for doy is stored in %v(jO:jl)
!      JO = (doy-1)*Nhours + 1     ! hour 1
!      jl = JO + 23                ! hour 24
!  OP  IP          Element                    Values   Definition
                  Local Standard Time
                  Year
                  Month
                  Day

kO =  1
kl = 11
Write(tbuf(kO:kl), '(Ix,14,"-",12.2,"-",12.2)') yyyy, mm, dd
klbase = kl
   !  For the time being skip every 25th hour. We are "Cycling" rather than
   !  changing the limits of the loop because "iv" has to be incremented
   !  correctly, otherwise will print daily value data as the  first
   !  hour of the next day.
   !      011-012     Hour                       1-24     Hour of day  in  local  standard  time
   kO = kl + 2
   kl = kO - 1 + 2
   Write(tbuf(kO:), '(12)') hh    ! kl not used: Write and clear the rest of the buffer

   !  Daily value: 1415 * 12 = 16980, requires 15

   !  01  Extraterrestrial           0-1415   Amount of solar radiation in Wh/m2
   !      Horizontal Radiation                received on a horizontal surface  at
   !                                          the top of the atmosphere during  the
   !                                          60 minutes preceding the hour indicated.
                                                          33

-------
Select Case(Xparam(iipar) %S arris on_vlO (iv) %s )
Case(T_Missing)
   is_a_number = .False.
   n_missing = n_missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(15, al)') &
         Int(Xparam(f_EHR)%Samson_vlO(iv)%v), &
         Xparam(f_EHR)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(15,  al)',  Icount=4)

!  02  Extraterrestrial Direct             Amount of solar  radiation  in Wh/m2
!      Normal Radiation            0-1415   received on  a  surface normal to
!                                          the sun at the top of the  atmosphere
!                                          during the 60  minutes preceding  the
!                                          hour indicated.
iipar = f_EDNR
kO = kl + 2
kl = kO - 1 + 6
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T_Missing)
   is a number = .False.
   n missing = n missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is a number)  Then
   Write(tbuf(kO:kl), '(15, al)  ' ) &
         Int(Xparam(f_EDNR)%Samson_vlO(iv)%v), &
         Xparam(f_EDNR)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(15,  al)')

!  03  Global Horizontal Radiation         Total amount of  direct  and  diffuse solar
!      Data Value                  0-1415   radiation in Wh/m2 received on a
!      Flag for Data Source       A-H,  ?   horizontal surface during  the  60 minutes
!      Flag for Data Uncertainty   0-9      preceding the  hour indicated.
                                                       34

-------
!  Table 3-6.   Solar Radiation Source Flags
I
!  Flag  Definition
I
!  A     Post-1976 measured solar radiation data as received from
!        NCDC or other sources
!  B     Same as 'A' except the global horizontal data underwent a calibration
!        correction
!  C     Pre-1976 measured global horizontal data  (direct and diffuse were
!        not measured before 1976), adjusted from solar to local time, usually
!        with a calibration correction
!  D     Data derived from the other two elements of solar radiation using the
!        relation,  Kt = Kn + Kd
!  E     Modeled solar radiation data using inputs of observed sky cover
!        (cloud amount)  and aerosol optical_depth s derived from direct
!        normal data collected at the same location
!  F     Modeled solar radiation using interpolated sky cover  and aerosol
!        optical depths derived from direct normal data collected at the
!        same location
!  G     Modeled solar radiation data using observed sky_cover and aerosol
!        optical depths estimated from geographical relationships
!  H     Modeled solar radiation data using interpolated sky cover  and
!        estimated aerosol optical_depths
!  ?     Source does not fit any of the above categories.  Used for nighttime
!        values, calculated extraterrestrial values, and missing data
!  Flag           Uncertainty Range  (%)
I
!  1              0-2
!  2              2-4
!  3              4-6
!  4              6-9
i  5              g-13
!  6              13-18
!  7              18-25
i  8              25-35
19              35-50
!  0              Not applicable

iipar = f_GHR
kO = kl + 2
kl = kO - 1 + 8   !  15 + s(l:l) + f(l:2)
Select Case(Xparam(iipar)%Samson vlO(iv)%s)
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
                                                       35

-------
   id of missing(iipar)  = id of missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is_a_number = .True.
End Select
If (is a number) Then
   Write(tbuf(kO:kl), '(15, al, a2)')  &
         Int(Xparam(f_GHR)%Samson_vlO(iv)%v), &
         Xparam(f_GHR)%S arris on_vlO(iv)%s(l:l), &
         Xparam(f_GHR)%Samson_vlO(iv)%f(1:2)
Else
   tbuf(kO:kl)  = Adjustr(f3(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(15,  al,  a2)')

!  04  Direct Normal Radiation             Amount of solar  radiation  in Wh/m2
!      Data Value                  0-1415   received within  a  5.7o  field of  view
!      Flag for Data Source       A-H,  ?   centered on the  sun, during  the  60
!      Flag for Data Uncertainty   0-9      minutes preceding  the hour indicated.
iipar = f_DNR
kO = kl + 2
kl = kO - 1 + 8    ! 15 + s(l:l) +  f(l:2)
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T_Missing)
   is a number = .False.
   n missing = n missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number) Then
   Write(tbuf(kO:kl), '(15, al, a2)')  &
         Int(Xparam(f_DNR)%Samson_vlO(iv)%v), &
         Xparam(f_DNR)%Samson_vlO(iv)%s(1:1) , &
         Xparam(f_DNR)%Samson_vlO(iv)%f(1:2)
Else
   tbuf(kO:kl)  = Adjustr(f3(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(15,  al,  a2)')

!  05  Diffuse Horizontal Radiation        Amount of solar  radiation  in Wh/m2
!      Data Value                  0-1415   received from  the  sky  (excluding the
!      Flag for Data Source       A-H,  ?   solar disk) on a horizontal  surface,
!      Flag for Data Uncertainty   0-9      during the 60  minutes preceding  the
!                                          hour indicated.
iipar = f_DHR
kO = kl + 2
                                                       36

-------
kl = kO - 1 + 8   !  15 + s(l:l) + f(l:2)
Select Case(Xparam(iipar)%S arris on_vlO(iv)%s)
Case(T_Missing)
   is_a_number = .False.
   n_missing = n_missing + 1
   id of missing(iipar)  = id of missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(15, al, a2) ' ) &
         Int(Xparam(f_DHR)%Samson_vlO(iv)%v),  &
         Xparam(f_DHR)%Samson_vlO(iv)%s(1:1),  &
         Xparam(f_DHR)%Samson_vlO(iv)%f(1:2)
Else
   tbuf(kO:kl) = Adjustr(f3(1:kl-kO+1))
End If
!If (cols_now) Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(15,  al,  a2)')

!  06  Total Sky Cover             0-10     Amount  of  sky  dome  (in  tenths)
!                                          covered by clouds.
iipar = f_TSC
kO = kl + 2
kl = kO - 1 + 3
Select Case (Xpar am (iipar) %S arris on_vlO (iv) %s )
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
   id of missing(iipar)  = id of missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(12, al) ' )  &
         Int (Xpar am ( f_TSC) %S arris on_vlO (iv) %v) ,  &
         Xparam(f_TSC)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl) = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now) Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(12,  al)')

!  07   Opague Sky Cover            0-10     Amount  of  sky  dome  (in  tenths)
!                                          covered by clouds that  prevent
!                                          observing  the  sky or  higher  cloud
!                                          layers.
                                                       37

-------
kO = kl + 2
kl = kO - 1 + 3
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
   id of missing(iipar)  = id of missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(12, al)') &
         Int(Xparam(f_OSC)%Samson_vlO(iv)%v),  &
         Xparam(f_OSC)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(12,  al)')

!  08  Dry Bulb Temperature       -70.0 to     Dry bulb temperature  in  degrees  C.
!                                 60.0
iipar = f_DBT
kO = kl + 2
kl = kO - 1 + 6
Select Case (Xpar am (iipar) %S arris on_vlO (iv) %s )
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
   id of missing(iipar)  = id of missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(fS.l, al) ' ) &
         Xpar am ( f_DBT ) %S arris on_vlO (iv) %v, &
         Xparam(f_DBT)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(f5.1,  al)')

!  09  Dew Point Temperature      -70.0 to     Dew point temperature in degrees C.
                                                       38

-------
Select Case(Xparam(iipar) %S arris on_vlO (iv) %s )
Case(T_Missing)
   is_a_number = .False.
   n_missing = n_missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(f5.1, al)') &
         Xparam(f_DPT)%Samson_vlO(iv)%v, &
         Xparam(f_DPT)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(f5.1,  al)')

!  10  Relative Humidity           0-100     Relative humidity  in percent.
iipar = f_RH
kO = kl + 2
kl = kO - 1 + 4
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T_Missing)
   is a number = .False.
   n missing = n missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(13, al)  ' )  &
         Int(Xparam(f_RH)%Samson_vlO(iv)%v),  &
         Xparam(f_RH)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(13,  al)')

!  11  Station Pressure            70.0-110.0   Station pressure in  kilopascals.
iipar = f_SP
kO = kl + 2
kl = kO - 1 + 6
Select Case(Xparam(iipar)%Samson  vlO(iv)%s)
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
                                                       39

-------
   id of missing(iipar)  = id of missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is_a_number = .True.
End Select
If (is a number) Then
   Write(tbuf(kO:kl), '(f5.1, al)') &
         Xparam(f_SP)%Samson_vlO(iv)%v, &
         Xparam(f_SP)%S arris on_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl) = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now) Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(fS.l,  al)')

!  12  Wind Direction             0-360       Wind direction  in  degrees.
!                                              (N = 0  or  360,  E = 90,  S =  180,
!                                             W =  270)
iipar = f_WD
kO = kl + 2
kl = kO - 1 + 4
Select Case(Xparam(iipar)%Samson vlO(iv)%s)
Case(T Missing)
   is_a_number = .False.
   n_missing = n_missing +  1
   id of missing(iipar)  = id of missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number) Then
   Write(tbuf(kO:kl), '(13, al)  ' )  &
         Int (Xparam ( f_WD) %S arris on_vlO (iv) %v) ,  &
         Xparam( f_WD) %S arris on_vlO (iv) %s (1:1)
Else
   tbuf(kO:kl) = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now) Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(13,  al)')

!  13  Wind Speed                 0.0-99.0    Wind speed in m/s  at  z=10 meters
iipar = f_WS
kO = kl + 2
kl = kO - 1 + 6
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T Missing)
   is a number = .False.
   n_missing = n_missing +  1
   id_of_missing(iipar)  = id_of_missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
                                                       40

-------
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl),  '(f5.1, al)') &
         Xparam(f_WS)%Samson_vlO(iv)%v, &
         Xparam(f_WS)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(f5.1,  al)

!  14   Visibility                 0.0-160.9   Horizontal  visibility  in
!                                             kilometers.
iipar = f_HV
kO = kl + 2
kl = kO - 1 + 7
Select Case (Xpar am (iipar) %S arris on_vlO (iv) %s )
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
   id of missing(iipar) = id of missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl),  '(f6.1, al) '  ) &
         Xparam(f_HV)%Samson_vlO(iv)%v, &
         Xparam(f_HV)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(f6.1,  al)

!  15 Ceiling Height             0-30450     Ceiling height  in meters.
iipar = f CH
kO = kl + 2
kl = kO - 1 + 7
Select Case (Xpar am (iipar) %S arris on_vlO (iv) %s )
Case(T_Missing)
   is_a_number = .False.
   n_missing = n_missing + 1
   id of missing(iipar) = id of missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
                                                       41

-------
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(16, al)') &
         Int(Xparam(f_CH)%Samson_vlO(iv)%v), &
         Xparam(f_CH)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(16,  al)')

!  16 Observation Indicator       0 or  9   0  = Weather observation made.
!                                         9  = Weather observation not
!      [Isr]  Thu 19 Oct 2000  11:58:19                 made  or  missing.
!            This field appears to be                  If this  field =  9  OR if  field
!            column 96 of the input  file.              13 (wind speed)  =  missing
!            The manual provides  no  data                (9999. or 99.0), then
!            to support this assertion.                fields 6,  7, 8,  10,  11,  17,
!      [Isr]  Wed Nov 21 09:33:59  2001                  and 18 were  all  modeled  and
!            Observation Indicator appears             not actually observed.
!            only in SAMSON v 1.0 files.

!  Xparam(f OI)%Samson vlO(iv)%v  = Observation Indicator
!  Xparam(f_OI)%Samson_vlO(iv)%f  = Present_weather
iipar = f_OI
kO = kl + 2
kl = kO - 1 + 2
Select Case (Xpar am (iipar) %S arris on_vlO (iv) %s )
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
   id of missing(iipar)  = id of  missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   Write (tbuf (kO:kl) , '(H, al) '  ) &
         Int (Xpar am ( f_OI) %S arris on_vlO (iv) %v) , &
         Xparam(f_OI)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols('Observation  Indicator', kO, kl,  '(H, al) ' )

!  17   Present weather    Present weather conditions  denoted by 9 indicators.
!  See 
iipar = f_OI
kO = kl + 2
kl = kO - 1 + LenF + 1
                                                       42

-------
Select Case(Xparam(iipar) %S arris on_vlO (iv) %s )
Case(T_Missing)
   is_a_number = .False.
   n_missing = n_missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(a9, al)  ' ) &
         Xparam(f_OI)%Samson_vlO(iv)%f, &
         Xparam(f_OI)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols('Present_weather', kO, kl,  '(a9,  al)')

!  18 Precipitable Water          0-100       Precipitable_water in
!                                            millimeters.
iipar = f_pH2O
kO = kl + 2
kl = kO - 1 + 4
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T_Missing)
   is a number = .False.
   n_missing = n_missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(13, al)  ' ) &
         Int(Xparam(f_pH2O)%Samson_vlO(iv)%v), &
         Xparam(f_pH2O)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(13,  al)')

                                 0.0-0.900    Broadband  aerosol optical_depth
                                              (broadband  turbidity)  on  the
!                                              day indicated.
iipar = f_BAOD
kO = kl + 2
kl = kO - 1 + 7
Select Case (Xpar am (iipar) %S arris on_vlO (iv) %s )
                                                       43

-------
Case(T_Missing)
   is a number = .False.
   n_missing = n_missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar)  + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(f6.3, al)') &
         Xparam(f_BAOD)%Samson_vlO(iv)%v, &
         Xparam(f_BAOD)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(£6.3, al)')

!  20  Snow_Depth                  0-100       Snow_depth  in centimeters  on
!                                             the day indicated.
iipar = f_SD
kO = kl + 2
kl = kO - 1 + 5
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T_Missing)
   is a number = .False.
   n missing = n missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar)  + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(14, al)  ' )   &
         Int(Xparam(f_SD)%Samson_vlO(iv)%v), &
         Xparam(f_SD)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(14,  al)')

!  21  Days Since Last Snowfall    0-88        Number of days  since  last  snowfall.
!                                             88 = 88 or  greater days.
iipar = f_DSLS
kO = kl + 2
kl = kO - 1 + 4
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T_Missing)
   is a number = .False.
                                                       44

-------
   n missing = n missing + 1
   id of missing(iipar)  = id of missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(13, al)')  &
         Int (Xparam( f_DSLS ) %Sarrison_vlO (iv) %v) , &
         Xparam(f_DSLS)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(13,  al)')

!  22  Hourly Precipitation       0.0  -        In cm
!                                 25.4e+6      (See information  below).
I
!      Hourly Precipitation Flag               See  explanation below.

!  Xparam(f_HP)%Samson_vlO(iv)%v =  Hourly_Precipitation
!  Xparam(f_HP)%Samson_vlO(iv)%f =  Hourly_Precipitation_Flag
iipar = f_HP
kO = kl + 2
kl = kO - 1 + 8
Select Case (Xpar am (iipar) %S arris on_vlO (iv) %s )
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
   id of missing(iipar)  = id of missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   Write(tbuf(kO:kl), '(£6.2,  al,  al)') &
         Xparam(f_HP)%Samson_vlO(iv)%v, &
         Xparam(f_HP)%Samson_vlO(iv)%s(1:1),  &
         Xparam(f_HP)%Samson_vlO(iv)%f(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f2(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(£6.2,  al,  al)
                                                       45

-------
iipar = f_FAO_SG_PET
kO = kl + 2
kl = kO - 1 + 7
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T_Missing)
   is a number = .False.
   n missing = n missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is a number) Then
   Write(tbuf(kO:kl), '(£6.2, al)  ' ) &
         Xparam(f_FAO_SG_PET)%Samson_vlO(iv)%v, &
         Xparam(f_FAO_SG_PET)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(fl(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(£6.2,  al)

!  24  Class A pan Evaporation,  mm/day
!      Range :
iipar = f_Ep
kO = kl + 2
kl = kO - 1 + 7
Select Case(Xparam(iipar)%Samson_vlO(iv)%s)
Case(T_Missing)
   is a number = .False.
   n missing = n missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is a number) Then
   Write(tbuf(kO:kl), '(£6.2, al)') &
         Xparam(f_Ep)%Samson_vlO(iv)%v, &
         Xparam(f_Ep)%Samson_vlO(iv)%s(1:1)
Else
   tbuf(kO:kl)  = Adjustr(f1(1:kl-kO+1))
End If
!If (cols_now)  Call hvf_Cols(Fieldlnfo(iipar)%Name, kO,  kl,  '(£6.2,  al)

!  25  K-P FWS Evaporation in mm/day
!      Range :     -6.22314         5.46000
iipar = f_KP_FWS_Evaporation
kO = kl + 2
                                                    46

-------
   kl = kO - 1 + 7
   Select Case(Xparam(iipar) %S arris on_vlO (iv) %s )
   Case(T_Missing)
      is_a_number = .False.
      n_missing = n_missing + 1
      id of missing(iipar)  = id of missing(iipar)  +  1
   Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
      is_a_number = .False.
   Case Default
      is a number = .True.
   End Select
   If (is_a_number)  Then
      IWrite(tbuf(kO:kl),  '(f6.2, al)')  &
      !       Xparam(f_KP_FWS_Evaporation)%Samson_vlO(iv)%v,  &
      !       Xparam( f_KP_FWS_Evaporation) %S arris on_vlO (iv) %s (1:1)
   Else
      tbuf(kO:kl) = Adjustr(fl(1:kl-kO+1))
   End If
   !!If (cols_now) Call hvf_Cols(Fieldlnfo(iipar)%Name,  kO,  kl,  '(£6.2,  al)')
   !   8 Feb 2002  5:41 pm:  until we develop a better  formulation,
   !     kill KP_FWS_Evaporation.
   tbuf(kO:kl) =  ''
   !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
   !If (cols_now) Call hvf_Cols( ' ' , 0, 0,  '', Last=.True.)
   first_time =  .False.
   !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
End If

tlen = Len_trim(tbuf(l:kl))

!  Check that there are no  '*'s  in the line.
If (Index(tbuf(l:tlen),  '*') >  0) Then
   ierr = ierr + 1
   Write (ULog,   9150)  tbuf(l:tlen)
   Format (///,   Ix,  '??  Field overflow:  ', /, Ix,  a)
   Do jpar =1,   f end
      Write  (ULog, 9170) Trim(Fieldlnfo(jpar)%Name), Xparam(jpar)%Samson_vlO(iv)
   End Do
   Format(lx, 3x, a,  ':  ', Ipgl4.6, Ix,  a, Ix,  a)
End If

If (wO) Then
   If  (hh /= NHours) Then
      Read (In_vO, '(a)') gObuf
   Else
      qObuf = ''
   End If
                                                       47

-------
               If  (one_file) Then
                  Write  (Out_rO, J
   End If
Else
   Write (Out_
End If
                               1 (a) ' ) tbuf(l:tlen)
         jd today = jd today + 1.0
      End Do
      Call lOClose(Out_rO)
      If  (wO) Then
         Call lOClose(In_vO)
         If  (.Not. one_file) Then
            Call lOClose(Out_vO)
         End If
      End If

      If  (n missing /= 0) Then
         Write  (ULog, 9190) y4, n_missing
         Format  (/, Ix,  '?? Dump_RO_One_Year: Year ==  ',  10,  ',  Missing values  ==
         Do jpar = 1, f_end
            If  (id of missing(jpar) > 0) Then
               Write  (ULog, 9210) Trim(Fieldlnfo(jpar)%Name),  id_of_missing(jpar)
               Format(Ix, 6x, a,  ': ',  10,  ' hourly values missing.')
            End If
         End Do
      End If
      If (ierr /= 0) Then
         Errors Detected =  .True.
         ICall IQsDeleteFile(rO_file)
      End If
   End Subroutine Dump_RO_One_Year

End Module Dump_RO
                                                                   48

-------
dumpmet
  8- 17
 18- 27
 28- 37
 38- 47
 48- 57
 58- 63
 64- 73
 74- 77
 78- 80
 81- 90
 91- 96
 97-102
103-108
109-112
113-118
119-122
                       Precipitation  [cm/day]
                       Pan Evaporation  [cm/day]
                       Temperature mean  [ °C]
                       Wind Speed @10 meter  [cm/s]
                       Solar Radiation  [Langleys/day]
                       Eto, FAO Short Grass  PET  [mm/day]
                       Station Pressure  [kiloPascal]
                       Relative Humidity [%]
                       Opague_Sky_Cover  [tenths]
                       Daylight Temperature  [ °C]
                       Broadband Aerosol [optical depth]
                       Daylight Mean Wind Speed  @ 10 meters  [m/s
                       Maximum Daylight Mean Wind Speed @10m  [m/
                       Direction of Maximum  Daylight Wind  [degre
                       Daylight Prevailing Wind  Speed @z=10m  [m/
                       Daylight Prevailing Wind_Direction  [Degre
   Use Date_Module
   Use Global Variables
   Use loSubs
   Use Utils2
   Use Utils3
   Use Winteracter
   Implicit None
                    first time = .True.
   Subroutine Dump_MET_flie()
      Implicit None

      Character(Len=350) :: tbuf
      Character(Len=30)  :: f1 =  '	'
      Integer ::  jday, hhOl, hh24, hh25
      Integer ::  kO, kl, jpar, tlen,  ierr, n_missing, iipar
      Integer ::  Out_MET
      Integer ::  yyyy, mm,  dd, hh
                                                                   49

-------
Logical : :
Logical : :
Integer : :
Real : :
! o!9*, n9*
Real : :
Real : :
Integer : :
Integer : :
okay, is daytime
is a number
ival~
rval, R s
— daylight guantity
d9 pressure, d9 RH, d9 OSC,
d9 mean wind speed, d9 max \
n9 pressure, n9 RH, n9 OSC,
n9 mean wind speed





d9 Temp, d9 Broadband Aerosol
*ind speed, d9 direction of max wind speed
n9 Temp, n9 Broadband Aerosol

!  dO*, nO* — lh-24h guantity
Real    :: dO_pressure, dO_RH, dO_OSC, dO_Temp, dO_Broadband_Aerosol
Real    :: dO mean wind speed, dO max wind speed, dO  direction  of  max wind speed
Integer :: nO pressure, nO RH, nO OSC, nO Temp, nO  Broadband  Aerosol
Integer :: nO_mean_wind_speed
Call lOWrite(Out_MET, name_met, Ok=okay)
If  (.Not. okay) Then
   Write (ULog, *) '?? Could not open MET  file  ',  Trim(name_met)
   Errors_Detected =  .True.
   Return
End If
!  First try to compute daylight values only,
Call Daylight Prevailing Wind(okay, d9 pwd, d9 pws,  OnlyDaylight=.True.)
If  (.Not. okay)  Then
    ! Some days missing. Compute all-day values and merge  results.
   Call Daylight Prevailing Wind(okay, dO pwd, dO pws,  OnlyDaylight=.False.)
   Do jday = jdO, jdl
      !  If one of (pwd, pws) is missing, then both are  missing.
      If (d9_pwd(jday)%s == T_Missing) Then
         !  The daylight value is missing: replace it with the  all-hours  value.
         d 9 pwd (jday) = d 0 pwd (jday)
         d9_pws(jday) = dO_pws(jday)
      End If
   End Do
                                                             50

-------
End If

!  15 Feb 2002  1:44 pm:
!  Note: We are not using "Do jday = jdO, jdl"
!  because we will modify "jday" when years are skipped.
j day = j dO - 1
Do
   jday = jday + 1
   If  (jday > jdl) Exit
   If (.Not. Issue_This_Year(yyyy)) Then
      !  Year is missing. Do not print records associated with  this  year.
      !  Skip the rest of the year.
      jday = Jd(yyyy, mm=12, dd=31) !  Last day of the  current  year
      Cycle
   End If

   tbuf = ''

   kO = 01
   kl = 07
   Write(tbuf(kO:kl), '(Ix,312.2)') mm, dd, Mod(yyyy,100)
   !If (first_time) Call dvf_Cols('mmddYY, Date', kO,  kl)
   !If (first time) Call dvf MkFMT(kO,  '(lx,312)')
   !  Precipitation  [cm/day]; RO:  [cm]
   iipar = g_Precipitation
   kO = 08
   kl = 17
   Select Case(Xparam(f_HP)%Samson_vlO(hh25)%s)
   Case(T_Missing)
      is a number = .False.
      n missing = n missing + 1
      id_of_missing(iipar)  = id_of_missing(iipar) +  1
   Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
      is a number = .False.
   Case Default
      is_a_number = .True.
   End Select
   If (is a number) Then
      rval = Xparam(f_HP)%Samson_vlO(hh25)%v
   Else
      rval = Zero
      !tbuf(kO:kl) = Adjustr(f1(1:kl-kO+1))
                                                             51

-------
End If
Write(tbuf(kO:kl),  '(flO.2)') rval
!If (first_time) Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl,  Icount=3)
!If (first_time) Call dvf_MkFMT(kO,  '(flO.2)')

!  Class A pan Evaporation  [cm/day]; RO:  [mm/day]
!  1 mm = 0.10000 cm
iipar = g_Pan_Evaporation
kO = 18
kl = 27
Select Case(Xparam( f_Ep ) %S arris on_vlO (hh25) %s )
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
   id of missing(iipar)  = id of missing(iipar)  +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number) Then
   rval = Xparam(f_Ep)%Samson_vlO(hh25)%v *  0.10000    ! mm ->  cm
Else
   rval = Zero
End If
Write(tbuf(kO:kl),  '(flO.2)') rval
!If (first_time) Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If (first_time) Call dvf_MkFMT(kO,  '(flO.2)')

!  Mean Temperature  [ °C]  ; RO:  [°C]
iipar = g Temperature mean
kO = 28
kl = 37
Select Case(Xparam( f_DBT ) %S arris on_vlO (hh25) %s )
Case(T_Missing)
   is_a_number = .False.
   n_missing = n_missing + 1
   id of missing(iipar)  = id of missing(iipar)  +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number) Then
   rval = Xparam(f_DBT)%Samson_vlO(hh25)%v
Else
   rval = Zero
End If
Write(tbuf(kO:kl),  '(flO.l)') rval
!If (first time) Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
                                                          52

-------
!If (first_time) Call dvf_MkFMT(kO,  '(flO.l)')

!  Wind speed z=10 meters  [cm/sec];   RO: Wind_Speed  @z=10m  [m/s]
iipar = g_Wind_Speed
kO = 38
kl = 47
Select Case(Xparam(f_WS)%Samson_vlO(hh25)%s)
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
   id of missing(iipar)  = id of missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined,  T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number) Then
   rval = Xparam(f WS)%Samson vlO(hh25)%v * meters  sec   to   cm  sec
Else
   rval = Zero
End If
Write(tbuf(kO:kl),  '(flO.l)1) rval
!If (first_time) Call dvf_Cols(MET_field(iipar)%Name, kO, kl)
!If (first time) Call dvf MkFMT(kO,  '(flO.l)1)
!  Solar Radiation  [Langleys/day]
!  RO: Rs == Global Horizontal Radiation  [Wh/m2/day]
!  1 watt hour m^-2 = 8.59845E-02 langley
iipar = g Solar Radiation
kO = 48
kl = 57
Select Case(Xparam(f_GHR)%Samson_vlO(hh25)%s)
Case(T_Missing)
   is a number = .False.
   n_missing = n_missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number = .False.
Case Default
   is_a_number = .True.
End Select
If (is_a_number)  Then
   rval = Xparam(f_GHR)%Samson_vlO(hh25)%v *  8.59845E-02  !  m/s  ->  cm/s
Else
   rval = Zero
End If
Write(tbuf(kO:kl), '(flO.l)1) rval
!If  (first_time)  Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If  (first time)  Call dvf MkFMT(kO,  '(flO.l)1)
                                                          53

-------
!  FAO Short Grass PET  [mm/day]
!  RO: same
iipar = g_FAO_Short_Grass
kO = kl + 1
kl = kO - 1 + 6
Select Case(Xparam(f_FAO_SG_PET)%Samson_vlO(hh25)%s)
Case(T_Missing)
   is_a_number = .False.
   n missing = n missing + 1
   id of missing(iipar) = id of missing(iipar) +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   rval = Xparam(f_FAO_SG_PET)%Samson_vlO(hh25)%v
Else
   rval = Zero
End If
Write(tbuf(kO:kl),  '(f6.1)') rval
!If  (first_time)  Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If  (first_time)  Call dvf_MkFMT(kO, '(f6.1)')

!  The following represent mean values for daylight  hours  only.
d9 pressure = Zero
n9_pressure = 0
d9_RH = Zero
n9_RH = 0
d9_OSC = Zero
n9_OSC = 0
d9_Temp = Zero
n9_Temp = 0
d9 Broadband Aerosol = Zero
n9_Broadband_Aerosol = 0

d9 mean wind speed = Zero
d9 max wind speed = -Huge(Zero)
d9_direction_of_max_wind_speed = -Huge(Zero)
n9_mean_wind_speed = 0

!  All hours values
dO_pressure = Zero
nO_pressure = 0
dO_RH = Zero
nO_RH = 0
dO_OSC = Zero
nO_OSC = 0
dO_Temp = Zero
                                                          54

-------
dO_mean_wind_speed = Zero
dO max wind speed = -Huge(Zero)
dO direction of max wind speed = -Huge(Zero)
nO_mean_wind_speed = 0
   If (Xparam(f_Rs)%Samson_vlO(hh)%s == T_Missing) Then
      is_daytime = .False.
   Else If (Xparam(f_Rs)%Samson_vlO(hh)%s == T_Undefined) Then
      is daytime = .False.
   Else
      R_s = Xparam(f_Rs)%Samson_vlO(hh)%v
      is daytime = (R s > Zero)
   End If

   Select Case(Xparam(f_WS)%Samson_vlO(hh)%s)
   Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
      !  Do nothing
   Case Default
      rval = Xparam(f_WS)%Samson_vlO(hh)%v
      dO mean wind speed = dO mean wind speed + rval
      nO mean wind speed = nO mean wind speed + 1
      If  (rval > dO_max_wind_speed) Then
         dO_max_wind_speed = rval
         dO direction of max wind speed = Xparam(f WD)%Samson vlO(hh)%v
      End If
      If  (is_daytime) Then
         d9_mean_wind_speed = d9_mean_wind_speed + rval
         n9 mean wind speed = n9 mean wind speed + 1
         If (rval > d9 max wind speed) Then
            d9_max_wind_speed = rval
            d9_direction_of_max_wind_speed = Xparam(f_WD)%Samson_vlO(hh)
         End If
      End If
   End Select

   Select Case(Xparam(f_SP)%S arris on_vlO(hh)%s)
   Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
      !  Do nothing
   Case Default
      rval = Xparam(f_SP)%Samson_vlO(hh)%v
      dO pressure = dO pressure + rval
      nO_pressure = nO_pressure + 1
      If  (is_daytime) Then
         d9 pressure = d9 pressure + rval
                                                          55

-------
      n9 pressure = n9 pressure + 1
   End If
End Select

Select Case(Xparam(f_RH)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   !  Do nothing
Case Default
   rval = Xparam(f_RH)%Samson_vlO(hh)%v
   dO_RH = dO_RH + rval
   nO_RH = nO_RH + 1
   If (is_daytime) Then
      d9_RH = d9_RH + rval
      n9_RH = n9_RH + 1
   End If
End Select

Select Case(Xparam(f_OSC)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   !  Do nothing
Case Default
   rval = Xparam(f_OSC)%Samson_vlO(hh)%v
   dO_OSC = dO_OSC + rval
   nO_OSC = nO_OSC + 1
   If (is_daytime) Then
      d9_OSC = d9_OSC + rval
      n9_OSC = n9_OSC + 1
   End If
End Select

Select Case(Xparam(f_DBT)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   !  Do nothing
Case Default
   rval = Xparam(f_DBT)%Samson_vlO(hh)%v
   dO_Temp = dO_Temp + rval
   nO_Temp = nO_Temp + 1
   If (is daytime) Then
      d9_Temp = d9_Temp + rval
      n9_Temp = n9_Temp + 1
   End If
End Select

Select Case(Xparam(f_BAOD)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   !  Do nothing
Case Default
   rval = Xparam(f_BAOD)%Samson_vlO(hh)%v
   dO_Broadband_Aerosol = dO_Broadband_Aerosol + rval
   nO Broadband Aerosol = nO Broadband Aerosol + 1
                                                       56

-------
      If  (is_daytime) Then
         d9 Broadband Aerosol = d9 Broadband Aerosol  +  rval
         n9_Broadband_Aerosol = n9_Broadband_Aerosol  +  1
      End If
   End Select
End Do OneDay
!  Station Pressure  [kilopascals]
iipar = g Daylight Station Pressure
kO = kl + 1
kl = kO - 1 + 10
If (n9_pressure > 0) Then
   rval = d9 pressure / n9 pressure
Else If (nO pressure > 0) Then
   rval = dO_pressure / nO_pressure
Else
   rval = Zero
   n missing = n missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) +  1
End If
Write(tbuf(kO:kl),  '(flO.l)') rval
!If (first_time) Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If (first_time) Call dvf_MkFMT(kO,  '(flO.l)1)

!  Relative Humidity [%];  Range: 0-100
iipar = g Daylight Relative Humidity
kO = kl +~1
kl = kO - 1 + 4
If (n9_RH > 0) Then
   ival = Nint(d9_RH / n9_RH)
Else If (nO_RH > 0) Then
   ival = Nint(dO_RH / nO_RH)
Else
   ival = 0
   n_missing = n_missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) +  1
End If
Write(tbuf(kO:kl),  '(14)') ival
!If (first_time) Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If (first_time) Call dvf_MkFMT(kO,  '(14)')

!  Opaque Sky_Cover;  Range: 0-10
!  Amount of sky dome (in tenths) covered by  clouds  that  prevent
!  observing the sky or higher cloud layers.
iipar = g Daylight Opaque Sky Cover
kO = kl + 1
kl = kO - 1 + 3
If (n9_OSC > 0) Then
   ival = Nint(d9 OSC / n9 OSC)
                                                          57

-------
Else If (nO_OSC > 0) Then
   ival = Nint(dO_OSC / nO_OSC)
Else
   ival = 0
   n_missing = n_missing + 1
   id of missing(iipar)  = id of missing(iipar) +  1
End If
Write(tbuf(kO:kl),  '(13)') ival
!If (first_time) Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If (first_time) Call dvf_MkFMT(kO,  '(13)')

!  Daylight temperature
iipar = g_Daylight_Temperature
kO = kl + 1
kl = kO - 1 + 10
If (n9_Temp > 0) Then
   rval = d9_Temp / n9_Temp
Else If (nO_Temp >  0) Then
   rval = dO_Temp / nO_Temp
Else
   rval = Zero
   n missing = n missing + 1
   id of missing(iipar)  = id of missing(iipar) +  1
End If
Write(tbuf(kO:kl),  '(flO.l)') rval
!If (first_time) Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If (first_time) Call dvf_MkFMT(kO,  '(flO.l)1)

!  Broadband aerosol optical_depth  (broadband turbidity)  on the  day indicated.
!  Range:  0.0-0.900
iipar = g Daylight  Broadband Aerosol
kO = kl +~1
kl = kO - 1 + 6
If (n9_Broadband_Aerosol > 0) Then
   rval = d9 Broadband Aerosol / n9 Broadband Aerosol
Else If (nO_Broadband_Aerosol > 0) Then
   rval = dO_Broadband_Aerosol / nO_Broadband_Aerosol
Else
   rval = Zero
   n_missing = n_missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar) +  1
End If
Write(tbuf(kO:kl),  '(f6.3)') rval
!If (first_time) Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If (first_time) Call dvf_MkFMT(kO,  '(f6.3)')

   !  Daylight Mean  Wind Speed @ 10 meters  [meters/second]
   !  RO:  Wind_Speed @z=10m  [m/s]
   iipar = g_Daylight_Mean_Wind_Speed
   kO = kl + 1
                                                          58

-------
!!!          kl  = kO - 1 + 6
!!!          If  (n9_mean_wind_speed > 0)  Then
!!!             rval = d9_mean_wind_speed / n9_mean_wind_speed
!!!          Else If (nO_mean_wind_speed > 0) Then
!!!             rval = dO_mean_wind_speed / nO_mean_wind_speed
!!!          Else
!!!             rval = Zero
!!!             n_missing = n_missing + 1
!!!             id_of_missing(iipar)  = id_of_missing(iipar)  + 1
!!!          End If
!!!          Write(tbuf(kO:kl),  '(£6.1)') rval
!!!          !If (first_time) Call dvf_Cols(MET_field(iipar)%Name, kO, kl)
!!!          !If (first_time) Call dvf_MkFMT(kO, '(£6.1)')
I I I
!!!          ! Maximum Daylight  Mean Wind Speed @ 10 meters [m/s]
!!!          ! RO:  Wind_Speed @z=10m [m/s]
!!!          iipar = d_Daylight_max_wind_speed
!!!          kO  = kl + 1
!!!          kl  = kO - 1 + 6
!!!          If  (n9_mean_wind_speed > 0)  Then
!!!             rval = d9_max_wind_speed
!!!          Else If (nO mean wind speed > 0) Then
!!!             rval = dO max wind speed
! ! !          Else
!!!             rval = Zero
! ! !             n missing = n missing + 1
!!!             id of missing(iipar)  = id of missing(iipar)  + 1
!!!          End If
!!!          Write(tbuf(kO:kl),  '(£6.1)') rval
!!!          !If (first_time) Call dvf_Cols(MET_field(iipar)%Name, kO, kl)
!!!          !If (first_time) Call dvf_MkFMT(kO, '(f6.1)')
I I I
!!!          ! Direction of Maximum Daylight Wind [degrees]
!!!          ! RO:  Wind direction in degrees. (N = 0 or 360,  E =  90, S =
!!!          iipar = d Daylight  direction of max wind speed
!!!          kO  = kl +~1
!!!          kl  = kO - 1 + 4
!!!          If  (n9 mean wind speed > 0)  Then
!!!             ival = Nint(d9 direction of max wind speed)
!!!          Else If (nO_mean_wind_speed > 0) Then
!!!             ival = Nint(dO_direction_of_max_wind_speed)
!!!          Else
!!!             ival = 0
!!!             n_missing = n_missing + 1
!!!             id_of_missing(iipar)  = id_of_missing(iipar)  + 1
!!!          End If
!!!          Write(tbuf(kO:kl),  '(14)') ival
!!!          !If (first_time) Call dvf_Cols(MET_field(iipar)%Name, kO, kl
! ! !          ! If (first time) Call dvf MkFMT(kO, ' (14) ' )
                                                                   59

-------
!  Daylight Prevailing Wind Speed @ 10 meters  [m/s]
iipar = d_PWS
kO = kl +~1
kl = kO - 1 + 6
Select Case(d9_pws(jday)%s)
Case(T Missing)
   is a number =  .False.
   n_missing = n_missing + 1
   id_of_missing(iipar)  = id_of_missing(iipar)  +  1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is a number =  .False.
Case Default
   is_a_number =  .True.
End Select
If (is a number)  Then
   rval = d9_pws(jday)%v
Else
   rval = Zero
End If
Write(tbuf(kO:kl), '(f6.1)') rval
!If  (first_time)  Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If  (first time)  Call dvf MkFMT(kO,  '(f6.1)')
!  Daylight Prevailing Wind Direction  [degrees]
!  RO: Wind direction in degrees.  (N =  0 or  360,  E  =  90,  S  =  180,  W = 270)
iipar = d_PWD
kO = kl +~1
kl = kO - 1 + 4
Select Case(d9 pwd(jday)%s)
Case(T Missing)
   is_a_number = .False.
   n_missing = n_missing + 1
   id of missing(iipar)  = id of missing(iipar)  + 1
Case(T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   is_a_number = .False.
Case Default
   is a number = .True.
End Select
If (is_a_number)  Then
   ival = Nint(d9_pwd(jday)%v)
Else
   ival = 0
End If
Write(tbuf(kO:kl),   '(14)') ival
!If  (first_time)  Call dvf_Cols(MET_field(iipar)%Name,  kO,  kl)
!If  (first time)  Call dvf MkFMT(kO,  '(14)')

-------
      tlen = Len_trim(tbuf(l:kl))

      !  Check that there are no  '•
      If (Index(tbuf(l:tlen) ,  '*'
         ierr = ierr + 1
         Write  (ULog, 9130) tbuf(1:tlen)
         Format (///, Ix,  '??  Field overflow:  ',  /,  Ix,  a)
      End If

      Write  (Out_MET, '(a)') tbuf(l:tlen)
   End Do

   If (n missing /=  0) Then
      Write  (ULog, 9150) n missing
      Format (/, Ix,  '?? Dump_MET: Missing values  == ',  10)
      Do jpar = 1, g_end
         If  (id of missing(jpar)  > 0) Then
            Write  (ULog, 9170) Trim(MET_field(jpar)%Name),  id_of_missing(jpar)
            Format(Ix, 6x, a,  ':  ', 10,  ' daily values  missing.')
         End If
      End Do
   End If

   Call lOClose(Out_MET)

   If (ierr /= 0)  Then
      Errors_Detected =  .True.
      ICall lOsDeleteFile(name_met)
   End If
End Subroutine Dump_MET_flie
                                                                61

-------
EtO

!      Last change:  LSR   6 Jun 2002    3:18 pm

Module ETO

   Use Date_Module
   Use Floating_Point_Comparisons
   Use Global_Variables
   Use LSQ2              ! Unconstrained linear least-squares
   Use LSQ2_derived_type
   Use Stats
   Use Strings
   Use Utilsl
   Implicit None

   Private
   Public :: ETO_et_al, Compute_Ep, Compute_E_fws,  Compute_ETO
   Public :: xRs_Over_Rso, Test_EtO
   Type(LSQ_type), Dimension(13),  Public,  Save ::  Buttner_Reg

   Real,  Public  :: L_z, L_m
   Real,  Public  :: Station_Latitude, SL_Sin, SL_Cos

   Type(Stat_Block), Save :: ETO_d
   Type(Stat_Block), Save :: Efws_d, Ep_d
   Type(Stat_Block), Save :: Adjusted_Rs_ov_Rso
   Private :: Vrmax

Contains
      Real ::  FAO gamma, t gamma, u2 to ulO
      Real ::  Rs_over_Rso, Tdew, Ta, RH, ulO
      Real ::  Rs, Ra, FAO_P, FAO_ETO,  FAO_Tdew
      Type(Val and Flag) :: ETO vfs    ! reference  evapotranspiration  [mm/day]
                                                                   62

-------
Real              ::  welev, rlat, rlon, rv
Type(Coords)       ::  wlat, wlon
Type(Site_Info), Target  :: xWBAN

Okay = .False.
ierr = 0
pWBAN => xWBAN    !  Global pointer.
wlat   = Coords('N', 16, 13)
rlat   = (wlat%degrees + wlat%minutes/60.0) ^ Degrees to  Radians
wlon   = Coords('W, 16, 15)
rlon   = (wlon%degrees + wlon%minutes/60.0) * Degrees_to_Radians
welev  = 8 !  meters
wtz    = '+!(?)'

!  New node initialization.
xWBAN%WBAN = '—001'
xWBAN%Text = "N'Diaye, Senegal"
xWBAN%Lat  = wlat
xWBAN%Lat_radians = rlat
xWBAN%Lon  = wlon
xWBAN%Lon radians = rlon
xWBAN%Elev = welev
xWBAN%TZ   = wtz
k = Index(wtz,   '(') - 1
Read(wtz(l:k),  *) xWBAN%iTZ
ICall Store_Elevation(xWBAN, edate='1800-01-01',  elevation_ft=30.0)

!  Station Latitude  [radians]
Station_Latitude = pWBAN%Lat_radians
SL_Sin = Sin(Station_Latitude)
SL_Cos = Cos(Station_Latitude)

!  Longitude of the center of the local time zone  [degrees west  of Greenwich]
L_z = TimeZone_to_Central_Meridian(pWBAN%iTZ)
!  Allocate a small "SAMSON" array environment.
!  Array to cover dates 1 October  (1961-10-01) 2h  and  14h.
Call ymdh_to_iv(1961, 10, 01, 02, iv02, t_doy)
Call ymdh_to_iv(1961, 10, 01, 14, iv!4, t_doy)

ndim = iv!4
Call Allocate SAMSON arrays(Nelements=ndim)
                                                             63

-------
FAO_Jdoy = 274    !  Day of year of 1 October 1961
If (FAO_Jdoy /= t_doy) Then
   ierr = ierr + 1
   Write (ULog, 9130) FAO_Jdoy, t_doy
   Format (Ix, '?? Test_EtO FAO_Jdoy /= t_doy:  ',  10,  Ix,  10)
End If
!  Climatic data
!  Thr: mean hourly temperature  	 = 28
!  RHhr: mean hourly relative humidity = 90
!  u2:  mean hourly wind speed 	 = 1.9
!  Rs :  total solar radiation 	 =
!  Ra:  Extraterrestrial radiation  .... =
!  Rs/Rso: 	 = 0.0
!  ETO: 	 = 0.00
                                             EtO
  Test #1: FAO: 21.98350000000000   4.342611420981305E-03
  Test #1: RO:  26.20274292447007   4.409919734092227E-03
  Test #2: FAO: 21.98350000000000   0.6269095810990636
  Test #2: RO:  26.41541277264032   0.6268624548236352
  Test #2: RO estimate of Rs over Rso == 0.8029946722967382
6.729999799304995E-02
6.757485681030362E-02
6.729999799304995E-02
6.758877044376800E-02
!  *** Test #1
FAO_P = 101.205
Rs = Zero / Watt_hour	to	MJoule
Ra = Zero / Watt hour  to  MJoule
ulO = 1.9 * u2_to_ulO
Ta = 28
RH = 90
Tdew = DewPointF(Ta, RH)

!  First, lets see how far off is our estimate of gamma,  given
!  the estimate of Tdew.
FAO gamma = 0.0673
t_gamma = GammaF(FAO_P, Tdew)
                                                             64

-------
!  Now, compute the Tdew that would generate  FAO gamma. We  are  doing
!  this to compare our results with FAO without too much problem.
!  Solved by Mathematica. 
!  Note that Gamma is a function of Tdew and  Pressure.  Therefore,
!  FAO_Tdew is the same for test cases #1 and  #2  (since  FAO_P  is
!  a constant).

FAO_Tdew = 21.9835
IWrite (6, *)  'FAO_Tdew, Tdew:  ', FAO_Tdew,  Tdew,  FAO_Tdew-Tdew
!  FAO_Tdew, Tdew:  21.98350000000000 26.20274292447007  -4.219242924470066
!  The Dew points are much different.
Xparam(f_Rs)%Samson_vlO(iv02)  = Val_and_Flag(T_SAMSONvlO,  Rs,  "")
Xparam(f_Ra)%Samson_vlO(iv02)  = Val_and_Flag(T_SAMSONvlO,  Ra,  "")
Xparam(f_DBT)%Samson_vlO(iv02) = Val_and_Flag(T_SAMSONvlO,  Ta,  "")
Xparam(f_DPT)%Samson_vlO(iv02) = Val_and_Flag(T_SAMSONvlO,  FAO_Tdew,  "")
Xparam(f_SP)%Samson_vlO(iv02)  = Val_and_Flag(T_SAMSONvlO,  FAO_P,  "")
Xparam(f_RH)%Samson_vlO(iv02)  = Val_and_Flag(T_SAMSONvlO,  RH,  "")
Xparam(f_WS)%Samson_vlO(iv02)  = Val_and_Flag(T_SAMSONvlO,  ulO,  "")
Xparam(f_pH2O)%Samson_vlO(iv02)= Val_and_Flag(T_SAMSONvlO,  Zero,  "")

FAO_ETO =0.0
Rs_over_Rso = 0.8
Do k = 1, 2
   If  (k == 1) Then
      rv = FAO_Tdew
      Xparam(f_DPT)%Samson_vlO(iv02) = Val_and_Flag(T_SAMSONvlO,  FAO_Tdew,
      xHead = 'Test #1:  FAO_Tdew =  '
   Else
      rv = Tdew
      Xparam(f_DPT)%Samson_vlO(iv02) = Val_and_Flag(T_SAMSONvlO,  Tdew,  "")
      xHead = 'Test #1:  Tdew = '
   End If

   Call Compute_ETO(iv02, Rs_over_Rso, ETO_vfs)
   If  (Abs(FAO_ETO-ETO_vfs%v) > 5.0e-3) Then
      ierr = ierr + 1
      Write (6,  9170) FAO_ETO, ETO_vfs%v,  FAO_ETO-ETO_vfs%v
      Write (ULog, 9170)  FAO_ETO, ETO_vfs%v,  FAO_ETO-ETO_vfs%v
                                                             65

-------
      Format  (Ix, '?? Test_EtO #1: FAO_ETO /= ETO_vfs:  ',  Ip3gl4.6)
   End If
   IWrite (6, *) Trim(xHead), rv,  '; ETO_vfs:  ', ETO_vfs,  ';  gamma  =  ',  GammaF(FAO_P,
End Do

!  *** Test #2
Rs = 2.450 / Wattjnour	to_
Ra = 3.543 / Watt_hour	to_
ulO = 3.3 * u2_to_ulO
Ta = 38
RH = 52
Tdew = DewPointF(Ta, RH)

!  First, lets see how far o
!  the estimate of Tdew.
t_gamma = GammaF ( FAO_P, Tdei
                                       timate of gamma,  given
   ierr = ierr
End If
!  The gammas are not too far off  (0.4%)
!  Now, compute the Tdew that would generate  FAO_gamma .  Bla  bla.
!  See comments for Test #1.
Xparam(f_Rs)%Samson_vlO(iv!4)
Xparam(f_Ra)%Samson_vlO(iv!4)
Xparam(f_DBT)%Samson_vlO(iv!4
Xparam(f_DPT)%Samson_vlO(iv!4
Xparam(f_SP)%Samson_vlO(iv!4)
Xparam(f_RH)%Samson_vlO(iv!4)
Xparam(f_WS)%Samson_vlO(iv!4)
                                 Val_and_Flag ( T_SAMSONvlO,  Rs ,  "")
                                 Val_and_Flag ( T_SAMSONvlO,  Ra,  "")
                                 Val_and_Flag ( T_SAMSONvlO,  Ta,  "")
                                 Val_and_Flag ( T_SAMSONvlO,  FAO_Tdew,
                                 Val_and_Flag(T_SAMSONvlO,  FAO_P,  ""
                                 Val_and_Flag(T_SAMSONvlO,  RH,  "")
                                 Val_and_Flag(T_SAMSONvlO,  ulO,  "")
Xparam(f_pH2O) %Samson_vlO (iv!4 )= Val_and_Flag ( T_SAMSONvlO,
FAO_ETO =0.63
Rs_over_Rso = 0.922
Do k = 1, 2
   If  (k == 1) Then
      rv = FAO_Tdew
      Xparam(f_DPT)%Samson_vlO(iv!4) = Val_and_Flag(T_SAMSONvlO,  FAO_Tdew,
      xHead = 'Test #2: FAO_Tdew =  '
   Else
      rv = Tdew
      Xparam(f_DPT)%Samson_vlO(iv!4) = Val_and_Flag(T_SAMSONvlO,  Tdew,  "")
                                                             66

-------
         xHead = 'Test #2: Tdew =  '
      End If
      Call Compute_ETO(iv!4, Rs_over_Rso, ETO_vfs)
      If  (Abs(FAO_ETO-ETO_vfs%v) > 4.0e-3) Then
         ierr = ierr + 1
         Write (6,  9210) FAO_ETO, ETO_vfs%v,  FAO_ETO-ETO_vfs%v
         Write (ULog,  9210) FAO_ETO, ETO_vfs%v,  FAO_ETO-ETO_vfs%v
         Format (Ix, '?? Test_EtO #1: FAO_ETO  /= ETO_vfs:  ',  Ip3gl4.6)
      End If
      IWrite (6,  *) Trim(xHead), rv, '; ETO_vfs:  ',  ETO_vfs,  ';  gamma = ',  GammaF(FAO_P, rv)
   End Do
Subroutine ETO et al(Xok)
     References:
     [1]  Crop evapotranspiration - Guidelines  for  computing  crop water reguirements
         - FAO Irrigation and drainage paper 56 by Richard G.  Allen,  Luis S.
         Pereira, Dirk Raes, and Martin Smith. Water  Resources,  Development and
         Management Service, FAO - Food and Agriculture  Organization  of the United
         Nations, Rome, 1998. ISBN 92-5-104219-5.
     Daily time step: see Ref[l:72]
     Hourly time step: see Ref[1:74]
     Pan evaporation: see Ref[l:78]
   Implicit None
   Logical,
   Integer
   Integer
   Integer
   Integer
   Integer
   Integer
Intent(Out)
                                                                67

-------
Real ::  Dlat
Real :: FWS_Rs,  FWS_Rdiff, FWS_Ta, FWS_Dew, FWS_u4d,  FWS_RH,  FWS_P
Real :: Efws_day

!  Class A pan evaporation  [mm/day]
Real :: pan Ep day
Real :: pan_Rs,  pan_up6d, pan_Ta, pan_RH, pan_P
!  where
!      Rso and b are regression parameters.
!      Rs — daily total radiation
!      [OSC]  -- daily mean
I
!  Fit:
!      Rs = a + m* [OSC]
!  Perform 13 regressions:
!      1:12 — Jan, Feb,  ..., Dec
!      13 -- all months
I
!  Variables for LSQ
!  nCoeff = 2, nvar = 1
!  wt    Weight of each data point
!  xx    Used to transfer data
Integer, Parameter ::  MaxCoeffs = 2
Real(dp),  Dimension(MaxCoeffs)  :: xx
Real(dp) :: wt, estim RsO, estim b
Character(Len=15), Dimension(MaxCoeffs)
Integer :: nCoeff, nvar
Logical :: fit const
Character(Len=30)  ::  tmonth
!  Station Latitude  [radians]
Station_Latitude = pWBAN%Lat_radians
SL_Sin = Sin(Station_Latitude)
SL Cos = Cos(Station Latitude)
                                                             68

-------
      !  Buttner regression
      nCoeff = 2
      nvar = nCoeff - 1    !  Do not count the constant
      fit const = .True.    !  Change to .false, if fitting a model without a constant.
      vname(1)  = 'Constant1
      vname(2)  = '[OSC]'
      wt = One !  Weight of each data point
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
Do ii = 1, 13
   !  Initializes the QR-factorization
   Call LSQ_startup(nvar, fit_const, Buttner_Reg(ii))
   If  (ii < 13) Then
      tmonth = Month_Table(ii)
   Else
      tmonth = 'All months'
   End If
   Call LSQ_set_names(&
          'Buttner: Rs[Watt hour m~-2] = a + m * OSC[tenths],  '//Trim(tmonth),  &
         vname, 'Rs', Buttner_Reg(ii))
End Do
      ICall  Sunset_Angle_Test()

      Call Vrmax(Initial!ze=.True.)
      By Days:  Do jday = jdO,  jdl      !  step by day
         hhOl  = (jday-jdO)*Nhours + 1  !  First hour of the day
         hh24  = hhOl + 23              !  Last hour of the day  (24th)
         hh25  = hh24 + 1               !  25th hour of jday ==  (jday-jdO+1)*NHours

         !  Determine the day of the year
         Call  Jd_to_ymd(jday,  jyyyy,  jmm, jdd)
         kdoy  = jdd - 32 +  Int(275*jmm/9.0)  + 2*Int(3/Real(jmm+1))  + &
               Int(jmm/100.0 - Modulo(jyyyy,4)/4.0 + 0.975)
         Ijdoy = jday - Jd ( j yyyy, 01, 01) + 1
         !If (jdoy /= kdoy)  Then
         !   Write (6,*) 'jday, j yyyy, jmm, jdd == ',  jday, j yyyy,  jmm, jdd
                                                                   69

-------
!    Write(6,*) 'jdoy == ', jdoy
!    Write(6,*) 'kdoy == ', kdoy
!    Stop '?? Stop: jdoy /= kdoy, ETO_et_al'
!End If
jdoy = kdoy

!  Initialize to "missing data"
ETO_vfs = Val_and_Flag(T_Missing, Missing_Data,  '')
Xparam(f_FAO_SG_PET)%Samson_vlO(hh25) = ETO_vfs
Xparam(f_KP_FWS_Evaporation)%Samson_vlO(hh25) =  ETO_vfs
Xparam(f Ep)%Samson_vlO(hh25) = ETO_vfs
!  dR a — daily Extraterrestrial Horizontal Radiation,
dR_a = Xparam(f_Ra)%Samson_vlO(hh25)%v

!  Any radiation today?
If ( (dR_s > EpsO)  .And.  (dR_a > EpsO)) Then
   Call EtO_subO()    ! ETO_day == Sum ETO_hr
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner

!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner

!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!!!Buttner
!  Buttner regression:
!      Rs  = a  + m [OSC]
I
!  Perform 13  regressions:
!      1:12 — Jan,  Feb,  .
!      13  -- all months
                               Dec
  Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
     !  Opaque sky cover missing. No data point available.
     Call LSQ_includ (weight=wt, xrow=xx, &
           yelem=dR_s, T=Buttner_Reg(13))
     Call LSQ includ(weight=wt, xrow=xx, &
           yelem=dR_s, T=Buttner_Reg(jmm))
Else
   !  If there is no radiation during the day, then darkness.
   !  Darkness over the land. Is the station North of the Arctic Circle?
   If (Dlat >= Latitude_Arctic_circle) Then
      Xparam(f_FAO_SG_PET)%Samson_vlO(hh25)%s = T_Perpetual_Darkness
                                                          70

-------
      Xparam(f_KP_FWS_Evaporation)%S arris on_vlO(hh25)%s  =  T_Perpetual_Darkness
      Xparam(f_Ep)%Samson_vlO(hh25)%s = T_Perpetual_Darkness
   Else
      !  Some other problem.
      Write  (ULog,  9130) Trim(pWBAN%WBAN),  Trim(pWBAN%Text),  jyyyy,  jmm,  jdd
      Format (Ix, '?? ETO_et_al: dRs=dRa=0  and not  Arctic Circle for ',  &
            a,   ': ' , a,  ';  ', 14,  ' - ' , 12.2,  '-', 12.2)
      Write  (6,  9130) Trim(pWBAN%WBAN), Trim(pWBAN%Text), jyyyy,  jmm,  jdd
      Write  (6,  *)  Dlat, Latitude_Arctic_circle
      Stop '@@@'
   End If
   Cycle By_Days
End If
!  When possible, use the daily values  computed  by
!      
FWS_Rs = Xparam(f_Rs)%Samson_vlO(hh25)%v         ! Watt  hour  meter^-2  day^-1
FWS_Rdiff = Xparam(f_Rdiff)%Samson_vlO(hh25)%v   ! same  units as  Rs
FWS_Ta = Xparam(f_DBT)%Samson_vlO(hh25)%v        ! °C
FWS_Dew = Xparam(f_DPT)%Samson_vlO(hh25)%v       ! °C
FWS_P = Xparam(f_SP)%Samson_vlO(hh25)%v         ! kPa
FWS_RH = Xparam(f_RH)%Samson_vlO(hh25)%v         !  %;  unused  by the current formulation
Call Compute_E_fws(FWS_Rs, FWS_Rdiff,  FWS_Ta,  FWS_Dew,  FWS_u4d,  FWS_RH,  FWS_P,  Efws_day)
!  Computations for daily Ep —
!  Use daily values for all computations.

pan_Ta = Xparam(f_DBT)%Samson_vlO(hh25)%v  ! mean  daily temperature
                                                          71

-------
           Write (Umath,  9150)  ETO_day, Efws_day, pan_Ep_day
           Format (3x,  '{',  flO.3, ',  ', flO.3,  ',  ', flO.3,  '},')
           ierr = ierr + 1
           Xparam(f_Ep)%Samson_vlO(hh25)%v =
           Xparam(f_Ep)%Samson_vlO(hh25)%s =
           Write (ULog,  9170)  '?? daily value
           Format(lx,  a, 14,  '-', 12.2, '-',
        End If
                                                 jmm,  jdd,  NHours,
                                                 Ip2gl4.6)
                                        pan  Rs,  pan  Ta
!IButtne
!!Buttne
!!Buttne
!IButtne
!IButtne
!!Buttne
!!Buttne
!IButtne
!IButtne
!!Buttne
!!Buttne
!  Perform Buttner regressions.
Do ii = 1, 13
   Call LSQ_Simple_Regression(Buttner_Reg(ii), ULog)
   estim_RsO = Buttner_Reg(ii)%beta(1)
   estimjo = - Buttner_Reg(ii)%beta(2) / estim_RsO
   Write  (ULog, *)
   Write  (ULog, 9330)
   Write  (ULog, 9330)
   Write  (ULog, 9330)
   Format
End Do
= Rso (1 - b  [OSC])'
Rso', estim_RsO,  '[Watt hour
 b ', estim_b,  '[dimensionles
, Ipgl4.6, :, Ix, a)
  Contains

     Subroutine EtO subO()
        Implicit None
        Integer ::  nETO,  N_missing, hh, ii
        Logical ::  is_daytime, was_nighttime, is_dawn
        Real    ::  ETO_hr,  R_s
        Logical ::  nan detected

        nETO = 0
        was nighttime = .True.
        nan detected = .False.
                                                                  72

-------
!  If missing parameters, skip this hour
N missing = 0
Select Case(Xparam(f_Rs)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   N_missing = N_missing + 1
End Select
Select Case(Xparam(f_Rdiff)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   N_missing = N_missing + 1
End Select
Select Case(Xparam(f_Ra)%S arris on_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   N_missing = N_missing + 1
End Select
Select Case(Xparam(f_DBT)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   N_missing = N_missing + 1
End Select
Select Case(Xparam( f_DPT) %Sarrison_vlO (hh) %s )
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   N_missing = N_missing + 1
End Select
Select Case(Xparam( f_SP) %Sarrison_vlO (hh) %s )
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   N_missing = N_missing + 1
End Select
Select Case(Xparam(f_RH)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   N_missing = N_missing + 1
End Select
Select Case(Xparam( f_WS ) %Sarrison_vlO (hh) %s )
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   N_missing = N_missing + 1
End Select
Select Case(Xparam(f_pH2O)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   N_missing = N_missing + 1
End Select
If (N missing > 0) Then
   Cycle OneDay
End If

!  Test perpetual darkness: 27502: Barrow, AK
!  It is dawn if the previous hour was nighttime and the
!  current hour is daytime. Note that the sunset hour will
                                                       73

-------
!  not be updated during the interval  [1, SunRise], because
!  it is still nighttime. This is the correct behaviour.
!  The sunrise and sunset hours should be updated only at dawn.
!  was_nighttime will remain .False, until the do loop is
!  restarted, next Julian day.
is dawn = was nighttime .And. is daytime
If (iSunset == Tbogus)  Then
   Call Find_Sunrise_Sunset(hhOl, hh24, jdoy, &
         dSunrise, iSunrise, dSunset, iSunset)
Else If (is_dawn) Then
   was nighttime = .False.
   Call Find_Sunrise_Sunset(hhOl, hh24, jdoy, &
         dSunrise, iSunrise, dSunset, iSunset)
End If
!  If the current hour (i.e., hh)  is contained in the closed interval
!      [iSunrise+Delta hours, iSunset-Delta hours]   (i.e., daytime)
!  then the ratio Rs/Rso is computed at ii = hh.
!  If iSunrise =< hh < iSunrise+Delta_hours (i.e., the hours
!  after sunrise), then the ratio is computed at
!         ii = iSunrise+Delta hours
!  If iSunset-Delta_hours <= hh (i.e., a few hours before sunset),
!  then the ratio is computed at
!         ii = iSunset-Delta hours

If (is_daytime)  Then
   ii = hh
   Call  xRs Over Rso(ii, jdoy, Rs over Rso)
   If (Rs_over_Rso > One) Then
      If (hh <= dSunrise) Then
         ii = dSunrise
         Call xRs Over Rso(ii, jdoy, Rs over Rso)
      Else If (dSunset <= hh)  Then
         ii = dSunset
         Call xRs_Over_Rso(ii, jdoy, Rs_over_Rso)
      End If
   End If
Else
   !  Nighttime.  Use the ratio computed before sunset.
   ii = dSunset
   Call  xRs Over Rso(ii, jdoy, Rs over Rso)
End If
Rs_over_Rso = Min(Rs_over_Rso, One)

If (IsNaN(Rs_over_Rso))  Then
   ierr = ierr + 1
   nan_detected = .True.
   Write(ULog,*)  '?? ETO et al: Rs_over_Rso=NaN for  ', &
                                                       74

-------
            Call Compute_ETO(hh, Rs_over_Rso, ETO_vfs)
            Case Default
               If (.Not. IsNaN(ETO_vfs%v)) Then
                  nETO = nETO + 1
                  ETO_hr = ETO_vfs%v
                  ETO_day = ETO_day + ETO_hr
               Else
                  ierr = ierr + 1
                  nan_detected =  .True.
                  Write  (ULog, 9130)  '??  ETO_et_al: ETO_hr==NaN  at  ',  &
                        JyyyYr jmm, jdd,  Modulo(hh,NHours),  hh
                  Format(lx, a, 14, '-',  12.2,  '-', 12.2,  13,  'h; iv:',  10)
               End If
            End Select
         End If
      End Do OneDay

      If (nETO > 0)  Then
         ICall Stat_Add_Point(ETO_d, ETO_day)
         Xparam(f_FAO_SG_PET)%Samson_vlO(hh25)%v = ETO_day
         Xparam(f_FAO_SG_PET)%Samson_vlO(hh25)%s = T_Estimated
      Else If  (nETO == 0) Then
         ierr = ierr + 1
         Write(ULog,*) '?? ETO_et_al: nETO==0 for  ', jyyyy,  jmm,  jdd
      End If
End Subroutine ETO_et_al


Subroutine Sunset_Angle_Test()

   Implicit None

   Integer ::  dSunrise, ISunrise, dSunset, ISunset
   Integer ::  i_sunset, d_sunset, iv_offset, h_angle, hO
   Integer ::  jj, kk, kO, jh_l_24, npts
   Integer ::  jday, hhOl, hh24, hh25, jdd, jmm, jyyyy, jdoy
                                                                75

-------
Real    ::  w_s,  aaa, B, S_c, aO, al, w_deg
Real    ::  Solar Declination, xx Rs over Rso
Logical ::  ok
Real    ::  SL_Tan
Character(Len=2)  :: xcoda
Integer, Dimension(-24:24)   :: Ksunset = 0, Ksunrise = 0
SL_Tan = SL_Sin / SL_Cos
Call Stat_Initialize(Sunset_Angle,  'Sunset angle -  90°')
Call Stat_Initialize(Hour_Range,  'Hour Range, Rs/Rso <= 1:  ')
Call Stat Initial!ze(Rs ov Rso daytime,  'Rs/Rso, from sunrise to  sunset')

Do jday = jdO, jdl                !  step by day
   hhOl = (jday-jdO)*Nhours + 1   !  First hour of the day
   hh24 = hhOl + 23               !  Last hour of the day  (24th)
   hh25 = hh24 + 1                !  25th hour of jday ==  (jday-jdO+1)*NHours
   !  Since the ratio Rs/Rso is used to represent cloud cover, when
   !  calculating Rnl for hourly periods during the nighttime, the ratio
   !  Rs/Rso can be set equal to the Rs/Rso calculated for a time period
   !  occurring 2-3 hours before sunset, before the sun angle becomes  small.
   !  This will generally serve as a good approximation of cloudiness  occurring
   !  during the subsequent nighttime. The hourly period that is 2 to  3 hours
   !  before sunset can be identified during computation of Ra as the  period
   !  where w, calculated from Equation 31, is within the range
   !  (w s - 0.79)  <= w <= (w s - 0.52), where w s is calculated using
   !  Equation 25.  As a more approximate alternative, one can assume
   !  Rs/Rso = 0.4  to 0.6 during nighttime periods in humid and subhumid
   !  climates and Rs/Rso = 0.7 to 0.8 in arid and semiarid climates.
   !  A value of Rs/Rso = 0.3 presumes total cloud cover.
   !  The sunset hour angle, w s, is given by Equation 25:
   w s = Acos(  -SL Tan * Tan(Solar Declination)  )
                                                             76

-------
!  Let
!         a = 0.5 + 0.06667*(L_z-L_m) + S_c  -  12
!  Then
!         w = (Pi/12)*(h+a)
!  And
!                     (w_s-0.79) <=  w  <=  (w_s-0.52)
!             (w_s-0.79) <=   (Pi/12)*(h+a)   <= (w_s-0.52)
!          12/Pi*(w_s-0.79)  - a <=  h  <=  12/Pi*(w_s-0.52)  -  a

!  S c — Seasonal correction for local time  [1:48]
B = Two_Pi * Real(Jdoy-81)  / 364.0
S_c = 0.1645*Sin(2*B) - 0.1255*Cos(B) - 0.025*Sin(B)

aaa = 0.5 + 0.06667*(L_z-L_m) + S_c - 12
aO = 12/Pi*(w_s-0.79) - aaa
al = 12/Pi*(w_s-0.52) - aaa

i sunset = Modulo(iSunset,NHours)
d sunset = Modulo(dSunset,NHours)
ok = (aO <= d_sunset) .And.  (d_sunset <=  al)
If (ok)  Then
   xcoda = ''
Else
   xcoda = '??'
End If

hO = Ceiling(aO)
iv_offset = dSunset / NHours
h_angle = hO + NHours*iv_offset

!  Collect statistics on the ratio Rs/Rso  for
!  the period sunrise to sunset.
Do jj = iSunset, iSunrise,  -1
   Call xRs Over Rso(jj,  Jdoy, xx Rs over Rso)
   Call Stat_Add_Point(Rs_ov_Rso_daytime, xx_Rs_over_Rso)
End Do

!  Starting from sunset and  ending on sunrise,
!  record the first hour for which Rs/Rso  <= 1.
Do jj = iSunset, iSunrise,  -1
   Call xRs_Over_Rso(jj ,  Jdoy, xx_Rs_over_Rso)
   If (xx_Rs_over_Rso .LessThanOrEgual. One)  Then
      kk = jj  - iSunset
      Ksunset(kk) = Ksunset(kk) + 1

      kO = jj  - iSunrise


                                                          77

-------
               Exit
            End If
         End Do

         w deg = w s * Radians to Degrees -  90
         Call Stat_Add_Point(Sunset_Angle, w_deg)

      End Do

      npts = jdl - jdO + 1

      Write (ULog, '(//)')
      Write (ULog, 9130) npts
9130  Format (Ix, 'Total number of points:  ', 10)

!!!Call Stat_Output(ULog, Sunset_Angle)
!!!Call Stat_Output(ULog, Rs_ov_Rso_daytime)

!!!          Write(ULog, 9570)  'Ksunset(Hour(Rs/Rso<=l)  -  h_angle)'
!!!          Write(ULog, 9570)  'Ksunset(Hour(Rs/Rso<=l)  -  dsunset)'
!!!       Write(ULog,  9570)  'Ksunset(Hour(Rs/Rso<=l)  -  isunset)'
!!!9570  Format  (/,  Ix, a)
I I I
!!!       Do jj  = Ubound(Ksunset,1), Lbound(Ksunset,1),  -1
!!!          If (Ksunset(jj) /= 0) Then
!!!             Write(ULog,  9580) jj, Ksunset(jj)
!!19580        Format  (Ix,  3x,  'Ksunset(', 13,  ') ==  ', 10)
!!!          End If
!!!       End Do
I I I
!!!       jj = Sum(Ksunset)
!!!       Write (ULog,  9590) jj,  npts-jj
!!!9590  Format  (Ix,  'Sum(Ksunset): ', 10, 3x,  '; Total pts  -  Sum(Ksunset)  == ',  10)
I I I
!!!       Write (ULog,  *)
!!!       Write(ULog,  9550)  Trim(Hour_Range%Header),  Hour_Range%xmin,  Hour_Range%xmax
!!!9550  Format  (Ix,  a, Ix, 2(Ix,Ipgl4.6))
I I I
I I I
!!!       Write(ULog,  9770)  'Ksunrise(Hour(Rs/Rso<=l)  -  isunrise)'
!!19770  Format  (/,  Ix, a)
                                                                   78

-------
!!19780         Format (Ix,  3x,  'Ksunrise(', 13, ') == ', 10)
!!!          End If
!!!       End Do
I I I
I I I
I I I
!!!Stop '##  Scheduled stop at Sunset_Angle_Test'
   End Subroutine Sunset_Angle_Test
      !  Text from [FAO:75]
      I
      !  Since the ratio Rs/Rso is used to represent cloud cover, when
      !  calculating Rnl for hourly periods during the nighttime, the ratio Rs/Rso
      !  can be set equal to the Rs/Rso calculated for a time period occurring 2-3
      !  hours before sunset,  before the sun angle becomes small. This will
      !  generally serve as  a  good approximation of cloudiness occurring during
      !  the subsequent nighttime. The hourly period that is 2 to 3 hours before
      !  sunset can be identified during computation of Ra as the period where w,
      !  calculated from Equation 31, is within the range
      !      (w_s - 0.79) <= w <= (w_s - 0.52),
      !  where w_s is calculated using Equation 25. As a more approximate
      !  alternative, one can  assume Rs/Rso = 0.4 to 0.6 during nighttime periods
      !  in humid and subhumid climates and Rs/Rso = 0.7 to 0.8 in arid and
      !  semiarid climates.  A value of Rs/Rso = 0.3 presumes total cloud cover.

      Implicit None
      Integer,           Intent(In)  :
      Integer,           Intent(In)  :
      Real,              Intent (Out) :
      !  S c — Seasonal correction for local time [1:48]
      B  = Two_Pi *  Real(Jdoy-81)  / 364.0
      S_c = 0.1645*Sin(2*B)  - 0.1255*Cos(B)  - 0.025*Sin(B)

      !  Solar time  angle  (lower case omega)  at the midpoint of the period,  [radians]


                                                                   79

-------
   !  K b — clearness index for direct beam radiation  [dimensionless]
   !  K_t -- turbidity coefficient. K_t == 1 for clean  air,  0.5  for  extremely tubid air.
   K_t =1.0
   K_b = 0.98 * Exp(-0.00146*P_kPa/(K_t*Sin_Phi) -  0.075*(W/Sin_Phi)**0.4)

   !  K_d -- Clearness index for diffuse radiation  [dimensionless]
   If (K_b .GreaterThanOrEqual. 0.15) Then
      K_d = 0.35 - 0.36 * K_b
   Else
      K_d = 0.18 + 0.82 * K_b
   End If

   !  R so — Short-wave radiation on a clear-sky day
   !  R_a -- Extraterrestrial Horizontal Radiation,
   !            SAMSON: [Watt hour m^-2],
   !            After Conversion:  [MJoule]
   R_a = Wattjnour	to	MJoule * Xparam(f_Ra)%Samson_vlO(Ihh)%v
   R so = (K b + K d) * R a
   !If (IsNaN(Rs_over_Rso))  Then
   !    Write (6,*) '??? IsNaN(Rs_over_Rso)), ihh =  ',  ihh
   !    stop
   !End If
Subroutine Find_Sunrise_Sunset(HourOl, Hour24, Jdoy,  &
      dSunrise, iSunrise, dSunset, iSunset)

-------
   !  Find sunrise and sunset hours in the interval  [HourOl, Hour24]
   Implicit None
   Integer, Intent(In)  :: HourOl, Hour24
   Integer, Intent(In)  :: Jdoy
   Integer, Intent(Out)  :: dSunrise, iSunrise, dSunset, iSunset

   Integer, Parameter ::  Delta hours = 3
   Integer : :  j j, dl
   Logical ::  xx_is_daytime

   iSunset = Tbogus     !  The last hour of the day  for which Rs >  0;
   iSunrise = Tbogus    !  The first hour of the day for which Rs >  0;
   dSunrise = Tbogus
   dSunset = Tbogus

   Do jj = HourOl, Hour24
      Select Case(Xparam ( f_Rs )%Samson_vlO(jj)%s)
      Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
         Cycle

      Case Default
         xx is daytime =  (Xparam ( f Rs ) %S amis on vlO(jj)%v > Zero)
         If (xx is daytime) Then
            iSunset = jj
            If  (iSunrise == Tbogus) Then
               iSunrise = j j
            End If
         End If
      End Select
   End Do

   !  If iSunset is set,  so is iSunrise.
   !  Daylight period: [iSunrise, iSunset]
   !           dSunrise <= dSunset
   !      iSunrise + dl <= iSunset - dl
   !  ==>            dl <=  (iSunset - iSunrise) / 2
   If (iSunset /= Tbogus)  Then
      dl = Min(Deltajnours, (ISunset-iSunrise)/2)
      dSunrise = iSunrise + dl
      dSunset = iSunset - dl
   End If

End Subroutine Find Sunrise Sunset
Subroutine Vrmax(Initialize, Xprint)

   Implicit None
   Logical, Optional, Intent(In) :: Initialize
   Logical, Optional, Intent(In) :: Xprint
                                                                81

-------
   If (Present(Initialize)) Then
      ICall Stat_Initialize(Adjusted_Rs_ov_Rso,  'Rs/Rso,  forced<=l,  all  24  hours')
      ICall Stat_Initialize(ETO_d, Fieldlnfo(f_FAO_SG_PET)%Name)
      ICall Stat_Initialize(Efws_d, Fieldlnfo(f_KP_FWS_Evaporation)%Name)
      ICall Stat_Initialize(Ep_d,  Fieldlnfo(f_Ep)%Name)
      Return
   End If

   If (Present(Xprint))  Then
      IWrite  (ULog, '(/)')
      ICall Stat_Output(ULog, Adjusted_Rs_ov_Rso)
      ICall Stat_Output(ULog, ETO_d)
      ICall Stat_Output(ULog, Efws_d)
      ICall Stat_Output(ULog, Ep_d)
      Return
   End If

End Subroutine Vrmax
   Implicit None
   Integer,           Intent(In)  :: Ihour
   Integer, Optional, Intent(In)  :: M      I Number  of  days  to  dump
   Integer :: yyyy, mm, dd, hh, jdoy, dOdays, dldays
   Integer :: jpar, ivO, ivl, n,  iv
   Real    :: xx Rs over Rso

   If  (Present(M))  Then
      dOdays = Abs(M)
      dldays = 2
   Else
      dOdays = 0
      dldays = 1
   End If

   I  see 
   n = Floor(Ihour/Real(Nhours))
   n = Max(n-dOdays, 0)
   ivO = n*Nhours + 1
   ivl = (n+dldays)*Nhours - 1

   Do iv = ivO,  ivl
      Call iv_to_ymdh(iv, yyyy, mm, dd, hh)
      jdoy = dd - 32 + Int(275*mm/9.0) + 2*Int(3/Real(mm+1)) + &
            Int(mm/100.0 - Modulo(yyyy,4)/4.0 +  0.975)
                                                                82

-------
         Do jpar = 1, f end
            Write (ULog, 9150) Trim(Fieldlnfo(jpar)%Name),  Xparam(jpar)%Samson_vlO(iv)
         End Do
9150     Format(lx,  3x, a, ':  ', Ipgl4.6, Ix, a,  Ix,  a)
      End Do
   End Subroutine Dump One Day
   Subroutine Vadd(Vnums, Rval)
      Integer ::  i

      i = Len trim(Vnums)  + 1
      Write (Vnums(i:), '(",", f!5.7)') Rval
   Subroutine Compute_E_fws(Rs, Rdiff, Ta, Tdew, u4d,  RH,  P,  E_fws)
      !  Compute E fws,  free-water-surface evaporation  [mm/day]
      Implicit None
                           Rs     ! Global horizontal radiation,  [W h  m^-2  day^-1]
                           Rdiff  ! Diffuse horizontal  radiation,  [W h m~-2 day^-1]
                           Ta     ! Ambient Temperature  [°C]
                           Tdew   ! Dew point Temperature  [°C]
                           u4d    ! Wind Speed  @z=4 meters  [km/day]
                           RH     ! Relative Humidity  [%]
                           P      ! Pressure  [kPa]
                           E_fws  ! free-water-surface  evaporation  [mm/day]
Real, Intent(In)
Real, Intent(In)
Real, Intent(In)
Real, Intent(In)
Real, Intent(In)
Real, Intent(In)
Real, Intent(In)
Real, Intent (Out
      !  Epsilon Water: Broad-band emmissivity of the water  surface,  [dimensionless]
      Real,  Parameter :: Epsilon_Water = 0.97

      !  Sigma: Stefan-Boltzman constant
      !  See  Tinoco, Sauer and Wang, Physical Chemistry,  3rd edition.  Page 23
                                                                   83

-------
   !  Lambda == Latent heat  (enthalpy) of vaporization  of water
   I
   !                         Sigma * T~4   kg[Water]
   !  Mass Water / m^2 /s ==	* 	
   !                           Lambda      m^2 s  10^6
   I
   !                         Sigma * T'M   mm[Water]     86400  s    3.93701e-2  inch

   !                           Lambda        s 10^6      1  day    1  mm
   I
   !  Sigma * 86400 * 3.93701e-2
   I  	
   !         Lambda * 10^6

   Real, Parameter :: Sigma_Inch = 7.87e-ll

   Real ::  Rn, tKelvin, e_s, delta, es_ea
   Real ::  fu4d, Ea, gammaP
   Real ::  terml, term2
   !  e_s    saturation water vapor pressure  [kPa]  at  temperature  Tc
   !  Delta  slope of saturation water vapor pressure  [kPa/°C]
   !         1 kilopascal = 0.29530 inchHg
   !         1 kilopascal/°C = 0.29530 inchHg *  100°C/180°F
   !                         = 0.16406 inchHg/°F
   Call Es_and_Delta(Ta, e_s, delta)
   delta = delta * 0.16406 !  inchHg/°F
   gammaP = 0.000108 * P    ! inchHg/°F
   E_fws = 25.4 *  (terml + Ea*term2) /  (delta+term2)

End Subroutine Compute E fws



Subroutine Compute_Ep(Ta, up6d, Rs, RH, P, Ep, okay)

-------
!  Compute Ep, Class A pan Evaporation  [mm/day]
Implicit None
         Intent(In)     Ta     ! Temperature  [°C]
         Intent(In)     up6d   ! Wind Speed @z=0.6 meters  [km/day]
         Intent(In)     Rs     ! Rs,  [W h m^-2 day^-1]
         Intent(In)     RH     ! Relative Humidity  [%]
         Intent(In)     P      ! Pressure  [kPa]
         Intent(Out)    Ep     ! Class A pan  Evaporation  [mm/day]
                        okay
!  e a  Atmospheric water vapor pressure; actual water  vapor  pressure,  [kPa]
ea=0.01*es*RH
!  If Rs == 0 and Ta <= 35 F, then delRn ==  0.
!  35 °F = 1.6667 °C
!  Reference:
!  [] Lamoreux, Wallace W. 1962. Modern Evaporation  Formulae  adapted
!     to computer use. Monthly Weather Review.  January  1962,  pages  26-28.
If  (Rs > Zero) Then
   tmpO = (1.8*Ta - 180) *  (0.1024 - 0.01066*Log(0.0862*Rs))
   delRn = 154.8 * Exp(tmpO)  -  0.01548
Else
    ! Rs <= 0
   If  (Ta .LessThanOrEqual. 1.6667) Then
      delRn = Zero
   Else
      Ep = Missing_Data
      Return
   End If
End If

gammap = 0.001568 * P
Ep = (delRn + gammap^Ea) /  (delta+gammap)
okay = .True.
                                                             85

-------
Subroutine Compute_ETO(hh, Rs_over_Rso, ETO_vfs)

   !  Compute (hourly) ETO, FAO Penman-Monteith  reference  evapotranspiration
   I
   !  hh  iv-type hour, e.g., hh==9126 represents  hour  ==  1
   I
   !  Sin_Station_Latitude     Sin(Station Latitude  [radians])
   !  Cos Station Latitude     Cos(Station Latitude  [radians])
   !  L z
   !  ETO vfs (Output) Hourly reference evapotranspiration  [mm/day]

   Implicit None
   Integer,            Intent(In)   :: hh
   Real,               Intent(In)   :: Rs_over_Rso
   Type(Val_and_Flag) , Intent(Out)  :: ETO_vfs    !  reference  evapotranspiration [mm/day]
   !  Energy flux per m~2 = J s~-l m~-2 = Sigma  *  I'M
   !      T == Temperature  [Kelvin]
   !  Sigma == Stefan-Boltzman constant = 5.67e-8  J  s~-l  m^-2  K^
   !  Lambda == Latent heat (enthalpy) of vaporization  of water
   Real, Parameter :: Sigma = 2.043e-10    ! MJ m"-2  hour"-!

   Real ::  Rs,  Ta, RH, Ra, Tdew, P
   Real ::  e s, e a,  delta, es minus ea, u2
   Real ::  R ns, R nl, R n hr, G hr, gamma
   Real ::  tmpO, tmpl, ETO_xxx
   Logical  :: is_daytime

-------
!                              %s,           %v, %f
ETO_vfs = Val_and_Flag(T_Missing, Missing_Data, '')

!  Rs -- Global Horizontal Radiation,  [Watt hour m~-2]
Select Case(Xparam(f_Rs)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   Return
End Select
Rs = Xparam(f_Rs)%Samson_vlO(hh)%v
is daytime =  (Rs > Zero)

!  Ra -- Extraterrestrial Horizontal Radiation,  [Watt hour m^-2]
Select Case(Xparam ( f_Ra )%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   Return
End Select
Ra = Xparam(f_Ra)%Samson_vlO(hh)%v

!  mean hourly air temperature, [°C]
Select Case(Xparam(f_DBT)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   Return
End Select
Ta = Xparam(f_DBT)%Samson_vlO(hh)%v

!  Relative Humidity [Percent]
Select Case(Xparam(f_RH)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   Return
End Select
RH = Xparam(f_RH)%Samson_vlO(hh)%v

!  Atmospheric Pressure,  [kPa]
Select Case(Xparam(f_SP)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   Return
End Select
P = Xparam(f_SP)%Samson_vlO(hh)%v

!  Precipitable_water,  [mm]
Select Case(Xparam(f_pH2O)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   Return
End Select
                                                             87

-------
!  Numerical noise made day es minus ea == -1.387778780781446E-17.
es minus ea = Max(e s - e a, Zero)
!  Hourly net radiation at the grass surface  [MJ m^-2 hour^-1]
R_n_hr = R_ns - R_nl

!  Soil heat flux
If (is_daytime) Then
   G_hr =0.1* R_n_hr
Else
   G_hr =0.5* R_n_hr
End If

!  The function returns wind speed  (in m/s) at z=2 meters
!  
Select Case(Xparam(f_WS)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
   Return
End Select
u2 = Wind_Speed_F(Xparam(f_WS)%Samson_vlO(hh)%v, T_u2 )

!  Dew point temperature,   [°C]
Select Case(Xparam(f_DPT)%Samson_vlO(hh)%s)
Case(T_Missing, T_Not_Applicable, T_Perpetual_Darkness)
   Return
   !  Gamma — Psychrometric constant  [kPa C^-l];  [kPa/°C]
   Gamma = GammaF(P, Tdew)
End Select

!  The FAO Penman-Monteith equation for hourly time steps  [1:74]
tmpO = 0.408 * Delta *  (R_n_hr - G_hr)  +  &
      Gamma * 37.O/(Ta+273.0)  * u2 *  es_minus_ea
tmpl = Delta  +  Gamma *  (1.0 + 0.34*u2)

-------
      ETO_xxx = tmpO / tmpl
      ETO_vfs = Val_and_Flag(T_Estimated, ETO_xxx,  '')

   End Subroutine Compute_ETO

End Module ETO
                                                                   89

-------
Evap
   Use Date_Module
   Use Floating Point Comparisons
   Use Global_Variables
   Use loSubs
   Use LSQ2_derived_type
   Use LSQ2             !  Unconstrained linear least-squares
   Use Strings
   Use Utilsl
   Use Stats
   Implicit None
   Subroutine Process Evaporation Data()

      !  The general form of the file is:
      !                                            DAILY
      I
      !  Station FARGO WSO AP                     Parameter        Evap
      !  PO Code ND                               Latitude    N46:55:31
      !  Stn ID  2859                             Longitude  W096:48:40
      !  County  CASS                             Elevation         900
      i  	Evap  (mm) 	
      !  1963     Jan    Feb    Mar    Apr    May    Jun    Jul    Aug    Sep    Oct    Nov    Dec  Annual
      ,    i      	    	    	    	    	    	      g

-------
i   12      	    	    	    	      6    	      7    	    	      6
i   13      	    	    	      4    	    	      7    	    	      7
!   14      	    	    	      5      4    	      3    	    	      5
I    .
i   29      	    	    	    	      6    	      9    	    	      5
           	    	    	    	      7    	      7    	    	      2
           	    	    	    	      g    	      7    	    	      4
I
i  Total    	    	    	     82    218    	    201    	    	    121
i  Extrm    	    	    	      9     15    	     13    	    	      8
!  ^L (sometimes)

!  Ignore blank lines, lines with "~L", lines with a leading "!"
I
!  The number of lines and the information contained in the lines before
!  the '	'  line varies with the type of data in the file. However the blocl<
!      1. a '	'  line with an identifier  ('WD16(km)' in this example)
!      2. year and month
!      3. 31 lines with data
!  is constant through all files.
I
!  After each block there are summary lines which vary with the file type.
!  These lines will be ignored.
Character(Len=l00)  :: xbuf
Character(Len=50)   :: xid
Integer ::  ios, nl, n2, jj, fO, fl, uin, ierror
Integer ::  npos, beg_col, end_col
Integer ::  yyyy, mm,  dd, hh, iv, jd today
Integer ::  points read, points excluded, points wo parameters
Logical ::  ok, missing_params, exclude_point, in_range
Real :: units to mm,  minV, maxV
Real :: maximum rainfall = 13.0  !  mm/day
Real :: up6

!  Variables for LSQ
!  Evap(Obs) = a*Evap(rO_estimate)  + b
!  nCoeff = 2, nvar = 1  (i.e., Evap(rO estimate))
!  We hope a == 1 & b == 0
Integer, Parameter ::  MaxCoeffs = 2
Integer  :: nCoeff,  nvar
                                                             91

-------
Logical  ::  fit const    !  .false, if  fitting  a  model  without  a  constant.

!  wt    Weight of each data point
!  xx    Used to transfer data
!  beta  Regression coefficients
Real(dp), Dimension(MaxCoeffs)  :: xx
Real(dp)  ::  wt, yobs, yteo
Character(Len=15), Dimension(MaxCoeffs)  :: vname
Real(dp), Dimension(jdO:jdl)  ::  yyobs, yyteo
Character(Len=Len(Xparam(l)%Samson_vlO(1)%s))  ::  steo
Integer,  Dimension(:), Pointer  :: Days in Month
Call Vrmax(Initial!ze=.True.)
vname(1)  = 'Constant1
vname(2)  = 'Ep_rO'
wt = One !  Weight of each data point

!  Find the evaporation file, e.g.,  'v:\evaporation\T  14914.evp'
Call IORead(uin, name_Daily_Evap, ierror,  ok=OK)
If  (.Not. OK) Then
   Write (ULog, *) '## Process Evaporation Data:  did  not  find  ',  Trim(name Daily Evap)
    ! Not finding the file is NOT  an error.  Just  return.
    !Errors_Detected =  .True.
   Return
Else
   Write (ULog, *) '## File: ', Trim(name_Daily_Evap)
    !   Call ToTTy('Process_Evaporation_Data:  found  '//Trim(name_Daily_Evap))
End If

!  Range of acceptable values.
minV = Fieldlnfo(f_Ep)%minimum_value
maxV = Fieldlnfo(f_Ep)%maximum_value

!  fO points to the character after the  last  DirDelim  of name Daily Evap,  therefore
!  name_Daily_Evap(f0:)  contains only the name  of the  input file.  This  makes
!  messages more readable.
!  I changed my mind  (24 Jan 2002  2:30  pm).  In case  of problems,
!  I do not want to hunt for a file.
fO = 1   !  + Index(name_Daily_Evap, DirDelim,  Back=.True.)
fl = Len_trim(name_Daily_Evap)

nCoeff = 2
nvar = nCoeff - 1
fit const =  .True.
                                                             92

-------
!  Initializes the QR-factorization
Call LSQ_startup(nvar, fit_const, Ep_all)
Call LSQ_startup(nvar, fit_const, Ep_some)

Call LSQ_set_names('Evaporation, all points', vname,  'Ep(obs)',  Ep_all)
Call LSQ set names('Evaporation, some deletions', vname,  'Ep(obs)',  Ep  some)
wt = one

points_read = 0
points excluded = 0
points wo parameters = 0
Read_One_Line: Do
   Read  (uin, '(a)', iostat = ios) xbuf
   If  (ios /= 0)  Exit  ! End-Of-File or Error
   !  Found the beginning of the data block.
   !  Find the name in the line, e.g.,  'Evap  (mm)'
   !  nl   points to the first character of the  name
   !  n2-l delimits the name. Note that the name  may  contain  blanks.

   nl = Verify(xbuf,  '- ')     ! Find first non  '-' or blank,  "E"  for  the  example.
   n2 = Index(xbuf(nl:),  '-')  !
   If  (n2 > 0) n2 = n2 + nl - 1 - 1
   xid = xbuf(nl:n2)           ! e.g.,  'Evap  (mm)'
   !  The program assumes evaporation is measured  in mm.
   !  Convert  (if needed) data file units to mm. I  am  told
   !  that the file units should be "mm", with
   !  (perhaps occasionally), "in"  (inches)
   Select Case(xid(nl:n2))
   C a s e( 'mm' )
      units to mm =1       ! 1 mm -> 1 mm
   Case('in')
      units_to_mm = 25.400  ! 1 inch -> 25.400 mm
   Case Default
      Write (ULog, *)  '?? Input file:  ', name_Daily_Evap(f0:f1)
      Write (ULog, 9130) xid(nl:n2)
      Format  (Ix, '??  Process_Evaporation_Data: Expecting "mm"  or  ',  &
            '"in", found "', a, '"')
                                                             93

-------
   Errors_Detected = .True.
   Return
End Select

!  The line following "	" identifies the year  and  the  columns:
!  1963     Jan    Feb    Mar    Apr    May    Jun    Jul    Aug     Sep     Oct    Nov    Dec  Annual

Read (uin, '(a)', iostat = ios)  xbuf
If (ios /= 0)  Then
   Write  (ULog, *) '?? Input file:  ', name_Daily_Evap(f0:f1)
   Write  (ULog, *) '    Expecting a  "year" line1
   Errors_Detected = .True.
   Return
End If

!  Get year.
Read (xbuf(1:4),   '(14)', iostat = ios) yyyy
If (ios /= 0)  Then
   Write  (ULog, *) '?? Input file:  ', name_Daily_Evap(f0:f1)
   Write  (ULog, *) '    Line: "', Trim(xbuf),  '"'
   Write  (ULog, *) '    The first four characters Do  not  represent  a year.'
   Errors Detected = .True.
   Return
End If

ok = (MinYear <= yyyy)  .And. (yyyy  <= MaxYear)
If (.Not. ok)  Then
   Write  (ULog, *) '?? Input file:  ', name_Daily_Evap(f0:f1)
   Write  (ULog, *) '    The year ',  yyyy, ' is not  between  ',  &
         MinYear, '  and  ', MaxYear
   Errors Detected = .True.
   Return
End If
!  Now load the data block  (the next 31 lines) in the  array.
Do jj =1, 31
   Read (uin, '(a)', iostat = ios) xbuf
   If (ios /= 0)  Then
      Write  (ULog, *)  '?? Input file:  ', name_Daily_Evap(f0:f1)
      Write  (ULog, *)  '   Error: Expecting month-day  ', jj
      Errors_Detected =  .True.
      Return
   End If
   !  Sanity check: jj must be egual to dd
                                                          94

-------
If  (jj /= dd) Then
   Write  (ULog, *)  '??  Input  file:  ',  name_Daily_Evap(f0:f1)
   Write  (ULog, *)  '    Error:  jj  /= dd;  jj, dd == ', jj, dd
   Errors_Detected  =  .True.
   Return
End If

!  1963     Jan    Feb     Mar     Apr    May    Jun    Jul    Aug
,    i      	    	     	     	    	    	      g    	
i    2      	    	     	     	      9    	      8    	     	       7     	
!28        06      31       00000000
             0    	       100000000
             0    	       000000000
             0    	       3     	      0    	      0       2     	       0     	

hh = NHours  ! the 25-th hour  is  the daily value
npos = 4     ! Start processing at this column.
Month Loop:  Do mm =1,  12
   Call GetQwordCols(xbuf,  npos,  beg col, end col, ierror)
   If (ierror /= 0) Then
      Write  (ULog,  *)  '?? Input  file:  ',  name_Daily_Evap(f0:f1)
      Write  (ULog,  *)  '    Line:  "', Trim(xbuf), '"'
      Write  (ULog,  ^)  '    contains  less than twelve months, mm ==  ',  mm
      Errors_Detected = .True.
      Return
   End If

    ! Make sure the  day  of the  month is valid for this month.
    ! Example: 1963-Feb  has  28  days. If we call ymdh_to_iv
    ! for 1963-Feb-29, the iv  returned is  for 1963-March-Ol
    !  (i.e.,  one day after 1963-Feb-28).  Ditto for 30-day months.
   If (dd >  Days_in_Month(mm)) Then
      !  Invalid date. Go to next (column) month.
      Cycle Month Loop
   End If

   If (xbuf(beg_col:end_col)  ==  '	'
      !  Missing data
      Cycle Month Loop
   End If
   Read(xbuf(beg  col:end  col),  ^
   If  (ios /=  0)  Then
      Write  (ULog,  *)  '??  Input file:  ',  name_Daily_Evap(f0:f1)
      Write  (ULog,  *)  '    Line:  "',  Trim(xbuf), &
             1", substr: "',  xbuf(beg col:end col),  '" '
      Write  (ULog,  *)  '    Not  a number.'
      Errors_Detected  =  .True.
      Return
   End If
                                                        95

-------
!  Before converting to appropriate units, make sure
!  this value is not a "flag" value.
!  Undocumented flag values are in the range:  [-8323  ,  -8290]
!  24 Mar 2002 11:55 am: anything less than -8000 will  be
!  considered to be a flag value and silently  skipped.
If  (yobs <= -8000) Then
    ! some flag value.
   Cycle Month_Loop
End If
!  value in range?
in range = ((minV <= yobs)  .And.  (yobs <= maxV))
If (.Not. in_range) Then
   Write (ULog, *) '?? Input file:  ', name_Daily_Evap(f0:f1)
   Write (ULog, *) '    Value not  in range, ignored v,minV,maxV  :  ',  yobs,  minV,  max\/
   Cycle Month Loop
End If

points read = points read + 1
Call Stat Add Point(ObsEp all, yobs)
!  We have an Ep observation. Replace the estimated Ep  (Class A
!  evaporation) with the observed value.
lyteo = Xparam(f_KP_FWS_Evaporation)%Samson_vlO(iv)%v
yteo = Xparam(f_Ep)%Samson_vlO(iv)%v
steo = Xparam(f_Ep)%Samson_vlO(iv)%s
Xparam(f_Ep)%Samson_vlO(iv)%v = yobs
Xparam(f_Ep)%Samson_vlO(iv)%s = T_EarthInfo
Xparam(f_Ep)%Samson_vlO(iv)%f = ''

!  if the estimated Ep is missing,  no further analysis  is possible.
Select Case(steo)
Case(T_Missing, T_Not_Applicable,  T_Undefined, T_Perpetual_Darkness)
   Cycle Month_Loop
End Select

!  Compute the Julian Day number of the current day
!  and store the corresponding pair.
jd_today = Jd(yyyy,  mm, dd)
yyteo(jd today) = yteo
yyobs(jd today) = yobs

!  Exclude days when
!  * pan is frozen: Xparam(f_DBT)%Samson_vlO(iv)%v <= 0
                                                    96

-------
               !  *  rainfall:  Xparam(f_HP)%Samson_vlO(iv)%v > 0
               !  *  high wind:  Xparam(f_WS)%Samson_vlO(iv)%v >= wO
               !  -- all of which interfere with observation.
               missing_params  = &
                     (Xparam(f_DBT)%Samson_vlO(iv)%s == T_Missing) .Or. &
                     (Xparam(f_HP)%Samson_vlO(iv)%s == T_Missing) .Or. &
                     (Xparam(f_WS)%Samson_vlO(iv)%s == T_Missing) !.Or. &
               !       (Xparam(f_KP_FWS_Evaporation)%Samson_vlO(iv)%s == T_Missing)
               If (missing_params)  Then
                  !   8  Feb 2002  5:41  pm:  until we develop a better formulation,
                  !     kill KP_FWS_Evaporation.
                  points_wo_parameters = points_wo_parameters + 1
                  IWrite (ULog, *)  '## Missing KP_FWS_Evaporation parameters for  ', yyyy, mm, dd
                  Cycle Month  Loop
               End  If

               !  The function  returns  wind speed (in m/s)  at z=0.6 meters
               !  up6 — Wind Speed in  meters/sec at z=0.6 meters
               !         (approx 2 feet, the height of  a Class A pan Anemometer)
               !  
               up6  = Wind_Speed_F(Xparam(f_WS)%Samson_vlO(hh)%v, T_up6)

!!!Call  LSQ includ(weight=wt,  xrow=xx, yelem=yobs,  T=Ep all)

               exclude_point = &
                     (Xparam(f_DBT)%Samson_vlO(iv)%v <= Zero)  .Or. &
                     (Xparam(f HP)%Samson  vlO(iv)%v  >= maximum rainfall) .Or. &
                     (up6  >= maximum_wind_speed)

               If (exclude point) Then
                  points excluded = points excluded +  1
                  Cycle Month_Loop
               End  If
                                                                   97

-------
         End Do
      End Do Read_One_Line

      !  All data was read. Close the file ...
      Call lOClose(uin)
      Call Vrmax(Xprint=.True.)
      Write (ULog,  9170) points read, points excluded, &
            points  wo parameters, Ep some%nobs
9170  Format (//,  &
            Ix,  'Points read 	 :   ', 10, /, &
            Ix,  'points excluded 	 :   ' , 10, /, &
            Ix,  'points wo parameters ... :   ', 10, /, &
            Ix,  'No.  of regression points :   ', 10)

      Call LSQ_Simple_Regression(Ep_some, ULog)
   End Subroutine Process Evaporation Data
      Implicit None
      Logical, Optional, Intent(In) :: Initialize
      Logical, Optional, Intent(In) :: Xprint

      If (Present(Initialize))  Then
         Call Stat_Initialize(ObsEp_all,  'Obs Evap, all values')
         Call Stat_Initialize(ObsEp_set,  'Obs Evap, values used  for  regression  only
         Call Stat Initial!ze(teoEp set,  'Estimated Ep at "regression points"')
         Return
      End If

      If (Present(Xprint))  Then
         !IWrite (ULog, '(//)')

         Call Stat_Output(ULog, ObsEp_all)
         Call Stat_Output(ULog, ObsEp_set)
         Call Stat_Output(ULog, teoEp_set)

         Return
      End If
   End Subroutine Vrmax
                                                                   98

-------
Fix  Data
   Use Date_Module
   Use Global_Variables
   Use Utilsl
   Implicit None

   Private
   Public ::  Fix_SAMSON

Contains
      !  Fix_SAMSON performs manual correction of the data records.
      !  Be careful when fixing precipitation records, in particular,
      !  with runs of missing, deleted, or accumulated values.
      !  Make sure the beginning or end of such a run is not lost
      !  on transfer.

      Implicit None
      Logical, Intent(Out)  :: Xok
      Else If (pWBAN%WBAN == '22516') Then
         Call Kahului_HI(Xok)

      Else If (pWBAN%WBAN == '14922') Then
         Call Minneapolis_St_Paul_MN(Xok)

      End If

   End Subroutine Fix SAMSON
      Implicit None
      Logical, Intent(Out)  ::  Xok
                                                                   99

-------
!  Observation Indicator  0 or 9   0 = Weather observation made.
!                                  9 = Weather observation not made or missing.
!  Present weather - Present weather conditions denoted by 9 indicators.
Implicit None
Logical, Intent(Out)  ::  Xok

Integer ::  jvO, jvl
                                                            100

-------
      Type(Val_and_Flag),  Dimension(:),  Pointer :: HP => Null()   !  Hourly precipitation

      If (.Not.  Have_ppt_Obs_hourly_data)  Then
         !  We need Earthlnfo hourly data.
         Xok = .False.
         Return
      End If

      HP => Xparam(f_HP)%Samson_vlO       !  Hourly Precipitation
      !  This  statement also transfers the daily values, but we
      !  do  not care.
      HP(jvO:jvl)  = Obs_ppt(jvO:jvl)
   Subroutine Minneapolis_St_Paul_MN(Xok)

      !  #===# 1:  Processing 14922:  Minneapolis/St.  Paul, MN

      !  The  subroutine assumes that the hourly Earthlnfo
      !  records  have been read.
      If (.Not.  Have_ppt_Obs_Daily_data)  Then
         !  We need Earthlnfo summary of the day data.
         Xok = .False.
         Return
      End If
!!!  Station MINNEAPOLIS AIRPORT              Parameter        Prep
!!!  PO Code MN                               Latitude    N44:52:59
!!!  Stn ID  5435                             Longitude  W093:13:44
!!!  County  HENNEPIN                         Elevation         834
i i i  	 Prcp (ln) 	
! ! !  1984      Jan    Feb    Mar    Apr    May    Jun    Jul    Aug
! ! !   1
                                                                  101

-------
      !  Neither the SAMSON nor the Earthlnfo hourly records for that day show precipitation.
      !  Zero the entry.

      Obs_ppt(218925)  = Val_and_Flag(T_Estimated, Zero,  '')

      Xok = .True.

   End Subroutine Minneapolis_St_Paul_MN


End Module Fix Data Records
                                                                  102

-------
Gaps
   Use Global Variables
   Use Utilsl
   Use Floating_Point_Comparisons
   Implicit None
      !  Filled — truth of "gap was resolved". Values were
      !            interpolated or gotten from previous years.
      !  Col_Beg -- iv of begin of gap
      !  Col_End -- iv of end of gap
      !  Col Prev — the hour previous to Col Beg.
      !              if Col Beg represents an hour in 2..24,
      !              then
      !                  Col_Prev = Col_Beg - 1
      !              Else
      !                  Col Beg is the 1st of the day and
      !                  Col_Prev represents the 24th hour of the previous day.
      !  Col_Post — the hour after Col_End.
      !              if Col End represents an hour in 1..23,
      !              then
      !                  Col_Post = Col_Beg + 1
      !              Else
      !                  Col_End is the 24th hour of the day and
      !                  Col Post represents the 1st of the next day.

      Logical :
      Integer :
      Integer :
      Integer :
      Integer ::  Col_Post = 0
   End Type Type_Gap
   Subroutine Find_i(VF, HourOl, Hour24, iFirst, iLast)

      !  Find iFirst and iLast hours in the interval [HourOl, Hour24]
      !  such that iFirst is the first hour of the day that is not
      !  missing, and iLast is the last hour not missing.
      Implicit None
                                                                  103

-------
   Type(Val_and_Flag),  Dimension(:), Intent(In)   :: VF
   Integer,                          Intent(In)   :: HourOl, Hour24
   Integer,                          Intent(Out)  :: iFirst, iLast

   Integer : :  j j

   iLast = 0    !  The last hour of the day with non-missing data;
   iFirst = 0   !  The first hour of the day with  non-missing data;
   Do jj  = HourOl, Hour24
      Select Case(VF(jj)%s)
      Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
         Cycle
      Case Default
         iLast = j j
         If (iFirst == 0) Then
            iFirst = jj
         End If
      End Select
   End Do

End Subroutine Find i
   !  Fill gaps.
   !  16 Feb 2002  9:49 am: At this time I think that
   !  since I will be using these arrays for all SAMSON
   !  parameters, I will leave the arrays allocated, rather
   !  than allocating and deallocating after each call.
   !  This subroutine will allocate arrays that will
   !  stay allocated between calls (this is a feature).
   I
   !  The call Find_Gaps(0, Release_Storage=.True.)
   !  will deallocate the arrays *only* and exit.
   !  (The first two argument slots need to be present
   !  eventhough will not be used.)
   !  Since we check only for the presence of "Release Storage"
   !  this argument should not be present during "regular"
   !  calls to this subroutine.
   Implicit None
   Integer,           Intent(In)
   Logical, Optional, Intent(In)
   Integer, Parameter ::  Size Small  = 1
   Integer, Parameter ::  Size Medium = Size Small + 1
   Integer, Parameter ::  Size_Large  = Size_Medium + 1

   Integer ::  current gap size, i  max
                                                               104

-------
Integer ::  i prev, col beg, col end
Integer ::  iv, ig
Logical ::  in_gap, point_is_missing, okay, first_message
Type(Val_and_Flag),  Dimension(:), Pointer  :: VF

Logical, Save ::  first time =  .True.
Integer, Save ::  Gap dim = 0
Integer ::  ngaps
Type(Type_Gap) ,  Dimension(:),  Pointer  :: Gap_Info => Null()

If (first_time)  Then
   Gap_dim =50
   Allocate(Gap_Info(Gap_dim))
   first time = .False.
End If

If (Present(Release_Storage))  Then
   If  (Associated(Gap Info))  Deallocate(Gap Info)
   Gap dim = 0
   first_time = .True.
   Return
End If

!  Is it sensible to fill gaps?
Select Case(k_id)
Case(f_OI)
   !  Observation Indicator, Present weather:
   !  It makes no sense to fill gaps in these parameters.
   !  We should not be here in  the first place.
   Write(6, 9130)
   Write(ULog, 9130)
   Format!//, lx,  '?? Find_Gaps: called with k_id ==  ', &
         'Observation Indicator, Present_weather',  //)
   Stop '?? Find Gaps: called  with k id == Observation  Indicator1
End Select
in gap = .False.
ig = 0            !  No gaps so far.
current_gap_size = 0
i prev = 0
!  We need to process gaps in the following order:
!      a)  first Small gaps
!      b)  Medium gaps
!      c)  Large gaps
!  This will allow the results of the smaller fills
                                                             105

-------
!  to  be  used for the larger data gaps.
   !  Skip the  25th hour
   If (Modulo(iv,25)  == 0)  Then
      Cycle
   End If

   !  We need to loop  one extra time to correctly process
   !  a gap occurring  at the end of the array.  Duplicating
   !  the code  for (in gap)  also works but I always forgot
   !  to propagate the changes to both instances of the code.

   If (iv <  i	max) Then
      !  At this stage,  if the point is missing, the point
      !  is missing ALL the time, otherwise the algorithm
      !  will interpolate with the assumption that the
      !  value  of the  point is correct!
      Select Case(VF(iv)%s)
      Case(T_Missing, T_Not_Applicable,  T_Undefined,  T_Perpetual_Darkness)
         point_is_missing = .True.
      Case Default
         point is missing = .False.
      End Select
   Else
      !  iv ==  i  max
      point  is missing = .False.
      !  The  point is  not missing -- it does not exist.
   End If

   If (in_gap)  Then
      If (point_is_missing)  Then
         current_gap_size = current_gap_size + 1
      Else
         ! The gap run just ended. Store terminating info.
         ! The gap finished on the previous column.
         Gap_Info(ig)%Col_End = i_prev
         Gap Info(ig)%Col Post = iv
                                                            106

-------
   Else
      If (point is missing) Then
         !  Start of a new gap
         If (ig >= Gap_dim) Then
            Gap_dim = 2 * Gap_dim
            Gap Info => Reallocate Gaps(Gap Info, Gap dim)
         End If
         ig = ig + 1
         Gap_Info(ig)%Filled = .False.
         Gap Info(ig)%Col Beg = iv
         Gap Info(ig)%Col Prev = i prev   ! "iv - 1"
         Gap_Info(ig)%Col_End = 0
         Gap_Info(ig)%Col_Post = 0
         in gap = .True.
         current gap size = 1
      Else
         !  No missing value and no gap.
         !  Do nothing.
      End If
   End If

   !  Previous column to the next column.
   !  Note that next column is iv+1, unless iv is a 24th hour.
   !  In that case the next column is iv+2  (i.e., the first
   !  hour of the next day.
   i  prev = iv
End Do

!  Now, we need to process all the small gaps first,
!  the medium gaps second, and the large gaps third.
!  What is the best way (more efficient, faster) of
!  passing through the arrays three times?
!  I can have essentially the same code replicated
!  three times, or the code once with if statements.
      okay = .False.
      col_beg = Gap_Info(ig)%Col_Beg
      col end = Gap Info(ig)%Col End
                                                            107

-------
      !  Do not count the 25-th hour(s)  as part of the gap.
      current gap size = col end - col beg + 1 - Multiples of(NHours, col beg,  col  end)

      !  Process all small gaps first, medium gaps second, and large gaps third.
      !  Tests:
      !  23063: Eagle,  CO has small, medium, and large gaps.
      !  26451: Anchorage, AK has gaps containing the array boundaries.

      Select Case(current_gap_size)
      Case(l:5)
         If (size_order == Size_Small)  Then
            Call Fill_Small_Gaps(VF,  Gap_Info(ig) , k_id, okay)
            Gap_Info(ig)%Filled = okay   ! Gap filled?
         End If

      Case(6:49)
         If (size_order == Size_Medium)  Then
            Call Fill  Medium Gaps(VF, current gap size, Gap Info(ig), &
                  k id, move back=.True., okay=okay)
            Gap_Info(ig)%Filled = okay   ! Gap filled?
         End If

      Case Default
         If (size_order == Size_Large)  Then
            Call Fill_Large_Gaps(VF,  current_gap_size, Gap_Info(ig) ,  &
                  k id, okay)
            Gap_Info(ig)%Filled = okay   ! Gap filled?
         End If
!  Now one more time (with feeling).  This time we want to
!  ensure that all gaps were filled
   If (Gap_Info(ig)%Filled)  Then
      Cycle
   End If

   col_beg = Gap_Info(ig)%Col_Beg
   col end = Gap Info(ig)%Col End
   current gap size  = col  end - col beg + 1 - Multiples of(NHours, col beg,  col  end)
                                                            108

-------
         first message =  .False.
      End If

      Write (ULog, 9150)  ig, Trim(Fieldlnfo(k_id)%Name),  &
            current_gap_size,   &
            Str iv to ymdh(col  beg),  &
            Str iv to ymdh(col  end)
      Format(Ix, 6x, 10,  ':  ',  a,  ':  gap  of  ',  10,  '  hours  from ',  &
            a,  ' to  ', a)
   End Do
Function Reallocate Gaps(pOld, Nnew) Result(pNew)
   Implicit None
   Type(Type_Gap), Dimension!:),  Pointer  :: pOld,  pNew
   Integer,                       Intent(In)  ::  Nnew
   Integer ::  nold, ierr
   nold = Min(Size(pOld), Nnew)
   pNew(l:nold) = pOld(l:nold)
   Deallocate(pOld)
End Function Reallocate_Gaps
   Implicit None
   Type(Val_and_Flag) , Dimension(:),  Intent(InOut)  ::  VF
   Type(Type_Gap),                    Intent(In)     ::  Gap_Info
   Integer,                           Intent(In)
   Logical,                           Intent(Out)

   Integer ::  Col_Beg, Col_End   ! Col_Beg  <=  Col_End
   Integer ::  xi, xO, xn, irange
                                                                109

-------
okay = .False.
irange = Huge(0)
Col_Beg = Gap_Info%Col_Beg
Col_End = Gap_Info%Col_End
within_range = (1 <= Gap_Info%Col_Prev)  .And. &
       (Gap_Info%Col_Post <= Ubound(VF,1))
If (within range) Then
   !  This is fine and dandy if the interval  [Col_Beg, Col_End] does  not
   !  contain a 25th hour  (daily values). We  need to  remove this
   !  extra/bogus hour from the computation of the slope and dx below.

   xO = Gap_Info%Col_Prev
   xn = Gap_Info%Col_Post
   irange = xn - xO - Multiples of(NHours, xO, xn)
   vO = VF(xO)%v
   vn = VF(xn)%v
   vslope = (vn-vO) / Real(irange)
Else
   !  The situation is more complex if a gap  starts  (or ends)
   !  at either boundary of the array.

   !  We know that one of V(xO) or V(xn) is not missing, namely,
   !  the side that stays within the array bounds.

   If (1 <= Gap_Info%Col_Prev) Then
      !  The starting column is within bounds.
      xO = Gap Info%Col Prev
      xn = xO
      vO = VF(xO)%v
      vslope = 0
                                                             110

-------
   Else
      !  The terminating column is within bounds.
      xO = Gap_Info%Col_Post
      xn = xO
      vO = VF(xO)%v
      vslope = 0
   End If
End If

t_code = T_Small_Gap
Select Case(k_id)
Case(f_OI)
   !  Observation Indicator, Present_weather
   !  It makes no sense to fill gaps in these parameters
   !  We should not be here in the first place.
   Write(ULog, 9130)
   Format!//, lx, '?? Warning: Fill_Small_Gaps with  ', &
          'Observation Indicator, Present weather1, //)
   Return

Case(f_HV)   ! Horizontal Visibility
   !  Be careful filling gaps when
   !  Visibility == unlimited visibility.
   If ((VF(xO)%s == TJJnlimited) .Or.  (VF(xn)%s == TJJnlimited))  Then
      t_code = T_SGU
   End If

Case(f_CH)   ! Ceiling Height
   !  Be careful filling gaps when
   !  Ceiling Height == unlimited ceiling height, or
   !                 == cirroform.
   !  We have this problem for 14914  (Fargo), 1965 1  1  12h-15h
   If ((VF(xO)%s == TJJnlimited) .Or.  (VF(xn)%s == TJJnlimited))  Then
      t_code = T_SGU
   Else If ((VF(xO)%s == T_Cirroform)  .Or.  (VF(xn)%s == T_Cirroform))  Then
      t_code = T_SGC
   End If

Case Default
   !  Do nothing.
End Select

Do xi = Col Beg, Col End
   !  Skip the 25th hour
   If (Modulo(xi,25) == 0) Then
      Cycle
   End If
                                                             111

-------
      VF(xi)%s = t_code
      VF(xi)%f = ''
   End Do
   okay = .True.
End Subroutine Fill_Small_Gaps
   Implicit None
   Type(Val_and_Flag) , Dimension(:), Intent(InOut)
   Integer,                          Intent(In)
   Type(Type_Gap),                    Intent(In)
   Integer,                          Intent(In)
   Logical,                          Intent(In)
   Logical,                          Intent(Out)
   Integer
   Integer
   Integer
   Integer
   Logical
::  Col  Beg,  Col  End  !  Col Beg
: :  j ,  j max,  j min,  JvO,  jvl,  iv
::  nh,  ntimes
::  jMidnight,  jSunset,  jSunrise
::  period found,  moving back
                                          <= Col End
   okay = .False.
   Col Beg = Gap Info%Col Beg
   Col End = Gap Info%Col End
         jvO = Col beg - j*Nhours
         jvl = Col End - j*Nhours
   !  Let
   !  Then, the set of possible periods j is:  jmin <= j <= jmax
   !  Similarly, if moving forward j periods:
   !      jvO = Col_beg + j*Nhours
   !      jvl = Col_End + j*Nhours
                                                                112

-------
!  subj ect to
!      Col_beg < jvO <= jvl <= M
!  Then, the set of possible periods j is:  jmin <= j <= jmax

moving_back = move_back
period found = .False.
t code = T Medium Gap

!  Only two options: move forward or backwards.
!  If we have failed twice, there is no more to do.
xDirection: Do ntimes =1,2
   If  (period_found) Exit xDirection

   jmin = 1 + Floor((Col_End-Col_Beg)/Real(Nhours))
   If  (moving back) Then
       ! search backwards.
      nh = -Nhours
      jmax = Floor((Col_Beg-l)/Real(Nhours))
   Else
       ! search forward.
      nh = +Nhours
      jmax = Floor((Ubound(VF,1)-Col_Beg)/Real(Nhours))
      jmax = Min(jmax, 2)  !  we will look  only in the  immediate vicinity
   End If

   If  (jmin > jmax) Then
       ! No periods in this direction. Switch directions and try again.
      moving_back = (.Not. moving_back)
      Cycle xDirection
   End If

   !  We can try in this direction.
   Find_period: Do j = jmin,  jmax
      jvO = Col_Beg + j*nh
      jvl = Col End + j*nh

       ! Evaluate the candidate period.
       ! Make sure there are no missing values.
       ! If this period has missing values, then try next period.
      Do iv = JvO, jvl
         !  Skip the 25th hour
         If (Modulo(iv,25) == 0) Cycle
                                                             113

-------
         Select Case(VF(iv)%s)
         Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
            !  Missing values render this segment unusable.
            !  Try next period.
            Cycle Find_period
         End Select
      End Do

      !  Found a period without missing values.
      period found = .True.
      VF(Col_Beg:Col_End)%v = VF(jvO:jvl)%v
      VF(Col_Beg:Col_End)%s = t_code
      VF(Col_Beg:Col_End)%f = ''
      Exit xDirection

   End Do Find_period
End Do xDirection
!  
!  Unsuccessful. If the gap size is less than 24 then:
!  * Set all hours before midnight to the "sunset" value.
!  * Set all hours after midnight to the "sunrise" value.
I
!  Example, adapted 14891 61.txt
            yyyy mm ^d hh
                                   10       10      ! jSunset
                                            10      ! Col Beg
                                                    ! jMidnight
                                             8      ! Col_End
                                             8      ! jSunrise
!  see 
If (Gap_Length > 24)  Then
   !  Gap spans more than one day. Exit
   Return
                                                            114

-------
   End If

   !  Find the 25th hour           !  See example above
   !hh = Modulo(Col_Beg, 25)      !   19
   !dl = NHours - hh              !    6 (delta hours from 25h)
   !jMidnight = Col_Beg + dl      !  500
   jMidnight = NHours * (1 + Col_Beg/NHours)   ! 500

   !  Find jSunset and jSunrise, making sure they lie within the
   !  array bounds.
   jSunset = Gap Info%Col Prev   !  pointer to value before midnight
   If (jSunset < Lbound(VF,1))  Then
      jSunset = Gap_Info%Col_Post
      If (jSunset > Ubound(VF,l))  Then
         !  The gap spans the whole array,  nothing sensible to do.
         Return
      End If
   End If

   jSunrise = Gap_Info%Col_Post  !  pointer to value after midnight
   If (jSunrise > Ubound(VF,1)) Then
      jSunrise = Gap Info%Col  Prev
      If (jSunrise < Lbound(VF,1))  Then
         !  The gap spans the whole array,  nothing sensible to do.
         Return
      End If
   End If

   VF(Col_Beg:jMidnight)%v = VF(jSunset)%v
   VF(Col_Beg:jMidnight)%s = t_code
   VF(Col_Beg:jMidnight)%f = ''

   VF(jMidnight+l:Col_End)%v = VF(jSunrise)%v
   VF(jMidnight+1:Col_End)%s = t_code
   VF(jMidnight+l:Col_End)%f =  ''

   okay = .True.

End Subroutine Fill Medium Gaps
Subroutine Fill Large Gaps(VF, Gap Length, Gap Info, k id, okay)

   !   
   !  Much Longer gaps of 50 to 8784 hours  (one leap year).
   !  Copy data from the same period from some other year.

   Implicit None
   Type(Val_and_Flag),  Dimension(:), Intent(InOut)  :: VF
                                                               115

-------
Integer,
Type(Type_Gap) ,
Integer,
Logical,
                         Intent(In)
                         Intent(In)
                         Intent(In)
                         Intent(Out)
Gap Length
Gap Info
k_id
okay
Integer
Integer
Integer
Integer
Integer
Integer
Real
Real
Real
Real
Real
Logical
Character
  Col  Beg,  Col  End  !  Col Beg <= Col End
  jvO,  jvl,  yyyy,  n min,  iv
  beg_year,  beg_mm,  beg_dd,  beg_hh
  nhours,  d_min,  d_max,  ig,  ic,  k
  best  year,  itimes,  g low,  g high
  bestJvO,  bestjvl
  best_mean_diff,  year_mean_diff
  best_sigma_diff,  year_sigma_diff
  gM_k,  gQ_k,  cM_k,  cQ_k
  M_kml,  x_k
  g_mean,  c_mean,  g_variance, c_variance
  best_found,  Lkeep
(Len(VF(l)%s))  ::  t code
okay = .False.
t_code = T_Large_Gap
Col Beg = Gap Info%Col Beg
Col End = Gap Info%Col End
!  Determine the date of the beginning of the gap.
Call iv to ymdh(Col Beg, beg year, beg mm, beg dd, beg hh)

!  According to the documentation, SAMSON may look at
!  periods up to 4 weeks adjacent to the gap.
!  Interval: 4 weeks * 7 days/week * 24h/day, prorated to  a  leap year
nhours = Max(10, 4*7*24*Gap_Length/8784)
!  Reference:
!  [2]  Nicholas J. Higham. 1996. Accuracy and Stability of Numerical
!      Algorithms. SIAM  (Society for Industrial & Applied Mathematics)
!      ISBN 0-89871-355-2. Page 13.
I
!  Accumulate:
I
!           1
I
                                                             116

-------
           k   1=1
!  Updating formulae:
!  After which:
I
!     Sample Mean = M_n
I
!                        Q_n
!     Sample Variance = -----
!                       n - 1
I
!  Note that the updating formulae can be written:
I
i     M 0 = 0
!      ~                x_k - M_{k-l}
!     M_k = M_{k-l}  +  ------------- ,
!
!     Q_0 = 0
!  mean diff = Abs(g mean - c mean)
!  sigma_diff = Abs(g_Variance - c_Variance)

best found = .False.          !  found a year?
best year = 0                 !  in MinYear .. MaxYear
best_mean_diff = Huge(Zero)   !  best mean difference so far
best sigma diff = Huge(Zero)
                                                            117

-------
   Cycle By Year
End If

!  Skip years not read, i.e., data for the whole year is missing.
If (Year_Data(yyyy)%SAMSON_vlO == 0) Then
   Cycle By Year
End If
!  Gap end falls outside array bounds ?
If (jvl > d_max) Then
   Cycle By Year
End If

!  Any entries missing?
By Hour: Do iv = jvO, jvl
   !  Skip the 25th hour
   If (Modulo(iv,25)  == 0) Cycle By_Hour
   Select Case(VF(iv)%s)
   Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
      !  This segment has missing values. Perhaps next year  ...
      Cycle By_Year
   End Select
End Do By_Hour

!  Found a candidate segment without missing values.
!  Determine mean and variance for both segments.
Qlnterval: Do itimes = 1, 2
   !  Execute twice to determine leading and trailing intervals.
   !  Make sure the leading and trailing intervals are within
   !  the array boundaries.

   !  n min is the number of entries common to both intervals; n min >= 0;

   If (itimes == 1)  Then   !  Determine leading interval.
      n min = Min(nhours, Col Beg-d min, jvO-d min)
      g low = Col Beg - n min
      g_high = Col_Beg - 1
   Else                    !  Determine trailing interval.
      n min = Min(nhours, d max-Col End, d max-jvl)
                                                         118

-------
      g low = Col End + 1
      g high = Col End + n min
   End If

   !  ig:  counter of gap
   !  ic:  counter of candidate
   Xview: Do ig = g low, g high
      ic = ig + jvO - Col_Beg

      !  The pre/post gap segments may contain missing values.
      !  Nothing we can do about that.
      Select Case(VF(ig)%s)
      Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
         !  Missing values. Skip.
         Cycle Xview
      End Select

      Select Case(VF(ic)%s)
      Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
         !  Missing values. Skip.
         Cycle Xview
      x_k = VF(ig)%v
      M_kml = gM_k
      gM_k = M_kml + (x_k-M_kml)/Real(k)
      gQ_k = gQ_k + (Real(k-1)/Real(k))*(x_k-M_kml)**2

      x_k = VF(ic)%v
      M_kml = cM_k
      cM_k = M_kml + (x_k-M_kml)/Real(k)
      cQ k = cQ k + (Real(k-1)/Real(k))*(x k-M kml)**2
If (k >= 2)  Then
   g_variance = gQ_k / Real(k-1)
   c_variance = cQ_k / Real (k-1)
Else
   !  Variance not defined for k<=l
   g variance = Huge(Zero)
   c_variance = Huge(Zero)
End If
                                                         119

-------
      year mean diff = Abs(g mean-c mean)
      year sigma diff = Abs(g variance-c variance)

      !  #1. Choose the year closest to the mean of the gap.
      !  #2. If the means are equal, choose the year with the
      !         closest variance.
      Lkeep = .False.
      If (year_mean_diff < best_mean_diff)  Then
         !  Current year has the smallest mean difference. Keep it.
         Lkeep = .True.
      Else If (Abs(year_mean_diff-best_mean_diff)  < EpsO) Then
         !  Means are equal, i.e., year_mean_diff == best_mean_diff.
         !  Keep this year if its variance difference is smaller than the
         !      best variance difference so far.
         Lkeep = (year sigma diff < best sigma diff)
      End If
      If (Lkeep) Then
         best found =  .True.  !  found a better year.
         best year = yyyy     !  in MinYear ..  MaxYear
         bestJvO = jvO
         bestjvl = jvl
         best mean diff = year mean diff
         best sigma diff = year sigma diff
      End If
   End Do By_Year

   If (best_found)  Then
      VF(Col_Beg:Col_End)%v = VF(best_jvO:best_jvl)%v
      VF(Col_Beg:Col_End)%f = ''
      VF(Col_Beg:Col_End)%s = t_code
   End If
   okay = best_found

End Subroutine Fill Large Gaps
Subroutine Fill_Dew_Point(Xok)

   !  Estimate missing Dew point

   Implicit None
   Logical, Intent(Out)  ::  Xok

   Integer ::  iv
   Integer ::  jyyyy, jmm,  jdd,  jhh
   Logical ::  missing params
                                                               120

-------
         !  Skip 25th hour
         If (Modulo(iv,25) == 0) Then
            Cycle
         End If

         !  Skip non-missing Dew points
         If (Xparam(f_DPT)%Samson_vlO(iv)%s /= T_Missing)  Cycle

         !  The estimation is a function of air temperature and Relative  Humidity.
         missing params = &
               (Xparam(f_DBT)%Samson_vlO(iv)%s == T_Missing)  .Or.  &
               (Xparam(f_RH)%Samson_vlO(iv)%s == T_Missing)
         !  If missing parameters, skip this point
         If (missing params) Cycle

         !  If Relative Humidity == 0, then the Dew point  is  undefined.
         If (Xparam(f_RH)%Samson_vlO(iv)%v > EpsO) Then
            Xparam(f_DPT)%Samson_vlO(iv)%v = DewPointF( &
                  Ta=Xparam( f_DBT) %S arris on_vlO (iv) %v,  &
                  RH=Xparam(f_RH)%Samson_vlO(iv)%v)

            Xparam(f_DPT)%Samson_vlO(iv)%s = T_Estimated
            Xparam(f_DPT)%Samson_vlO(iv)%f =  ''
         Else
            !  Relative Humidity == 0: Dew point is undefined.
            Call iv to ymdh(iv, jyyyy, jmm, jdd, jhh)
            Write(ULog,  9130)  jyyyy, jmm, jdd, jhh
            Format(Ix, '?? Fill_Dew_Point: RH == 0 for  ',  14, 2(
            Xparam(f_DPT)%Samson_vlO(iv)%v = -Huge(Zero)
            Xparam(f_DPT)%Samson_vlO(iv)%s = T_Undefined
            Xparam(f_DPT)%Samson_vlO(iv)%f =  ''
         End If

      End Do
      Xok = .True.
   End Subroutine Fill_Dew_Point

End Module Process  Gaps
                                                                   121

-------
global
   Use Constants     !  F90Lib
   Use loSubs
   Implicit None

   !  Errors and debug variables
   Logical, Save
   Logical, Save
   Integer, Save
   Integer, Save
   Integer, Save
Errors_Detected = .FalE
Global_Debug = .False.
ULog = 0
Umetadata = 0
Umath = 0
   !  Location of files
   Character(MaxNamLen) ,
   Character(MaxNamLen),  Save
   Character(MaxNamLen),  Save
   Character(MaxNamLen),  Save
   Character(MaxNamLen),  Save
   Character(MaxNamLen)
   Character(MaxNamLen)
             R0_full = ''
             Raw Data dir
!  Changes  by station
   !  1-24: hourly values
   !    25: daily averages
   Integer, Parameter :: Nhours = 25
                                                                  122

-------
!  Use EpsO for fuzzy comparisons.
  The initial precision of SAMSON and Earthlnfo data is
  typically le-2, i.e., if the difference of two numbers A and
  is less that le-2, for all intents and purposes the numbers
  are equal. We were getting differences on the order
  of le-16 to le-18. If B = A +- le-16, then the numbers are
  clearly equal and the difference is due to numeric flutter.

  The value for EpsO below was chosen after examination of the
  behaviour of different sections of code of make rO.
  See,  
  among others.
                     Test:
                     Abs(A-B) < EpsO
                     Abs(A-B) >= EpsO
                     Abs(A-B) < EpsO  .Or.  EpsO <  (A-B)
Real, Parameter
!  Because of roundoff errors and the initial precision
!  of the precipitation data, differences less than 0.02 cm
!  are not significant (0.01 inch == 0.0254 cm).
Real, Parameter :: ppt_Eps = 0.02

!  All legal values are non-negative.
Integer, Parameter ::  Missing_Data = 999999
Real,    Parameter ::  Zero =0.0
Real,    Parameter ::  One =1.0

IReal, Parameter  ::  Pi = 3.141592653589793238462643383279502884197
Real,    Parameter ::  Degrees_to_Radians = Pi / 180.0
Real,    Parameter ::  Radians_to_Degrees = 180.0 / Pi
Real,    Parameter ::  Two Pi = 2.0 * Pi
                                                               123

-------
!  A value outside the index range of both arrays Samson vlO and  Samson vll.
Integer, Parameter :: Tbogus = -Huge(0)
!  Watt hour = 3.6e-3 MJoule
Real, Parameter :: Watt hour
!  Watt hour m~-2 = 8.59845E-02 Langley
Real, Parameter :: Watt_hour_per_m2	to	Langley = 8.J

!  1 millibar = 0.10000 kilopascal
Real, Parameter :: millibar  to  kilopascal = 0.10000
Integer,
Integer,
Integer,
Integer,
Integer,
! field
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Parameter
Parameter
Parameter
Parameter
Parameter
ids
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
                      f_EHR = 1
                      f_EDNR = 2
                      f_GHR
                      f_DNR
                      f_DHR
                      f_TSC
                      f_OSC
                      f_DBT
                      f_DPT
                      f_RH
                      f_SP
                      f_WD
                      f_WS
                      f HV
= 8
  10
  11
  12
  13
  14
!  Extraterrestrial Horizontal Radiation
!  Extraterrestrial Direct Normal Radiation
!  Global  Horizontal Radiation
!  Direct  Normal  Radiation
!  Diffuse Horizontal Radiation
!  Total  Sky Cover
!  Opaque  Sky Cover
!  Dry Bulb Temperature
!  Dew Point Temperature
!  Relative Humidity
!  Station Pressure
!  Wind Direction
!  Wind Speed
!  Horizontal Visibility
                                                               124

-------
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
! Integer,
! 19 Apr
I
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Integer,
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
2002 11:41
g * vs d *
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter












































f CH = 15 ! Ceiling Height
f pH2O = 16 ! Precipitable Water
f baod = 17 ! Broadband Aerosol Optical Depth
f SD = 18 ! Snow Depth
f DSLS = 19 ! Days since last Snowfall
f HP = 20 ! Hourly Precipitation (value + flags)
f OI = 21 ! Observation Indicator / Present Weather
f SAMSON =22-1 ! Last SAMSON parameter.
f FAO SG PET = 22 ! FAO Short Grass PET, mm/day
f Ep = 23 ! Class A pan Evaporation, mm/day
f KP FWS Evaporation = 24 ! K-P FWS Evaporation, mm/day
f end =25-1 ! Last daily parameter.
f Dry Bulb Temperature = f DBT
f Hourly Precipitation = f HP
f Observation Indicator = f OI
f Opague Sky Cover = f OSC
f PW = f OI ! Present Weather
f Ra = f EHR ! FAO name
f Rdiff = f DHR ! name used in Dr Burns' manuscript
f Relative Humidity = f RH
f Rs = f GHR ! FAO name
f Station Pressure = f SP
f Wind Direction = f WD
f Wind Speed = f WS
: f Pan Evaporation = f KP FWS Evaporation
am : : I cannot remember why I selected
for the names .
g Precipitation = 1
g Pan Evaporation = 2
g Temperature mean = 3
g Wind Speed = 4
g Solar Radiation = 5
g FAO Short Grass = 6
g Daylight Station Pressure = 7
g Daylight Relative Humidity = 8
g Daylight Opague Sky Cover = 9
g Daylight Temperature = 10
g Daylight Broadband Aerosol = 11
g Daylight Mean Wind Speed = 12
d Daylight max wind speed = 13
d Daylight direction of max wind speed = 14
d PWS = 15 ! Daylight Prevailing Wind Speed
d PWD = 16 ! Daylight Prevailing Wind Direction
g end = 17-1 ! Last MET parameter.
125

-------
   Type  ::  Coords
      Character(Len=l)  ::  Letter = ''
      Integer :: degrees  = 0
      Integer :: minutes  = 0
   End Type Coords

   !  @ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @ =
   Type  ::  Samson_Header
                           WBAN = ''   !  94018
                           Text = ''   !  Boulder, CO
                           Lat        !  N 40 1
      Type(Coords)
      Real
      Integer
   End Type  Samson  Header
                        Lon
                        Elev
                        TZ
                                                                          ===@@@
      Integer ::  Expected_Ndays =
      Type(Samson_Header)  ::  Head
!!!!!!Type(Errors_type),  Pointer
!!!!!!Type(Errors_type),  Pointer
                                  0
                                 pHead => Null()
                                 pTail => Null()
   Integer, Dimension(:,:), Pointer :: Every_Hour_Present => Null(
   Logical ::  Check_Header_Info = .False.
End Type Filelnfo
   Type  ::  Fieldlnfo_type
      Character(Len=80)  ::  Name = ''

      !  The day has to have at least  Minimum_obs_per_day,
      !  otherwise the  missing count will be increased.
      Integer ::  Minimum obs per day  = 0
      Real  ::  minimum  value = Zero
   End Type  Fieldlnfo_type

   !!Type(Fieldlnfo_type), Dimension(0:f_SAMSON),  Target,  Save :: Fieldlnfo
   Type(Fieldlnfo_type),  Dimension(0:f_end),  Target,  Save  ::  Fieldlnfo
   Type(Fieldlnfo_type),  Dimension(0:g_end),  Target,  Save  ::  MET_field

   !  @@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@==
   Type :: Year type
      Integer ::  SAMSON_vlO = 0
      Integer ::  SAMSON_vll = 0
   End Type  Year_type
                                                                  126

-------
@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @
See  
Data source values used in the rO files.

See 

19 Feb 2002  3:03 pm
* Leave as missing: Hourly Wind Speed, Hourly Wind Direction, Snow Depth,
       Days since last snowfall.
* Daily Wind Speed -- fill with the monthly mean.
                      13 Mar 2002  3:44 pm: Not anymore. Use Fill_Gap  algorithms.
* Dew Point -- estimate using 
^ GapLength = 49 hours included in the range of "Medium Gaps".

T_Missing -- value missing
T Not Applicable — value was cleared. Do not count as missing, *but*  print  as  a
           regular missing value, e.g., '	'. Used, for example:
           * 25-th hour wind direction. There is no daily value for WD.
           * 25-th hour Present_weather and indicators. Ditto above.
           * Broadband Aerosol Optical Depth  (Wed Dec 12 14:48:31 2001)
             BAOD is measured only during daylight.
T_Undefined -- Value is undefined, given the context;
               e.g.,  Dew point is undefined if RH == 0.
T Perpetual Darkness — Region is under complete darkness for some period
                        of the year.  (Rs,  Ra)  == 0 for that period, which
                        prevents the computation of Eto and Ep.
T_Accumulation -- resolution of an accumulation flag (Hourly precipitation)

                                        Unset
                                        used by SAMSON; Accumulation
                                        used by SAMSON; Calibrated
                                        used by SAMSON
                                        used by SAMSON; Deleted
                                        used by SAMSON; Estimated
                                        used by SAMSON
                                        used by SAMSON
                                        used by SAMSON
Perpetual Darkness
       Missing

       Average
                                                             127

-------
                                          Cirroform
                                                                         DEL:
Character ( Len=l ) ,
Character ( Len=l ) ,
Character (Len=l ) ,
Character (Len=l ) ,
Character ( Len=l ) ,
Character ( Len=l ) ,
Character (Len=l ) ,
Character (Len=l ) ,
Character ( Len=l ) ,
Character ( Len=l ) ,
Character (Len=l ) ,
Character (Len=l ) ,
Character ( Len=l ) ,
Character ( Len=l ) ,
Character (Len=l ) ,
Character (Len=l ) ,
Character ( Len=l ) ,
Character ( Len=l ) ,
Character (Len=l ) ,
Character (Len=l ) ,
Character ( Len=l ) ,
Character (Len=l ) ,
Character (Len=l ) ,
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter























T Unset = '@
T Measured = 'W
T Calibrated = 'B
T Deleted = 'D
T Estimated = 'E
T Observed = T 1
T Small Gap = T
T Medium Gap = T
T Large Gap = T
T Missing = ' -
T Earthlnfo = 'R
T SAMSONvlO = 'S
T SAMSONvll = 'T
T Unlimited = 'U
T SGU = T
T SGC = T
T Cirroform = 'Z
T Undefined = '?
T Perpetual Darkn
T Accumulation =
T Average = '/
T Cumulative = '+
T Not Applicable
                                                    Estimated
                                                Measured     ! Observed
                                                Estimated    ! 
                                                Estimated    ! 
                                                Estimated    ! 
                                                   ! Missing data
                                                   ! Earthlnfo data
                                                   ! SAMSON version 1.0  files
                                                   ! SAMSON version 1.1  files
                                                   ! Unlimited in Visibility  & Ceiling  Height
                                              T_Unlimited  ! Short-gap interpolation with  Unlimited
                                              T_Estimated  ! Short-gap interpolation with  Cirroform
                                                   ! Cirroform in Ceiling Height data
                                                   ! Undefined
                                                   s =  '#'
Type ::  Val_and_Flag
        - Data_Source 
            T_EarthInfo, T_SAMSONvlO, T_SAMSONvll,
            T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness,
            T_Estimated,
            T_Unlimited, T_Cirroform,
            T_Small_Gap (T_SGU, T_SGC), T_Medium_Gap, T_Large_Gap
            T Unset
   !  %f
- real number value

- flag associated with the value
                                                               128

-------
   !         %f(1:2):  GHR, DNR, DHR
   !         %f(l:9):  Present_weather  (f_OI)
   !         %f(l:l):  (ADME ) Hourly_Precipitation_Flag  (f_HP)
   !                  T_Accumulation,
   !                  Earthlnfo precipitation flags

   Character(Len=l)
   Real : :  v
   Character(Len=9)                                       _
End Type Val_and_Flag

!  @@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@
Type :: Parameter_Type
   !  Store data in a vector array so that we can find gaps easier.
   !  Assume a virtual array: vData(ndays, Nhours)
   !      Ndays = 365 or 366 == WFilelnfo%Expected_Ndays
   I
   !    Ndays|   1     2  3  4  ...     24     25    Nhours = 25
   i    	+	
   !      1
   !  nbase = Hours_since_JdO(yyyy)
   !  iv = (doy-1)*Nhours + hh + nbase
   !  Xparam(f_Ra)%Samson_vlO(iv)%v = EHR
   Type(Val_and_Flag),  Dimension(:), Pointer  :
   Type(Val_and_Flag),  Dimension!:), Pointer  :
End Type Parameter_Type

!  @ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @
!  Suite of files associated with one WBAN year.
Type  ::  Name_type
   Character(MaxNamLen)  ::  Samson vlO = ''
   Character(MaxNamLen)  ::  Samson vll = ''
End Type Name_type

!  @ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @
!  Store error messages.
Type  ::  Errors_type
   Type(Errors_type) , Pointer :: pNext  => Null()
   Character(Len=132) :: Error Text = ''
                                                               129

-------
End Type Errors_type

!  @@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@
!  Elevation measured in millimeters.
Type ::  ElevationBlock
   Integer ::  Julian Day = 0
   Real  :: Elevation meter = 0.0
End Type ElevationBlock

!  @ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @
!  See Initialize_Node Read_SAMSON_Station_Notes for initialization
!  * 
Type ::  Site_Info
   Integer ::  item = 0  !  Unused. Remnant of Red Black derived type.
   Logical ::  Color     !  Unused. Remnant. Which can assume RED or BLACK.
   Type(Site_Info), Pointer ::  Parent => Null()     !  Pointer to the parent.
   Type(Site_Info), Pointer ::  pLeft  => Null()     !  Pointer to the left child.
   Type(Site Info), Pointer ::  pRight => Null()     !  Pointer to the right child.
                                                           Head of linked list
                                                           Tail of linked list
   Type(ElevationBlock), Dimension(7) :: Elev Directives
   Integer ::  Nelev = 0
End Type  Site_Info

!  @ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @
Type ::  Stat_Block
   Character(Len=80)  ::  Header = ''
   Integer ::  k = 0
   Real    ::  M_k = Zero
   Real    ::  Q_k = Zero
   Real    ::  xmin = +Huge(Zero)
   Real    ::  xmax = -Huge(Zero)
                                                               130

-------
   Real    :: xMean = -Huge(Zero)
   Real    :: xVariance = -Huge(Zero)
End Type Stat_Block
!  @@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@===@@@
Type ::  Year_Stats
   Integer ::  k = 0
   Real     ::  Total = Zero
End Type Year_Stats

!  @ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @
Type ::  Accum_type
   Integer ::  ibeg = 0
   Integer ::  lend = 0
   Real     ::  Total = Zero
End Type Accum_type

!  @ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @===@ @ @
!  Other  variables.
Real,     Save :: Maximum_Horizontal_Visibility = Zero
Real,     Save :: Maximum_Ceiling_Height = Zero
Integer, Save :: Maximum Text Length = 0

!  * 
Type(Stat_Block),     Dimension(0:f_end), Save :: Xp_ranges
Type(Parameter Type), Dimension(0:f end), Save :: Xparam
Type(Year type),  Dimension(MinYear:MaxYear), Save :: Year Data
Type(Name_type),  Dimension(MinYear:MaxYear), Save :: Year_Names
Type(Site_Info),  Pointer, Save :: pWBAN => Null()

!  Observed data of various sorts, of various dimensions
!  Obs_ppt -- ol	' 	j_j4-_4-j.
Type(Val and Flag),  Dimension(:), Pointer, Save  :: Obs ppt
Logical, Save :: Have ppt Obs daily data = .False.
Logical, Save :: Have_ppt_Obs_hourly_data =  .False.
Type(Accum_type), Dimension(:), Pointer, Save  :: Accum_Samson =5
Type(Accum type), Dimension(:), Pointer, Save  :: Accum El =^
!  
Character(MaxNamLen),  Dimension(MinYear:MaxYear)
                        name met =  ' '
                        name txt =  ''
                        name_Daily_Evap =  ''
                        name_Daily_ppt =  ''
                        name Hourly ppt =  ''
Character(MaxNamLen)
Character(MaxNamLen)
Character(MaxNamLen)
Character(MaxNamLen)
Character(MaxNamLen)
                                                               131

-------
   Logical,  Dimension(MinYear:MaxYear), Save  :: Issue This Year =  .True.

   !  Format  of the Daily values file (dvf) and
   !  Hourly  values file (hvf).
   Character(300) , Save :: FMT_dvf = '()'
   Character(500) , Save :: FMTJnvf = '()'

   !  We want to analyze SAMSON(Hourly), Earthlnfo(Hourly), and Earthlnfo(daily)
   Type(Year_Stats),  Dimension(MinYear:MaxYear, 1:13), Save  :: ppt_SH,  ppt_EIH,  ppt_EID
   Subroutine ToTTy(TheMessage)

      Implicit None
      Character(Len=^), Intent(In) :: TheMessage
      Character(Len=08) ::  xdate = '' !  yyyymmdd
      Call Date_and_time(Date = xdate, Time = xtime)

      !  E.g,  'Executing InitialSetUp  at 13:29:00.216'
      IWrite  (ULog, 0010)  '## '//Trim(TheMessage), xtime(l:2), xtime(3:4),  xtime(5:10)
      Write (6,  9130)  Trim(TheMessage), xtime(l:2), xtime(3:4), xtime(5:10)
      IWrite  (ULog, 0010)  Trim(TheMessage), xtime(l:2), xtime(3:4), xtime(5:10)
9130  Format(lx,  a, '   at ', 3(a, :,  ':'))
      Call FLushAll()

   End Subroutine ToTTy
      Implicit None
      Real,  Intent(In) ::  x
      Logical          ::  IsNaN

      IsNaN = (x /= x)
   End Function IsNaN
                                                                   132

-------
   Subroutine FLushAll()

      Implicit None

      Call FLush(6)
      Call FLush(ULog)
      Call Flush LUNs()
      Implicit None
      Character(Len=*), Intent(In)
      Integer
      Call IOWrite(uu, Vfile, Ok=Ok)
      If  (.Not. Ok) Then
         uu = 6
      End If
   End Function IOF

End Module Global Variables
                                                                   133

-------
LinkedList

!      Last change:  LSR  16 May 2002    3:19 pm

Module Linked List

   !Use Floating Point Comparisons
   !Use loSubs
   !Use Module_Config
   !Use mXgetargs
   Use Date_Module
   Use FileStuff
   Use Global_Variables
   Use Strings
   !  Store info in a binary tree since we want sorted output.

   !  []  Cooper Redwine. 1995. Upgrading to Fortran 90.
   !     Springer Verlag; ISBN: 0387979956; pages 333-343.

   Interface Add Error
      Module Procedure Append_Text_to_Listl
      Module Procedure Append_List2_to_Listl
   End Interface
   Subroutine Save_and_Output(pHead, pTail, Tbuf, Jout)

      Implicit None
      Type(Errors_type), Optional, Pointer    :: pHead
      Type(Errors_type), Optional, Pointer    :: pTail
      Character(Len=*),            Intent(In) :: Tbuf
      Integer,           Optional, Intent(In) :: Jout

      Integer ::  k

      k = Len_trim(Tbuf)

      If  (Present(pHead) .And. Present(pTail)) Then
         Call Add_Error(pHead, pTail, Tbuf(l:k))
      End If

      If  (Present(Jout)) Then
         Write (Jout,  '(lx, a)')  Tbuf(l:k)
      End If
                                                                  134

-------
End Subroutine Save and Output


Subroutine Append_Text_to_Listl(plHead, plTail, Etext, qdebug)

   !  Add an item (Etext) to a linked list  (pi*)

   Implicit None
   Type(Errors_type),     Pointer :: plHead
   Type(Errors_type),     Pointer :: plTail
   Character(Len=*),  Intent(In) :: Etext
   Logical, Optional,  Intent(In) :: qdebug

   Logical ::  tdebug
   Type(Errors type),  Pointer :: pprev

   If (Present(qdebug))  Then
      tdebug = qdebug
   Else
      tdebug = .False.
   End If

   If (tdebug) Then
      Call Prev_Node(pprev, plHead, plTail)
   End If

   !                              pTail —+
   I
   !                                      v
   !  pHead —> Node_l  +—> Node_2  +—> Node_3
   !            Data_l   |    Data_2  |     Data_3
   !            pNext --+    pNext --+    pNext --> disassociated

   !  Test whether the queue is currently empty (or not).
   If (.Not.  Associated(plHead)) Then
      !  Queue is empty:  Create storage for the node; plHead points to it
      Allocate(plHead)
      plTail => plHead  ! Point to the only node.
   Else
      !  Queue is not empty: Create storage for new last node  and point to  it.
      Allocate(plTail%pNext)
      plTail => plTail%pNext
   End If

   plTail%Error_Text = Etext    ! Store data
   plTail%pNext => Null()        ! Last node in the queue.

   If (tdebug) Then
      Call Prev_Node(pprev, plHead, plTail)
   End If
                                                               135

-------
End Subroutine Append Text to Listl
Subroutine Append_List2_to_Listl(plHead, plTail, &
      p2Head, p2Tail, qdebug)
                                                              (pi*
   Implicit None
   Type(Errors_type) ,     Pointer :: plHead
   Type(Errors_type),     Pointer :: plTail
   Type(Errors_type) ,     Pointer :: p2Head
   Type(Errors_type),     Pointer :: p2Tail
   Logical, Optional,  Intent(In) :: qdebug

   Logical ::  tdebug
   Type(Errors type),  Pointer :: pprev

   If (Present(qdebug))  Then
      tdebug = qdebug
   Else
      tdebug = .False.
   End If

   If (tdebug) Then
      Call Prev_Node(pprev, plHead, plTail)
   End If
   !  Short version. In the initial version I did not check if the
   !  lists were non-null. The bug was very difficult to find because
   !  it was not clear where the problem was located  (it looked as an
   !  event triggered by a missing file).  The bug showed its ugly
   !  little head in other parts of the program. It has taken
   !  9 hours to locate this bug.
   !                              pTail —+
   I
   !                                      v
   !  pHead —> Node_l  +—> Node_2  +—> Node_3
   !            Data_l  |     Data_2  |     Data_3
   !            pNext --+    pNext --+    pNext --> disassociated

   If (Associated(p2Head))  Then
                                                               136

-------
      If (Associated(plHead))  Then
         !  Both lists are non-null. Append p2 to the end of pi
         plTail%pNext => p2Head
         plTail => p2Tail
      Else
         !  pi is empty; Just transfer list p2 to pi
         plHead => p2Head
         plTail => p2Tail
      End If
   Else
      !  p2 is a null-list so there is nothing to append.
      !  pi remains unchanged.  There is nothing to do.
   End If

   If (tdebug) Then
      Call Prev_Node(pprev, plHead, plTail)
   End If
End Subroutine Append List2 to Listl
Function Number Of Links(pHead) Result(NLinks)

   !  Determine the number of links in the list
   Implicit None
   Type(Errors_type),  Pointer  :: pHead
   Integer                     :: NLinks

   Type(Errors_type),  Pointer  :: ptmp

   !  temp node points  to the first node of the queue
   ptmp => pHead

   NLinks = 0
   Do While (Associated(ptmp))
      NLinks = NLinks  + 1
      ptmp => ptmp%pNext  !  Point to next node
   End Do
End Function Number Of Links
Subroutine Prev_Node(pPrev, pHead, pTail, QMessage)

   !  Find the node before the pTail node.
   !  If Qmessage is present, a sanity check will be
   !      performed. This subroutine will abort
   !      if the test fails.

   Implicit None
   Type(Errors_type),            Pointer    :: pPrev
                                                               137

-------
   Type(Errors_type),  Pointer :: ptmp
   Logical ::  pOK

   If (Associated(pHead))  Then
      !  previous pointer has meaning only if pHead is associated.
      ptmp => pHead
      pPrev => ptmp

      Do While  (Associated(ptmp))
         pPrev => ptmp
         ptmp => ptmp%pNext  !   Point to next node
      End Do
      If (Present(Qmessage))  Then
         !  pTail and pPrev must point to the same place.
         pOK = Associated(pTail, pPrev)
         If (.Not.  pOK) Then
            Write(ULog, 9130) Trim(Qmessage)
            Write(6,    9130) Trim(Qmessage)
            Format(Ix, '?? Prev_Node: pTail /= pPrev at:  ',  a)
            Stop '?? pTail /= pPrev1
         End If
      End If
   Else
      pPrev => Null()
   End If
End Subroutine Prev Node
Subroutine Release_Storage(pHead, pTail)

   !  Release list storage.
                                 pHead     ! Intent(InOut)
                                 pTail
                                 current_item, previous_item
Implicit None
Type(Errors type), Pointer :
Type(Errors_type), Pointer :
Type(Errors_type) , Pointer :

previous item => pHead
current_item => pHead%pNext
   If (Associated(pHead))  Then
      Loop Thru Buckets: Do
         If (.Not.  Associated(current_item)) Exit Loop_Thru_Buckets

         !  Delete "current item" bucket. The new "current item" will
                                                                138

-------
            !  be the bucket following the deleted bucket.
            previous item%pNext => current item%pNext
            Deallocate!current_itern)
            current_item => previous_item%pNext

         End Do Loop_Thru_Buckets
      End If
      Nullify(pHead)
      Nullify(pTail)
   End Subroutine Release_Storage
End Module Linked List
                                                                  139

-------
Make RO
                    LSR
     References:
     [1]  (Short name: FAO)
         Crop evapotranspiration - Guidelines for computing crop water
         requirements - FAO Irrigation and drainage paper 56 by Richard G.
         Allen, Luis S. Pereira, Dirk Raes, and Martin Smith. Water Resources,
         Development and Management Service, FAO - Food and Agriculture
         Organization of the United Nations, Rome, 1998, ISBN 92-5-104219-5.
         The book can be found online at
            http://www.fao.org/docrep/X049OE/xO49OeOO.htm#Contents
         or locally at
            Docs\fao\index.html
   Use Date_Module
   Use F2kCLI
   Use Global Variables
   Use Process_Raw_Data
   Use Setup

   Implicit None
   Character(Len=80) :: xexe =  ''
   Character(Len=80) :: ybegin_date, yend_date, gOtmp
   Integer :: nargs    ! Number of arguments in the command line
   Integer :: nn
   Call CPU_Time(time_beg)
   ybegin date = Unix Date()

   Errors_Detected = .False.
   Call Get Command Argument(0, xexe)   ! Get application name.

   !  Decode/Process command line arguments.
   nargs = Command_Argument_Count()
   If  (.False.)  Then
                                                                  140

-------
      If (nargs /= 1)  Then
         !  Remove possible path.
         nn = 1 + Index(xexe, DirDelim, Back=.True.)
         Write (6, "(3a)") '  Syntax:  ', Trim(xexe(nn:)),  &
               1  config_file_name'
         Errors Detected = .True.
         Go To 9999
      End If
   End If

   !  ULog is set  first to "6" (the console) to write  errors
   !  detected during input, then attached to a file to  write
   !  errors detected during the processing of the files.
   ULog = 6

!!!    Call  Get_Command_Argument(1,  Config_file_name)  !  e.g., mkmet.in
!!!    If (Len_Trim(Config_file_name) == 0) Then
!!!       Config_file_name =  'MkMET.in'
!!!    End If
9999 Continue
   Write (6,  '(/lx,3a)') '### Check "', Trim(Log_flie),  '"  for messages.
   If (Errors_Detected) Then
      Write (6,  '(/lx,a)')  '?? Errors detected.'
   Else
      Write (6,  '(/lx,a)')  'Program completed successfully.'
   End If

   yend_date  = Unix_Date()
   Call CPU_Time(time_end)

   Call Elapsed Time(time end-time beg, gOtmp)
   Write (ULog,  '(///,a)') Repeat!'	', 20)
   Write (ULog,  '(lx,a,a)') '## Started  on  ....:  ', Trim(ybegin_date)
   Write (ULog,  '(Ix,a,a)') '## Finished on  ....:  ', Trim(yend date)
   Write (ULog,  '(lx,a,a)') '## Elapsed cpu  time:  ', Trim(gOtmp)
                                                                   141

-------
Precip
      Last change:  LSR   4 Jun 2002   10:51 am
Module Precipitation module
   Use Date_Module
   Use Global_Variables
   Use Reallocate_Module
   Use UtilsO
   Use Utilsl
   Use Utils4
   Use Utils5
   !Use Floating Point Comparisons
   Implicit None
   Private
   Public
   Public
   Public
   Public
   Public
   Public
   Public
   Public
   Public
Print_HP
Process Precipitation
Process_Precip_Records
Read_Daily_ppt
Read Hourly ppt
Reconcile HP samson earthinfo
Standardize_ppt
Test_Accumulation
Yearly_Precip_Stats
Character (Len=* ) ,
Character (Len=* ) ,
Character (Len=* ) ,
Character (Len=* ) ,
Character (Len=* ) ,
Character (Len=* ) ,
Character (Len=* ) ,
Character (Len=* ) ,
Character (Len=* ) ,
Character (Len=* ) ,
Character (Len=* ) ,
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
Parameter
                                  Q_PW_Missing =  'm'
                                  Q_PW_No_Rain =  'n'
                                  Q_PW_Yes_Rain =  'r
                                  Q_Perhaps_Rain =  ' :
                                  X_Zero =  'z'
                                  X_Missing =  'm'
                                  X Accum = 'a'
                                  X_Delete =  'd'

                                  Flag_Continue =  'c
                                  Flag Done =  'y'
                                  Flag Error =  'e1
   Integer, Save ::  dimV = 0
   Real, Dimension!:), Pointer, Save  :: Vmin=>Null(), Vmax=>Null(), Vval=>Null()
   Character(Len=l), Dimension(:), Pointer, Save  ::  Vpw=>Null()
   Logical,          Dimension(:), Pointer, Save  ::  &
         Vmissing_hours=>Null(), Vzero_ppt=>Null(),  vSelect=>Null(),  &
                                                                  142

-------
   Type(Val_and_Flag), Dimension!:),  Pointer  ::  HP   =>  Null
   Type(Val_and_Flag), Dimension!:),  Pointer  ::  OI   =>  Null
   Type(Val_and_Flag), Dimension!:),  Pointer  ::  OSC  =>  Null

   !  Global debugging variables.
   Logical, Save :: print_now =  .False.

Contains
      Implicit None
      Logical, Intent(Out)  :: Xok

      Xok = .True.
      If (Xok) Then
         Write(6,     9130)
         Write(ULog,  9130)
         Format  (Ix,  '## No accumulation test procedure.1)
      Else
         Write(6,     9130)
         Write(ULog,  9130)
      End If
      Implicit None
      Logical, Intent(Out)  :: Okay
                                                                   143

-------
! ! ! 123456789 <-- column number
! ! ! ! Some comment
i i i
i i i
! ! ! Station FARGO WSO AP
! ! ! PO Code ND
! ! ! Stn ID 2859
! ! ! County CASS
! ! !
! ! ! 1963 Jan Feb Mar
III 1
I'' 2
I'' 3
III A
III c
ill g 	 	 	
ill 7 	 	 	
III g 	 	 	
III g 	 	 	
Ml 10 	 	 	
I'' 1 ?
Ml 13 	 	 	
III 14 	 	 	
DAILY

Parameter
Latitude
Longitude
Elevation
Apr May Jun J

9



3 10 	
6 15 	
2 12 	
2 10 	
3 12 	
4 5 	
	 6 	
4 	 	
5 4 	


Evap
N46:55:31
W096: 48:40
900
"ul Aug Sep
g 	 	
p
o 	 	

	 	
	 	
7 	 	
8 	 	
9 	 	
7 	 	
4 	 	
7 	 	
3 	 	






Oct





6
4
3
3
4
3
4
6
7
5


% Coverage 42
Begin M/Yr 04/1963
End M/Yr 09/1980
# Record Years 18
Nov Dec Annual





	 	
	 	
	 	
	 	
	 	
	 	
	 	
	 	
!!!  Total     	
!!!  Extrm     	
!!!  ~L (sometimes)
218
 15
      !  Ignore blank lines,  lines with II/XL", lines with a leading " ! "
      Character(Len=*),                Parameter ::
      Character(Len(T_EarthInfo)),     Parameter ::
      Real,                            Parameter ::              	
      !  The  array Obs ppt has already been initial!zed to T Unset.

      Character(Len=100)  ::  xbuf
      Character(Len=50)   ::  xid,  yflag
      Integer ::  ios, nl, n2, jj,  fO, fl, uin, jerr, ierror
      Integer ::  npos,  beg col, end col, kk, ip
      Integer ::  yyyy,  mm,  dd,  hh,  iv, nobs
      Logical ::  in_range,  file_was_open
      Real     ::  minV,  maxV, yobs,  y original
                                                                  144

-------
Integer, Parameter ::  Daily hour = 25
Integer, Dimension(:), Pointer  :: Days in Month

nobs = 0
ierror = 0
Okay = .False.
Have_ppt_Obs_daily_data = .False.

!  fO points to the character after the last DirDelim  of  name_Daily_ppt,  therefore
!  name Daily ppt(fO:)  contains  only the name of the input  file.  This  makes
!  messages more readable.
!  I changed my mind (24 Jan 2002  2:30 pm). In case of problems,
!  I do not want to hunt for the  file.
fO = 1   !  + Index(name_Daily_ppt, DirDelim, Back=.True.)
fl = Len trim(name Daily ppt)
Call IORead(uin, name Daily ppt, jerr, file was open)
If  (.Not. file_was_open) Then
   Write (ULog, *) '## Read_Daily_ppt: did not find  ',  name_Daily_ppt(f0:f1)
    ! Not finding the file is NOT an error. Just return.
   Go To 9999   ! Jump to End-of-Subroutine
Else
   Write (ULog, *) '## File: ', name_Daily_ppt(f0:f1)
End If
Read_One_Line: Do
   Read (uin, '(a)', iostat = ios) xbuf
   If (ios /= 0)  Exit  ! End-Of-File or Error
   !  Found the beginning of the data block.
   !  Find the name in the line, e.g.,  'Prep  (in)'
   !  nl   points to the first character of the name
   !  n2-l delimits the name. Note that the name  may  contain  blanks.

   nl = Verify(xbuf,  '- ')     ! Find first non  '-' or blank,  "P"  for  the  example.
   n2 = Index(xbuf(nl:),  '-')  !
   If  (n2 > 0) n2 = n2 + nl - 1 - 1
   xid = xbuf(nl:n2)           ! e.g.,  'Prep  (in)'
                                                             145

-------
                             !  xid(nl:n2)  == 'in'

  ! !  Make  sure  the  units are what we expect.
  !If (xid(nl:n2)  /= Zunits)  Then
  !  Make  sure  the  header is what we expect.
  If (Trim(xid)  /= Zheader) Then
     !  This  is a fatal  error.
     Write  (ULog,  *)  '?? Read_Daily_ppt:  Input file: ', name_Daily_ppt(f0:f1)
     Write  (ULog,  9130)  Zheader, Trim(xid)
     Format  (Ix,  '??  expecting "',  a,  '",  found "', a,  '"')
     ierror  =  ierror  +  1
     Go To  9999   !  Jump to End-of-Subroutine
  End If
 line  following "-
3     Jan     Feb
  Read  (uin,  '(a)',  iostat = ios)  xbuf
  If  (ios  /=  0)  Then
     Write (ULog,  *)  '?? Read_Daily_ppt:  Input file: ', name_Daily_ppt(f0:f1)
     Write (ULog,  ^)  '    Expecting a "year" line1
     ierror = ierror +  1
     Go  To 9999   !  Jump to End-of-Subroutine
  End If

  ! Get  year.
  Read  (xbuf(1:4),  '(14)', iostat  = ios)  yyyy
  If  (ios  /=  0)  Then
     Write (ULog,  *)  '?? Read_Daily_ppt:  Input file: ', name_Daily_ppt(f0:f1)
     Write (ULog,  *)  '    Line:  "', Trim(xbuf), '"'
     Write (ULog,  *)  '    The first four characters Do not represent a year.'
     ierror = ierror +  1
     Go  To 9999   !  Jump to End-of-Subroutine
  End If

  in_range =  (MinYear <= yyyy)  .And. (yyyy <= MaxYear)
  If  (.Not. in_range)  Then
     Write (ULog,  *)  '?? Read_Daily_ppt:  Input file: ', name_Daily_ppt(f0:f1)
     Write (ULog,  *)  '    The year  ', yyyy, '  is not between ', &
          MinYear,  '  and ', MaxYear
     ierror = ierror +  1
     Go  To 9999   !  Jump to End-of-Subroutine
  End If

  Days in  Month  => Number of Days  in Month(yyyy)
                                                           146

-------
     If  (ios /= 0) Then
        Write  (ULog, *)  '?? Read_Daily_ppt:  Input  file:  ',  name_Daily_ppt(f0:f1)
        Write  (ULog, *)  '   Error: Expecting month-day  ',  jj
        ierror = ierror + 1
        Go To  9999   ! Jump to End-of-Subroutine
     End If

     !  Get the day
     npos = 3
     Read (xbuf(1:npos),  '(13)') dd
     npos = npos + 1   !  Skip over the day of the  month.

     !  Sanity  check: jj must be egual to dd
     If  (jj  /= dd) Then
        Write  (ULog, *)  '?? Read_Daily_ppt:  Input  file:  ',  name_Daily_ppt(f0:f1)
        Write  (ULog, *)  '   Error: jj /= dd; jj, dd ==  ',  jj,  dd
        ierror = ierror + 1
        Go To  9999   ! Jump to End-of-Subroutine
     End If

        Jan    Feb    Mar    Apr
Next 12 numbers: January, February,  ..., December
Missing Data denoted With '	'
Trailing 'X' means extrapolated value
1OT'  - trace amount
Trailing 'A1 - Accumulated value. Treat as  "missing data".

     Month_Loop: Do mm =1, 12
        Call GetQwordCols(xbuf, npos,  beg_col,  end_col,  jerr)
        If  (jerr /= 0) Then
           Write (ULog, *) '?? Read_Daily_ppt:  Input  file:  ',  name_Daily_ppt(f0:f1)
           Write (ULog, *) '   Line:  "', Trim(xbuf),  '"'
           Write (ULog, *) '   contains less than  twelve  months,  mm ==  ',  mm
           ierror = ierror + 1
           Go To 9999  !  Jump  to End-of-Subroutine
        End If

        !  Is this a valid day  for the  month? Note  that  the  table
                                                            147

-------
!  has 31 entries for each month, regardless of the number
!  of days in the month.
!  Example:  1963-Feb has 28 days. If we call ymdh_to_iv
!  for 1963-Feb-29,  the iv returned is for 1963-March-Ol
!  (i.e., one day after 1963-Feb-28).  Ditto for 30-day months.
If (dd > Days_in_Month(mm))  Then
   !  Bogus  table filler date. Go to next month.
   Cycle Month_Loop
End If
If (xbuf(beg_col:end_col)  == '	') Then
   !  Missing data
   Obs_ppt(iv) = Val_and_Flag(T_Missing, Missing_Data,  ''
   Cycle Month_Loop
End If

kk = end_col
ip = Verify(xbuf(kk:kk), Set='0123456789')
!  ip > 0  Then  xbuf(kk:kk) is a non-digit.
If (ip == 0) Then
   yflag =  ''
Else
   yflag = xbuf(kk:kk)
   kk = kk - 1
End If

      Select Case (xbuf(kk:kk))
      Case  ('A')
         !  Accumulated value. Treat as missing Data.
         Cycle Month_Loop
           ( 'T' )
         !  Some of the precipitation Data is recorded as  'OT', i.e., trace.
         !  From http://airguality.tor.ec.gc.ca/natchem/precip/summary95.html  -
         !     # TRACE SAMPLING PERIODS: Number of trace sampling periods  in the
         !     summary period. A trace sampling period is defined as  a  sampling
         !     period when both the standard gauge and the collector  reported
         !     trace precipitation depths, i.e., less than the instrumental
         !     detection limits. These detection limits are 0.2 millimeters  (mm)
         !     for the standard gauge and 0.1 mm for the collector.
         !  We will replace 'OT' With half of the detection limit for the
         !  standard gauge, i.e., 0.2 mm/2 = 0.1 mm = 0.01 cm.
                                                   148

-------
      Case Default
         !  Do nothing.
         *** Undefined flag.
      End Select
   End If

Read(xbuf(beg_col:kk), *, iostat = ios) y_original
If (ios /= 0) Then
   Write (ULog, *)  '?? Read_Daily_ppt: Input  file:  ',  name_Daily_ppt(f0:f1)
   Write (ULog, *)  '    Line: "', Trim(xbuf),  &
         '", substr:  "', xbuf(beg_col:kk) ,  '"'
   Write (ULog,9150)  yyyy,mm,dd
   Format(Ix,  '   Not a number at  ',  14,  2('-',12.2))
   ierror = ierror + 1
   Go To 9999  !  Jump to End-of-Subroutine
End If

!!  Before converting to appropriate units,  make  sure
!!  this value is not a "flag" value.
!If (y original <= -8000) Then
!    !  some flag value.
!    Cycle Month_Loop
!End If

!  Convert input units to whatever
yobs = y_original * Zfac

!  value in range?
in range =  ((minV <= yobs)  .And.  (yobs <= maxV))
If (.Not. in_range) Then
   Write (ULog, *)  '?? Read_Daily_ppt: Input  file:  ',  name_Daily_ppt(f0:f1)
   Write (ULog, *)  &
         1    Value not in range, ignored  v,minV,maxV  :  ',  &
         yobs, minV,  maxV
   Cycle Month_Loop
End If
                                                    149

-------
         Case Default
            !  We have a previous value.
            If  ((Abs(Obs_ppt(iv)%v - yobs) <  EpsO)  .And.  &
                   (Obs_ppt(iv)%f == yflag)) Then
                ! Same value. Do nothing.
            Else
               Write  (ULog, *)  '?? Read_Daily_ppt:  duplicate  ',
                     yyyy, mm, dd, Daily  hour
               Write  (ULog, *)  '   Old:  ', Obs_ppt(iv)
               Write  (ULog, *)  '   New:  ', Zsource,  yobs, yflag
            End If
         End Select

      End Do Month_Loop
   End Do
End Do Read_One_Line

!  Finished reading the file. At this stage anything unset
!  will be declared missing. We will look  only the  25h  slot,
!  i.e., the daily values.
Do iv = 25, Ubound(Obs_ppt,1), NHours
   If  (Obs_ppt(iv)%s == TJJnset) Then
       ! At this stage "unset" implies  Zero precipitation.
      Obs ppt(iv) = Val and Flag(Zsource,  Zero,  '')
   Else If (Obs_ppt(iv)%s == Zsource) Then
      If (Abs(Obs_ppt(iv)%v - Missing_Data)  <  EpsO)  Then
         Call iv_to_ymdh(iv, yyyy, mm, dd, hh)
         Write  (ULog,  9170) '%s ok but missing %v:',  &
               iv, yyyy, mm, dd, hh,  &
               Obs_ppt(iv)%s, Obs_ppt(iv)%v, Trim(Obs_ppt(iv)%f)

         Format(lx, a,  ': Obs(', 10,  15,  2('-',i2.2),  13,  'h)  ==  ',  &
               a, Ix,  Ipgl4.6,  ' "',  a,  '"')
      End If
   End If
End Do

   !  Verify there are  no missing values
   Do iv = 25,  Ubound(Obs_ppt,1), NHours
      If (Obs_ppt(iv)%s /= Zsource) Then
         Call iv to ymdh(iv, jyyyy, jmm,  jdd,  jhh)
         Write  (ULog,  6130) iv, jyyyy, jmm,  jdd, jhh
         Format(Ix,  '?? Read_Daily_ppt:  ', &
                'Obs ppt(iv) is  missing  ',  17,  Ix,  &
                                                             150

-------
                     14, '-', 12.2, '-', 12.2, 13,  'h')
               Write (ULog, *) '    ',  Obs_ppt(iv)
            End If
         End Do
      !  All data was read. Close the file ...
9999  Continue
      If (file_was_open) Call lOClose(uin)
   End Subroutine Read_Daily_ppt
!!!  123456789 <-- column number
!!!  !Some comment
I I I
I I I
!!!  Station      JACKSON WSFO AIRPORT
! ! !  PO Code      MS                Latitude
!!!  Station ID   4472
!!!  County       RANKIN            Elevation
MI  	 Prcp  (in.)
I I I
!!!  01/01/1961  0100
!!!              0700
!!!              1300
!!!              1900
!!!  07/01/1963  0100
!!!              0700
!!!              1300
                                                                   151

-------
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
1900
0100
0700
1300
1900
0100
0700
1300
1900
0100
0700
1300
1900
0100
0700
1300
1900
0100
0700
1300
1900
0100
0700
1300
1900
0100
0700
1300
1900
0100
0700
1300
1900
	A
      !  Ignore all lines except lines of  form  above.
      !  '	': denotes missing Data

      Character(Len=^) ,             Parameter  ::  Zunits  =  'Prep (in.)1
      Character(Len(T Earthlnfo)), Parameter  ::  Z source = T  Earthlnfo
      Real,                         Parameter  ::  Zfac  =  inches	to	cm
      !  The  array Obs_ppt has already been  initialized  to T_Unset.
                                                                   152

-------
Character(Len=100)
Character(Len=50)
Character(Len=l)
Integer
Integer
Integer
Integer
Integer
Logical
           xbuf
           xid
           dl, d2, yflag
ios, nl, n2, jline, fO, fl, uin, ierror, nobs
npos, kk, kO, kl, kf, i	max
yyyy, mm, dd, hh, iv, iv base
j yyyy, jmm, jdd, j hh
id_hour, h_val, ierrors
ok, in_range, are_eg
file was open
year range, month range, day range
minV, maxV, yobs, y_original
Type ::  Track_Date
   Integer ::  last_iv = 0
   Character(Len(X_Zero))
End Type Track_Date
!  Days in Month Contains the days in the month  for pyear.
Integer
nobs = 0
Okay = . False.
ierrors = 0
Have_ppt_Obs_hourly_data = .False.

!  fO points to the Character after the last DirDelim of  name_Hourly_ppt ,  therefore
!  name Hourly ppt(fO: )  Contains Only the name of the input  file.  This  makes
!  messages more readable.
!  I changed my mind  (24 Jan 2002  2:30 pm) . In Case of problems,
!  I Do not want to hunt for the file.
fO = 1   !  + Index ( name_Hourly_ppt , DirDelim, Back=.True.)
fl = Len trim(name Hourly ppt )

Call ToTTy ( ' Read_Hourly_ppt :  File: ' //name_Hourly_ppt ( f 0 : f 1 ) )

Call IORead(uin, name Hourly ppt, ierror,  file was open)
If  (.Not. file_was_open) Then
   Write (ULog, *) '## Read_Hourly_ppt : did not find  ',  name_Hourly_ppt ( f 0 : f 1 )
    ! Not finding the file is NOT an error. Just Return.
                                                             153

-------
   Go To 9999  !  Jump to End-of-Subroutine
Else
   Write (ULog, *)  '## File:  ', name_Hourly_ppt(f0:f1)
   !    Call ToTTy('Read_Hourly_ppt: found  '//name_Hourly_ppt(f0:f1)
End If
iLev = 0    !  0:Max_BackTracks
pDate(iLev)%last_iv = 1
pDate(iLev)%last_action = X_Zero

Look for Date: Do
   Read (uin,  '(a)', iostat = ios) xbuf
   If (ios /= 0)  Exit !  End-Of-File or Error
   !  Skip lines With leading blanks.
   If (xbuf(1:1) ==  '  ') Cycle Look_for_Date

   !  If the line is a begin-of-Data-Block, verify  it  Contains
   !  the right units.
   i  	 Prep  (in.) 	
   If (xbuf (1:10) == '	') Then

      !  Found the beginning of the Data Block.
      !  Find the name in the line, e.g.,  'Prep  (in.)'
      !  nl   points to the first Character of the  name
      !  n2-l delimits the name. Note that  the name may  contain  blanks.

      nl = Verify(xbuf,  '- ')      ! Find first non  '-' or blank,  "P"  for the  example.
      n2 = Index(xbuf(nl:), '-')  !
      If (n2 > 0) n2 = n2 + nl - 1 - 1
      xid = xbuf(nl:n2)           ! e.g.,  'Prep  (in.)'

      !  Make sure the header is what we expect.
      If (Trim(xid) /= Zunits)  Then
         !  This is a fatal error.
         Write  (ULog, *) '?? Read_Hourly_ppt: Input file:  ', name_Hourly_ppt(f0:f1)
         Write  (ULog, 9130) Zunits, Trim(xid)
         Format  (Ix, '?? Expecting "', a,  '", found "', a,  '"')
         ierrors = ierrors + 1
         Go To 9999  !  Jump to End-of-Subroutine
                                                             154

-------
   End If
   Cycle Look for Date
End If

!  Try to decode a date.
!  Skip lines that Do not start With a valid date "mm/dd/yyyy"
!  1234567890 <- Columns
!  01/01/1961  ...
!  Update (If needed) the number of days in the month for the current  year.
If (pyear /= yyyy) Then
   pyear = yyyy
   Days_in_Month => Number_of_Days_in_Month(pyear)
End If

year_range = (MinYear <= yyyy) .And.  (yyyy <= MaxYear)
month_range = (1 <= mm) .And.  (mm <=  12)
If (month range) Then
   day range =  (1 <= dd)  .And. (dd <= Days in Month(mm))
Else
   day_range =  .False.
End If
If (.Not. ok) Then
   Write (ULog, *) '?? Read_Hourly_ppt: Input file:  ', name_Hourly_ppt(f0:f1)
   Write (ULog, *) '?? It looked like  a date: ', &
         xbuf(1:npos), yyyy, mm, dd
   Cycle Look for Date
End If
!  We have a date.
!  # [Isr]  5 Apr 2002 11:13 am
!    * careful with changes. I took two days  (and many  false
!      starts) to get this code.
I
!  Case 1:
!  Consider last iv == 24  (last hour set) and now we are
!  reading the next day: iv_base == 25. We should not call
!  Xupdate because the 25th hour is not going to be altered.
!  See records (4) and  (5) below.
                                                         155

-------
!  Case  3:
!   5  Apr  2002  11:01  am:  I thought that a solitaire T_Missing
!  was a bad omen of  problems but for Jackson,  MS,  when
!  records  were merged,  a single "missing" was  produced.
!  This  is  the  correct behaviour.
I
!  Note  that the records  below generate,  among  other things,
!  a solitare missing value at 1963-07-16 2h.
!  A solitaire  missing value is not part  of a  larger
!  'm' ..  'M' block.

                iv
                h=24     Date           Data
      1.   22776 22799 1963-07-01 'm'  	
      2.   23151 23174 1963-07-16 	  'M'
      3.   22776 22799 1963-07-01  Og
      4.   22851 22874 1963-07-04
                                     'M1
!  #0.  Initialize:
!         iLev = 0
!         pDate(iLev)  = (last iv=l,  last action=X zero)
I
!  #1.  Read record  (1): 1963-07-01 Ih :: iv = 22776;
!                                        iv_base = iv - 1
!      1.1 If (pDate(iLev)%last_iv < (ivjoase - 1))  Then
!             Apply:  pDate(iLev)%last action
!              from:  pDate(iLev)%last_iv
!              to..:  iv_base - 1
!          End If
!      1.2 Process  all 24  hours of current_date; iv = 22799
!      1.3 pDate(iLev=0)  =  (last_iv=(iv+2)122799+2,  last_action=X_missing)
!            iv is  a  date  at 24h
!            iv + 2  is next  day's date at Ih
I
!  #2.  Read record  (2): 1963-07-16 Ih :: iv = 23151
!      2.1 Ditto 1.1
!      2.2 Process  all 24  hours of current_date; iv = 23174
!      2.3 pDate(iLev=0)  =  (last_iv=23174+2, last_action=X_zero)
                                                         156

-------
!      3.2  Process all 24 hours of current_date; iv = 22799
!      3.3  If (iv < pDate(ILev)%last_iv)
!              22799 < 23176 — True
!          Then:  ILev = ILev +1 (  == 1)
!      3.4  pDate(iLev=l)  = (last_iv=22799+2,  last_action=X_zero)
I
!  #4.  Read record (4): 1963-07-04  Ih ::  iv = 22851
!      4.1  If (pDate(iLev)%last_iv < (iv_base - 1))
!              22801 < 22851-2 ? True.
!          Then apply Xupdate ...
!      4.2  Process all 24 hours of current_date; iv = 22874
!      4.3  If (iv < pDate(iLev)%last_iv)
!              22874 < 22876 ? —  False
!      4.4  pDate(iLev=l)  = (last_iv=22874+2,  last_action=X_missing)
!      4.5  Do
!            If iLev == 0 Exit
!            If (pDate(iLev-1)%last_iv <= pDate(iLev)%last_iv) Then
!               pDate(iLev-1) = pDate(iLev)
!               iLev = iLev - 1
!            Else
!               Exit
!            End  If
!          End Do
!          -- iLev unchanged.
I
!  #5.  Read record (5): 1963-07-05 Ih ::  iv = 22876
!      5.1  If (pDate(iLev)%last_iv < (ivjoase - 1))
!              22876 < 22876-2 ? False.
!      5.2  Process all 24 hours of current_date; iv = 22899
!      5.3  If (iv < pDate(iLev)%last_iv)
!              22899 < 22876 ? —  False
!      5.4  pDate(iLev=l)  = (last_iv=22899 + 2,  last_action=X_zero)
!      5.5  Do
!            If iLev == 0 Exit
!            If (pDate(iLev-1)%last_iv <= pDate(iLev)%last_iv) Then
!               pDate(iLev-1) = pDate(iLev)
!               iLev = iLev - 1
!            Else
!               Exit
!            End  If
!          End Do
I
!  #6.  Read record (6): 1963-07-16 Ih ::  iv = 23151
!      6.1  If (pDate(iLev)%last_iv < (ivjoase - 1))
!              22901 < 23151-2 ? True.
!          Then apply Xupdate ...
!      6.2  Process all 24 hours of current date; iv = 23174
!      6.3  If (iv < pDate(iLev)%last_iv)
!              23174 < 22901 ? —  False
!      6.4  pDate(iLev=l)  = (last_iv=23174+2,  last_action=X_zero)
                                                         157

-------
          Do
            If iLev == 0 Exit
            If (pDate(iLev-1)%last_iv <= pDate(iLev)%last_iv) Then
               !— 23176 <= 23176 ? True
               pDate(ILev-l)  = pDate(iLev)
               !-- pDate(O) =  (last_iv=23174+2, last_action=X_zero)
               iLev = iLev - 1
               !-- iLev = 0
            End If
          End Do
      Read record (7): 1963-07-16 Ih  :: iv = 23226
      7.1 If (pDate(iLev)%last_iv <  (ivjoase - 1))
              22901 < 23176-2 ? True.
          Then apply Xupdate ...
      7.2 Process all 24 hours of current_date; iv = 23249
      7.3 If (iv < pDate(iLev)%last_iv)
              23249 < 23176 ? — False
      7.4 pDate(iLev=0) =  (last_iv=23249 + 2, last_action=X_zero)
      7 . 5 Do
            If iLev == 0 Exit
            If (pDate(iLev-1)%last_iv <= pDate(iLev)%last_iv) Then
            Else
               Exit
            End If
          End Do
!  The rest of this line  (and the next 3 lines) compose an hourly  record.
Call ymdh to iv(yyyy, mm, dd, hh=l, iv=iv base)
iv base = iv base - 1
hh~= 0

If (pDate(iLev)%last_iv < (ivjoase - 1)) Then
   Call Xupdate(ifrom=pDate(iLev)%last iv, &
         ito=iv_base - 1, &
         The_action=pDate(iLev)%last_action, &
         Zsource=Zsource)
End If
   !  xbuf Contains the line to process.
   Read (xbuf(13:16),  '(14)', iostat = ios) id_hour
   If (ios /= 0) Then
      Write (ULog, *)  '?? Read_Hourly_ppt: Input file:  ', name_Hourly_ppt(f0:f1)
      Write (ULog, *)  '    Line: "', Trim(xbuf),  '",  "', xbuf(13:16),  '"'
      Write (ULog, *)  '    Expecting Id_hour 0100,  0700, 1300,  1900'
      Write (ULog, *)  '    Date =  ', yyyy, mm, dd
                                                         158

-------
   ierrors = ierrors + 1
   Go To 9999   ! Jump to End-of-Subroutine
End If

!           12345678
!  12345678901234567890123456789012345678901234567890123456789012345678901234567890
!  01/01/1961  0100      0 g       .
!              0700      11.           224
!  12345678901234567890123456789012345678901234567890123456789012345678901234567890
!           12345678
!  12345678901234567890123456789012345678901234567890123456789012345678901234567890
I
h_val = 100 *  ((jline-l)*6 +  1)
If (h_val /= id_hour) Then
   Write (ULog, *)  '?? Read_Hourly_ppt:  Input file:  ',  name_Hourly_ppt(f0:f1)
   Write (ULog, *)  '   Expecting  ',  h_val,  '  found ',  id_hour, &
         1; Date =  ', yyyy, mm, dd
   ierrors = ierrors + 1
   Go To 9999   ! Jump to End-of-Subroutine
End If

!  Get 6 values  from  the line
!  k = 1 . .  6
!  the kth number begins in column  (k+l)*10   :  20,  30,  40,  ...
!  the kth number ends   in column  (k+l)*10+3:  23,  33,  43,  ...
!  the kth flag   is     in column  (k+l)*10+5:  25,  35,  45,  ...
By Col: Do kk =1, 6
   kO = 10 * (kk+1)  !  number begins here
   kl = kO + 3       !  number ends  here
   kf = kO + 5       !  flag column
   ICall iv_to_ymdh(iv, jyyyy,  jmm,  jdd,  jhh)
   !o k = (yyyy == j yyyy)  •And.  (mm  ==  j mm)  .And.  &
   !       (dd == jdd)  .And.  (hh ==  jhh)
   !If  (.Not. ok) Then
   !    Write (ULog, 0102) yyyy, mm, dd,  hh,  jyyyy,  jmm,  jdd,  jhh
   !    Write (6,   0102) yyyy, mm, dd,  hh,  jyyyy,  jmm,  jdd,  jhh
   !    Stop  '?? Read_Hourly_ppt:  Date  mismatch'
                                                       159

-------
!End If
Format(Ix, '?? Read Hourly ppt: Date mismatch  ',  &
      2(14, '-', 12.2,  '-', 12.2, 13,  'h;  '))

!  Perhaps the combination " 7 M" is invalid  (i.e., non-missing
!  value with a M-flag).  However, Earthlnfo documentation does not
!  explicitly preclude. Certainly SAMSON was  not afraid  to  use it.
!  We will make sure that if we have a  number,  it  is decoded.
Select Case(xbuf(kO:kl))
CaseC  .  ')
   !  Earthlnfo Documentation: Times having no  reported  events
   !   (presumably zero precipitation) simply  have  decimal point
   !  place-markers in their cells.
   y original = Zero
   yobs = Zero

Case(' 	')
   !  Missing value display value.
   y original = Missing Data
   yobs = Missing_Data

Case Default
   Read(xbuf(kO:kl), ^,  iostat = ios)  y original
   If (ios /= 0) Then
      Write (ULog, *) '?? Read_Hourly_ppt: Input  file:  ',  name_Hourly_ppt(f0:f1)
      Write (ULog, *) '    Line: "', Trim(xbuf), &
            '", substr:  "', xbuf(kO:kl),  '"'
      Write (ULog,9170)  yyyy,mm,dd
      Format(Ix, '   Not a number at ', 14,  2('-',12.2))
      ierrors = ierrors + 1
      Go To 9999  !  Jump to End-of-Subroutine
   End If

   !!  Before converting to appropriate units,  make sure
   !!  this value is not a "flag" value.
   !If (y_original <= -8000) Then
   !    !  some flag value.
   !    Cycle By Col
   !End If
   !  value in range?
   in_range = ((minV <= yobs)  .And.  (yobs <= maxV))
   If (.Not. in_range) Then
      ierrors = ierrors + 1
      Write  (ULog, *)  '?? Read_Hourly_ppt: Input  file:  ',  name_Hourly_ppt(f0:f1)
      Write  (ULog, *)  &
             1   Value  not in range,  ignored v,minV,maxV  :  ',  &
                                                    160

-------
                   yobs, minV, maxV
             Write (ULog, *)  '   Date =  ', yyyy, mm, dd
             Cycle By_Col
          End If
       End Select
       !  Process current point  (observation)
       If (Abs(yobs - Missing_Data ) < EpsO) Then
          !  yobs == Missing Data
          nobs = nobs + 1
          Current_Obs = Val_and_Flag ( T_Missing, yobs,  '')
          If  ( (yflag == 'm')  .Or.  (yflag == '  ')) Then
             current action = X Missing
          Else If  (yflag == 'M') Then
             current_action = X_Zero
          Else If  (yflag == 'a') Then
             current action = X Accum
          Else If  (yflag == 'A') Then
              ! An accumulation run with missing accumulation value
              ! Fake an accumulation run with zero accumulation.
             current action = X Zero

11 Apr 2002 11:11 am
Warning.  At this time we are  ignoring
         accumulation runs in Earthlnfo files
             Current_Obs = Val_and_Flag ( T_Missing, yobs,
          Else If  (yflag ==  'd') Then
             current action = X Delete
          Else If  (yflag ==  'D') Then
             current_action = X_Zero
          Else If  (yflag ==  ',') Then
             current action = X Missing
          Else
             !  Issue a warning:
             ierrors = ierrors + 1
             Write  (ULog, *)  '
                    '", substr:
             Write  (ULog, *)  &
                    1   yobs == Missing_Data and yflag  " ' ,  &
                   yflag, '"  not { mM aA dD ,  }'
             Write  (ULog, ^)  '   Date = ', yyyy, mm, dd, hh
             Cycle By_Col
          End If
                                                           161

-------
               Else
                  !  yobs /= Missing Data
                  nobs = nobs + 1
                  Current_Obs = Val_and_Flag ( Zsource, yobs, '')
                  If ( (yflag == 'g')  .Or. (yflag ==  ' ' )  .Or.   (yflag ==  'E')
                     current action = X Zero
                  Else If (yflag == 'A') Then
                     current_action = X_Zero
MI  * * *
!!!  ***  11  Apr 2002 11:11 am
I | |  ***  Warning.  At this time we are ignoring
! ! !  ***           accumulation runs in Earthlnfo files
III  * * *
                     Current Obs = Val and Flag(T Missing, yobs,  ' ' )
                  Else
                     !  Issue a warning:
                     ierrors = ierrors + 1
                     Write (ULog,  *)  '    Line: "', Trim(xbuf), &
                           '", substr:  "', xbuf ( kO : kl ) ,  '"'
                     Write (ULog,  *)  &
                           1    yobs /= Missing_Data and yflag " ' ,  &
                           yflag,  ' "  not { g A E} '
                     Write (ULog,  *)  '    Date = ', yyyy, mm, dd, hh
                     Cycle By_Col
                  End If

                  !Else  !  E I
                  !    Write (ULog, *)  '?? Read_Hourly_ppt : Input file:  ', name_Hourly_ppt ( f 0 : f 1 )
                  !    Write (ULog, *)  '    Line: "',  Trim(xbuf), '"'
                  !    Write (ULog, *)  '    Do not know how to handle flag " ' , yflag,  ' " '
                  !    Write (ULog, *)  '    Date =  ',  yyyy,  mm, dd
                  !    ierrors = ierrors  + 1
                  !    Go To 9999  !  Jump to End-of-Subroutine
               End If
               !  Make sure we will not overwrite previous good  (non-missing) data.
               !   (input)   Old%s == T_Unset, T_Missing, Zsource
               !   Current%s .... == T_Missing, Zsource
               !   (output) Old%s == T Missing, Zsource
               I
               !   (input/output) %f == yflag: {   }

               If ((Obs_ppt(iv)%s == T Unset) .Or. (Obs_ppt(iv)%s == T_Missing)) Then
                                                                  162

-------
      !  Obs ppt(iv) is unset or missing.
      !  Current value just replaces the old value.
      Obs_ppt(iv) = Current_Obs

   Else If (Obs_ppt(iv)%s == Zsource) Then
      !  We have a previous observation.

      If  (Current_Obs%s == T_Missing) Then
          ! If current_obs is missing we keep the old obs.
          ! Nothing to do.
      Else
          ! If either of the values is Zero, keep the non-zero value.
         If (Abs(Obs_ppt(iv)%v) < EpsO) Then
            !  Obs is zero. Replace it with the current observation.
            Obs ppt(iv) = Current Obs
         Else If  (Abs (Current_Obs%v) < EpsO) Then
            !  Current observation is zero.
            !  Keep the old value  (i.e., nothing to do).
         Else
            !  Else current_obs has data: Unless both obs  are identical,
            !                             we have a problem.
            are eq = (Obs ppt(iv)%s == Current Obs%s)  .And. &
                   (Abs(Obs_ppt(iv)%v - Current_Obs%v) <  EpsO)  .And.  &
                   (Obs_ppt(iv)%f == Current_Obs%f)
            If  (.Not. are_eq) Then
               ierrors = ierrors + 1
               Call iv to ymdh(iv, jyyyy, jmm, jdd, jhh)
               Write (ULog,  9190) 'Duplicate Old:', iv,  jyyyy,  jmm,  jdd,  jhh,  &
                     Obs_ppt(iv)%s,  Obs_ppt(iv)%v, Trim(Obs_ppt(iv)%f)
               Write (ULog,  9190) '           New:1, iv,  jyyyy,  jmm,  jdd,  jhh,  &
                     Current Obs%s,  Current Obs%v, Trim(Current Obs%f)
            End If
         End If
      End If
   End If
End Do By_Col
!  Read next line of the hourly Block.
If (jline /= 4) Then
   Read (uin,  '(a)', iostat = ios) xbuf
   If (ios /= 0) Then
      Write  (ULog, *)  '?? Read_Hourly_ppt: Input file:  ', name_Hourly_ppt(f0:f1)
      Write  (ULog, *)  '   EOF: Expecting  line  ', jline+1, &
             '/ 4 of hourly Block  ', yyyy, mm, dd
      ierrors = ierrors + 1
      Go To 9999  !  Jump to End-of-Subroutine
   End If
                                                      163

-------
      End If
   End Do Read One Record
   If (iv < pDate(iLev)%last_iv) Then
      !  We moved backwards in time when we read this observation.
      !  Push date onto stack.
      If (iLev >= Max_BackTracks)  Then
         Write (ULog, *)   '?? Read_Hourly_ppt: Input file:  ', name_Hourly_ppt(f0:f1)
         Write (ULog, *)   '   Increase Max_BackTracks ==  ', Max_BackTracks
         Write (ULog, *)   '   Date: ', yyyy, mm, dd
         ierrors = ierrors + 1
         Go To 9999  !  Jump to End-of-Subroutine
      End If
      iLev = iLev + 1
   End If

   !  iv is a date at 24h; iv + 2 is next day's date at ih;
   !  2 == Nhours -24+1
   pDate(iLev)%last_iv = iv + Nhours -24+1
   pDate(iLev)%last action = current action
      If (pDate(iLev-1)%last_iv > pDate(iLev)%last_iv) Exit
      pDate(iLev-1)  = pDate(iLev)
      iLev = iLev - 1
   End Do
End Do Look for Date
   !  Skip the 25th hour
   If (Modulo(iv,25) == 0) Then
      Cycle
   End If
                                                            164

-------
         !  At this stage:
         !   %s == T_Unset, T_Missing, Zsource
         !   %f == yflag:  {  }
         I
         !  * 
         !   Initialization: Obs_ppt = Val_and_Flag(T_Unset, Missing_Data,  '')
         Else If (Obs_ppt(iv)%s == Zsource) Then
            If (Abs(Obs_ppt(iv)%v - Missing_Data)  < EpsO) Then
               Call iv_to_ymdh(iv, jyyyy, jmm, jdd, jhh)
               Write (ULog, 9190) '%s ok but missing %v:', &
                     iv,  j yyyy, jmm, jdd, jhh, &
                     Obs_ppt(iv)%s,  Obs_ppt(iv)%v, Trim(Obs_ppt(iv)%f)
            End If
         End If
      End Do
9999  Continue
      !  All Data was Read. Close the file ..
      If (file_was_open)  Call lOClose(uin)

      !  On  Output:
      !      Obs ppt%s == T Missing, Zsource
      !      Obs~ppt%f == yflag:  {   }
      !  Auxiliary routine for Read Hourly ppt
      Implicit None
      Integer,          Intent(In) :: ifrom, ito
      Character(Len=^),  Intent(In) :: The action
      Character(Len=^),  Intent(In) :: Zsource
                                                                  165

-------
   Do iv = ifrom, ito
      If (Modulo(iv,25) == 0) Then
         !  Skip 25-th hour of the day.
         Cycle

         !Else If (Obs_ppt(iv)%s == Zsource) Then
         !    !  Leave things the way they are.

      Else If (Obs_ppt(iv)%s == TJJnset) Then
         !  This entry has not been set, so we can overwrite it
         !  without a second thought.
         If (The_action == X_Zero) Then
            Obs_ppt(iv) = Val_and_Flag(Zsource, Zero,  '')
         Else If  (The_action == X_Missing) Then
            Obs_ppt(iv) = Val_and_Flag(T_Missing, Missing_Data,  '')
         End If

      Else If (Obs_ppt(iv)%s == T_Missing) Then
         If (The_action == X_Zero) Then
            Obs_ppt(iv) = Val_and_Flag(Zsource, Zero,  '')
         End If
      End If
   End Do
End Subroutine Xupdate
Subroutine Yearly_Precip_Stats(Header, Jout)

   Implicit None
   Character(Len=^),  Intent(In) :: Header
   Integer, Optional, Intent(In) :: Jout

   Integer ::  uu
   Integer ::  yyyy,  mm, dd, hh, jvO, jvl, iv, hlen
   Logical ::  okay
   Integer, Dimension!:), Pointer  :: Days_in_Month
   Real :: sum_SH, sum_EIH, sum_EID

   !  ppt_SH  - Sums computed using SAMSON hourly values  (lh-24h)
   !  ppt_EIH - Sums computed using Earthlnfo hourly values  (lh-24h)
   !  ppt_EID - Sums computed using Earthlnfo daily values  (stored  in  25h)
   !      The Earthlnfo hourly and daily values came from different  files.

   If  (Present(Jout)) Then
      uu = Jout
   Else
      uu = ULog
   End If
                                                               166

-------
hlen = Len trim(Header)
Write (uu, 9130)  '## Yearly_Precip_Stats:  ', Header(1:hlen)
Write (uu, 9130)  '   Station WBAN Number:  ', Trim(pWBAN%WBAN),  &
      ',  ', Trim(pWBAN%Text)
ppt_SH  = Year_Stats(0, Zero)
ppt_EIH = Year_Stats(0, Zero)
ppt_EID = Year_Stats(0, Zero)
HP => Xparam(f_HP)%Samson_vlO        ! Hourly  Precipitation

By_Year: Do yyyy = MinYear, MaxYear

   If (Year_Data(yyyy)%SAMSON_vlO == 0) Then
      !  Year is missing.
      Cycle By_Year
   End If

   Write (uu, 9150) yyyy,  'SAMSON(h)',  'Earthlnfo(h)',  'Earthlnfo(d)'
   Format (/, Ix, 14, &
         T15, a!3, &
         T30, a!3, &
         T45, a!2)
            Select Case(HP(iv)%s)
            Case(T_Missing, T_Not_Applicable, T_Undefined,  T_Perpetual_Darkness,  T_Unset)
                ! Do nothing.
            Case Default
               ppt_SH(yyyy,mm)%k = ppt_SH(yyyy,mm)%k  +  1
               ppt_SH(yyyy,mm)%Total = ppt_SH(yyyy,mm)%Total  +  HP(iv)%v
            End Select

            Select Case(Obs_ppt(iv)%s)
            Case(T_Missing, T_Not_Applicable, T_Undefined,  T_Perpetual_Darkness,  T_Unset)
                ! Do nothing.
            Case Default
               ppt_EIH(yyyy,mm)%k = ppt_EIH(yyyy,mm)%k  +  1
                                                             167

-------
            ppt_EIH(yyyy,mm)%Total = ppt_EIH(yyyy,mm)%Total  +  Obs_ppt(iv)%v
         End Select

      Else
         !  25th hour: Daily totals -- only for Earthlnfo.
         Select Case(Obs_ppt(iv)%s)
         Case(T_Missing, T_Not_Applicable, T_Undefined,  T_Perpetual_Darkness,  T_Unset)
            !  Do nothing.
         Case Default
            ppt_EID(yyyy,mm)%k = ppt_EID(yyyy,mm)%k  +  1
            ppt_EID(yyyy,mm)%Total = ppt_EID(yyyy,mm)%Total  +  Obs_ppt(iv)%v
         End Select
      End If
   End Do By_Hour

   !  Print this month's sums
   Write (uu,  9170) mm, Month_Table(mm)(1:3), &
         ppt_SH(yyyy,mm)%Total,  ppt_SH(yyyy,mm)%k,    &
         ppt_EIH(yyyy,mm)%Total, ppt_EIH(yyyy,mm)%k,   &
         ppt_EID(yyyy,mm)%Total, ppt_EID(yyyy,mm)%k
   Format (Ix,  3x, 12,  '-', a3, T15,  f8.2, '(',  10,  ')',  &
         T30,  £8.2,  ' ( ' , 10,  ')',  &
         T45,  £8.2,  ' ( ' , 10,  ')')

   !  Update yearly sums
   sum_SH  = sum_SH  + ppt_SH(yyyy,mm)%Total
   sum_EIH = sum_EIH + ppt_EIH(yyyy,mm)%Total
   sum_EID = sum_EID + ppt_EID(yyyy,mm)%Total
End Do By_Month

!  Because of roundoff errors and the initial precision of the
!  precipitation data, differences  less than  0.02  cm  are  not
!  significant.  Flag everything else.
If (Abs(sum_SH-sum_EID) <= ppt_Eps) Then
   !  Annual sum of SAMSON hours == Annual sum of  Earthlnfo summary of  the  day
   okay = .True.
Else
   !  Numbers are different. It is  ok if the  SAMSON
   !  number is the largest.
   I
   !  See 
!  DATA  FORMAT—HOURLY PRECIPITATION
!
!  It  stands to reason that for most hours the non-occurrence of
!  precipitation is  prevalent.   Therefore, in order to save space in
!  the original digital file,  there are entries only for:
I
!     1.   The  first day and hour of each month where observations were
!          taken even if no precipitation occurred during that month.
I
!     2.   Hours with precipitation > zero.
I
!     3.   Beginning and ending hours of missing periods.
I
!     4.   Beginning and ending hours of accumulating periods.
I
!     5.   Beginning and ending periods of deleted data.
                                                            169

-------
!  month unless  there is  precipitation during that hour,  in which case
!  the  measured  value will  be provided.   On other days during the
!  month without precipitation,  no entry will be made.  099999
!  indicates  that the value is unknown.
I
!  Hourly Precipitation Flag:
I
!  A          Accumulated period and amount.   An accumulated period
!             indicates that the precipitation amount is  correct, but
!             the exact beginning and ending times are only known to
!             the extent  that the precipitation occurred  sometime
!             withinthe  accumulation period.  Begin accumulation data
!             value will  always  be 099999.  *** [LSR]  Not  always so.
I                                          -k-k-k gee example below.
I
!  D          Deleted Flag.  Beginning and  ending of a deleted period.
!             A  deleted value indicates  that the original data were
!             received, but were unreadable or clearly recognized as
             Missing Flag.   (Beginning and ending of a missing
             Period.)   A missing flag indicates that the data were
             not  received.   This flag appears on the first and last
             day  of each month for which data were not received or
             not  processed  by NCDC.   Prior to 1984 a missing period
             was  recorded as " OOOOOM" at the beginning and ending
             hours.   If precipitation occurred during the last hour
             of the missing period,  the second M appears with a non-
             zero value.   Beginning in 1984 the beginning and ending
             hours of the missing period are recorded as "099999M".
!  Examples:
                                            000030b
                                            099999A    Accumulation begins
                                            099999A    Accumulation continue
                                            000390A    Accumulation ends
                                                       Accumulation begins
                                                       Accumulation ends
                                                            170

-------
                                                       First record of the
                                                       month
                                                       Accumulation begins
                                                       Accumulation continues
                                                       Accumulation ends
                                                       Deleted data begins
                                                       Deleted data ends
                                                       Missing data
                                                       Missing data
                       0001       0100      099999M
                       0031       0100      099999M
          02           0001       0100      099999M
                       0028       0100      099999M
!  That is not the complete story. Example: 94018:
I
!  yyyy mm dd hh   HP(i)%v  %f  %s
                            A
                            A
                         !  Begin
                         !  End
           6 10
           1  1
           1  9
                         !  Begin
                         !  Continue
                         !  End
                                     ! Begin
                                     ! End
Implicit None
Type(Val_and_Flag),  Dimension(:), Intent(InOut)  :: Vdata
Type(Accum type),    Dimension(:), Pointer        :: AccumList
Logical,                          Intent(Out)    :: Xok
Integer
Integer
Logical
Logical
Logical
Integer
col beg, col end, iv,
j yyyy, jmm, jdd, j hh
in_accum_gap
in_delete_gap
in missing gap
ngaps, Gap dim
If (Associated(AccumList))  Then
   Gap dim = Ubound(AccumList,1)
                                                            171

-------
Else
   Gap dim = 30
   Allocate(AccumList(Gap_dim))
End If

!  Observation Indicator  0 or 9   0 = Weather observation made.
!                                  9 = Weather observation not made or missing.
!  Present_weather - Present_weather conditions denoted by 9 indicators.
I
!     Xparam(f OI)%Samson vlO(iv)%v = Observation Indicator
!     Xparam(f_OI)%Samson_vlO(iv)%f = Present_weather
!     Xparam(f_OI)%Samson_vlO(iv)%s = data_source

ierr = 0
ngaps = 0
in_accum_gap = .False.
in_delete_gap = .False.
in missing gap = .False.
   !  Do not check the 25th hour
   If (Modulo(iv,25) == 0) Then
      Cycle By_Hours
   End If

   If (Vdata(iv)%f == 'D') Then
      !  Delete gap  (start or end).
      !  Delete this point.
      !  Toggle in delete gap flag.
      Vdata(iv)%v = Missing Data
      in delete gap = (.Not. in delete gap)
      Cycle By Hours
   Else If (in_delete_gap) Then
      Vdata(iv)%v = Missing_Data
      Vdata(iv)%s = T_Missing  !  T_Deleted
      Vdata(iv)%f = 'D'
      Cycle By_Hours
   End If

   If (Vdata(iv)%f == 'M') Then
      !  Missing gap (start or end).
      !  Delete this point.
      !  Toggle in missing gap flag.
      If (in missing gap) Then
         !  From the SAMSON documentation above: If precipitation occurred
         !  during the last hour of the missing period, the second M appears
         !  with a non-zero value. Guess what? This is the "second M".
                                                            172

-------
      !  (%v > 0)  and  ( %v /= Missing_Data)  ?
      If ((Vdata(iv)%v > Zero) .And.  (Abs(Vdata(iv)%v-Missing_Data) > EpsO)) Then
         !  Non zero value -- Keep it.
         Vdata(iv)%s = T_Estimated
         Vdata(iv)%f = ''
      Else
         Vdata(iv)%v = Missing_Data
         Vdata(iv)%s = T_Missing
      End If
   Else
      Vdata(iv)%v = Missing Data
      Vdata(iv)%s = T_Missing
   End If
   in missing gap = (.Not. in missing gap)
   Cycle By Hours
Else If (in_missing_gap)  Then
   Vdata(iv)%v = Missing_Data
   Vdata(iv)%s = T_Missing
   Vdata(iv)%f =  'M'
   Cycle By_Hours
End If

If (Vdata(iv)%f ==  'A') Then

   !  An accumulation point.
   !  Determine type: begin, continue, or end.

   If (Abs(Vdata(iv)%v) < EpsO) Then
      !  If  value is Zero,  then this is the start of a new gap.
      !  If  in accum gap == .T., then we have a problem.
      If (in accum gap) Then
         Call iv_to_ymdh(iv,  jyyyy, jmm, jdd, jhh)
         Write(ULog,*) '?? Standardize_ppt:  runaway gap at  ', jyyyy, jmm, jdd, jhh
         Write(6,    *) '?? Standardize ppt:  runaway gap at  ', jyyyy, jmm, jdd, jhh
         Stop '?? Standardize ppt: runaway gap1
      End If
      !  Start of a new gap
      in accum gap =  .True.
      col beg = iv
   Else If  (Vdata(iv)%s == T_Missing) Then
      !  %s  == T_Missing  iff  %v == 99999.
      !  This may be a "begin" or "continuation".
      If (in accum gap) Then
         !  A continuation. Nothing to do.
         Cycle By_Hours
      Else
         !  A beginning. (A very delicate time.)
         !  Start of a new gap
         in_accum_gap = .True.
         col beg = iv
                                                         173

-------
   End If
Else
   !  We better be within a gap.
   If (.Not. in_accum_gap) Then
      Call iv_to_ymdh(iv, jyyyy, jmm, jdd, jhh)
      Write(ULog,^)  '?? Standardize ppt: Begin-of-gap missing  ',  &
            jyyyy, jmm, jdd, jhh
      Write(6,   *)  '?? Standardize_ppt: Begin-of-gap missing  ',  &
            jyyyy, jmm, jdd, jhh
      Call FLushAll()
      Stop  '?? Standardize ppt: Begin-of-gap missing1
   End If

   !  End of gap.
   col end = iv

   Select Case(Vdata(col_end)%s)
   Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
      !  Not a valid number: This is a severe error.
      Call iv_to_ymdh(col_end, jyyyy, jmm, jdd, jhh)
      Write(ULog, 9130) jyyyy, jmm, jdd, jhh
      Format  (Ix, &
             '?? Standardize_ppt: ', &
             'Total amount missing  for ', &
            14,   '-', 12.2,  '-', 12.2, 13,  'h')
      ierr = ierr + 1
      in accum gap =  .False.
      Cycle By_Hours
   End Select

   !  The gap run just ended. Store it.
   If (ngaps >= Gap_dim) Then
      Gap_dim = 2 * Gap_dim  +  10
      AccumList => Reallocate Accum type(AccumList,  Gap  dim)
   End If
   ngaps = ngaps + 1
   AccumList(ngaps)%ibeg = col_beg
   AccumList(ngaps)%iend = col end
   AccumList(ngaps)%Total = Vdata(col_end)%v

   ICall iv_to_ymdh(col_beg, jyyyy, jmm, jdd, jhh)
   !Call iv to ymdh(col end, kyyyy, kmm, kdd, khh)
   !Write (ULog, 9125) jyyyy, jmm, jdd, jhh, kyyyy,  kmm,  kdd,  khh
   Format!//, Ix, '## Standardize_ppt gap  from  ', &
         14,  '-', 12.2,  '-', 12.2, 13,  'h  to  ', &
         14,  '-', 12.2,  '-', 12.2, 13,  'h')

   in_accum_gap = .False.

   !  Henceforth, for this array, accumulation data will  be
                                                       174

-------
            !  retrieved from AccumList.
            Ace Loop: Do jv = col beg, col end
               If  (Modulo(jv,25) == 0) Then
                  Cycle Acc_Loop
               End If
               Vdata(jv)%s = T_Missing
               Vdata(jv)%f = 'A'
            End Do Acc_Loop
            Vdata(col_end)%v = Zero
         End If
      End If
   End Do By_Hours
   If (in_accum_gap) Then
      !  This is a mistake. After an Accumulation gap
      !  we must have the amount measured.
      ierr = ierr + 1
      Call iv_to_ymdh(col_beg, jyyyy, jmm, jdd, jhh)
      Write (6, 9170) j yyyy, jmm, jdd, jhh
      Write (ULog,  9170) jyyyy, jmm, jdd, jhh
      Format(Ix,  '?? Standardize_ppt:  (EOF) Unresolved Accumulation  gap  ',  &
            'starting on  ', 14,  '-', 12.2,  '-', 12.2, 13,  'h')
      Call FLushAll()
      Stop '?? Stopping in Standardize ppt:  (EOF) Unresolved Accumulation  gap.
   End If

   !  Trim AccumList to exact size.
   AccumList => Reallocate Accum type(AccumList, ngaps)
   Xok =  (ierr == 0)

End Subroutine Standardize ppt
Function Reallocate Accum type(pOld, Nnew) Result(pNew)
   Implicit None
   Type(Accum_type) , Dimension!:),  Pointer :: pOld, pNew
   Integer,                     Intent(In) :: Nnew
   Integer ::  nold,  ierr
                                                                175

-------
   If (.Not. Associated(pOld)) Return

   nold = Min(Size(pOld), Nnew)
   pNew(l:nold) = pOld(l:nold)
   Deallocate(pOld)
End Function Reallocate Accum type
   Integer
   Integer
   Logical
   Integer
   Integer
   Real
i v
i	max, ierr
are_ok, id_ok, v_ok, okay
nsamson, igap, nO, nl, nx
col beg, col end
Total_ppt
                                        ! Hourly  Precipitation

   !  Pass 1: Process 'M',  'D', Zsource
   !  Needed only if we have Observed Hourly data.
   If (Have_ppt_Obs_hourly_data) Then
      i	max = Ubound(HP,l)
      Pass 1: Do iv = 1, i  max

         !  Skip the 25th hour
         If  (Modulo(iv,25) == 0) Then
            Cycle Pass_l
         End If

         !!  Skip any 'accumulation1 records. We  will do  them later.
         !If ((HP(iv)%f == 'A')  .Or.  (Obs_ppt(iv)%f ==  'A')) Then
         !    Cycle Pass_l
         !End If
                                                                176

-------
         !  SAMSON source: missing value
         !  Earthlnfo source value >= 0
         !  Earthlnfo replaces SAMSON value.
         id_ok = ((HP(iv)%s == T_missing)  .And. &
               (Obs_ppt(iv)%s == T_EarthInfo))

         !  SAMSON %v == missing  and  Earthlnfo %v >= 0
         !         %f == "M"                     %f == ""
         v_ok = (Obs_ppt(iv)%v >= Zero)  .And. &
               (Abs(HP(iv)%v-Missing_Data) <  EpsO)
         are ok = (id ok) .And.  (v ok)
         If (are_ok) Then
            HP(iv)  = Obs_ppt(iv)
         End If
      End Do Pass_l
   End If

   !If (Associated(Accum Samson)) Nullify(Accum Samson)
   !If (Associated(Accum_EI)) Nullify(Accum_EI)

   !  Pass 2: process accumulation.
   nsamson = 0
   If (Associated(Accum Samson)) nsamson = Ubound(Accum Samson,!)


   If (nsamson > 0)  Then
      Do igap = 1,  nsamson
         col_beg = Accum_Samson(igap)%ibeg
         col_end = Accum_Samson(igap)%iend
         Total ppt = Accum Samson(igap)%Total
         Else
            Call Fill_Buckets(okay, col_beg, col_end, Total_ppt)
         End If

         If (.Not.  okay) Then
            ierr = ierr + 1
         End If
      End Do
   End If
Subroutine Print HP(Header, JvO, Jvl, Jout)
                                                               177

-------
Implicit None
Character(Len=*),  Intent(In)  :: Header
Integer, Optional, Intent(In)  :: JvO, Jvl
Integer, Optional, Intent(In)  :: Jout

Integer ::  uu, col beg, col end
Integer ::  iv, jyyyy, jmm, jdd, jhh
Real    ::  sum_samson_lday, sum_total

If  (Present(Jout)) Then
   uu = Jout
Else
   uu = ULog
End If

HP => Xparam(f_HP)%Samson_vlO        ! Hourly  Precipitation

If  (Present(JvO)   .And. Present(Jvl)) Then
   col beg = JvO
   col_end = Jvl
Else
   col beg = 1
   col_end = Ubound(HP,l)
End If
By_Hours:  Do iv = col_beg, col_end
   Call iv_to_ymdh(iv, jyyyy, jmm, jdd, jhh)
   Write(uu, 9150) iv, jyyyy, jmm, jdd, jhh,  &
         'HP',  HP(iv)%s, HP(iv)%v, HP(iv)%f(1:2),  &
         'Obs', Obs_ppt(iv)%s, Obs_ppt(iv)%v, Obs_ppt(iv)%f(1:2)
   If (Modulo(iv,25) /= 0) Then
      sum samson Iday = sum samson Iday + HP(iv)%v
      sum_total = sum_total + HP(iv)%v
   Else
      Write(uu, 9170) sum samson Iday
      Format (Ix, t26, 'Sum 1-24:', Ipgl4.6)
      sum_samson_lday = Zero
   End If
End Do By Hours
                                                             178

-------
End Subroutine Print HP
   !  This routine collects most of the precipitation-related
   !  subroutine calls.
   !  
   !  

   Implicit None
   Logical, Intent(Out)  :: Xok

   Logical ::  Have Precip Data
   Integer ::  hhOl,  hh24,  hh25, jday, jvO, jvl
   Integer ::  ierr
   Type(Val_and_Flag), Dimension!:), Pointer  :: HP
   !  Was this station identified by SAMSON as "Little/No Hourly ppt data"  ?
   !  

   If (.Not. Have_Precip_Data) Then
      !  
      !  
      !    * make all hourly precipitation missing, even when
      !      present. Fill daily value record  (hh == 25) with
      !      the summary of the day.
      L31:  Do jday = jdO, jdl           ! step by day
         hhOl = (jday-jdO)*Nhours + 1   ! First hour of the day
         hh24 = hhOl + 23               ! Last hour of the day  (24th)
         HP(hh01:hh24)  = Val_and_Flag(T_Missing, Missing_Data,  '')
      End Do L31

      !  Do we have the Earthlnfo summary of the day?
      If (Have_ppt_Obs_daily_data) Then
         !  Yes .
         L41: Do hh25 = 25, Ubound(HP,1), NHours
            Select Case(Obs_ppt(hh25)%s)
            Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
                                                                179

-------
            !  Missing value. Set to Zero.
            HP(hh25) = Val_and_Flag(T_Estimated, Zero,  '')
         Case Default
            HP(hh25) = Obs_ppt(hh25)
         End Select
      End Do L41

   Else
      !  No. Bummer.
      Write (ULog, 9130) Trim(pWBAN%WBAN), Trim(pWBAN%Text)
      Format (///, &
            Ix, 45('?'), /, &
            Ix, '?? Missing Earthlnfo summary of the day data  for  station  ',  a,  ':  ',  a,  /,  &
            Ix, '?? Daily values set to  "missing"1, /,  &
            Ix, 45('?'), / )
      L42: Do hh25 = 25, Ubound(HP,1), NHours
         HP(hh25)  = Val_and_Flag(T_Missing, Missing_Data,  '')
      End Do L42
      ierr = ierr + 1
   End If

   !!  Compute the daily value.
   !!  See 
   MCall Daily_Values (f_HP, T_Cumulative, Xok)
   ICall Ppt_Daily_Values(Xok)
   !If (.Not.  Xok) Then
   !    ierr = ierr + 1
   !    Errors_Detected = .True.
   !End If
   Xok =  (ierr == 0)
   Return
End If


!  We have precipitation data, however the record may be incomplete.
!  For example:
!      22516: Kahului HI —
!         Missing hourly data for 1961-Jan to 1962-Dec.
!         Complete hourly data for 1963-Jan to 1990-Dec.


!  Precipitation: missing values not in an accumulation  run
!  will be set to Zero. Since one of the  algorithms used to
!  fill Accumulation runs references OSC, fill all gaps  before
!  resolving Accumulation runs.
I
!   5 Mar 2002  3:41 pm:  Well, we have a  problem here.  '99999A'
!  in an accumulation may mean one of two things:
!      1)  this is the start of an accumulation run, or
!      2)  continue the accumulation run.


                                                             180

-------
!  So, the 'missing1 value has to be seen in the context of  'A1;
!  we cannot just set the missing value to zero.
Call Process Precip Records(Xok)
If  (.Not. Xok)  Then
   Errors_Detected = .True.
End If
Call FLushAll()

ICall Yearly_Precip_Stats('before Reconcile_HP_samson_earthinfo')  !!-
Call Reconcile HP samson earthinfo(Xok)
If  (.Not. Xok)  Then
   Errors_Detected = .True.
End If

!  Compute the daily value.
!  See 
ICall Daily_Values(f_HP, T_Cumulative, Xok)
Call Ppt_Daily_Values(Xok)
If  (.Not. Xok)  Then
   Errors_Detected = .True.
End If
Call Yearly Precip Stats('After all processing completed.')
!  
!  
            744
        <-- Sum S(h),   i.e., sum all the SAMSON hours
                                                             181

-------
           hours              of the month.

      If A <= B, i.e., SAMSON has more precipitation,
                       Nothing to do. Exit.
          24
      If Sum El(h) == El(d)
          1

         Then Replace:  S(h) <— EI(h)

                        2 4
      Else If  EI(d) > Sum EI(h)
                        1

         Then: accumulation run:
               delta = El(d) - Sum S(h)
               allocate delta over the 24-hour period

      Else  !  El(d) < Sum El(h)
         Dump the month. Determine what is going on.
Integer ::  yyyy, mm, dd, hh, jvO, jvl, iv, hhOl, hh24, hh25
Integer ::  ierr, iday
Logical ::  okay
Integer ::  missing sd, missing SAMSON, missing in SAMSON day
Integer, Dimension(:), Pointer :: Days in Month

!  The following are used for fuzzy comparisons.
!  See -------
   Case Default
      sum_SAMSON_day = sum_SAMSON_day + HP(iv)%v
   End Select

   Select Case(Obs_ppt(iv)%s)
   Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness,  T_Unset)
   Case Default
      Sum_EI_h = Sum_EI_h + Obs_ppt(iv)%v
   End Select
End Do

!      If C(i) >= EI(d), i.e., the SAMSON hour data has more
!                              rain than summary of the day.
!                              Nothing to do. Exit.
Select Case(Obs_ppt(hh25)%s)
Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness,  T_Unset)
   !  Summary of the day missing;
   !  Set the daily value to the sum of the SAMSON hourly values  for this day.
   HP(hh25) = Val_and_Flag(T_Estimated, sum_SAMSON_day,  '')
   Cycle By_Day
End Select
EI_d = Obs_ppt(hh25)%v

!  The daily value is the maximum of the sum of the SAMSON hours
!      of the day or the Earthlnfo summary of the day.
!    
HP(hh25)  = Val_and_Flag(T_Estimated, Max(sum_SAMSON_day,EI_d),  '')

!  See 
End If
!          24
!      If Sum El(h) == El(d)
!          1

If (Abs(Sum_EI_h-EI_d) < EpsO) Then

   !         Then Replace:  S(h) <— EI(h)
                                                   185
-------
   HP(hh01:hh24) = Obs_ppt(hhOl:hh24)
   IWrite(ULog,*)   '(3) Sum_EI_h==EI_d: hhOl,  hh24:',  hhOl,  hh24
   Go To 99887   !  Jump to End-Do-By_Day  
End If

!                        24
!      Else If  EI(d) > Sum EI(h)
!                        1

!  See 
-------
        If any of the P(i) worked, then
            Call Fill_Buckets(Col_beg, Col_end, Total_amount)
      = Else
            Dump arrays.
Implicit None
Logical, Intent(Out)
Integer, Intent(In)
Real,    Intent(In)
Integer
Integer
Integer
Integer
Real
Real
Real
Logical
Logical
lerr
nO, nl, nx, hhOl, hh24, hh25
iv, ivO, ivl
periods resolved
amt in, amt out, sd nx, delta nx
cumulative_ppt, amt_allocated
total_this_day
another accumulation, okay, found missing
current sd missing, some sd missing
Namelist/xxO/ amt_in, amt_out, sd_nx, delta_nx, total_this_day
Namelist/xxl/ another accumulation, some sd missing, &
      current sd missing
Namelist/xx2/ Total_amount, &
      cumulative_ppt, amt_allocated
                                     ! Hourly Precipitation
                        !  First day of accumulation interval.
                        !  Last day of accumulation interval.

                        !  ppt allocated so far.
!  some_sd_missing -- true if any sd(nO:nl-l) were missing.
!  if any sd was missing, then the sum "cumulative_ppt" is
!  incomplete, because it is missing precipitation for at
!  least one 24-hour period.
some_sd_missing = .False.
current_sd_missing = .False.

Loop nO nl:  Do nx = nO, nl    !  For each day ...
   hhOl = nx*Nhours + 1
   hh24 = hhOl + 23
   hh25 = hh24 + 1
   amt_in = Zero
   amt_out = Zero
   another accumulation = .False.
                   !  First hour of the day
                   !  Last hour of the day
                   !  Daily value
                                                            191
-------
!  At this state "current sd missing" contains the value
!  of the previous iteration. By performing the test now,
!  "some_sd_missing" tests whether any of the previous sd's
!  (nO:nx-l)  were missing.
If (current_sd_missing) Then
   some sd missing = .True.
End If

Do iv = hhOl, hh24
   If ((Col_beg <= iv)  .And. (iv <= Col_end)) Then
      !  iv falls inside the accumulation interval.
      If (HP(iv)%s /= T_Missing) Then
         amt_in = amt_in + HP(iv)%v
      Else
         HP(iv)%v = Zero    ! In preparation of resolution via "Fill Buckets'1
      End If
   Else
      !  iv falls outside accumulation interval.
      If (HP(iv)%s /= T_Missing) Then
         amt_out = amt_out + HP(iv)%v
      End If
      If (HP(iv)%f ==  'A') Then
         another accumulation = .True.
      End If
   End If
End Do

!  sd_nx = daily precipitation (summary of the day) for day nx
If (Obs_ppt(hh25)%s /= T_Missing)  Then
   sd_nx = Obs_ppt(hh25)%v
   current sd missing = .False.
Else
   !  The summary of the day is  not available for this day.
   sd nx = Zero
   current sd missing = .True.
End If

If (nx < nl)  Then
   If (current sd missing) Cycle Loop nO nl
   delta_nx = sd_nx -  (amt_in + amt_out)
Else
   !  Last Interval:   nO == nl == nx  -or-  nx == nl (nO < nl)
   If (another accumulation) Then
      !  The last day contains another accumulation run.
      If (some_sd_missing) Then
         !  There is nothing more we can do at this time.
         !  A finishing pass will be applied later.
         Cycle Loop_nO_nl
      Else
         delta nx = Total amount - (cumulative ppt + amt in)
                                                         192
-------
      End If
   Else If (.Not. current sd missing) Then
      !  We have summary of the day "sd_nx".
      delta_nx = sd_nx - (amt_in + amt_out)
   Else If (.Not. some_sd_missing) Then
      !  If all sd(nO:nl-l)  were present, then all previous intervals
      !  were allocated and cumulative ppt  is complete.
      delta_nx = Total_amount - (cumulative_ppt + amt_in)
   Else
      !  Else at least one of the intervals was not allocated.
      !  If we use
      !      delta_nx = Total_amount - (cumulative_ppt + amt_in)
      !  we would be allocating all the remaining precipitation to the
      !  last interval, completely ignoring the unallocated intervals.
      I
      !  There is nothing more we can do at this time.
      !  A finishing pass will be applied later.
      Cycle Loop nO nl
   End If
End If

ivO = Max(hh01, Col_beg)
ivl = Min(hh24, Col_end)

!  delta_nx -- delta difference between the amount to
!      be allocated for the period nx and the amount
!      already in the period  (amt in).
!  total_this_day -- amount to be allocated in this period.
total_this_day = delta_nx + amt_in

If (delta_nx > EpsO) Then
   Call Fill_Buckets(okay,  ivO, ivl,  total_this_day)
Else If (Abs(delta_nx) < EpsO) Then
   !  delta nx == Zero (fuzzily).  Make it Zero  (exactly).
   !  (we still need to update the HP array).
   delta_nx = Zero
   Call Fill_Buckets(okay,  ivO, ivl,  total_this_day)
Else
   !  For example:
   !  sd == 0.0
   !  amt_out == 0.2032
   !  Total_amount == 0.127
   !  The day already has too much precipitation (according
   !  to the summary of the day) and we still want to add
   !  more precipitation.
   I
   !  If this is not the last day,  allocate no precipitation
   !  (we still need to update the HP array).
   If (nx < nl) Then
      delta nx = Zero
                                                         193
-------
         Call Fill_Buckets(okay, ivO, ivl, total_this_day)
      Else
         !  Else, allocate
         delta_nx = Max ( Total_amount -  ( cumulative_ppt + amt_in ) , Zero)
         total_this_day = delta_nx + amt_in
         Call Fill_Buckets(okay, ivO, ivl, total_this_day)
      End If
   End If

   If (okay) Then
      !  Do not update variables for the last interval.
      If (nx < nl)  Then
         periods_resolved = periods_resolved + 1
         !cumulative ppt = cumulative ppt + sd nx   !  2 May 2002 11:19 am
         !   2 May 2002 11:32 am: Tested with 23129: Long Beach, CA
         !   2 May 2002  3:23 pm: Tested with 23063: Eagle, CO
         cumulative_ppt = cumulative_ppt + total_this_day
      End If
   Else
      ierr = ierr + 1
      Call Print_24('(2):  okay== F', nO, nl, nx,  &
            Col Beg,  Col End, Total amount, total  this day)
   End If
End Do Loop_nO_nl
!  It is conceivable that all precipitation has been
!  allocated and that there are still
!      HP(Col beg:Col end)%s == missing
!  present. For example, if some  (non-last)
!  sd was missing, that interval would not be
!  called and ( ) %s would not be changed.

amt_allocated = Zero
found_missing = .False.
Do iv = Col beg, Col end
   If (HP(iv)%s /= T_Missing) Then
      amt_allocated = amt_allocated + HP(iv)%v
   Else
      found missing = .True.
   End If
End Do

delta nx = Total amount - amt allocated
                                                            194
-------
      !  See 
-------
   If ( (Abs (Vval (k) )  >= EpsO) .And. &
         (Abs (Vval (k) -Missing_Data ) >= EpsO)) Then
      !  Vval(k) > 0  and  Vval(k)  /= MissinData
      Vused(k) = .True.
      hours_with_ppt = hours_with
   End If
End Do
If (hours_with_ppt > 0) Then
   rdiv = xresid / hours with ppt
   Do iv = Col_Beg, Col_End
      k = iv - Col_Beg + 1      ! Entry in V* arrays
      If (.Not. Vused(k)) Cycle
      Vval(k) = Vval(k) + rdiv
   End Do
   !  All rain allocated. Jump to end of subroutine.
   Status_Flag = Flag_Done
   Go To 99999
End If

!  If the sky is opaque, then it rained.

!  All hours available except 25-th hour
Do iv = Col_Beg, Col_End
   k = iv - Col Beg + 1      ! Entry in V* arrays
   Vused(k) =  (Modulo(iv,25) /= 0)
End Do
Select Case(Status_Flag)
Case(Flag Continue)
   !  Do next phase.
Case(Flag_Done)
   !  All rain allocated. Jump to end of subroutine.
   Go To 99999
Case(Flag_Error)
   !  Error. Jump to end of subroutine and return.
   Go To 99999
End Select

!  The sky was clear and it rained. Sigh.
!  Last resort. Use all hours, regardless.
!  All hours available except 25-th hour
Do iv = Col_Beg,  Col_End
   k = iv - Col_Beg + 1      ! Entry in V* arrays
   If (Modulo(iv,25)  /= 0) Then
                                                            207
-------
            !  Ih - 24h
            Vused(k)  = .False.
            vSelect(k) = .True.
         Else
            !  25h
            Vused(k)  = .True.
            vSelect(k) = .False.
         End If
      End Do

      Call Do_Phase(Col_Beg, Col_End, Xresid, &
            vSelect,  vSelect, Status_Flag, Vused, Vtempl)

      Select Case(Status_Flag)
      Case(Flag Continue)
         !  Do  next phase.
         Go To 99999
      Case(Flag_Done)
         !  All rain allocated. Jump to end of subroutine.
         Go To 99999
      Case(Flag_Error)
         !  Error. Jump to end of subroutine and return.
         Go To 99999
      End Select
99999 Continue
      okay = (Status_Flag == Flag_Done)
      Xok = okay
      If (okay)  Then

         !  Note:
         !      %v:  value;
         !      %s:  may contain "Missing" flag;
         !      %f:  may contain T_Accumulation

         !  Note  that
         !      HP(Col_Beg:Col_End)%v = Vval(l:nv)
         !      HP(Col_Beg:Col_End)%s = T_Estimated
         !      HP(Col_Beg:Col_End)%f = T_Accumulation
         !  would set the daily values, causing problems later.

         Do iv = Col_Beg, Col_End
            k =  iv - Col_Beg + 1      ! Entry in V* arrays
            If  (Modulo(iv,25) == 0)  Then
               Cycle !  Skip 25th hour
            End  If
                                                                  208
-------
         Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
            !  HP(iv) is missing. Replace it with the estimated value.
            HP(iv) = Val_and_Flag(T_Estimated, Vval(k), T_Accumulation)
         Case Default
            If (Abs(HP(iv)%v-Vval(k))  >= EpsO) Then
               !  HP(iv) is different from the estimated value.
               !  Replace it with the estimated value.
               HP(iv) = Val_and_Flag(T_Estimated, Vval(k), T_Accumulation)
            End If
         End Select
      End Do

   Else
      !  Algorithms failed.
      Write (ULog, 9150) str iv to ymdh(col beg), &
            str_iv_to_ymdh(col_end), ddt_marker

      Format(Ix,   '?? Fill_Buckets:  ',  &
            'Unresolved Accumulation gap from ', &
            a,  '  to  ', a, '; ddt_marker: ', 10)
      Call Print_Ph3('Fill_Buckets -- Final Failure',  &
            Col Beg, Col End, &
            Total ppt, Vused, Vtempl)
   End If

End Subroutine Fill Buckets
Subroutine Do Phase(Col Beg, Col End, Xresid, &
      Xuse me, Xhas property, Status Flag, Xused, Xtempl)
     Xhas_property(k) == .T. ==> This element posseses the property
            in question. Vague enough? Examples of properties  are
            — it rained during the kth hour
            — OSC >= 5 during the hour
            -- 1 <= OSC <= 4 during the hour
     Xtempl — provides only storage space and carries no  information
            neither into nor out of the routine. A local array would
            do, but I am trying to avoid allocating and deallocating
            continuously this array, which may be used up  to  5 times
            per call to Fill_Buckets.
                                                               209
-------
!  Algorithm:
!  1. Generate the set of candidate hours. Stored the hours
!         in Xcandidate_hour  (pointer to Xtempl)
!  2. Determine if there are hours with bounds, e.g.,
!         if Present Weather(2:2) == "1"  (i.e., Moderate rain),
!         then  0.25 cm <= capacity of the bucket <= 0.76 cm.
!         Fill these hours first.
!  4
Implicit None
Integer,                 Intent(In)
Real,                    Intent(InOut)
Logical, Dimension(:),   Intent(In)
Logical, Dimension(:),   Intent(In)
Character(Len(Flag_Done)), Intent(Out)
Logical, Dimension!:),   Intent(InOut)
Col Beg, Col End
Xresid
Xuse_me
Xhas property
Status_Flag
Xused
!  Xcandidate hour — temporary internal array; points to Xtempl.
Logical, Dimension(:), Pointer :: Xcandidate_hour
Real    :: amt, in_residual, mean_ppt
Integer :: iv, k, ncandidates, itimes, ierr
Logical :: at least one bound
Integer, Save ::  ddt_marker = 0

ddt marker = ddt marker + 1
!  First, generate the set of candidate hours.
ncandidates = 0
Xcandidate hour => Xtempl
Xcandidate hour = .False.   ! Start with an empty set.
Do iv = Col_Beg, Col_End
   k = iv - Col_Beg + 1     ! Entry in V* arrays

   If (Modulo(iv,25) == 0) Then
      !  Skip 25-th hour of the day.
      !  Do not select this point.
      Cycle
   End If
                                                            210
-------
   !  If this element was used before, cycle.
   If (Xused(k))  Cycle
   Xcandidate hour(k) = .True.
   ncandidates = ncandidates + 1
   at_least_one_bound = at_least_one_bound .Or. Vbounds(k)
End Do

If (ncandidates == 0) Then
   !  No candidates for the given conditions.
   !  Return with "Continue", since we may still solve
   !  this accumulation with a different set of conditions.
   If (Abs(Xresid) < EpsO) Then
      !  Success. Xresid == Zero  (fuzzily). Make it Zero  (exactly)
      Xresid = Zero
      Status_Flag = Flag_Done
   Else
      Status_Flag = Flag_Continue
   End If
   Return
End If

!  Loop three times :
!  After the first pass all cells have the minimum amount.
I
!  Second time: Distribute the remainder equally among the bucket
I
!  Third time:  Allocate as much rain as each bucket can contain.
   !  mean ppt will be used when itimes == 2.
   !  A <= B :: Abs(B-A) < EpsO  .Or.  EpsO <  (B-A)
   mean_ppt = Xresid / ncandidates
   If ((Abs(minimum_allocation-mean_ppt)  < EpsO)  .Or. &
         (EpsO <  (minimum allocation-mean ppt)))  Then
      !  mean ppt <= minimum allocation: mean ppt  is smaller than
      !  the initial precision of the data. Choose a larger value.
      mean_ppt = Min(minimum_allocation,  Xresid)
   End If
                                                            211
-------
Loop k: Do iv = Col Beg, Col End
   k = iv - Col Beg + 1     ! Entry in V* arrays
   If (Abs(Xresid) < EpsO) Then
      !  Success. Xresid == Zero  (fuzzily). Make it Zero  (exactly)
      Xresid = Zero
      Exit Loop k
   Else If (Xresid < -EpsO) Then
      !  Xresid < 0 -- error.
      ierr = ierr + 1
      Exit Loop k
   End If
      !  Hours with bounds. Example:
      !      if Present Weather(2:2) == "1"  (i.e., Moderate rain),
      !      then 0.25 cm <= capacity of the bucket <= 0.76 cm.
      !      Fill these hours first.
      !  If at_least_one_bound == .T., then at least one hour  (k)
      !  has bounds. If no hours have bounds, then we can skip
      !  the iteration itimes==l completely.
      If (.Not. at least one bound) Cycle Loop Times

      !  If this entry does not has bounds to be respected, get
      !  next hour. In this step we are only considering hours
      !  such that
      !      Vmin <= Vval <= Vmax
      !  where  (Vmin, Vmax) /=  (0, Huge(0))
      If (.Not. Vbounds(k)) Cycle Loop_k

      !   9 May 2002  3:24 pm -- Initially, I was allocating
      !         Vval(k) = Vmin(k), i.e.,  as much rain as
      !         the minimum amount per Present Weather flags.
      !         The problem was that sometimes the amount
      !         of rain detected by an accumulation run
      !         would be Zero, but present weather says
      !         that on hour x, between 0.25 cm and 0.76 cm
      !         of rain fell  (for example). This behaviour
      !         was observed with WBAN 23063, Eagle, CO,
      !         iv:189496 1981-10-02 21h.
      I
      !  We will allocate either Vmin or the residual, whichever
      !  is smaller. If the bucket amount Vval is already >= Vmin,
      !  no more precipitation will be added (in this iteration).
                                                         212
-------
   Case(3)
      !  Allocate as much as the bucket will contain.
      amt = Min(Vmax(k)-Vval(k), Xresid)
   End Select
   !  If the residue that would be left is less than the
   !  precision of the intrument, allocate the remainder
   !  in the current bucket.
   If ((Xresid - amt) < minimum_allocation)  Then
      amt = Xresid
   End If

   Vval(k) = Vval(k) + amt
   Xresid = Xresid - amt
   Xused(k) = .True.
End Do Loop_k

If (ierr /= 0) Then
   !  Some error.
   !If (print_now) Write  (ULog, *)  '## Do_Phase: Errors.  ',  &
   !       'itimes='//Trim(Itoa(itimes)),  ' Xresid:  ', Xresid, &
   !       '; ddt marker:  ', ddt marker
   Status_Flag = Flag_Error
   Return
Else If (Abs(Xresid) < EpsO) Then
   !  Success
   !If (print_now) Write  (ULog, *)  '## Do_Phase: Success  itimes='//&
   !      Trim(Itoa(itimes)),  '; ddt_marker:  ', ddt_marker
   Status_Flag = Flag_Done
   Return
Else If (Xresid < -EpsO) Then
   !  Critical failure. After adding  to each bucket the minimum
   !  amount, xresid < 0, i.e., not enough initial ppt was provided.
   !If (print_now) Then
   !    Write  (ULog,  *)  '## Do_Phase:  Failure itimes='//Trim(Itoa(itimes)),  &
   !           ',  Xresid:  ', Xresid,  ', ddt_marker:  ', ddt_marker
   !End If
   Status_Flag = Flag_Error
   Return
Else
   !  We may continue. We may still solve this accumulation.
   !If (print_now) Write  (ULog, *)  '## Do_Phase: Status_Flag =  ',  &
                                                         213
-------
            !       'Flag Continue, itimes='//Trim(Itoa(itimes))
            Status Flag = Flag Continue
         End If
      End Do Loop_Times

   End Subroutine Do Phase
   Subroutine Print_Ph3(xHeader, Col_Beg, Col_End, Total_ppt, Xused,  Xcandidatejnour)

      !  Print arrays associated with Fill_Buckets and Do_Phase.
      Implicit None
      Integer,          Intent(In) ::  Col Beg, Col End
      Character(Len=^), Intent(In) ::  xHeader
      Real,              Intent(In) ::  Total_ppt
      Logical, Dimension(:), Intent(In)  :: Xused, Xcandidate  hour
      Write (ULog, '(lx,4x,a)') Trim(xHeader)
      Write (ULog, 9130) 'k   Vmin   Vval  Vmax   * OI  PW        OSC  Xcandidatejnour,Xused:
9130  Format (Ix, 2x, t28,  a)
         If (Modulo(iv,25) == 0) Then
            !  Skip 25-th hour of the day.
            Cycle
         End If
                                  ! Entry in V* arrays
         Write (ULog, 9150) &
               str iv to ymdh(iv), &
               k, qmin,  Vval(k), qmax, &
               Vpw(k), Nint(OI(iv)%v), OI(iv)%f, &
               Nint(OSC(iv)%v), &
                                                                  214
-------
               Xcandidate hour(k), Xused(k)
9150     Format (Ix, a, &
               14, Ix, 3f7.3, Ix, &
               a,  Ix, 11, Ix, a, &
               14, &
               L2, L2)
   End Subroutine Print Ph3
   Subroutine Accum based on OSC(Status Flag, Col Beg,  Col  End,  &
         Xresid, Xcandidate hour, XOSC val, Xused)
      I	
      !  75 10  4 14
      !  75 10  4 15
      !  75 10  4 16
      !  75 10  4 17
      !  75 10  4 18
      17510  419      41A
      17510  420       OA
      !  75 10  4 21
      !  75 10  4 22
      !  75 10  4 23
      !  75 10  4 24
      !  75 10  5  1       9A

      Implicit None
      Character(Len(Flag_Done)), Intent(Out)  :: Status_Flag
      Integer,                   Intent(In)   :: Col_Beg,  Col_End
      Real,                     Intent(InOut)  :: Xresid
      Logical, Dimension(:),     Intent(In)   :: Xcandidate hour  !  Entries  to use.
                                                                  215
-------
Real,    Dimension(:),     Intent(In)  :: XOSC_val     ! OSC value
Logical, Dimension(:),   Intent(InOut)  :: Xused
If (Abs(Xresid) < EpsO) Then
   !  Success. Xresid == Zero  (fuzzily). Make it Zero  (exactly).
   Xresid = Zero
   Status_Flag = Flag_Done
   Return
End If

total amount osc = Zero
hours with osc = 0

Do iv = Col_Beg, Col_End
   If (Modulo(iv,25) == 0) Then
      !  Skip 25-th hour of the day.
      Cycle
   End If
   k = iv - Col Beg + 1    !  Entry in V
   total amount osc = total amount osc + XOSC val(k)
   hours with osc = hours with osc + 1
End Do

If (total amount osc > 0) Then
   !  If total amount osc > 0, then we will allocate
   !  all the precipitation.
   Status_Flag = Flag_Done
Else If (Abs(total_amount_osc) < EpsO) Then
   !  No OSC.
   Status_Flag = Flag_Continue
   Return
Else
   !  No candidates.
   Status_Flag = Flag_Continue
   Return
End If

frac_osc = Xresid /  total_amount_osc
Do iv = Col_Beg, Col_End
   If (Modulo(iv,25) == 0) Then
      !  Skip 25-th hour of the day.
      Cycle
   End If
                                                            216
-------
   k = iv - Col Beg + 1    !  Entry in V* arrays
   If (Abs(Xresid) < EpsO) Then
      !  Success. Xresid == Zero  (fuzzily).  Make it Zero  (exactly).
      Xresid = Zero
      Status_Flag = Flag_Done
      Return
   Else If (Xresid < -EpsO) Then
      !  Xresid < 0 -- error.
      Status_Flag = Flag_Error
      Return
   End If

   !  If the residue that would be left is less than the
   !  precision of the intrument, allocate the remainder
   !  in the current bucket.
   amt = Min(XOSC_val(k) * frac_osc, Xresid)
   If ((Abs(minimum_allocation-amt)  < EpsO)  .Or. &
          (EpsO <  (minimum allocation-amt)))  Then
      !  amt <= minimum allocation: amt is smaller than
      !  the initial precision of the data.  Choose a larger value.
      amt = Min(minimum_allocation,  Xresid)
   End If

   If ((Xresid - amt) < minimum_allocation)  Then
      amt = Xresid
   End If

   Vval(k) = Vval(k) + amt
   Xresid = Xresid - amt
   Xused(k)  = .True.
End Do
!  #1. If the amount to be distributed is less than or equal to 0.1 inches,
!      allocate the whole amount to the reporting hour (Col End).
                                                            217
-------
!      will be dumped into one of the previously allocated buckets.

Implicit None
Character(Len(Flag_Done)), Intent(Out)  :: Status_Flag
Integer,                   Intent(In)     :: Col_Beg, Col_End
Real,                      Intent(InOut)  :: Xresid
nv = Col End - Col Beg + 1

If ((Abs(minimum_allocation-Xresid) < EpsO)  &
      .Or. (EpsO < (minimum allocation-Xresid))) Then
   !  A <= B :: Abs(B-A) < EpsO  .Or.  EpsO < (B-A)
   !  Xresid <= minimum_allocation
   !  Case #1.  Dump the whole amount in the reporting hour.
   Vval(nv)  = Vval(nv) + Xresid

Else

   !  Case #2.  Allocate in chunks of minimum allocation.

   Do iv = Col_End, Col_Beg, -1
      If  (Modulo(iv,25) == 0) Then
          ! Skip 25-th hour of the day.
         Cycle
      End If

      k = iv - Col Beg + 1    !  Entry in V^ arrays

      If  (Abs(Xresid) < EpsO) Then
          ! Xresid <= 0
          ! No more precipitation to distribute. Terminate loop.
         Xresid = Zero
         Exit
      Else If ((Abs(minimum_allocation-Xresid)   < EpsO) &
            .Or.  (EpsO < (minimum allocation-Xresid))) Then
          ! 0 < Xresid <= minimum allocation.
          ! We are done, one way or the other.
          ! Add the residue to the hour of the measurement.
         Vval(nv)  = Vval(nv) + Xresid
         Xresid = Zero
         Exit
      End If

      !  Xresid >= minimum allocation.
      amt = Min(minimum_allocation, Xresid)
      Vval(k)  = Vval(k) + amt
      Xresid = Xresid - amt
                                                            218
-------
         End Do

         If (Abs(Xresid) >= EpsO) Then
            !  Dump any remaining amount to the hour of the measurement
            Vval(nv)  = Vval(nv) + Xresid
         End If
      End If
   End Subroutine Accum Last Resort
End Module Precipitation_module
                                                                  219
-------
raw data
   Use Binary Tree
   Use Date_Module
   Use Dump_MET
   Use Dump_RO
   Use ETO
   Use Evaporation_module
   Use Global_Variables
   Use loSubs
   Use Read_Info
   Use SAMSON
   Use Strings
   Use Utilsl
   Use Utils2
   Use Utils5
   Implicit None

Contains
   Subroutine Internal_Standard(Tests_Passed)

      Implicit None
      Logical, Intent(Out) :: Tests_Passed

      Real ::  pan Ep day      !  Class A pan evaporation  [mm/day]
      Real ::  pan_Rs, pan_up6d,  pan_Ta, pan_RH, pan_P
      Real ::  pan_EpTest
      Logical ::  okay

      Real ::  FWS_Result, E_fws
      Real ::  FWS_Rs, FWS_Rdiff,  FWS_Ta, FWS_Dew, FWS_u4d, FWS_RH, FWS_P
      Integer ::  nerrors
      Call Stat_Test(ULog, okay)
      If  (okay)  Then
         Write(6, *) '## Stats tests passed.'
         Write(ULog, *) '## Stats tests passed.'
      Else
         Write(6, *) '## Stats tests failed.'
         Write(ULog, *) '## Stats tests failed.'
                                                                  220
-------
   nerrors = nerrors + 1
End If
Call Test_EtO(okay)
If  (okay) Then
   Write(6,    9130)  'passed'
   Write(ULog,  9130)  'passed'
   Format  (Ix,  '## Tests of EtO:
Else
   Write(ULog,  9130)  'failed'
   nerrors = nerrors + 1
End If
                   ! Ta = 15.2  °C
                   ! u_p =261  km/day
                   ! Rs = 5964  W h m^-2 day^-1
                   ! RH = 43.7%
                   ! P = 78.1 kPa  (at elevation
Call Compute Ep(pan Ta, pan up6d, pan Rs, pan  RH,  pan  P,  pan Ep day,  okay)
If  (Abs(pan_EpTest-pan_Ep_day) < 0.01) Then
                                             pan_EpTest,  pan_Ep_day
                                             pan  EpTest,  pan Ep day
   Write (6,    9150)  '## Test Ep passed:
   Write (ULog, 9150)  '## Test Ep passed:
Else
   nerrors = nerrors + 1
   Write (6,    9150)  '
   Write (ULog, 9150)  '
End If
Format  (Ix, a, Ip2gl7.6
                       ?? Test Ep  failed  (expected,computed)
                       ?? Test Ep  failed  (expected,computed)
pan_EpTest, pan_Ep_day
pan_EpTest, pan_Ep_day
!  Test
FWS_Rdiff = 0         ! sam<
FWS_Ta =15.2         ! °C
FWS_Dew =3.0         ! °C
FWS_P =78.1          ! kPa
FWS_u4d = 261.0       ! km/day
FWS RH = 43.7         ! %;  unused by the  current  formulation
FWS_Result =0.08     ! mm/day
Call Compute_E_fws(FWS_Rs, FWS_Rdiff,  FWS_Ta,  FWS_Dew,  FWS_u4d,  FWS_RH,  FWS_P,  E_fws)
If  (Abs(FWS_Result-E_fws)  < 0.01) Then
   Write (6,    9170)  '##  Test E_fws passed:  ',  FWS_Result,  E_fws
                                                             221
-------
         Write (ULog, 9170) '## Test E_fws passed:  ', FWS_Result, E_fws
      Else
         nerrors = nerrors + 1
         Write (6,    9170) '?? Test E_fws failed  (expected,computed):  ',  FWS_Result,  E_fws
         Write (ULog, 9170) '?? Test E_fws failed  (expected,computed):  ',  FWS_Result,  E_fws
      End If
9170  Format (Ix, a, Ip2gl7.6)


      Tests_Passed = (nerrors == 0)
      If (Tests_Passed)  Then
         Write (6,    9170) '## Internal_Standard tests passed.'
         Write (ULog, 9170) '## Internal_Standard tests passed.'
      Else
         Write (6,    9170) '?? Internal_Standard tests failed.'
         Write (ULog, 9170) '?? Internal_Standard tests failed.'
      End If
      !Stop '@ Internal_Standard'
      !  Get basic info for all stations.
      Call Read_SAMSON_Station_Notes(Xstations)
      Call Read_Elevations(Xstations )
      Call Read_Info2(Xstations)
      Write(ULog, '(lx,a,iO)') 'Maximum Text Length =  ', Maximum Text Length
      If (Errors_Detected) Return

      Call Display Station Info(Xstations)
      If (Errors_Detected) Return

      Call Internal_Standard(Tests_Passed)
      If (.Not.  Tests_Passed)  Then
         Errors  Detected = .True.
         Return
      End If
                                                                  222
-------
Character(Len=132)  :: tbuf
Character(Len=l0)   :: wban
Logical            :: xOK, Node_Was_New, loop_once
Integer            :: j, nbuf, Jin, ios, nstations
Integer            :: nerrors
Type(Site_Info), Pointer :: xWBAN

Errors_Detected = .False.
nerrors = 0
Call IORead(jin, Filename, ok=xOK)
If  (.Not. xOK) Then
   Errors_Detected = .True.
   Return
End If

loop_once = .False.
nstations = 0
ReadFile: Do
   Read  (Jin,   '(a)',  iostat = ios) tbuf
   If  (ios  /=  0) Exit !  End-Of-File or Error

   nbuf = Len  trim(tbuf)
   If  (nbuf <= 0)  Cycle ReadFile  ! Empty line

    ! Remove comments from the line.
   j = Scan(tbuf(l:nbuf),  '!#')
   If  (j >  0)   Then
      tbuf(j:nbuf)  = ''
      nbuf  = Len_trim(tbuf(1:j))
      If (nbuf <= 0)  Cycle ReadFile !  Empty line
   End If

    ! Get the WBAN number or command
   j = 1
   Call GetQword(tbuf,  j, wban)
                                                            223
-------
      Case('exit', 'end' ,  'quit')
         Exit ReadFile

         !Case('Senegal')
         !    loop_once = .True.
         !    Call Add Senegal(Xstations, wban)
         !    Call Display_Station_Info(Xstations,  .True.)

      Case Default
      End Select

      Call Get_Node(Xstations, wban, Node_Was_New, xWBAN)
      If (Node_Was_New) Then
         !  Error: all nodes should be defined by now.
         Errors  Detected = .True.
         Write (6, *)    '?? Read_RO_List:  ', Trim(wban),  '  not  defined.
         Write (ULog, *)  '?? Read_RO_List:  ', Trim(wban),  '  not  defined.
         Stop '?? Read_RO_List:  all nodes should be defined  by now.'
      End If

      Call FLushAll()

      nstations  = nstations +  1
      Call Process_One_WBAN_Station(xWBAN,  nstations)

      Call FLushAll()

      If (Errors_Detected)  Then
         nerrors = nerrors + 1
         Errors  Detected = .False.
      End If

      If (loop_once)  Exit ReadFile
   End Do ReadFile
End Subroutine Read RO List
                                                               224
-------
      Implicit None
      Type(Site_Info) ,  Pointer    :: xWBAN    ! Pointer to a WBAN
      Integer,         Intent(In) :: nstations
      Integer
      Logical
      Character(Len=8 0)
      Logical
      Type(Name_type)
      Type(Filelnfo)
      Type(Timing_Type)
      Logical
YYf yyyy, nqo
Empty File        ! Empty or non-existent  file.
tbuf, xqO
Have_Precip_Data
Xnames
WF10, WF11
T
Some Years Missing, All Years Missing
      If (.Not.  Associated(xWBAN))  Then
         Write (6,*)     '?? Process_One_WBAN_Station: xWBAN not associated'
         Write (ULog,*)  '?? Process_One_WBAN_Station: xWBAN not associated'
         Stop '?? Process_One_WBAN_Station: xWBAN not associated'
      End If
      !  Point global variable to the current WBAN station.
      pWBAN => xWBAN
      Have_ppt_Obs_hourly_data = .False.
      Have_ppt_Obs_daily_data = .False.
      Write(ULog,  9130)  nstations, &
            Trim(pWBAN%WBAN),  &   ! 14914
            Trim(pWBAN%Text)      ! Fargo, ND
9130  Format (///,  &
            Ix,  10('#===#'), /, &
            Ix,  '#===# ', 10,  ':  Processing ', a,  ':  ', a)

      Errors_Detected = .False.

      Call Station_With_Missing_Data(pWBAN%WBAN, Have_Precip_Data)
      If (Have_Precip_Data)  Then
         Write(ULog,  9150)  'Yes'
      Else
         Write(ULog,  9150)  'No'
      End If
9150  Format (Ix,  '#===# ',  'Have_Precip_Data:  ',  a)

      Write(ULog,  *)
                                                                  225
-------
Call Generate File names()

Call Initialize_Output_Directory()

Maximum_Horizontal_Visibility = Zero
Maximum Ceiling Height = Zero

!  Algorithm:
!    = Find all WBAN*.z files
!    = Allocate storage
!    = Initialize storage
!    = For each wban_yy.z
!      + Collect data
!      + Issue error messages
!      + Store data & stats
!    = Process WBAN
!    = Deallocate storage
  Procedure:
  Do yyyy = MinYear, MaxYear
     Decompress file wban yy. z -> wban yy.txt   (in  some  temporary  directory)
     Open wbam yy.txt
         check headers against the information  in pWBAN
         Read data, copy selected fields to pWBAN
            Normalize windspeed to height = 10  meters
     Open Samson vl.l/wban yy.txt
         Read data, copy selected fields to pWBAN
     Detect missing values and other problems
     rO file <- v:\rO\AK\wban yy.txt
     Write data to rO file
     Save rO_file
  End Do
  make sure all years were written.
   !  Initialize file information derived type.
   Call Initialize_FileInfo(WF10, yyyy)
   Call Initialize_FileInfo(WF11, yyyy)

   !  Get all file names associated with this WBAN  and year.
                                                            226
-------
   !  Open and read SAMSON version 1.0  file
   Call Read_SAMSON_vlx(Trim(Xnames%Samson_vlO), WF10,  &
         Is_vll=.False., Empty_File=Empty_File)
   If  (.Not. Empty_File) Then
      Year_Data(yyyy)%SAMSON_vlO = Year_Data(yyyy)%SAMSON_vlO  +  1
   End If

   !  Open and read SAMSON version 1.1  file
   Call Read_SAMSON_vlx(Trim(Xnames%Samson_vll), WF11,  &
         Is_vll=.True., Empty_File=Empty_File)
   If  (.Not. Empty_File) Then
      Year_Data(yyyy)%SAMSON_vll = Year_Data(yyyy)%SAMSON_vll  +  1
   End If
End Do
Call Str_years(tbuf)
Write (ULog,  '(//,Ix,a,a,/)')  '## Years present:',  Trim(tbuf)

If  (All_Years_Missing) Then
    ! This year was missing;  do not  issue  it.
   Write(ULog, 9170)  &
         Trim(pWBAN%WBAN),  &   ! 24013
         Trim(pWBAN%Text)      ! Minot, ND
   Format (///, &
         Ix,  45('?'), /, &
         Ix,  '?? All years missing  for station  ',  a,  ':  ',  a,  /,
         Ix,  '?? No files will be issued.',  /,  &
         Ix,  45 ('?'), / )
   Go To 99999
End If
I  ^^^ Generate functions for missing data  et  al.
i  *** pin missing data.
Call Process_Set()

Call Process Evaporation Data()

!  Create RO files.
Call ToTTy('Dumping RO  files')
Do yyyy = MinYear, MaxYear
   If (Issue_This_Year(yyyy))  Then
      Call Dump_RO_One_Year(yyyy)
   End If
                                                             227
-------
      End Do

      !  Create MET file.
      Call Dump_MET_flie()

      Call Meta_Data_File()

      !  Dump ranges
      IWrite (ULog, 9430)
9190  Format (//,  &
            lx^ i*** WARNING: "hourly" header notwithstanding, the following
            Ix, '              ranges include the daily values', /)

      !Do jpar =1, f end
      !    !  Ranges et al.  have no meaning for the Observation Indicator
      !    If (jpar == f_OI)  Cycle  !  Observation Indicator
      I
      !    Call Stat_Output(ULog, Xp_ranges(jpar))
      !End Do
      !* 
      Call xTiming(T,  TEnd)

      If (Errors_Detected)  Then
         tbuf = '  Ill-failed: '  // Trim(pWBAN%WBAN)//': '//Trim(pWBAN%Text)
      Else
         tbuf = '  Ill-passed: '  // Trim(pWBAN%WBAN)//': '//Trim(pWBAN%Text)
      End If
      Call xTiming(T,  TPrint, ULog, Id=Trim(tbuf))
      I  See Assumption[1].  All weather data is located in one directory,
      I  namely Raw Data  dir.

      Implicit None
      Character(Len=*),         Intent(In)  :: WBAN
      Integer,                 Intent(In)  :: YY
      Type(Name_type),  Target, Intent(Out) :: Xnames

      Integer               ::  i
                                                                  228
-------
   Character(10)         :: tversion
   Character(MaxNamLen)  :: tname, tO
   Character(MaxNamLen),  Pointer  :: p
   Character(MaxNamLen),  Dimension!:), Pointer  :: YList =>  Null(
   Do i = 1, 2
      Select Case(i)
      Case(l)
         !  Look for SAMSON vl.0 file
         tversion = 'vl.0'
         tO = Trim(tname) //  '.z'
         p => Xnames%Samson vlO
      Case(2)
         !  Look for SAMSON vl.1 file
         tversion = 'vl.1'
         tO = Trim(tname) //  '.txt'
         p => Xnames%Samson_vll
      End Select

      p = '  '
      Call Find_Files(Xname=tO, Xdir=Raw_Data_dir, YList=YList)
      If (.Not. Associated(YList)) Then
         Write  (ULog,  9150) Trim(tversion), Trim(tO)
         Format(Ix, '?? Get_File_Names: Could not  find  SAMSON  ',  a,  '  file  ',  a)

      Else If  (Ubound(YList,!) >  1) Then
         Write  (ULog,  9170) Trim(tversion), Trim(tO)
         Format(Ix, '?? Get File  Names: Found more than one  SAMSON  ',  a,  '  file ',  a)

      Else
         p = YList(1)
      End If
   End Do
   If (Associated(YList)) Deallocate(YList)

End Subroutine Get File Names
Subroutine Initialize_FileInfo(tFI, yyyy)

   !  Initialize file information derived type.

   Implicit None
   Type(Filelnfo), Intent(InOut)  :: tFI
   Integer,        Intent(In)    :: yyyy
   tFI%Head%WBAN =
                                                               229
-------
      tFI%Head%Text = ''
      tFI%Head%Lat  = Coords('', 0, 0)
      tFI%Head%Lon  = Coords!11, 0, 0)
      tFI%Head%Elev = 0
      tFI%Head%TZ   = 0
      !  Expected number of observations
      If (IsLeapYear(yyyy))  Then
         tFI%Expected_Ndays = 366
      Else
         tFI%Expected_Ndays = 365
      End If
      Allocate(tFI%Every_Hour_Present(tFI%Expected_Ndays,Nhours)
      tFI%Every_Hour_Present = 0

   End Subroutine Initialize Filelnfo
   Subroutine Deallocate Filelnfo(tFI)
      Implicit None
      Type(Filelnfo), Intent(InOut)  :: tFI

      !  Release space allocated to the list
      ICall Add_Error(tFI%pHead, tFI%pTail,

      Deallocate(tFI%Every_Hour_Present)

   End Subroutine Deallocate_FileInfo

End Module Process Raw Data
                                                                  230
-------
read info
   Use Binary Tree
   Use Floating_Point_Comparisons
   Use GetNumbers
   Use GetNumbers
   Use Global Variables
   Use loSubs
   Use Strings
   Use UtilsO
   Implicit None
      Implicit None
      Type(Site Info), Pointer :: Xstations  !  Pointer to root of tree
      Character(Len=132)
      Character(Len=50)
      Integer
      Integer
      Logical
      Real
      Type(Coords)
tname, tbuf
wban, wtext, wstate, wtz
ierr, ios, Jin, i, j, k, icol, npos, nstations
ksign
xok, Node_Was_New
welev, rval, rlat, rlon
wlat, wlon, p
      Call ToTTy('Read_SAMSON_Station_Notes ')
      Errors Detected = .False.
      !SITES
                          WBAN
                                     LAT
                                                        ELEV   TZ
      ICO Boulder
      !    Denver
                                                                  231
-------
!PI Guam            41415     N 13 33

!  Skip lines until 'SITES' is found.
Call Skip_Until( 'SITES' , Trim(tname), jin)

icol = 20   ! WBAN number starts at this column.
nstations = 0
xWBAN => Null()
Loop: Do
   Read  (jin, '(a)',  lostat = ios) tbuf
   If (ios /= 0) Exit Loop
   ierr = 0

   !  Skip empty lines.
   If (Len_trim(tbuf)  == 0) Cycle Loop

   !  These lines make processing more dificult. Ignore  them.
   !                   123456789-123456789-1234567
   If (tbuf(1:27)  ==  '   This station has little  ') Cycle  Loop
   If (tbuf(1:05)  ==  '') Cycle Loop
   !                   123456789
   If (tbuf(1:09)  ==  'Footnotes') Exit Loop     ! No more  station  information.
   !  Secondary station info may be ignored  (e.g., see Denver  above).
   If (tbuf(1:03)  ==  '') Cycle Loop

   !  Remaining lines contain useful information.
   nstations = nstations + 1

   wstate = tbuf(1:2)
   wtext  = tbuf(4:icol-1)
   npos = icol
   Call GetQword(tbuf, npos, wban)

   !  loop twice, first for the latitude, then the longitude.
   Do i = 1, 2
      npos = NextNb(tbuf, npos)   ! Skip WhiteSpace

      p%Letter = tbuf(npos:npos)   ! N
      npos = npos + 1

      Call Get Numbers(tbuf, npos, xok, p%degrees)  ! 61
      If  (.Not.  xok)  Then
         Write  (ULog,  9130) 'degrees', Trim(tbuf)
         Format (Ix,   '?? Read_SAMSON_Station_Notes(', a,
         Errors Detected = .True.
         Return
      End If

      Call Get Numbers(tbuf, npos, xok, p%minutes)  ! 10
                                                            232
-------
   If (.Not. xok) Then
      Write (ULog, 9130)  'minutes', Trim(tbuf)
      Errors_Detected = .True.
      Return
   End If

   !  Why ksign et al.? Consider Longitude for Guam  (see  above).
   ksign = Sign(1.0, p%degrees)
   rval = ksign * (Abs(p%degrees)  + Abs(p%minutes)/60.0)  *  Degrees_to_Radians
   If (i == 1) Then
      !  Latitude: N or S
      wlat = p
      If (p%Letter == 'N') Then
         rlat = rval
      Else
         rlat = -rval
      End If
   Else
      !  Longitude: E or W
      wlon = p
      If (p%Letter == 'W') Then
         rlon = rval
      Else
         rlon = -rval
      End If
   End If
End Do

!  Get elevation  (meters)
Call  Get Numbers(tbuf, npos, xok,  welev)
If (.Not. xok) Then
   Write (ULog, 9150)  Trim(tbuf(npos:))
   Format (Ix, '?? Read_SAMSON_Station_Notes: Elevation  errors  in  »',  a,  '«')
   Errors_Detected = .True.
   Return
End If

!  Get time zone
Call  GetQword(tbuf,  npos,  wtz)

!  If  the last character is a  '/' then the next
!  line contains the rest of the text.
j  = Len trim(wtext)
If (wtext(j:j) == '/') Then
   Read  (Jin,   '(a)', lostat = ios)  tbuf
   If (ios /= 0)  Then
      Write (ULog, 9170)
      Format  (Ix, '?? Read_SAMSON_Station_Notes:  Expecting  another line since  ',  &
            'site ends in "/"')
      Errors Detected = .True.
                                                         233
-------
               Return
            End If

            wtext(j+l:)  = Adjustl(tbuf(l:icol-l))
            j  = Len trim(wtext)
         End If
         Maximum_Text_Length = Max(Maximum_Text_Length, j
         wtext(j+l:)  =  ', '  // Trim(wstate)

!!IWrite(ULog,*)  '    wtext ..: '
!!IWrite(ULog,*)  '    wban ...: '
!!IWrite(ULog,*)  '    wlat ...: '
!!IWrite(ULog,*)  '    wlon ...: '
!!IWrite(ULog,*)  '    welev ..: '
!!IWrite(ULog,*)  '    wtz ....: '
         !  All  nodes should be new.
         Call  Get_Node(Xstations,  wban,  Node_Was_New, xWBAN)
         If (Node_Was_New)  Then
            !  New node initialization.
            xWBAN%WBAN = wban
            xWBAN%State = wstate
            xWBAN%Text = wtext
            xWBAN%Lat  = wlat
            xWBAN%Lat_radians = rlat
            xWBAN%Lon  = wlon
            xWBAN%Lon radians = rlon
            xWBAN%Elev = welev
            xWBAN%TZ   = wtz
            k  = Index(wtz,  '(')  -  1
            Read(wtz(1:k),  *)  xWBAN%iTZ
         Else
            Errors_Detected = .True.
            Write (ULog, 9190)  Trim(xWBAN%WBAN),  Trim(xWBAN%Text)
            Format (Ix,  '?? Read_SAMSON_Station_Notes:  Duplicated station
            Return
         End If
      End Do Loop
      Call  lOClose(jin)
   End Subroutine Read SAMSON Station Notes
                                                                  234
-------
!  Get station Anemometer Elevation  (in Feet) & Dates
I
!  To generate the (text) elevation  file:
!  # Open WordPerfect file
!      ...\3MET\raw.data\Elevation\Anemometer heights.wpd
!  # Make sure there are no "?"
!  # Choose Print.
!      Select Printer: Generic Text  only
!      Print Details: Print to file.
!  # WP Menu:  Format/Page/Page Setup
!      Select Landscape
!      Page margins:  set all to Zero.
!  # Return to the document and manually increase
!      the width of the colums
!  # Print the document.
!  # Edit the *.prn document:
!      Align fields  (use Ed4W)
!      Remove "M^L, Ed4w regex \013\012  (decimal)
!      Add "H	" line — see below.
!  # Done.
!  File fragment:
I
114733
Implicit None
Type(Site_Info),  Pointer :: Xstations   ! Pointer to root of tree
                      wban
                      tbuf, tname
                      ios, j in
Character(Len=50)
Character(Len=132)
Integer

Logical
Integer
Real
Character(Len=15)
Type(Site_Info),  Pointer :: xWBAN  ! Pointer to the current WBAN station.

Call ToTTy('Read_Elevations')
Errors_Detected = .False.

!  See 
!   14914   86 feet = 26.213 meter   1953-11-01
!           28 feet = 8.5344 meter   1963-05-11
!tname = 'v:\Docs\Anemometer heights.prn'
                                                            235
-------
   tname = 'z:\Elevation\Anemometer heights.prn'
   Call IORead(jin, tname)

   xWBAN => Null()
   Loop: Do
      Read (Jin, '(a)', Iostat=ios)  tbuf
      If (ios /= 0) Exit Loop

      !  Skip comments.
      If (tbuf(1:1) == '!') Cycle Loop
      !  Skip empty lines.
      If (Len_trim(tbuf)  == 0) Cycle Loop

      !  Not an empty line. If field 1  (the Id) is non-blank,
      !  then the line contains a new station.
      npos = 5
      wban = tbuf(1:npos)
      If (Len_trim(wban)  > 0)  Then
         !  Start of elevations for a new station.
         Call Get_Node(Xstations, wban, Node_Was_New, xWBAN)
         If (Node_Was_New) Then
            !  Error:  all nodes should be defined by now.
            Errors Detected = .True.
            Write  (6, *)     '?? Read_Elevations:  ', Trim(wban),  '  not  defined.
            Write  (ULog,  *) '?? Read_Elevations:  ', Trim(wban),  '  not  defined.
            Stop '?? Read Elevations: all nodes should be defined  by now.'
         End If
      End If

      npos = npos + 1
      Call Get Numbers(tbuf, npos, xok, elevation ft)
      If (.Not.  xok)  Then
         Write  (ULog, 9130) Trim(tbuf)
         Format (Ix,   '?? Read Elevations: Elevation Errors  in  »',  a,  '«')
         Errors_Detected = .True.
         Return
      End If

      Call GetQword(tbuf, npos, edate)

      Call Store_Elevation(xWBAN, edate, elevation_ft)
   End Do Loop
   Call lOClose(jin)
Subroutine Store_Elevation(xWBAN, edate, elevation_ft)

   !  Store elevation data  for the given station.
                                                               236
-------
Implicit None
Type(Site_Info) ,  Pointer     :: xWBAN   ! Intent(InOut)
Character(Len=*), Intent(In)  :: edate
Real,              Intent(In)  :: elevation_ft

Integer, Pointer ::  Nelev
Integer ::  yyyy, mm, dd, ios
Logical ::  ok
Type(ElevationBlock), Dimension(:), Pointer  :: Elev_Directives

Errors_Detected = .False.
If (.Not.  Associated(xWBAN))  Then
   Write (6,*) '?? Store_Elevation: xWBAN not associated'
   Write (ULog,*) '?? Store_Elevation: xWBAN not associated'
   Stop '?? Store_Elevation:  xWBAN not associated'
End If

Nelev => xWBAN%Nelev
Elev_Directives => xWBAN%Elev_Directives

If (Nelev >= Ubound(Elev_Directives,l)) Then
   Write (ULog, *)   '?? Increase Dimension of Elev Directives.'
   Errors Detected = .True.
   Return
End If
Read (edate ,  '(14,Ix,12,Ix,12)', iostat = ios) yyyy, mm, dd
If (ios /= 0)  Then
   Errors Detected =  .True.
   Write (6,*)    '?? Store_Elevation: Problems With edate  "',  Trim(edate
   Write (ULog,*) '?? Store_Elevation: Problems With edate  "',  Trim(edate
   !Stop '?? Store_Elevation:  Problems With edate'
End If
!  Make sure entries in chronological order
If (Nelev > 1) Then
   ok = Elev_Directives(Nelev-1)%Julian_Day < &
         Elev_Directives(Nelev)%Julian_Day
   If (.Not. Ok) Then
                                                            237
-------
         Errors_Detected = .True.
         Write (ULog, 9130) Trim(xWBAN%WBAN), Trim(xWBAN%Text)
         Write (ULog, 9150)
         Format(Ix,  '?? Store_Elevation:  ',  a,  :,  ',  ',  a)
         Format(lx,  '   Elevation Data not  in chronological  order.'
         Return
      End If
   End If
End Subroutine Store Elevation
   Implicit None
   Type(Site Info), Pointer :: Xstations   ! Pointer to  root  of  tree

   Character(Len=50)  :: wban
   Character(Len=132)  :: tbuf, tname
   Integer            :: ios,  Jin
   Logical            :: xok,  Node_Was_New
   Type(Site_Info), Pointer :: xWBAN  ! Pointer to the current WBAN station.

   !  This is a comma-delimited file.
   Character(Len=*), Parameter :: Xdelim =  ','

   Integer, Parameter :: dimz = 13
   Integer, Parameter :: max len = 50
   Character(Len=max_len) , Dimension(dimz)   :: zfields
   Character(Len=max_len) :: gObuf
   Integer            :  : nargs, npos, nb
   Integer            :: nlines, tlen, gOlen
   Call ToTTy('Read_Info2')
   Errors_Detected = .False.

   !  See 
   tname = 'v:\Docs\WBAN.txt'
   Call IORead(jin, tname)

   nlines = 0
   xWBAN => Null()
   Loop: Do
      Read (Jin, '(a)', Iostat=ios) tbuf
      If (ios /= 0) Exit Loop

      !  Skip comments.
      If (tbuf(1:1) ==  '!')  Cycle  Loop
      !  Skip empty lines.
                                                               238
-------
If (Len_trim(tbuf)  == 0) Cycle Loop
tlen = Len_trim(tbuf)
nlines = nlines + 1
!  Split the line.
nargs = 0
zfields = ''
npos = 1

IWrite (uoutl, 9230) nlines, tbuf(1:tlen)
Format (/, Ix, 'Line ', 13,  ':  ', a)
    10
    11
    12
    13
        149B
Split_the_line: Do
   !  Terminate if End-of-Line
   If (npos > tlen) Exit Split_the_line

   !  Find next delimiter
   nb = Scan(tbuf(npos:tlen), Set=Xdelim)
   If (nb > 0) Then
      nb = nb + npos - 1 - 1
   Else
      !  Last field has no trailing delimiter.
      nb = tlen
   End If

   If (nargs >= dimz)  Then
      Errors_Detected = .True.
      Write (*, *) '  ?? Increase the dimension of zfields.
      Exit Loop
   End If
                                                         239
-------
      Exit Loop
   End If

   nargs = nargs + 1
   zfields(nargs)  = tbuf(npos:nb)
   !Write  (uoutl,  9330) nargs, Trim(zfields(nargs))
   Format  (ix, ix, 13,  ':  ',  a)

   !  Note that tbuf(nb + 1) == Xdelim
   npos = nb + 2

End Do Split_the_line

wb an = zfields(l)
If (Len_trim(wban) > 0) Then
   Call Get_Node(Xstations, wban, Node_Was_New, xWBAN)
   If (Node_Was_New) Then
      !  Error: all nodes should be defined by now.
      Errors_Detected =  .True.
      Write  (6, *)     '??  Read_Info2:  ', Trim(wban),  '  not  defined.'
      Write  (ULog, *)  '??  Read_Info2:  ', Trim(wban),  '  not  defined.'
      Stop '?? Read Info2: all nodes should be defined  by now.'
   End If
End If

!  Replace the station text.
qObuf = Trim(zfields(2)) // ', ' //  Trim(zfields(3))
gOlen = Len_trim(gObuf)

If (xWBAN%Text /= gObuf(1:gOlen)) Then
   IWrite  (ULog, 9430) Trim(xWBAN%Text), gObuf(1:gOlen)
   Format  (Ix,  'Replacing  "', a, '"  with "', a,  '"')
End If
IRead (zfields(6), *) rlat
Irlat = Sign(rlat,xWBAN%Lat_radians) * Degrees_to_Radians
I
IRead (zfields(7), *) rlon
!rlon = Sign(rlon,xWBAN%Lon radians) * Degrees to  Radians
!!  A preview of the differences show all Abs(deltas)  <  0.20  minutes
!If (Abs(xWBAN%Lat_radians - rlat) > 0.20) Then
!    Write (6,  *)     '??  Read_Info2: Lats  different  (N,r,delta):  ',  xWBAN%Lat_radians,  rlat,  xWBAN%Lat_radians
!    Write (ULog,  *)  '??  Read_Info2: Lats  different  (N,r,delta):  ',  xWBAN%Lat_radians,  rlat,  xWBAN%Lat_radians


                                                         240
-------
         !End If

         !delta_sec = (xWBAN%Lon_radians - rlon) * Radians_to_Degrees *  60
         !If (Abs(xWBAN%Lon_radians - rlon) > 0.20) Then
         !    Write  (6, *)     '?? Read_Info2: Ions different  (N,r,delta):  ',  xWBAN%Lon_radians,  rlon,  xWBAN%Lon_radians  - rlon,  delta_sec
         !    Write  (ULog,  *)  '?? Read_Info2: Ions different  (W,r,delta):  ',  xWBAN%Lon_radians,  rlon,  xWBAN%Lon_radians  - rlon,  delta_sec
         !End If
   End Subroutine Read_Info2

End Module Read Info
                                                                  241
-------
Red  Black
!  []  Robin A. Vowels. 1998. Algorithms and data
!     structures in F and Fortran. Pages 98-130.
!     ISBN: 0-9640135-4-1
I
!  Example: See
!      ...\0.examples\Red.Black.BinaryTree\Red_Black.f90
!  for an example.
I
!     Figure 3.14  Algorithm for manipulating a
!                  Red-Black binary tree
   Use Global Variables
   Implicit None
   Private
   Logical, Parameter, Public
   Logical, Parameter, Public
   Integer, Parameter, Public
   Integer, Parameter, Public
Red = .True.
Black = .False
Right = 1
Left = 0
   Public
   Character(Len=l), Parameter
   Character(Len=l), Parameter
   Character(Len=l), Parameter
   Character(Len=l), Parameter
                                                                       character.
 White =
      !  This procedure receives an isolated node Xnew, in which all pointers
      !  null, and which contains a value, ready for insertion in the tree. T
      !  procedure searches the tree from the root along a path determined by
      !  the node Xnew's value, until the item of found or the path terminate
      !  in a null pointer.
      I
                                                                  242
-------
!  colored red. The pointer to its parent is initialized. The
!  pointer V indicates the position of the current node in the tree as
!  the search progresses along a branch. Pointer W gives the current
!  parent of V.
I
!  In:  Knew — A pointer to a node to be inserted into the tree.
!  Out: Knew — points to the node containing the value  (old or new node)
!       Node_Was_New — If Xnew was inserted, .True.
!                    — If the value was in the tree,  .False.

Implicit None
Type(Site_Info),  Pointer :
Type(Site_Info),  Pointer :
Logical,     Intent(Out) :
Node_Was_New = .True.
V => Xroot  !  The initial position of the search.
Nullify(W)  !  A pointer to the parent of V.

!  Find the place in the tree to graft the new node - travel from
!  the root to a node containing a null pointer, unless the item
!  is already there.
Do
   If (.Not. Associated(V))  Exit
   W => V

   If (Xnew%WBAN == V%WBAN)  Then
      !  The item is already in the tree. No new node to insert.
      !  Give the user a pointer to the existing node and return.
      Deallocate(Xnew)   !  Release storage.
      Xnew => V
      Node_Was_New = .False.
      Return
   Else If  (Xnew%WBAN < V%WBAN)  Then
      V => V%pLeft
   Else
      V => V%pRight
   End If
End Do

!  We have found a node W whose left or right pointer field is null.

Xnew%Parent => W                  ! Make the new node point at its parent.
If (.Not.  Associated(W)) Then     ! There's only one node in the tree.
   Xroot => Xnew
   Nullify(Xroot% Parent)
   Xroot%Color = Black
                                                            243
-------
   Else
      W%pRight => Knew               ! The new  node  is  in  the  right branch.
   End If
End Subroutine Insert In Tree
Subroutine ROTATE_LEFT(Root, Pivot)
   !  This procedure performs a left rotation  of  a  branch  of  a
   !  Red-Black tree, with node  as the pivot.
   I
   !  In: Pivot = a pointer to the node about  which a  branch  of
   !                    the tree is to be rotated.

   Implicit None
   Type(Site_Info), Pointer  :: Root
   Type(Site_Info), Pointer  :: Pivot

   Type(Site_Info), Pointer  :: Y, X

   X => Pivot              ! Can't use Pivot  directly.  Must  use  a temporary.

   Y => X%pRight           ! Y is the right child  of  X.
   X%pRight => Y%pLeft     ! Change the left  subtree  of Y into X's right subtree.
   If (Associated(Y%pLeft))   Then
      Y%pLeft%Parent => X  ! The left sub-node of  Y points back  at X --
      !                     ! that is, X is now the parent of Y's left subtree.
   End If
   Y%Parent => X%Parent    ! X's parent now becomes the parent of Y.
   If (.Not. Associated(X%Parent)) Then    ! We are at the root node.
      Root => Y
   Else If  (Associated(X, X%Parent%pLeft)) Then  !  X is  on the  left of its parent.
      X%Parent%pLeft => Y                        !  The left pointer of X's parent points at Y.
   Else                                          !  X is  on the  right subtree of its parent.
      X%Parent%pRight => Y                       !  The right  pointer of X's parent points at Y.
   End If
   Y%pLeft => X     ! Make X  a left child of node Y.  (X's  left  subtree comes with X).
   X%Parent => Y    ! X's parent is now Y.

End Subroutine ROTATE LEFT
                                                                244
-------
Subroutine ROTATE_RIGHT(Root,  Pivot)
   !  This procedure performs a right rotation of a branch of a Red-Black tree, with node 
   !  as the pivot. This procedure is the mirror image of ROTATE_LEFT, with the words Left
   !  and Right interchanged.
   I
   !  In: Pivot = a pointer to the node about which a branch of the tree is to be  rotated.

   Implicit None
   Type(Site_Info), Pointer :: Root
   Type(Site_Info), Pointer :: Pivot

   Type(Site_Info), Pointer :: Y, X

   X => Pivot               ! Can't use Pivot directly. Must use a temporary.

   Y => X%pLeft             ! Y is the left child of X.
   X%pLeft => Y%pRight      ! Change the right subtree of Y into X's left subtree.
   If  (Associated(Y%pRight)) Then
      Y%pRight%Parent => X  ! The right sub-node of Y points back at X --
       !                     ! that is, X is now the parent of Y's right subtree
   End If
   Y%Parent => X%Parent     ! X's parent now becomes the parent of Y.
   If  (.Not. Associated(X%Parent))  Then    ! We are at the root node.
      Root => Y
   Else If  (Associated(X, X%Parent%pRight)) Then   ! X is on the right of its parent.
      X%Parent%pRight => Y  ! The right pointer of X's parent points at Y.
   Else                     ! X is on the left of its parent.
      X%Parent%pLeft => Y   ! The left pointer of X's parent points at Y.
   End If
   Y%pRight => X            ! Put X on the  left of Y.
   X%Parent => Y            ! X's parent is now Y.

End Subroutine ROTATE RIGHT
Subroutine DELETE(Root, Vanish)
   !  This subroutine deletes a node from a Red-Black binary tree.
   !  There are four main sections:
   I
   !  Section 1: The tree is checked to see if it is empty, and if
   !             it is, the subroutine quits.
   !  Section 3: Deals with the straight-forward case where the node to be deleted
   !             has no children.
   I
   !  Section 4: Deals with the case where the node to be deleted has one child.
                                                               245
-------
!  In: Vanish points at the node to be deleted.

Implicit None

Type(Site_Info),  Pointer :: Root
Type(Site Info),  Pointer :: Vanish
X => Vanish
!  Case 1:  the tree is empty.
If (.Not. Associated(X))  Then  ! The tree is empty.
   Return
End If

!  Case 2:  the node has 2 children.
!  We find the successor node, move the content of that node to the  current  node  X,
!  and then delete the successor node.
If (Associated(X%pLeft) .And. Associated(X%pRight)) Then  ! Find the next-largest node.
   !  The next-largest node is found in the right  subtree.
   Child => X%pRight
   Do
      If (.Not. Associated(Child%pLeft))  Exit  ! Seek the  left-most  node  of  the subtree
      Child => Child%pLeft
   End Do
   !  The successor is now due for deletion. This will be handled by Case  3
   !  (the node is a leaf) or by Case 4  (the node has one child).
   X => Child
End If

!  Now delete node X.
!  Case 3:  the node has no children.
If ((.Not. Associated(X%pRight))  .And.  (.Not. Associated(X%pLeft))) Then
   !  The node is a leaf.
   If (.Not. Associated(X%Parent))  Then    ! Node X is the root.
      Deallocate(X)
      Nullify(Root)
      Return
   End If
   If (X%Color .Eqv. Black) Then  !  If the color of the node to be deleted  is  black  .
      Call RESTRUCTURE_AFTER_DELETION(Root, X)
   End If
   If (Associated(X, X%Parent%pRight)) Then  ! Chop off the leaf X.
      Nullify(X%Parent%pRight)               ! Remove X which is a right child..


                                                            246
-------
      Else
         Nullify(X%Parent%pLeft)                 ! Remove X which is a left child.
      End If
      Deallocate(X)
      Return
   End If

   !  Case 4:  the node has one child. First find out which it is, and then splice  it  out.
   If (.Not. Associated(X%pRight))  Then
      Child => X%pLeft  !  It's a left child of X.
   Else
      Child => X%pRight !  It's a right child of X.
   End If

   If (.Not. Associated(X%Parent))  Then  ! Node X is the root.
      Root => Child                      ! X's only child becomes the root.
      Deallocate(X)                      ! Get rid of X.
      Nullify(Root%Parent)               ! The root can't have a parent.
      Root%Color = Black                 ! Color it black ...
      Return                             ! ... and guit.
   Else                                  ! Node X is not the root. Splice out the node.
      !  Make the grandparent point at the child.
      If (Associated(X, X%Parent%pRight)) Then  ! Node X is a right child.
         X%Parent%pRight => Child
      Else                               ! Node X is a left child.
         X%Parent%pLeft => Child
      End If

      Child%Parent => X%Parent           ! Make the child point up at the grandparent.
   End If

   !  The next segment will restructure the tree when the deleted node is
   !  black. However, there is one particular case when the deleted note is
   !  black and its child is red.  In this situation, its child is merely
   !  re-colored black, thus restoring the deficiency of one black node. The
   !  following code indirectly achieves this: RESTRUCTURE_AFTER_DELETION is
   !  called, its main loop is not executed,  and the subroutine terminates after
   !  re-coloring the child black.
   If (X%Color .Eqv. Black) Then !  If the color of the node to be deleted is black ...
      Call RESTRUCTURE_AFTER_DELETION(Root,  Child)
   End If

   Deallocate(X)

End Subroutine DELETE


Subroutine RESTRUCTURE_AFTER_DELETION(Root,  Current)
   !  This procedure re-colors nodes and/or restructures a Red-Black tree
   !  following a deletion. This routine is entered when the deleted node


                                                               247
-------
!  was black. (Node X is the child of the deleted node). The crux is to
!  balance the two subtrees whose roots are node X and its brother.
!  General strategy:
!  (1) Simple case: If the child of the deleted node is red, change it
!                   to black and finish.
!  (2) General case:  Either:
!      (2a) Perform a rotation about the parent, so as to bring a node
!           into the subtree, to compensate for the deleted node. In
!           this case, color the new node black and finish.
!      (2b) Change a node of the sibling's subtree from black to red,
!           and move up the tree. In this event, repeat step  (2).
I
!  In: Current = points at the child of the deleted node.
Implicit None
Type(Site_Info),  Pointer :: X !  the child of the deleted node
Type(Site_Info),  Pointer :: Brother

X => Current
   !  The crux balances the two subtrees whose roots are at node X and its brother.
   If (Associated(X, X%Parent%pLeft))  Then  ! Node X is a left child.
      Brother => X%Parent%pRight
      If (Brother%Color .Eqv. Red) Then
         !  Case 1: Rotate left about X's parent, and re-color.
         Brother%Color = Black
         X%Parent%Color = Red
         Call ROTATE_Left(Root, X%Parent)
         Brother => X%Parent%pRight
      End If                                !  ... and move on to apply case  2.

      If (COLOR_OF(Brother%pLeft) .Eqv. Black .And.   &  !  If both children  of the
            COLOR_OF(Brother%pRight)  .Eqv. Black) Then       ! brother are black  ...
         !  Case 2: Color the brother red, and move up the tree.
         Brother%Color = Red
         X => X%Parent !  Move up the tree.
      Else
         If (COLOR_OF(Brother%pRight)  .Eqv. Black) Then
            !  Case 3: Rotate right about the brother, and re-color
            If  (Associated(Brother%pLeft)) Then
               Brother%pLeft%Color = Black
            End If
            Brother%Color = Red
                                                            248
-------
         Call ROTATE_RIGHT(Root, Brother)
         Brother => X%Parent%pRight
      End If                             ! ...  and go on to Case 4.

      !  Case 4: Rotate left about X's parent,  which brings an extra node to
      !  the subtree through X, and which is then colored black.
      Brother%Color = X%Parent%Color
      X%Parent%Color = Black
      Brother%pRight%Color = Black
      Call ROTATE_Left(Root, X%Parent)   !  Brings a black node to the left
      !                                   !  subtree; Left & Right  subtrees are balanced.
      Exit TREE_CLIMBING_LOOP            !  Quit, rebalancing is complete.
   End If
Else                                     !  Node X is a right child.
   !  Same as the THEN clause, with "Right" and "Left" interchanged.
   Brother => X%Parent%pLeft
   If (Brother%Color .Eqv. Red) Then
      !  Case 1: Rotate left about X's parent,  and re-color
      Brother%Color = Black
      X%Parent%Color = Red
      Call ROTATE_RIGHT(Root, X%Parent)
      Brother => X%Parent%pLeft
   End If                                !  ... and move on to apply case 2.

   If (COLOR_OF(Brother%pLeft) .Eqv. Black .And.   &  !  If both children of the
         COLOR_OF(Brother%pRight)  .Eqv. Black) Then      !  brother are black  ...
      !  Case 2: Color the brother red, and move up the tree.
      Brother%Color = Red
      X => X%Parent                      !  Move up the tree.
   Else
      If (COLOR_OF(Brother%pLeft)  .Eqv. Black) Then
         !  Case 3: Rotate left about the brother, and re-color
         If (Associated(Brother%pRight))  Then
            Brother%pRight%Color = Black
         End If
         Brother%Color = Red
         Call ROTATE_Left(Root, Brother)
         Brother => X%Parent%pLeft
      End If                             ! ...  and go on to Case 4.

      !  Case 4: Rotate right about X's parent, which brings an extra node to
      !  the subtree through X, and which is then colored black.
      Brother%Color = X%Parent%Color
      X%Parent%Color = Black
      Brother%pLeft%Color = Black
      Call ROTATE_RIGHT(Root, X%Parent)  !  Brings a black node to the right
      !  subtree; Left & Right subtrees are balanced.
      Exit TREE_CLIMBING_LOOP            !  Quit, rebalancing is complete.
   End If
End If
                                                         249
-------
   End Do TREE_CLIMBING_LOOP

   X%Color = Black !  Having encountered a red node, color it black and quit.

End Subroutine RESTRUCTURE AFTER DELETION
   Type(Site_Info),  Pointer :: Node_Ptr

   Logical ::  Node_Color

   If (Associated(Node_Ptr))  Then
      Node_Color = Node_Ptr%Color
   Else
      Node Color = Black
   End If
Subroutine Rebalance_Tree(Root,  Dummy_Current)
   !  This procedure rebalances and re-colors the nodes of a Red-Black sorted binary tree,
   !  following an insertion. The node pointed at by X has just been inserted into the tree,
   !  and is the node where one of the 4 properties of Red-Black trees may have been violated.
   !  After a breach of Rule 1 has been rectified, X is adjusted to point at its grandparent,
   !  where tests for a breach of the rules is again carried out, and so on for each grandparent
   !  in turn. If Rules 2 or 3 are breached, one or two rotations of a branch of the tree are
   !  carried out (about the current node X), and the procedure terminates.
   !  When this procedure terminates, the root node is black, and the tree is quasi-balanced,
   !  and the four properties of Red-Black trees are satisfied:
   I
   !  Rule 1. Every node is either red or black;
   !  Rule 2. Every null pointer is considered to be pointing to an imaginary black node;
   !  Rule 3. If a node is red, then both its children are black; and
   !  Rule 4. Every direct path from the root to a leaf contains the same number of black nodes.
   I
   !  In: Dummy_Current = a pointer to a (red) node that has been inserted in the tree.
   Implicit None
   Type(Site_Info), Pointer :: Root
   Type(Site Info), Pointer :: Dummy Current

   Type(Site_Info), Pointer :: X, Y
   Logical :: Red Uncle


                                                               250
-------
Logical ::  Iterating

X => Dummy_Current

Do
   !  when X and its parent are both red.
   Iterating = .Not. Associated(X, Root)  ! Cannot iterate when we  are  at  the  root.
   If  (Iterating) Then                    ! There must be a parent  ...
      Iterating = X%Parent%Color  .Eqv. Red
   End If
   If  (Iterating) Then                    ! ... and there must be a  grandparent.
      Iterating = Associated(X%Parent%Parent)
   End If
   If  (.Not. Iterating) Exit

   !  We enter this loop when X and its parent are both  red.
   If  (Associated(X%Parent, X%Parent%Parent%pLeft)) Then
       ! The parent is a left node of X's  grandparent.
      Y => X%Parent%Parent%pRight         ! Get the address of the  uncle.
      RedJJncle = Associated(Y)
      If (RedJJncle) Then
         RedJJncle = Y%Color .Eqv. Red
      End If
      If (RedJJncle) Then
         !  CASE 1.  There is an uncle. X  and its parent and
         !  uncle are all red. Fix violation of Rule 3.
         X%Parent%Color = Black           ! The parent must be black.
         Y%Color = Black                  ! The uncle must be black.
         X%Parent%Parent%Color = Red      ! The grandparent must be  red.
         X => X%Parent%Parent             ! Move 2 places up the tree,  to  the  grandparent.
      Else                                ! The uncle is black, or  is non-existent.
         If (Associated(X, X%Parent%pRight)) Then ! CASE 2.
            X => X%Parent                 ! Move up the  tree.
            Call ROTATE_Left(Root, X)
         End If
         !  CASE 3.
         X%Parent%Color = Black
         X%Parent%Parent%Color = Red
         Call ROTATEJ^IIGHT (Root, X%Parent%Parent)
      End If
       ! This segment is the mirror image  of the code for the "then" part,
       ! with the words Right and Left interchanged.
   Else                                   ! The parent is a right node  of  X's  grandparent.
      Y => X%Parent%Parent%pLeft          ! Get the address of the  uncle.
      RedJJncle = Associated(Y)
      If (RedJJncle) Then
         RedJJncle = Y%Color .Eqv. Red
      End If
      If (RedJJncle) Then                 ! CASE 1.
         X%Parent%Color = Black           ! The parent must be black.


                                                            251
-------
            Y%Color = Black                  ! The uncle must be black.
            X%Parent%Parent%Color = Red      ! The grandparent must be red.
            X => X%Parent%Parent             ! Move 2 places up the tree, to the grandparent.
         Else                                ! X and its parent are red, but its uncle  is blac
            !                                 ! or is missing. Fix violation of Rule  3.
            If (Associated(X, X%Parent%pLeft)) Then !  CASE 2.
               X => X%Parent                 ! Move up the tree.
               Call ROTATE_RIGHT(Root, X)
            End If
            !  CASE 3.
            X%Parent%Color = Black
            X%Parent%Parent%Color = Red
            Call ROTATE_Left(Root, X%Parent%Parent)
         End If
      End If
   End Do

   Root%Color = Black !  Ensure that the root  is black.

End Subroutine Rebalance Tree
Recursive Subroutine TRAVERSE(Current)
   !  This recursive subroutine retrieves and prints the values from the tree  in  ascending  order.
   Implicit None
   Type(Site_Info), Pointer :: Current

   If (Associated(Current%pLeft))  Then  ! Take the left subtree.
      Call TRAVERSE(Current%pLeft)
   End If
   If (Associated(Current%pRight))  Then  ! Take the right subtree.
      Call TRAVERSE(Current%pRight)
   End If

End Subroutine TRAVERSE
Subroutine DISPLAY_SIDEWAYS(Root)
   !  This procedure prints/displays a binary tree sideways.
   I
   !  Method:  An in-order traversal of the tree is first performed, in order
   !  to determine the longest branch  (that is, the greatest depth of the
   !  tree).  This value is used to determine the number of nodes as if all
   !  branches were of this length. For each node, an excursion is taken from
   !  the root to the node to be printed. The route is determined by the
   !  number of the current node  (nodes number from 1 to 2**Max Depth-1), and
                                                               252
-------
!  is decoded by Mask, initially set to 2**Max_Depth/2. Each bit  in the
!  binary representation of the node's number corresponds to a  fork in the
!  tree. A zero bit causes a right path to be taken, while a one-bit
!  causes a left path to be taken. When a node is absent from the tree,
!  an empty line is written out so as to maintain the  geometry  of the tree.

Implicit None
Type(Site_Info),  Pointer :: Root

Type(Site_Info),  Pointer :: Ptr
Integer              ::  Max Nodes
Integer              ::  Node_No

!  Used to indicate the current level of a node during an excursion from
!  the root to a node to be printed.
Integer :
Integer :
Logical :
Max Depth !  The maximum depth of the tree  (levels of nodes).
Printed
Character(Len=l0)  ::  Layout !  For preparing a dynamic format specification.
!  Section to visit each node of the tree.
!  Nodes are numbered starting from the right-most leaf, as if doing  an  in-order  traversal.
Do Node_No = 1, Max_Nodes - 1
   Ptr => Root  !  Begin each journey from the root.
   Mask = Max_Nodes / 2
   Printed = .False.

   !  Section to travel from the root, to the node to be printed.
   Do Level = 1, 1000
      If (Iand(Node_No, Mask) /= 0) Then
         !  Take the right path.
         Ptr => Ptr%pRight
      Else !  Take the left path.
         If ((Modulo(Node_No, Mask) == 0) .Or.  (Mask == 1)) Then
            Write (unit=*, fmt=*)
            Dmask = 2 * Mask
            If  (Node_No /= Max_Nodes/2) Then
               Write (unit=Layout, fmt="(a, 13, a)") "(tr", 10*(Level-1)+1,  ", a)"
               If (Iand(Node_No, Dmask) /= 0) Then
                  Write (unit=*, fmt=Layout, advance="no") "\"
               Else
                  Write (unit=*, fmt=Layout, advance="no") "/"
               End If
                                                            253
-------
               End If
               If (Ptr%Color .Eqv. Red) Then
                  Write (unit=*, fmt="(a)") Rosso
               Else
                  Write (unit=*, fmt="(a)") Verde
               End If
               Write (unit=*, fmt="('(',10,')')", advance="no") Ptr%Item
               Printed = .True.
            End If
            Ptr => Ptr%pLeft
         End If
         Mask = Mask / 2
         If ((Level >= Max_Depth)  .Or. &
               (.Not. Associated(Ptr)) .Or. Printed) Then
            Exit
         End If
      End Do

      If (.Not. Printed) Then           !  The  node did not exist.
         Do Nlevels = Level, Max_Depth
            Print *                     !  Leave a blank line so as to preserve the
         End Do                         !  structure of the tree.
      End If
   End Do
   Print *, Verde
End Subroutine DISPLAY_SIDEWAYS


Subroutine DISPLAY_TREE(Root)
   !  This subroutine displays a tree in graphic form, showing  the nodes in their  actual
   !  positions. It is intended for a screen display, but the screen parameters can be  altered
   !  readily enough for a wide screen or printer. For each node, this subroutine  displays  the
   !  value in its appropriate color  (red or black), along with the letters R or B (R=red,
   !  B = black),  in case you don't have a color screen. This routine displays 5 levels;
   !  at the fifth level, 16  elements are displayed on one screen line of  80 columns.
   I
   !  Method: An in-order traversal of the tree is first performed, in order to determine the
   !  longest branch  (that is, the greatest depth of the tree). This value is used to
   !  determine the number of nodes as if all branches were of  this length.

   Implicit None
   Type(Site_Info),  Pointer  ::  Root
   Type(Site_Info),  Pointer  ::  Ptr

   !  Used to indicate the current level of a node during an excursion from
   !  the root to a node to be printed.
   Integer ::  Level
   Integer ::  Nodes  ! The maximum number of nodes at level LEVEL.
   Integer ::  Depth  ! The number of nodes from here to the root.
   Integer ::  Spaces, Gap,  J, Node_No, Trip, Mask


                                                               254
-------
Integer ::  Max Depth   ! The maximum depth of  the  tree  (levels  of  nodes).
Level = 0
Nodes = 1
Ptr => Root
Call SET_COLOR(Ptr)
Write (unit=*, fmt="(/ tr35, 13)", advance="no")  Ptr%Item
If  (Ptr%Color .Eqv. Red) Then
   J = 1
Else
   J = 0
End If
Write (unit=*, fmt="(a)")   Palette(J)
Write (unit=*, fmt="(tr37,  a)")   "A"
Write (unit=*, fmt="(tr36,  a)") "/   \"
Do
   !  Visit all the nodes to the specified depth.
   If (Depth >= Max_Depth) Exit
                                             !  The  level  of  the  nodes  being displayed.
   Do Node No = 0, Nodes-1                   ! Visit  all  the  nodes  at  a  given level.
      Ptr => Root                            ! Start  from the root.
      Mask = 1
      Do J = 1, Depth-2
         Mask = Mask * 2
      End Do

      Do Trip = 1, Depth-1
         If  (.Not. Associated(Ptr)) Exit
         !  Travel from the root to a node  at  the  given depth
         If  (Iand(Node_No, Mask)  /= 0) Then  ! Take the right branch.
             Ptr => Ptr%pRight
         Else                                ! Take the left  branch.
                                                             255
-------
         Ptr => Ptr%pLeft
      End If
      Mask = Mask/2
   End Do

   If (Associated(Ptr)) Then
      Call SET_COLOR(Ptr)
      Write (unit=Layout, fmt="(a, 13.3, a)")   "(tr", Gap-4,  ",13)"
      If (Gap < 5)  Then
         Layout = "(13)"
      End If
      Write (unit=*,  fmt=Layout, advance="no")  Ptr%Item
      If (Can_Color)  Then
         !  Comment the next line if your PC or  terminal  lacks  color.
         Write (unit=^, fmt="(a)", advance="no")  "  "
      Else

         !  Un-comment the next 6 lines if your  PC or terminal  lacks  color.
         If (Ptr%Color .Eqv. Red) Then
            J = 1
         Else
            J = 0
         End If
         Write (unit=*, fmt="(a)", advance="no")  Palette(J)
      End If
   Else
      Write (unit=Layout, fmt="(a, 13.3, a)")    "(tr", Gap-4,  ",2a)"
      If (Gap < 5)  Then
         Layout = "(2a)"
      End If
      If (Can_Color)  Then
         !  Comment the next line if your PC or  terminal  lacks  color.
         Write (unit=*, fmt=Layout, advance="no") White,  "  -   "
      Else
         !  Un-comment the next line if your PC  or terminal  lacks  color.
         Write (unit=*, fmt=Layout, advance="no") " -  "
      End If
   End If
   Gap = Spaces                   ! Assume normal  spacing  between  nodes.
   Mask = Mask/2
End Do

If (Can_Color) Then
   !  Comment the next line if your PC or terminal lacks  color.
   Write (unit=*, fmt="(a)") White
Else
   !  Un-comment the next line if your PC or terminal lacks  color.
   Write (unit=*, fmt=*)
End If
Gap = Spaces/2
                                                         256
-------
      If (Depth < Max_Depth) Then
         Do Node_No = 0, Nodes-1
            Write  (unit=Layout, fmt="(a, 13.3, a)")    "(tr",  Gap-2,  ",  a)
            If (Gap < 3) Then
               Layout = "(a)"
            End If
            Write  (unit=^,   fmt=Layout, advance="no")  "/  \"
            Gap = Spaces
         End Do
      End If

      Write (unit=*, fmt="(a)")
      Write (unit=*, fmt="(a)", advance="no")  "  "
      Gap = Spaces/2
      If (Depth < Max_Depth) Then
         Do Node_No = 0, Nodes-1
            Write  (unit=Layout, fmt="(a, 13.3, a)")    "(tr",  Gap-4,  ",  a)
            If (Gap < 5) Then
               Layout = "(a)"
            End If
            Write  (unit=*,   fmt=Layout, advance="no")  "/  \"
            Gap = Spaces
         End Do
      End If
   End Do

Contains

   !  This procedure changes the display color  to either  red  or  green.
   Subroutine SET_COLOR(Ptr)
      Implicit None
      Type(Site_Info), Pointer  :: Ptr

      If (Ptr%Color .Eqv. Red) Then
         Write (unit=*, fmt="(a)", advance="no") Rosso
      Else
         Write (unit=*, fmt="(a)", advance="no") Verde
      End If
   End Subroutine SET_COLOR
End Subroutine DISPLAY TREE
Function Longest_Branch(xRoot) Result(Max_Depth)
   !  Determines the longest branch of a binary tree
   Implicit None
   Type(Site_Info), Pointer :: xRoot
   Integer              : :  Max Depth
                                                               257
-------
      Max_Depth = 0
      Current_Depth = 0
      Call LBO(xRoot)

   Contains
      Recursive Subroutine LBO(Current) !  i.e., Longest Branch 0
         !  Auxiliary subroutine for Longest Branch
         Implicit None
         Type(Site_Info),  Pointer :: Current

         If (.Not.  Associated(Current)) Return

         Current_Depth = Current_Depth + 1

         If (Current_Depth > Max_Depth) Then
            Max_Depth = Current_Depth
         End If
         If (Associated(Current%pLeft)) Then
            Call LBO(Current%pLeft)
            Current_Depth = Current_Depth - 1
         End If
         If (Associated(Current%pRight))  Then
            Call LBO(Current%pRight)
            Current_Depth = Current_Depth - 1
         End If

      End Subroutine LBO
   End Function Longest_Branch
End Module Red_Black_Binary_Tree
                                                                  258
-------
samson
   !  For a description of the SAMSON file format see
   !      -------
Integer :
Integer :
Integer :
Integer :
Integer :
Integer :
Integer :
Character
Integer :
Real    :
Integer :
Integer :
Integer :
Real    :
Real    :
Integer :
Character
Integer :
Real    :
Integer :
Integer :
Integer :
Character

Integer :
Logical :
Integer :
Integer :
Integer :
Character
Real    :
Logical :
EHR
EDNR
GHR_v, GHR_u
  yy,  mm,  dd,  hh !  2-digit year,  month,  day,  hour
                 '  4-digit year
                 !  Extraterrestrial Horizontal Radiation
                 !  Extraterrestrial Direct Normal Radiation
                 !  Global  Horizontal Radiation
                 !  Direct  Normal  Radiation
                 !  Diffuse Horizontal Radiation
               _ ,  DNR_s ,  DHR_s
  Total_Sky_Cover,  Opaque_Sky_Cover
  Dry_Bulb_Temperature,  Dew_Point_Temperature
  Relative Humidity
  Station_Pressure
  Wind_Direction
  Wind Speed  !  in m/s
  Horizontal Visibility
  Ceiling_height !  in  meters
 Len=09)  ::  Present_weather
  Precipitable water
  baod !  Broadband  aerosol optical depth
  Snow_Depth
  Days_Since_Last_Snowf all
  Hourly Precipitation
(Len=01)  : :  Hourly  Precipitation  Flag

  Fyear,  nlines
  ok,  is  daytime
  doy,  j yyyy,  jmm,  jdd,  jdoy,  jhh, jv
  jd_today
  nbase,  iv
 Len=200)  :: tbuf,  qline
  ulO,  Station elevation  in meters
  Xfound
Integer, Dimension(:,:), Pointer : :
Type(Val_and_Flag)  :: d
Character(Len(d%s))  :: data source
!Logical
!Integer
   Print  now
   jvO, jvl
                                   '0'
!  PWT — Present Weather Table
!  Used to validate Present_weather's 9 flags
!  Numbers with "*" denote additions to the SAMSON
!  document. See .
Character(Len=*), Parameter :: PWT = '0123456789'
Integer ::  i

nlines = 0
                                                            260
-------
Empty_File = .True.

!  Open the input file
If (Len_trim(InFile) == 0) Then
   !  No file name.
   Return
End If

If (Is_vll) Then
   Call IORead(jin, InFile)
   data_source = T_SAMSONvll
Else
   Call Decompress_and_Open_File(Jin, InFile)
   data_source = T_SAMSONvlO
End If
Fyear = WFlx%yyyy
Write  (ULog, *)  '## File:  ', Trim(InFile)
Call ToTTy('Read SAMSON vlx  '//Trim(InFile))
!  Assign pointers
p_every_hour => WFlx%Every_Hour_Present
!  * [Isr] 25 Mar 2002  8:50 am
!    + We will copy the missing years from existing years.
!      Say 1990 is missing. We will copy 1961 or  1964  (if
!      leap year). This will allow make_rO to complete  the
!      run. We will then eliminate the 1990.hvf file and the
!      MET file records associated with 1990.
I
!  Fid Position   Element        Definition
I
!  001 - 001      Indicator      Indicates the header  record.
I
                 WBAN Number    Station's Weather Bureau Army  Navy number.

                 City
                                                            261
-------
!  031 - 032      State          State where the station is located  (abbreviated
!                                to two letters).
I
                 Time Zone      Time zone is the number of hours by which the
                                local standard time lags or leads Universal
                                Time.  For example, Mountain Standard Time is
                                designated -7 because it lags Universal Time by
                                7 hours.

                 Latitude       Latitude of the station.
                                N = North of equator
                                Degrees
                                Minutes

                 Longitude      Longitude of the station.
                                W = West, E = East
                                Degrees
                                Minutes

                 Elevation
Read (gline, 9130, lostat = ios)  WBAN_Number,   City, State, Time_Zone, &
      Latitude Let,  Latitude Degrees,  Latitude Minutes, &
      Longitude_Let, Longitude_Degrees, Longitude_Minutes, &
      Elevation meters
If (WFlx%Check_Header_Info) Then
   WFlx%Head%WBAN = WBAN_Number
   WFlx%Head%Text = Trim(City) //','// Trim(State)
   WFlx%Head%Lat  = Coords(Latitude_Let,  Latitude_Degrees,  Latitude_Minutes)
   WFlx%Head%Lon  = Coords(Longitude Let, Longitude Degrees, Longitude Minutes)
   WFlx%Head%Elev = Elevation_meters
   WFlx%Head%TZ   = Time_Zone
End If
                                                            262
-------
If (Present(Jout))  Then
   Write (Jout, 9150) WBAN_Number,   City, State, Time_Zone, &
         Latitude_Let,  Latitude_Degrees,  Latitude_Minutes, &
         Longitude_Let, Longitude_Degrees, Longitude_Minutes, &
         Elevation meters
   !  Same format as
   Format (
         2x, al,
         2x, al,
         2x, 14)
   !  Add the output header
   Write (Jout, 9170)
   Format ('~YR MO DA HR I
               8     9  10
             17     18   19
End If
14
       15
  Table 2. Data Elements in the NSRDB Hourly Data Files
  (For all except the first record of each file)
  IP - position in input file
  OP - field number in output file
!  OP  IP
                  Element
                  Local Standard Time
                  Year
                  Month
                  Day
                  Hour
      [Isr]  Thu 19 Oct 2000  11:58:19
            This field appears to be
            column 96 of the input file.
            The manual provides no data
            to support this assertion.
      [Isr]  Wed Nov 21 09:33:59 2001
            Observation Indicator appears
            only in SAMSON v 1.0 files.
                  Extraterrestrial
                  Horizontal Radiation
                                             Values   Definition
        Year of observation
        Month of observation
        Day of month
        Hour of day in local standard time

        0 = Weather observation made.
        9 = Weather observation not
        made or missing.
        If this field = 9 OR if field
        13 (wind speed) = missing
        (9999. or 99.0), then
        fields 6, 7, 8, 10, 11, 17,
        and 18 were all modeled and
        not actually observed.


        Amount of solar radiation in Wh/m2
        received on a horizontal surface at
        the top of the atmosphere during the
        60 minutes preceding the hour indicated.
                                                            263
-------
                  Extraterrestrial Direct
                  Normal  Radiation
Amount of solar radiation in Wh/m2
received on a surface normal to
the sun at the top of the atmosphere
during the 60 minutes preceding the
hour indicated.
                  Global  Horizontal Radiation
                  Data Value                 0-1415
                  Flag for Data Source       A-H,  ?
                  Flag for Data Uncertainty  0-9
Total amount of direct and diffuse
solar radiation in Wh/m2 received on a
horizontal surface during the 60
minutes preceding the hour indicated.
9999 = missing data.
                  Direct Normal Radiation
                  Data Value                 0-141E
                  Flag for Data Source       A-H,  1
                  Flag for Data Uncertainty  0-9
                  Diffuse Horizontal Radiation
                  Data Value                 0-1415
                  Flag for Data Source       A-H,  ?
                  Flag for Data Uncertainty  0-9
Amount of solar radiation in Wh/m2
received within a 5.7o field of view
centered on the sun, during the 60
minutes preceding the hour indicated.
9999 = missing data.

Amount of solar radiation in Wh/m2
received from the sky (excluding the
solar disk) on a horizontal surface,
during the 60 minutes preceding the
hour indicated.  9999 = missing data.
     == End of SAMSON version 1.1 parameters =====
                                                      Amount of sky dome (in tenths)
                                                      covered by clouds that prevent
                                                      observing the sky or higher cl
                                                      layers. 99 = missing data.
                              .oud
!  08   054-058      Dry Bulb Temperature
   Dry bulb temperature in degrees C.
   9999. = missing data.
      060-064      Dew Point Temperature
   Dew point temperature in degrees C.
   9999. = missing data.
                                                         Relative humidity in percent.
                                                         999 = missing data.
!  11   070-073      Station Pressure
                                                            264
-------
!  18  110-11J
                  Wind Direction



                  Wind Speed


                  Visibility



                  Ceiling Height
                  Hourly Precipitation
                  Hourly Precipitation Flag
                                             Table
                                             Below
                  Present weather
                  Precipitable Water
                  Broadband Aerosol
                  Optical_Depth
                  Snow Depth
                  Days Since Last Snowfall   0-88
            Wind direction in degrees.
            (N = 0 or 360, E = 90, S = 180,
            W = 270)   999 = missing data.
                            missing data.
0.0-160.9   Horizontal visibility in
            Precipitable water in
            millimeters.  9999 = missing data.

            Broadband aerosol optical depth
            (broadband turbidity) on the
            day indicated.
            99999.  = missing data.
            In inches and hundredths
            (See information below).

            See explanation below.
Loop: Do
   Read (Jin, '(a)', lostat = ios)  qline
   If (ios /= 0) Goto 9999
   nlines = nlines + 1
                                                            265
-------
         !  Print the Hourly Precipitation part of the  record.
         !  This record is available only for vl.0 files.
         !If (.Not. Is_vll) Then
         !    Write(1001, '(Ix,a,a,Ix,a)')   'SAMSON:  ',  qline(l:13),  Trim(qline(123
         !End If

         Read (qline, 9190, lostat = ios)  yy, mm, dd,  hh,  EHR,  EDNR,  &
               GHR_v, GHR_s, GHR_u, DNR_v, DNR_s, DNR_u,  DHR_v,  DHR_s,  DHR_u, &
               Total_Sky_Cover, Opaque_Sky_Cover, &
               Dry_Bulb_Temperature, Dew_Point_Temperature,  &
               Relative Humidity, Station Pressure,  &
               Wind_Direction, Wind_Speed, &
               Horizontal_Visibility, Ceilinq_heiqht,  Observation_Indicator,  &
               Present weather, Precipitable water,  &
               baod, Snow Depth, Days Since Last Snowfall,  &
               Hourly_Precipitation, Hourly_Precipitation_Flag

9190     Format (  4(lx,12), 2(lx,14), &
               3(lx,14,lx,al,il), &
               2(lx,12), 2(lx,f5.1), Ix, 13, Ix, 14, &
               Ix, 13, £5.1, £6.1, 16,  Ix, 11, &
               a9, 14, &
               £6.3, 14, 13, &
               Ix, 16, al  )
MI  *********************** Calendar and "iv" tests  commented  out  on Wed Dec 12 12:29:37 2001, because
MI  *********************** jfj__ All tests were passed without  problems.
MI  *********************** #2. With the tests active,  it  took 3m  21s to read all files;
iii  ***********************     With the tests commented out,  it took 1m 36s to read all files;

         jd_today = jd(yyyy, mm, dd)
!!!          Call Jd_to_ymd(jd_today,  jyyyy, jmm, jdd)
!!!          ok = (yyyy == jyyyy) .And.  (mm == jmm)  .And.  (dd == jdd)
!!!          If  (.Not. ok) Then
!!!             Write(ULoq,0102) '?? jd  /= Jd_to_ymd  ',  yyyy, mm, dd
!!!             Write(6,0102)    '?? jd  /= Jd_to_ymd  ',  yyyy, mm, dd
! ! !             Stop  '?? jd /= Jd_to_ymd'
! ! !          End If
                                                                   266
-------
doy = iDoY(yyyy, mm, dd)
   Call Calend(yyyy, doy, jmm, jdd)
   ok = (mm == jmm)  .And.  (dd == jdd)
   If (.Not. ok) Then
      Write(ULog,0102)   '?? IDoY /=  Calend
      Write(6,0102)     '?? IDoY /=  Calend
      Stop  '?? IDoY  /= Calend1
   End If
dd
dd
                                    24
                                                 Nhours  = 2J
   !  Test inverse.
   jdoy = (iv+Nhours-1) / Nhours
   jhh  = iv -  (jdoy-1)*Nhours
   ok = (hh == jhh)   .And.  (doy ==  jdoy)
   If (.Not. ok) Then
      Write(ULog,0102) '?? iv /=  (doy,hh)  ',  yyyy,  mm,  dd,  hh
      Write(6,0102)     '?? iv /=  (doy,hh)  ',  yyyy,  mm,  dd,  hh
      Stop  '?? iv /=  (doy,hh)'
   End If
                                                          267
-------
         ! Print now = ( ( j vO <= iv)  . And .  ( iv <= j vl) )
         !If (Print_now)  Then
         !    Write (ULog,  *)  yyyy,  mm,  dd,  hh, &
         !       ':  Days_Since_Last_Snowfall = ', Days_Since_Last_Snowfall
         !End If
I I I
I I I
I I I
I I I
I I I
I I I
! ! !0202
I I I
I I I
I I I
I I I
I I I
I I I
I I I
!!!0212
I I I
I I I
   !  Test iv to ymdh and inverse.
   Call iv_to_ymdh(iv, jyyyy, jmm
   ok = (yyyy == jyyyy)
   If (.Not. ok) Then
      Write(ULog,0202)  '
      Write(6,   0202)  '
      Format!///, lx, a,
      Stop  '?? iv to ymdh1
   End If
   Call ymdh_to_iv(yyyy,
   ok = (iv == jv)  .And.
   If (.Not. ok) Then
      Write(ULog,0212)  '?? ymdh_to_iv:  ',
      Write(6,   0212)  '?? ymdh_to_iv:  ',
      Format!///, lx, a,  'iv=', 10,  '/=',
      Stop  '?? ymdh to iv1
   End If
         !  Tally this day and hour.
         p  every hour(doy,hh) = p every hour(doy,hh) + 1
         !WFlx%Every_Hour_Present(doy,hh)  = 1 + &
         !       WFlx%Every_Hour_Present(doy,hh)

         !  It is daylight if Rs>0 (and Rs  is not missing).   (Rs is an alias for GHR v.)
         !  "is daytime" is used to determine if other parameters are truly
         !  missing,  e.g., if a parameter X is to be output only for daylight hours,
         !  then parameter X is (effectively) non-missing if Rs>0 for the same record  (hour).
         !  The default for "is daytime" is .True., i.e., any parameter will be missing
         !  unless we can determine it is nighttime. This will take care of the  (rare) case
         !  when Rs is missing.
         is_daytime  = .True.
                            lobal Horizontal Radiation
                                                               Total amount of direct and diffuse
                           Data Value                 0-1415
                           Flag for Data Source       A-H, ?
                           Flag for Data Uncertainty  0-9
                                                      solar radiation  in Wh/m2  received  on
                                                      a horizontal  surface  during  the  60
                                                      minutes preceding the hour indicated.
i                                                      9999 = missing data.
!  Ref[FAO]  Rs == Global Horizontal Radiation == samson GHR_v == huswo  iGRAD
!  1 Watt hour == 3.6e-3 MJoule
!  1 Watt hour m^-2 == 8.59845E-02 Langley
If ((0 <= GHR_v) .And. (GHR_v <= 1415)) Then
   is_daytime = (GHR_v > 0)
   If (Is_vll)  Then
      Xparam(f_GHR)%Samson_vll(iv)%v = GHR_v
                                                                  268
-------
      Xparam(f GHR)%Samson vll(iv)%s = data source
   Else
      Xparam(f_GHR)%Samson_vlO(iv)%v = GHR_v
      Xparamtf_GHR)%Samson_vlO(iv)%s = data_source
   Endif
   If (Verify(GHR_s, 'abcdefghABCDEFGH?')  == 0) Then
      If (Is_vll) Then
         Xparam(f_GHR)%Samson_vll(iv)%f(1:1) = GHR_s
      Else
         Xparam(f_GHR)%Samson_vlO(iv)%f(1:1) = GHR_s
      Endif
   Else
      Write  (ULog, 9290) iv, yyyy, mm, dd, hh, &
             'GHR_s', GHR_s, '{abcdefghABCDEFGH?}'
   End If
   If ((0 <= GHR_u) .And.  (GHR_u <= 9))  Then
      If (Is_vll) Then
         Xparamtf_GHR)%Samson_vll(iv)%f(2:2) = Achar(GHR_u+iaO)
      Else
         Xparam(f_GHR)%Samson_vlO(iv)%f(2:2) = Achar(GHR_u+iaO)
      Endif
   Else
      Write  (ULog, 9270) iv, yyyy, mm, dd, hh, &
             1GHR_u', GHR_u, '{0..9}'
   End If
End If

!  01  014-017     Extraterrestrial           0-1415   Amount of solar radiation  in Wh/m2
!                  Horizontal Radiation                received on a horizontal surface  at
!                                                      the top of the atmosphere  during  the
!                                                      60 minutes preceding the hour  indicated.
!  Ref[FAO]  Ra == Extraterrestrial Horizontal Radiation
!  1 Watt hour == 3.6e-3 MJoule
If ((0 <= EHR)  .And. (EHR <= 1415)) Then
   If (Is_vll)  Then
      Xparam(f_EHR)%Samson_vll(iv)%v = EHR
      Xparamtf_EHR)%Samson_vll(iv)%s = data_source
   Else
      Xparam(f_EHR)%Samson_vlO(iv)%v = EHR
      Xparam(f_EHR)%Samson_vlO(iv)%s = data_source
   Endif
End If

!  Extraterrestrial Direct Normal Radiation
If ((0 <= EDNR) .And.  (EDNR <= 1415)) Then
   If (Is_vll)  Then
      Xparam(f_EDNR)%Samson_vll(iv)%v = EDNR
      Xparam(f_EDNR)%Samson_vll(iv)%s = data_source
   Else
      Xparam(f_EDNR)%Samson_vlO(iv)%v = EDNR


                                                         269
-------
      Xparam(f_EDNR)%Samson_vlO(iv)%s = data_source
   Endif
End If

!  Direct Normal Radiation
If ((0 <= DNR_v) .And.  (DNR_v <= 1415)) Then
   If (Is_vll)  Then
      Xparam(f_DNR)%Samson_vll(iv)%v = DNR_v
      Xparam(f_DNR)%Samson_vll(iv)%s = data_source
   Else
      Xparam(f_DNR)%Samson_vlO(iv)%v = DNR_v
      Xparamtf_DNR)%Samson_vlO(iv)%s = data_source
   Endif
   If (Verify(DNR_s,  'abcdefghABCDEFGH?') ==  0) Then
      If (Is_vll) Then
         Xparam(f_DNR)%Samson_vll(iv)%f(1:1)  =  DNR_s
      Else
         Xparam(f_DNR)%Samson_vlO(iv)%f(1:1)  =  DNR_s
      Endif
   Else
      Write  (ULog,  9290) iv, yyyy, mm, dd, hh,  &
             'DNR_s', DNR_s, '{abcdefghABCDEFGH?}'
   End If
   If ((0 <= DNR_u) .And.  (DNR_u <= 9)) Then
      If (Is_vll) Then
         Xparam(f_DNR)%Samson_vll(iv)%f(2:2)  =  Achar(DNR_u+iaO)
      Else
         Xparam(f_DNR)%Samson_vlO(iv)%f(2:2)  =  Achar(DNR_u+iaO)
      Endif
   Else
      Write  (ULog,  9270) iv, yyyy, mm, dd, hh,  &
             1DNR_u', DNR_u, '{0..9}'
   End If
End If

!  Diffuse Horizontal Radiation
If ((0 <= DHR_v) .And.  (DHR_v <= 1415)) Then
   If (Is_vll)  Then
      Xparam(f_DHR)%Samson_vll(iv)%v = DHR_v
      Xparam(f_DHR)%Samson_vll(iv)%s = data_source
   Else
      Xparam(f_DHR)%Samson_vlO(iv)%v = DHR_v
      Xparam(f_DHR)%Samson_vlO(iv)%s = data_source
   Endif
   If (Verify(DHR_s,  'abcdefghABCDEFGH?') ==  0) Then
      If (Is_vll) Then
         Xparam(f_DHR)%Samson_vll(iv)%f(1:1)  =  DHR_s
      Else
         Xparam(f_DHR)%Samson_vlO(iv)%f(1:1)  =  DHR_s
      Endif
                                                         270
-------
   Else
      Write (ULog, 9290) iv, yyyy, mm, dd, hh, &
            'DHR_s',  DHR_s, '{abcdefghABCDEFGH?}'
   End If
   If ((0 <= DHR_u) .And.  (DHR_u <= 9))  Then
      If (Is_vll) Then
         Xparam(f_DHR)%Samson_vll(iv)%f(2:2) = Achar(DHR_u+iaO)
      Else
         Xparam(f_DHR)%Samson_vlO(iv)%f(2:2) = Achar(DHR_u+iaO)
      Endif
   Else
      Write (ULog, 9270) iv, yyyy, mm, dd, hh, &
            1DHR_u',  DHR_u, ' {0 . . 9} '
   End If
End If
!  SAMSON version 1.1 files have no more parameters
If (Is vll)  Cycle Loop
!  Total Sky_Cover
If ((0 <= Total_Sky_Cover) .And.  (Total_Sky_Cover <= 10)) Then
   Xparam(f_TSC)%Samson_vlO(iv)%v = Total_Sky_Cover
   Xparam(f_TSC)%Samson_vlO(iv)%s = data_source
End If

!  07   051-052     Opaque Sky_Cover           0-10     Amount of sky dome  (in tenths)
!                                                      covered by clouds that prevent
!                                                      observing the sky or higher  cloud
!                                                      layers. 99 = missing data.
If ((0 <= Opaque_Sky_Cover) .And. (Opaque_Sky_Cover <= 10)) Then
   Xparam(f_OSC)%Samson_vlO(iv)%v = Opaque_Sky_Cover
   Xparam(f_OSC)%Samson_vlO(iv)%s = data_source
End If

!  08   054-058     Dry Bulb Temperature       -70.0 to    Dry bulb temperature in degrees  C.
!                                             60.0        9999. = missing data.
If ((-70.0 <= Dry_Bulb_Temperature)  .And. &
      (Dry_Bulb_Temperature <= +60.0)) Then
   Xparam(f_DBT)%Samson_vlO(iv)%v = Dry_Bulb_Temperature
   Xparam(f_DBT)%Samson_vlO(iv)%s = data_source
End If

!  Dew Point Temperature
If ((-70.0 <= Dew Point Temperature)  .And. &
      (Dew_Point_Temperature <= +60.0)) Then
   Xparam(f_DPT)%Samson_vlO(iv)%v = Dew_Point_Temperature
   Xparam(f_DPT)%Samson_vlO(iv)%s = data_source


                                                         271
-------
                  Relative Humidity          0-100       Relative humidity  in percent.
i                                                         999 = missing data.
If ((0 <= Relative_Humidity) .And.  (Relative_Humidity <= 100)) Then
   Xparam(f_RH)%Samson_vlO(iv)%v = Relative_Humidity
   Xparam(f_RH)%Samson_vlO(iv)%s = data_source
End If
!  11  070-073     Station Pressure           700-1100    File: Station pressure  in millibars.
!  1 millibar = 0.10000 kilopascal                        Internal: kilopascal
If ((700 <= Station_Pressure) .And.  (Station_Pressure <= 1100)) Then
   Xparam(f_SP)%Samson_vlO(iv)%v = Station_Pressure * millibar	to	kilopascal
   Xparam(f_SP)%Samson_vlO(iv)%s = data_source
End If
                                                         Wind direction in degrees.
!                                                          (N = 0 or 360, E =  90,  S =  180,
!                                                         W = 270)  999 = missing data.
If ((0 <= Wind_Direction) .And.  (Wind_Direction <= 360)) Then
   Xparam(f_WD)%Samson_vlO(iv)%v = Wind_Direction
   Xparam(f WD)%Samson vlO(iv)%s = data source
End If
!  Wind Speed will be normalized to z=10 meters. See "Data Base Project Documentation".
If ((0.0 <= Wind_Speed) .And.  (Wind_Speed < +99.0)) Then
   If (Wind_Speed .NotEqual. 0.0) Then
      ulO = Wind Speed * 5.81 / Log(Station elevation in meters/0.03)
      Xparam(f_WS)%Samson_vlO(iv)%v = ulO
   Else
      Xparam(f_WS)%Samson_vlO(iv)%v = Wind_Speed
   End If
   Xparam(f_WS)%Samson_vlO(iv)%s = data_source
End If

!!  too many missing.
!!  14  083-088     Visibility                 0.0-160.9   Horizontal visibility  in
!!                                                         kilometers.  777.7 = unlimited
!!                                                         visibility. 99999. = missing data.
If ((0.0 <= Horizontal_Visibility) .And. &
      (Horizontal_Visibility < 99999)) Then
   Xparam(f_HV)%Samson_vlO(iv)%v = Horizontal_Visibility
   Xparam(f HV)%Samson vlO(iv)%s = data source
   If ((0.0 <= Horizontal Visibility) .And. &
          (Horizontal_Visibility <= 160.9)) Then
      Maximum_Horizontal_Visibility = Max(Maximum_Horizontal_Visibility, Horizontal_Visibility)
   Else If (Horizontal_Visibility .Eguals. 777.7) Then
                                                         272
-------
      Xparam(f_HV)%Samson_vlO(iv)%s = T_Unlimited
   End If
End If

!  15  089-094     Ceiling Height             0-30450   Ceiling height  in meters.
!                                               77777 = unlimited ceiling height.
!                                               88888 = cirroform.
I                                              gggggg = missing data.
If ((0 <= Ceiling_height) .And.  (Ceiling_height < 999999)) Then
   Xparam(f CH)%Samson vlO(iv)%v = Ceiling height
   Xparam(f CH)%Samson vlO(iv)%s = data source
   If ((0 <= Ceiling_height)  .And. (Ceiling_height <= 30450)) Then
      Maximum_Ceiling_Height = Max(Maximum_Ceiling_Height, Ceiling_height)
   Else If (Ceiling height == 77777)  Then
      Xparam(f_CH)%Samson_vlO(iv)%s = T_Unlimited
   Else If (Ceiling_height == 88888)  Then
      Xparam(f_CH)%Samson_vlO(iv)%s = T_Cirroform
   End If
End If

!  Observation Indicator  0 or 9    0 = Weather observation made.
!                                   9 = Weather observation not made or  missing.
!  Present weather - Present weather conditions denoted by 9  indicators.
Select Case(Observation_Indicator)
Case(0,  9)
   !  Obs made.  Save the present weather table.
   Xparam(f OI)%Samson vlO(iv)%v = Observation Indicator
   Xparam(f_OI)%Samson_vlO(iv)%f = Present_weather
   Xparam(f_OI)%Samson_vlO(iv)%s = data_source

   !  Check the  present weather table.
   Do i = 1,  9
      If  (Verify(Present_weather(i:i), PWT)  == 0) Cycle   !   Ok.
      Write  (ULog, 9250) iv, yyyy, mm, dd, hh, &
             1Present_weather( ',i, ' ) ' , Present_weather(i:i),   PWT
      Format (/, Ix,  '?? Read_SAMSON_File_vlx: ', &
            17,  Ix, 14, 2('-',i2.2),  13,  'h, ', a, 10, a, &
             1:  invalid value: "',  a,  '", expecting: "', a, '"' /)
   End Do

Case Default
   Write  (ULog,  9270)  iv, yyyy, mm, dd, hh,  &
          'Observation Indicator1,  Observation Indicator,  '{0  9}'
   Format (/, Ix,   '?? Read_SAMSON_File_vlx:  ', &
         17,  Ix, 14,  2('-',i2.2),  13, 'h, ', a, &
          1:  invalid value:  ', 10,  ',  expecting:  ', a, /)
End Select

!  Precipitable  water
If ((0 <= Precipitable_water) .And.  (Precipitable_water <= 100)) Then
                                                         273
-------
   Xparam(f_pH2O)%Samson_vlO(iv)%v = Precipitable_water
   Xparam(f_pH2O)%Samson_vlO(iv)%s = data_source
End If

!  Broadband aerosol optical_depth (broadband turbidity) on the day indicated.
If ((0.0 <= baod) .And. (baod <= 0.900)) Then
   Xparam(f baod)%Samson vlO(iv)%v = baod
   Xparam(f_baod)%Samson_vlO(iv)%s = data_source
End If

!  Snow Depth
If ((0 <= Snow_Depth)   .And. (Snow_Depth <= 100)) Then
   Xparam(f_SD)%Samson_vlO(iv)%v = Snow_Depth
   Xparam(f SD)%Samson vlO(iv)%s = data source
End If

!  Days Since Last Snowfall
If ((0 <= Days_Since_Last_Snowfall)  .And.  (Days_Since_Last_Snowfall <= 88)) Then
   Xparam(f_DSLS)%Samson_vlO(iv)%v = Days_Since_Last_Snowfall
   Xparamtf_DSLS)%Samson_vlO(iv)%s = data_source
End If
!If (Print_now)  Then
!    Write (ULog, ^)  yyyy,  mm,  dd, hh,  &
!       ': Xparam(f_DSLS)%Samson_vlO(iv) =  ', Xparam(f_DSLS)%Samson_vlO(iv)
!End If

!  21  124-129     Hourly Precipitation       000000-     In inches and hundredths
i                                             099999      (See information below).
I
!      130-130     Hourly Precipitation Flag              See explanation below.
I
!  DATA FORMAT—HOURLY  PRECIPITATION
I
!  It stands to reason that for most hours the non-occurrence of
!  precipitation is prevalent.   Therefore, in order to save space in
!  the original digital file, there are entries only for:
I
!      1.   The first day and hour of each month where observations were
!          taken even if no precipitation occurred during that month.
I
!      2.   Hours with precipitation > zero.
I
!      3.   Beginning and ending hours of missing periods.
I
!      4.   Beginning and ending hours of accumulating periods.
I
!      5.   Beginning and ending periods of deleted data.
                                                         274
-------
!  The  actual  precipitation data value:   The data value portion is a
!  six-digit  integer.   Units are inches  and hundredths.   Range =
!  000000-099999.   000000 will  be used only on the first hour of each
!  month unless  there  is  precipitation during that hour, in which case
!  the  measured  value  will be provided.   On other days during the
!  month without precipitation,  no entry will be made.  099999
!  indicates  that the  value is  unknown.
I
!  Hourly Precipitation Flag:
I
!  A          Accumulated period and amount.   An accumulated period
!             indicates that the precipitation amount is correct, but
!             the exact beginning and ending times are only known to
!             the extent  that the precipitation occurred sometime
!             withinthe  accumulation period.  Begin accumulation data
!             value will  always  be 099999.
I
!  D          Deleted  Flag.  Beginning and  ending of a deleted period.
!             A  deleted value indicates  that the original data were
!             received, but were unreadable or clearly recognized as
!             noise.
I
!  M          Missing  Flag.  (Beginning  and ending of a missing
!             Period.)   A missing flag indicates that the data were
!             not received.  This flag appears on the first and last
!             dayofeach month  for which data were not received or
!             not processed by  NCDC.  Prior to 1984 a missing period
!             was recorded as "  OOOOOM"  at  the beginning and ending
!             hours.   If  precipitation occurred during the last hour
!             of the missing period, the second M appears with a non-
!             zero value.  Beginning in  1984 the beginning and ending
!             hours of the missing period are recorded as "099999M".
I
!  b          Blank.   No  Flag needed.
I
!  Examples:
I
!  The  precipitation accumulation from 1st  month day 02 to 2nd month
i  Hc,ir  n/i -
                                            	    Accumulation begins
                                            099999A    Accumulation continues
                                            000390A    Accumulation ends
!  Accumulated precipitation for 1 month only:
I
!          01
                                                         275
-------
           Accumulated, deleted, and missing precipitation data through months
           01 and 02:

                   01           0001       0100      OOOOOOb    First  record  of  the
                                                                month
                                                                Accumulation  begins
                                                                Accumulation  continues
                                                                Accumulation  ends
                                                                Deleted data  begins
                                                                Deleted data  ends
                                                                Missing data
                                                                Missing data
         I
         !  Reguired precipitation charts or forms were never
         I
         !          01           0001
         !  Again Hourly Precipitation In inches and hundredths
         !  Example: WBAN 14914, 1961 range: 0 - 218; i.e., 218

         If ((0 <= Hourly_Precipitation) .And.  (Hourly_Precipitation  <  099999))  Then
            Xparam(f_HP)%Samson_vlO(iv)%v = inches	to	cm * Hourly_Precipitation  / 100.0
            Xparam(f_HP)%Samson_vlO(iv)%s = data_source
         End If

         !  Valid range: ADM E(undocumented)  Blank
         Xparam(f_HP)%Samson_vlO(iv)%f = Hourly_Precipitation_Flag
         Select Case(Hourly_Precipitation_Flag)
         Case  ( 'A',  'D', 'M',  'E',  ' ' )
            !  Ok.
         Case Default
            !  Invalid value.
            Write  (ULog, 9290) iv, yyyy, mm,
                   'Hourly Precipitation flag1
                  Hourly Precipitation Flag, &
                   1{A D M E Blank}'
            Format (/, Ix,   '?? Read_SAMSON_File_vlx: ', &
                  17, Ix, 14, 2('-',i2.2), 13,  'h,  ', a, &
                   1:  invalid value: "', a,  '"; Expecting:  ', a,  /)
         End Select
      End Do Loop
9999  Continue
      Call lOClose(jin)
      Empty_File = (nlines == 0)
   End Subroutine Read_SAMSON_vlx
End Module SAMSON
                                                                  276
-------
setup

!      Last change:  LSR  17 May 2002    6:11 pm

Module Setup

   Use Date_Module
   Use F2kCLI
   Use FileStuff
   Use Global Variables
   Use Stats
   Use Utilsl
   Use loSubs
   Implicit None
   Subroutine InitialSetUp()

      Implicit None
      Character(Len=30)  ::  ydate =  ''
      Character(Len=80)  ::  xexe =  ''
      Character(Len=80)  ::  xversion =  ''
      Integer ::  nn

      !  Get the directory delimiter
      DirDelim = DirectoryDelimiter()

      ydate = Unix_Date()
      Call Get Command Argument(0, xexe)   ! Get application name.
      !  Remove possible path.
      nn = 1 !+ Index(xexe, DirDelim, Back=.True.)
      Call FileTimeStamp(xexe, xversion)

      Call STD_dir(Log_dir)
      Call STD_dir(R0_root)
      Call STD dir(Raw Data dir)
      !  Open the log file.
      Call Get Log File Name(Log file, Log dir, ULog)

      !  Dump data for Mathematica here
      Call lOWrite(Umath,  'Omath.del')
                                                                  277
-------
      !  Header for the log file: date and files used.
      Write (ULog, *)  'Executable: ', Trim(xexe(nn:))
      Write (ULog, *)  'Version  ..:
      Write (ULog, *)  'run of ...:
      Write (ULog, *)  'TimeStamp  :
      Write (ULog,  9130)
9130  Format (/ &
            Ix, 'Notes:',  /, &
            Ix, '*  None as of 11 Feb 2002  2:27 pm', /)

      !  To Do List: 
      Write (ULog,  9150)
9150  Format (  &
            Ix, 'To Do List: ', /,  &
            Ix, '*  Look for "***" "!!" "!!!"', /)

      Call SetFieldlnfo()
      Call Set_Hours_since_JdO()

      ICall TestJATinteracter ( )
      ICall Test_Multiples_of()
      ICall Test_Azimuth()
      ICall Test_NaN()
      I Call Test_iv_to_ymdh()

      Call FLushAll()

   End Subroutine InitialSetUp
   Subroutine Check Drives and Files()

      Implicit None
      Character(Len=l0),  Dimension(2), Parameter  :: xDrive =  (/  'v:\.',  'z:\.'  /)
      Logical ::  have drive
      Logical ::  have_file
      Integer : :  nerr, j ,  n
      I  Verify that the substituted drives are present.
      Do j  = 1,  Ubound(xDrive,1)
         Inquire(File=xDrive(j),  Exist=have drive)
         If (.Not.  have_drive) Then
            n = Len_trim(xDrive(j))  - 2    I Do not display trailing  "\."
            Write(ULog,  9130)  xDrive(j)(1:n)
                                                                  278
-------
         Format (Ix, '?? Check Drives and Files: Could not  find drive  ',  a)
         nerr = nerr + 1
      End If
   End Do

   !  make sure "zcat" exists.
   Inquire(File=zcat, Exist=have file)
   If (.Not. have_file) Then
      Write (ULog, *)  '?? Check_Drives_and_Files: Could not  find  file  zcat:  ',  Trim(zcat)
      nerr = nerr + 1
   End If

   !  make sure metadata file exists.
   Inquire(File=metadata coda, Exist=have file)
   If (have_file)  Then
      Call lORead(Umetadata, metadata_coda)
   Else
      Write (ULog, *)  '?? Check_Drives_and_Files: Could not  find  file:  ',  Trim(metadata_coda)
      nerr = nerr + 1
   End If

   If (nerr > 0)  Then
      Stop '?? Missing drives/files'
   End If

End Subroutine Check Drives and Files
   I  ^^ insert subroutine in
   !  

   !  Generate log file name, e.g.,  'Logs\2001-10-03_090547.log';
   !  If Log Path is present, it must terminate with the directory delimiter,  'Logs\';
   !  If ULog is present, Log_Name will be opened with write  access  and  attached  to  ULog,

   Implicit None
   Character(Len=^),            Intent(Out) :: Log Name
   Character(Len=*),  Optional, Intent(In)  :: Log_Path
   Integer,          Optional, Intent(Out) :: ULog
   Call Date and time(Date = xdate, Time = xtime)
                                                               279
-------
   !   tbuf 2001-10-03_090547.log
   !  xdate yyyymmdd
   !  xtime hhmmss.sss
   !        123456789-123456789-1
   tbuf = 'yyyy-mm-dd_hhmmss.log'

   tbuf(01:04) = xdate(l:4)  ! year
   tbuf(06:07) = xdate(5:6)  ! Month
   tbuf(09:10) = xdate(7:8)  ! day of Month
   tbuf(12:17) = xtime(1:6)  ! hhmmss

   If (Present(Log_Path)) Then
      tdir = Log_Path
      Call STD_dir(tdir)
      Log_Name = Trim(tdir)  // tbuf
   Else
      Log_Name = tbuf
   End If

   If (Present(ULog))  Then
      Call lOWrite(ULog, Log_Name)
   End If
End Subroutine Get Log File  Name
Subroutine SetFieldlnfo()
   Implicit None

   !  Parameter Zero: Other counts
   Fieldlnfo(0)%Name =  'Year counts'
   Fieldlnfo(0)%Minimum obs per day = 0    ! Unused  for this  field.
   !  FAO Ra == Extraterrestrial Horizontal Radiation
   !  Extraterrestrial Horizontal Radiation - Amount of solar  radiation  in Wh/m2
   !         received on a horizontal surface at the top of the  atmosphere during  the
   !         60 minutes preceding the hour indicated.
   Fieldlnfo(f_EHR)%Name =  'Extraterrestrial Horizontal Radiation  [Wh/m2]  (Ra)'
   Fieldlnfo(f_EHR)%Minimum_obs_per_day = 3
   Fieldlnfo(f EHR)%minimum value = Zero
   Fieldlnfo(f_EHR)%maximum_value = 1415 * 24   !  24 hours

   Fieldlnfo(f_EDNR)%Name = 'Extraterrestrial Direct Normal Radiation  [Wh/m2]'
   Fieldlnfo(f_EDNR)%Minimum_obs_per_day = 3
   Fieldlnfo(f_EDNR)%minimum_value = Zero
   Fieldlnfo(f EDNR)%maximum value = 1415 * 24  !  24 hours
                                                               280
-------
!  MET Solar Radiation == FAO Rs == Global Horizontal Radiation
!                      == samson GHRv == huswo iGRAD
!  Global Horizontal Radiation - Total amount of direct and diffuse  solar
!         radiation in Wh/m2 received on a horizontal surface during the
!         60 minutes preceding the hour indicated.
Fieldlnfo(f_GHR)%Name = 'Global Horizontal Radiation  [Wh/m2]  (Rs)'
Fieldlnfo(f_GHR)%Minimum_obs_per_day = 3
Fieldlnfo(f_GHR)%minimum_value = Zero
Fieldlnfo(f_GHR)%maximum_value = 1415 * 24   !  24 hours

Fieldlnfo(f_DNR)%Name = 'Direct Normal Radiation  [Wh/m2]'
Fieldlnfo(f_DNR)%Minimum_obs_per_day = 3
Fieldlnfo(f_DNR)%minimum_value = Zero
Fieldlnfo(f_DNR)%maximum_value = 1415 * 24   !  24 hours

Fieldlnfo(f_DHR)%Name = 'Diffuse Horizontal Radiation  [Wh/m2]'
Fieldlnfo(f_DHR)%Minimum_obs_per_day = 3
Fieldlnfo(f DHR)%minimum value = Zero
Fieldlnfo(f_DHR)%maximum_value = 1415 * 24   !  24 hours

!  Total Sky Cover
Fieldlnfo(f_TSC)%Name = 'Total Sky Cover  [tenths]'
Fieldlnfo(f_TSC)%Minimum_obs_per_day = 3
Fieldlnfo(f_TSC)%minimum_value = Zero
Fieldlnfo(f_TSC)%maximum_value = 10

!  Opaque Sky Cover - Amount of sky dome (in tenths) covered by  clouds  that  prevent
!         observing the sky or higher cloud layers.
Fieldlnfo(f_OSC)%Name = 'Opaque_Sky_Cover [tenths]'
Fieldlnfo(f OSC)%Minimum obs per day = 3
Fieldlnfo(f OSC)%minimum value = Zero
Fieldlnfo(f_OSC)%maximum_value = 10

!  Dry bulb temperature in degrees C.
Fieldlnfo(f_DBT)%Name = 'Dry Bulb Temperature [°C]'
Fieldlnfo(f_DBT)%Minimum_obs_per_day = 3
Fieldlnfo(f_DBT)%minimum_value = -70.0
Fieldlnfo(f_DBT)%maximum_value = +60.0

!  Dew Point Temperature in degrees C.
Fieldlnfo(f_DPT)%Name = 'Dew Point Temperature [°C]'
Fieldlnfo(f_DPT)%Minimum_obs_per_day = 3
Fieldlnfo(f_DPT)%minimum_value = -80.0
Fieldlnfo(f_DPT)%maximum_value = +60.0

!  Relative humidity in percent.
Fieldlnfo(f_RH)%Name = 'Relative_Humidity [Percent]'
Fieldlnfo(f_RH)%Minimum_obs_per_day = 3
Fieldlnfo(f_RH)%minimum_value = Zero
Fieldlnfo(f RH)%maximum value = 100
                                                            281
-------
!  Station pressure in kPa.
Fieldlnfo(f_SP)%Name = 'Station_Pressure  [kPa]1
Fieldlnfo(f_SP)%Minimum_obs_per_day = 1
Fieldlnfo(f_SP)%minimum_value = 70.0
Fieldlnfo(f_SP)%maximum_value = 110.0

!  Wind direction in degrees.
!  (N = 0 or 360, E = 90,  S = 180, W = 270)
Fieldlnfo(f_WD)%Name = 'Wind_Direction  [Degrees]'
Fieldlnfo(f_WD)%Minimum_obs_per_day = 3
Fieldlnfo(f WD)%minimum value = Zero
Fieldlnfo(f_WD)%maximum_value = 360

!  Wind Speed in meters/sec at height = 10 meters
Fieldlnfo(f_WS)%Name = 'Wind_Speed @z=10m  [m/s]'
Fieldlnfo(f_WS)%Minimum_obs_per_day = Fieldlnfo(f_WD)%Minimum_obs_per_day
Fieldlnfo(f_WS)%minimum_value = Zero
Fieldlnfo(f_WS)%maximum_value = 98.9

!  Horizontal Visibility
Fieldlnfo(f_HV)%Name = 'Horizontal Visibility  [km]'
Fieldlnfo(f HV)%Minimum obs per day = 3
Fieldlnfo(f HV)%minimum value = Zero
Fieldlnfo(f_HV)%maximum_value = Zero    ! See Process_Set. Maximum value  is  station-dependent

!  Ceiling Height
Fieldlnfo(f_CH)%Name = 'Ceiling Height  [m]'
Fieldlnfo(f_CH)%Minimum_obs_per_day = 3
Fieldlnfo(f_CH)%minimum_value = Zero
Fieldlnfo(f CH)%maximum value = Zero    ! See Process Set. Maximum value  is  station-dependent

!  Observation Indicator  0 or 9   0 = Weather observation made.
!                                  9 = Weather observation not made or missing.
!  Present weather - Present weather conditions denoted by 9 indicators.
Fieldlnfo(f_OI)%Name = 'Observation Indicator/Present weather'
Fieldlnfo(f_OI)%Minimum_obs_per_day = 1
Fieldlnfo(f_OI)%minimum_value = Zero    ! N/A for this parameter
Fieldlnfo(f OI)%maximum value = Zero    ! N/A for this parameter

!  Precipitable Water
Fieldlnfo(f_pH2O)%Name = 'Precipitable Water [mm]'
Fieldlnfo(f_pH2O)%Minimum_obs_per_day = 3
Fieldlnfo(f pH2O)%minimum value = Zero
Fieldlnfo(f_pH2O)%maximum_value = 100

!  Broadband Aerosol Optical Depth (0.0-0.90) - Broadband aerosol optical depth
!  (broadband turbidity) on the day indicated.
Fieldlnfo(f_baod)%Name = 'Broadband Aerosol Optical_Depth []'
Fieldlnfo(f_baod)%Minimum_obs_per_day = 1
Fieldlnfo(f baod)%minimum value = Zero


                                                            282
-------
Fieldlnfo(f baod)%maximum value =  0.900

Fieldlnfo(f_SD)%Name =  'Snow Depth  [cm]'
Fieldlnfo(f_SD)%Minimum_obs_per_day =  3
Fieldlnfo(f_SD)%minimum_value = Zero
Fieldlnfo(f_SD)%maximum_value = 100

Fieldlnfo(f_DSLS)%Name =  'Days since last  Snowfall  [days]'
Fieldlnfo(f_DSLS)%Minimum_obs_per_day  =  3
Fieldlnfo(f_DSLS)%minimum_value =  Zero
Fieldlnfo(f_DSLS)%maximum_value =  88

!  Hourly  Precipitation
Fieldlnfo(f_HP)%Name =  'Hourly Precipitation  [cm]'
Fieldlnfo(f_HP)%Minimum_obs_per_day =  3
Fieldlnfo(f_HP)%minimum_value = Zero
Fieldlnfo(f_HP)%maximum_value =400

Fieldlnfo(f_FAO_SG_PET)%Name = 'Eto, FAO Short  Grass  [mm/day]'
Fieldlnfo(f_FAO_SG_PET)%Minimum_obs_per_day =  0
Fieldlnfo(f_FAO_SG_PET)%minimum_value  =  -1
Fieldlnfo(f_FAO_SG_PET)%maximum_value  =  35

Fieldlnfo(f_KP_FWS_Evaporation)%Name = 'K-P FWS Evaporation [mm/day]'
Fieldlnfo(f_KP_FWS_Evaporation)%Minimum_obs_per_day =  0
Fieldlnfo(f_KP_FWS_Evaporation)%minimum_value  = -10
Fieldlnfo(f_KP_FWS_Evaporation)%maximum_value  = +20

Fieldlnfo(f_Ep)%Name =  'Ep, Class A pan  Evaporation [mm/day]'
Fieldlnfo(f Ep)%Minimum obs per day =  0
Fieldlnfo(f Ep)%minimum value = -1
Fieldlnfo(f_Ep)%maximum_value = 180

!  MET field information.
MET_field(g_Precipitation)%Name =  'Precipitation [cm/day]'
MET_field(g_Pan_Evaporation)%Name =  'Pan Evaporation  [cm/day]'
MET_field(g_Temperature_mean)%Name = 'Temperature mean [°C]'
MET_field(g_Wind_Speed)%Name = 'Wind Speed @10  meter  [cm/s]'
MET_field(g_Solar_Radiation)%Name =  'Solar Radiation  [Langleys/day]'
MET_field(g_FAO_Short_Grass)%Name = Fieldlnfo(f_FAO_SG_PET)%Name
MET_field(g_Daylight_Station_Pressure)%Name =  'Daylight  Station Pressure [kiloPascal]'
MET_field(g_Daylight_Relative_Humidity)%Name =  'Daylight  Relative Humidity [%]'
MET_field(g_Daylight_Opague_Sky_Cover)%Name =  'Daylight  Opague  Sky Cover [tenths]'
MET_field(g_Daylight_Temperature)%Name = 'Daylight  Temperature  [°C]'
MET_field(g_Daylight_Broadband_Aerosol)%Name =  'Daylight  Broadband Aerosol  [optical depth]'
MET_field(g_Daylight_Mean_Wind_Speed)%Name =  'Daylight Mean Wind Speed @ 10 meters  [m/s]'
MET field(d Daylight max wind speed)%Name  =  'Maximum Daylight Mean Wind Speed @10m [m/s]'
MET_field(d_Daylight_direction_of_max_wind_speed)%Name =  'Direction of Maximum Daylight Wind [degre
MET_field(d_PWS)%Name = 'Daylight  Prevailing Wind_Speed  @z=10m  [m/s]'
MET_field(d_PWD)%Name = 'Daylight  Prevailing Wind_Direction [Degrees]'


                                                             283
-------
   End Subroutine SetFieldlnfo
   Subroutine TestjAfinteracter ( )

      Use Winteracter
      Implicit None
      Integer ::  uu = 6
      Character(Len=200) :: tbuf, wbuf, tdir
      Character(Len=200),  Dimension(50) :: vfiles
      Integer ::  nn, j, ierr
      Logical ::  have_dir

      Write (uu,  *) '  ***  Winteracter  ***  '
      tdir = 's:\ '
      have_dir = lOsDirExists(tdir)
      Write (uu, ^)  'Have directory  ', Trim(tdir),  '  ?  ', have dir

      !  Check create directory; Get  rid of the path and  create
      !  the new directory in the current directory.
      !  Warning: cannot create C:\a\b\c where \a\b does  not  exist.
      Call Temp_File_Name(tdir)
      j  = Index(tdir,  '\',  Back=.True.) + 1
      tdir = '000.'  // tdir(j:)
      If (.Not.  lOsDirExists(tdir))   Then
         Write  (uu,  ^ )  'Directory ', Trim(tdir),  ' did not exist; creating  ....'
         Call IQsDirMake(tdir)
         have_dir = lOsDirExists(tdir)
         Write  (uu,  *)  'Directory ', Trim(tdir),  ' exists ?  ', have  dir
      Else
         Write  (uu,  *)  'Bummer. Directory ', Trim(tdir),  ' exists; will  not  create.
      End If

      !  %temp% == "e:\TEMP"
      !  Note:  no trailing slash.
      tbuf = 'temp'
      Call IQsVariable(tbuf,  wbuf)    ! wbuf == e:\TEMP
      Write (uu, 9130)  Trim(tbuf),  Trim(wbuf)
9130  Format (Ix, '%',  a,  '% == "',   a, '"')

      !  does not look into subdirs.
      Vfiles(l)  = '**None**'
      tdir = 'z:\'
      tbuf = '14914_*.*'
      nn = 1
                                                                  284
-------
   Do j = 1, 2
      Call lOsDirEntryType('FD')
      Call lOsDirlnfo(tdir, tbuf, vfiles, nn)
      ierr = InfoError(l)
      Write (uu, *)  'lOsDirlnfo: nn =  ', nn,  ';  ierr
      Write (uu, *)  'Vfiles(l) == "', Vfiles(l),  '"'
      nn = Ubound(vfiles,1)
   End Do

   Stop 'Stopping at Test_Winteracter'

End Subroutine Test Winteracter
Subroutine Test_Multiples_of()

   Implicit None

   Integer ::  iNum
   Integer ::  uu = 9021
                  !! iNum =
   Call ttO( 1, 24)
   Call ttO(24, 25)
   Call ttO(25, 25)
   Call ttO(24,
   Call ttO(48,
   Call ttO(48,
   Call ttO( 2, J

   iNum = 3
   Write (uu, *)
   Call ttO(l, 2)   ! 0
   Call ttO(2, 4)   ! 1
   Call ttO(2, 8)   ! 2
   Call ttO(27, 29)   ! 1
   Call ttO(26, 33)   ! 3
   Call ttO(26, 34)   ! 3
   Call ttO(33, 33)   ! 1
   Call ttO(33, 39)   ! 3
   Stop 'Stopping at Test_Multiples_of'

Contains
                                                                285
-------
      Implicit None
      Integer, Intent(In) :: kO, kl

      Integer ::  n
   End Subroutine ttO

End Subroutine Test_Multiples_of
Subroutine Test Azimuth()

   !  Wind Direction
   !   Azimuth: Wind direction in degrees.
   !            (N = 0 or 360, E = 90, S = 180, W = 270)
   I
   !   Theta: regular angle measured counterclockwise
   !          from the +x axis.
   I
   !   Interconversion Formulae:
   !      Theta = Modulo(90-Azimuth, 360)
   !      Azimuth = Modulo(90-Theta, 360)
   I
   !  From Mathematica,  for the test case: (ArcTan(x/y) +  Pi) == Azimuth
   !  Note that Theta = ArcTan(y/x) + Pi
                                                               286
-------
1
I
I
I
1
1
I
I
1
1
I
I
1
1
I
I
1
1
I
I
1
1
I
I
1
1
Impli
Real
Real
Real
Real
Integ
Integ
Chara
Azimuth
0.0
15.0
30.0
45. 0
60. 0
75.0
90.0
105. 0
120. 0
135.0
150.0
165. 0
180. 0
195.0
210.0
225. 0
240.0
255.0
270.0
285. 0
300. 0
315.0
330.0
345. 0
360. 0
cit None
: : xO, xl,
Tt


(


]

3'
3:
3]
3t
2E
2'
2;

2^
2]
1<
If
If
i;
i:
i;
1C
c

xinc
: : aj ! Azimuth
: : tj ! Theta
: : bj ! A
er : : npts
er : : Jout
cter (Len=2
zimuth
, j
= 200
) : : tc
                    Theta   Azimuth  from Theta
                      90.0                   0.0
                      75.0                  15.0
                      60.0                  30.0
                      45.0                  45.0
                      30.0                  60.0
                      15.0                  75.0
                      0.0                  90.0
                      5.0                 105.0
                    330.0                 120.0
                    315.0                 135.0
                    300.0                 150.0
                      5.0                 165.0
                    270.0                 180.0
                    255.0                 195.0
                    240.0                 210.0
                                          225. 0
                                          240.0
                                          255.0
                                          270.0
                                          285. 0
                                          300. 0
                                          315.0
                                          330.0
                                          345. 0
                                            0.0     ?? !  0 is equivalent to 360. Result is ok.
                    tcoda

xO = 0
xl = 360
xinc = 15
npts = Ceiling((xl-xO)/xinc)
Write  (Jout, 9130)  'Azimuth',  'Theta',  'Azimuth from Theta'
Format (Ix, alO, 3x,  alO,  3x,  a!8)

Do j = 0, npts
   aj = xO + j ^xinc
   tj = Modulo(90-aj, 360)
   bj = Modulo(90-tj, 360)
   If  (Abs(aj-bj) <=  le-6)  Then
      tcoda =  ''
                                                             287
-------
         Else
            tcoda = '??'
         End If
         Write (Jout,  9150) aj,  tj, bj, tcoda
9150     Format (Ix, flO.l, 3x,  flO.l, 3x, f!8.1, 4x, a)
      End Do
      !  Zero/Zero generates a NAN
      Implicit None
      If (IsNaN(r2))  Then
         Write (6,*)  'Zero/Zero == NAN'
      Else
         Write (6,*)  'Zero/Zero /= NAN'
      End If
      !        0  1960-12-31 25h
      !        1  1961-01-01  Ih
      !   273924  1990-12-31 24h
      i   999999  2070-07-07 24h
      !  Given iv,  this subroutine computes the corresponding yyyy-mm-dd  hh
      !  and,  optionally, doy (day of the year).
                                                                  288
-------
Implicit None
Integer : :  yyyy, mm, old, hh
Integer ::  jv, jdoy, nbase, ymax,  i,  nperiods
   Write (ULog, *)
   Write (ULog, *)  'jv	:  ',  jv
   Write (ULog, *)  'nperiods...:  ',  nperiods
   Write (ULog, ^ )  ' ymax	:  ' ,  ymax
   Do yyyy =
      !! Hours_since_JdO(yyyy) =  (Jd(yyyy,01,01)  - JdO)  * Nhours
      !!nbase = Hours since JdO(yyyy)
      nbase = (Jd(yyyy,01,01)  - JdO)  *  Nhours
      If (jv > nbase) Exit
   End Do
   Write (ULog,  ^ )  ' nperiods ^Nhours	:  ' ,  nperiods ^Nhours
   Write (ULog,  *)  '(Jd(yyyy,01,01) -  JdO)  	:  ',  (Jd(yyyy,01,01) - JdO)
   Write (ULog,  *)  '(Jd(yyyy,01,01) -  JdO)  *  Nhours...:  ',  (Jd(yyyy,01,01) - JdO) * Nhours
                                                             289
-------
         j v = j v - nbase
         j doy = (j v+Nhours-1)  / Nhours
      End Do
   End Subroutine Test iv to ymdh
End Module Setup
                                                                  290
-------
Stats

!      Last change:  LSR  12 Mar 2002    9:05 am

Module Stats

   Use Global Variables

   !  Numerically stable computation of the variance.
   I
   !                         1     n
   !     Sample variance = 	  Sum  (x_i-x_mean)^2
   !                       n - 1  1=1
   !  Reference:
   !  [2]  Nicholas J. Higham. 1996. Accuracy and Stability of Numerical
   !      Algorithms. SIAM (Society for Industrial & Applied Mathematics
   !      ISBN 0-89871-355-2. Page 13.
   I
   !  Accumulate:
   !  Note that the updating formulae can be written:
   I
   !     M 0 = 0
                                                                  291
-------
Implicit None
Public
Real, Private, Parameter :: rZero = 0.0
Subroutine Stat_Test(Uout, xOk)

   !  Simple test of module "Stats"

   Implicit None
   Integer, Intent(In)
   Integer ::  k
   Real
   Type(Stat_Block)

   !  Test set #1
   Real,  Dimension(3)
   Real
   Real
Eps
Xblo<
   !  Initialize accumulator block
   Call Stat_Initialize(Xblock)

   !  Add points to accumulator
   Do k = 1, Ubound(Setl,l)
      Call Stat_Add_Point(Xblock, Setl(k)
   End Do
                                           Test  set  #1
                                                               292
-------
!  Compute results
Call Stat Results(Xblock)
If (xOk) Then
   Write(Uout, 9130)  ' Setl'
   Write(Uout, 9170) Xblock%xMean
   Write(Uout, 9190) Xblock%xVariance
Else
   Write(Uout, 9150)  'Setl1
   Write(Uout, 9170) Xblock%xMean, Msetl
   Write(Uout, 9190) Xblock%xVariance, Vsetl
End If
!  Initialize accumulator block
Call Stat_Initialize(Xblock)

!  Add points to accumulator
Do k = 1, Ubound(Set2,l)
   Call Stat_Add_Point(Xblock, Set2(k)
End Do
                                        Test  set  #2
!  Epsilon(Vset2) =  1.19209290E-07
!  Abs(Xblock%xMean-Mset2) =  2.38418579E-06
!  Abs(Xblock%xVariance-Vset2) =  5.96046448E-08
Eps = l.Oe-5 !  Kludge
xOk = (Abs(Xblock%xMean-Mset2)  < Eps)  .And.  &
      (Abs(Xblock%xVariance-Vset2)  < Eps)

IWrite(Uout,*)   'Eps = ', Eps
IWrite(Uout, *)   'Epsilon(Vset2)  = ', Epsilon(Vset2)
IWrite(Uout,*)   'Abs(Xblock%xMean-Mset2) = ', Abs(Xblock%xMean-Mset2)
IWrite(Uout,*)   'Abs(Xblock%xVariance-Vset2)  =  ', Abs(Xblock%xVariance-Vseti
                                                            293
-------
   End If

End Subroutine Stat_Test



Subroutine Stat Initialize(Xblock, Header)

   Implicit None
   Type(Stat_Block),            Intent(Out)  :
   Character(Len=*),  Optional, Intent(In)   :

   Xblock%k = 0
   Xblock%M k = rZero
   Xblock%Q k = rZero
   Xblock%xMean = -Huge(rZero)
   Xblock%xVariance = -Huge(rZero)
   Xblock%xmin = +Huge(rZero)
   Xblock%xmax = -Huge(rZero)

   If (Present(Header))  Then
      Xblock%Header = Header
   Else
      Xblock%Header = ''
   End If

End Subroutine Stat Initialize
:  Xblock
:  Header
   Implicit None
   Type(Stat_Block),  Target, Intent(InOut)  ::
   Real,
                             Intent(In)
            Pointer
   Real,
   Real
   Integer, Pointer
   Q k =
   k = k + 1
   !If (k >= 2) Then
   !    M_kml = M_k
   !    M_k = M_kml + (x_k-M_kml)/Real(k)
   !    Q_k = Q_k + (Real(k-1)/Real(k))*(x_k-M_
   !Else
                                                               294
-------
   !    !  k = 1
   !    M_k = x_k
   !    Q_k = rZero
   !End If
   M_kml  = M_k
   M_k =  M_kml +  (x_k-M_kml)/Real(k)
   Q_k =  Q_k + (Real(k-1)/Real(k))*(x_k-M_kml)**2
   Xblock%xmin = Min(x_k, Xblock%xmin)
   Xblock%xmax = Max(x_k, Xblock%xmax)

End Subroutine Stat Add Point
   Implicit None
   Type(Stat_Block),  Target, Intent(InOut)  :: Xblock
   If (Xblock%k >= 2) Then
      Xblock%xVariance = Xblock%Q_k/Real(Xblock%k-l)
   Else
      !  Variance not defined for k<=l
      Xblock%xVariance = -Huge(rZero)
   End If
   !  Output data descriptive statistics.
   !  Calls:  Stat_Results(Xblock)

   Implicit None
   Integer,                    Intent(In)     :: Uout
   Type(Stat_Block) ,            Intent(InOut)  :: Xblock
   Character(Len=*),  Optional, Intent(In)     :: Header

   Real ::  std dev !  Sample standard deviation
   Write(Uout, *)

   If (Present(Header))  Then
                                                               295
-------
         Write(Uout, 9130) Trim(Header)
      Else If (Len_trim(Xblock%Header) >  0) Then
         Write(Uout, 9130) Trim(Xblock%Header)
      End If
9130  Format  (Ix, a)

      Write(Uout, 9150) Xblock%k, Xblock%xMean, Xblock%xVariance
9150  Format  ( &
            Ix,   '   n  ....:  ', 10, /,  &
            Ix,   '   Mean  .:  ', Ipgl4.6, /,  &
            Ix,   '   Var ..:  ', Ipgl4.6)

      If  (Xblock%xVariance > rZero)  Then
         std dev = Sqrt(Xblock%xVariance)
         Write(Uout, 9170) std_dev
         Format  (Ix, '     StdDev:  ',  Ipgl4.6)
      End If
   End Subroutine Stat_Output

End Module Stats
                                                                   296
-------
UtilsO
   Use Date_Module
   Use Global_Variables
   Use loSubs
   Use Strings
   Implicit None
      !  Skip lines until we find a line starting with Xstring;
      !  All errors are fatal.

      Implicit None
      Character(Len=^), Intent(In) :: FileName
      Character(Len=^), Intent(In) :: Xstring
      Integer,          Intent(In) :: Jin

      Character(Len=132)  :: tbuf
      Integer            :: ios, lien
      Logical            :: Found_header_line

      Errors Detected = .False.
      Found header line =  .False.
      lien = Len(Xstring)
      GetHeader:  Do
         Read  (Jin,  '(a)',  lostat = ios) tbuf
         If (ios /=  0)  Exit GetHeader

         If (tbuf(l:Ilen)  == Xstring) Then
            !  Found  the header line.
            Found header line =  .True.
            Exit
         End If
      End Do GetHeader
      If (.Not. Found_header_line)
         Errors_Detected = .True.
         Write  (6,    9130) Xstring, Trim(FileName)
         Write  (ULog, 9130) Xstring, Trim(FileName)
         Format (Ix,  '?? Skip_Until: Could not  find  "',  a,
         Stop  '?? Skip_Until: Could not find header  line'
         !Return
                                                                  297
-------
   End If
End Subroutine Skip_Until
Subroutine Roundoff(Xval,  Nval, Wformat, &
      Target total, Xeps,  Yval, Delta_Sum)
     Statement of the problem: The problem when we distribute
     hourly precipitation among hours. The total amount to be
     distributed is given (Target_total, 2.3622). When the
     partial amounts are printed  (.e.g,  ' ( f 10 • 2 ) ' ) , the total
     sum of the printed values (xtotal,  2.35) is different.
     This subroutine attempts to
               Xval
               HP(full)
   Implicit None
   Real, Dimension(:
   Integer,
   Character(Len=*),
   Real,
   Real,
   Real, Dimension!:
   Real,
       tval
       HP(f0.2)
Intent(In)
Intent(In)
Intent(In)
Intent(In)
Intent(In)
Pointer
Intent(Out)
Xval
Nval
Wformat
Target_total
Xeps
Yval
Delta Sum
                                         tbuf
   xtotal = Zero
   n = Len_trim(Wformat)

   Do i = 1, Nval
                                                               298
-------
         Write(tbuf(i), Wformat(1:n)) Xval(i)
         Read(tbuf(i), *) Yval(i)
         xtotal = xtotal + Yval(i)
      End Do

      Delta_Sum = Target_total - xtotal
      If (Abs(Delta_Sum) > Xeps) Then
         Yval(l) = Yval(l) + Delta_Sum
      End If

   End Subroutine Roundoff
End Module UtilsO
                                                                  299
-------
Utilsl
   Use Date_Module
   Use FileStuff
   Use Global_Variables
   Use loSubs
   Use Strings
   Use Winteracter
   Use Utils5
   Implicit None
Contains
   Recursive Subroutine Display Station Info(Xstations, Xfull)

      Implicit None
      Type(Site_Info),   Pointer     :: Xstations   !  Pointer to  root  of  tree
      Logical, Optional, Intent(In)  :: Xfull
         !  Visit smaller values first.
         Call Display_Station_Info(Xstations%pLeft, Xfull)

         !  Process and write the current node.
         Call Display_This_Station(Xstations, Xfull)

         !  Then visit larger values.
         Call Display_Station_Info(Xstations%pRight, Xfull)
      End If
   End Subroutine Display Station Info
   Subroutine Display_This_Station(xWBAN, Xfull)

      Implicit None
      Type(Site_Info),   Intent(In)  :: xWBAN
      Logical, Optional, Intent(In)  :: Xfull
                                                                  300
-------
   Integer : :  i, yyyy, mm, dd
   Logical : :  all info

   If (Present (Xfull) ) Then
      all_info = Xfull
   Else
      all info = .False.
   End If
      Write (ULog, 9150) Trim (xWBAN%WBAN )
      Format  (Ix,  '@@@ Station Name:  ',  a)
      Write (ULog, *)  'Latitude  :  ', xWBAN%Lat
      Write (ULog, *)  'Longitude:  ', xWBAN%Lon

      Write (ULog, 9190) xWBAN%Elev
      Format  (Ix,  'Elev: ', Ipgl4.6)
      Write (ULog, 9230) xWBAN%Nelev
      Format  (Ix,  'Nelev:  ', 10)

      Do i = 1, xWBAN%Nelev
         Call Jd_to_ymd(xWBAN%Elev_Directives(i)%Julian_Day,  yyyy,  mm,  dd)
         Write  (ULog, 9250) i, yyyy, mm, dd, xWBAN%Elev_Directives(i)%Elevation_meter
         Format  (Ix,  '        [', 10,  ']  ',  14,  '-',  12.2,  '-',  12.2, ':  ',  Ipgl4.6)
      End Do
   End If

   If (xWBAN%Nelev == 0) Then
      Errors_Detected =  .True.
      Write (ULog, 9270) Trim(xWBAN%WBAN),  Trim(xWBAN%Text)
      Format  ('?? Station without elevation data:  ',  3x,  a,  3x,  a)
   End If

End Subroutine Display_This_Station
                                                                301
-------
!  Propagate modifications to Allocate_SAMSON_arrays and Deallocate_SAMSON_arrays
!  * 
!  * 

!  0.0/0.0 generates a NaN. I am using the NaN so that the program will
!  generate a message if the entry is used without being set first.
!  Good idea, but what about missing entries in the SAMSON file?
!  Missing entries are not read ==> value is NaN.

Implicit None

!  Nelements: used for testing Senegal. We need an array of an
!  specific size
Integer, Optional, Intent(In) :: Nelements
If (Present(Nelements))  Then
   M elems = Nelements
Else
   M_elems = (jdl-jdO+1)  * Nhours
End If
   !  Samson vlO
   Allocate(Xparam(jpar)%Samson_vlO(M_elems))
   Xparam(jpar)%Samson_vlO%s = T_Missing
   Xparam(jpar)%Samson vlO%v = Missing Data
   !Xparam(jpar)%Samson vlO%v = Zero/Zero !  NaN
   Xparam(jpar)%Samson_vlO%f = ''

   !  Samson vll
   If ((f_EHR <= jpar) .And. (jpar <= f_DHR))  Then
      Allocate(Xparam(jpar)%Samson_vll(M_elems))
      Xparam(jpar)%Samson_vll%s = T_Missing
      Xparam(jpar)%Samson vll%v = Missing Data
      !Xparam(jpar)%Samson vll%v = Zero/Zero  ! NaN
      Xparam(jpar)%Samson_vll%f = ''
   End If
End Do
                                                            302
-------
End Subroutine Allocate SAMSON arrays
                           vs .
   !  Deallocate SAMSON arrays
   !  Propagate modifications to Allocate_SAMSON_arrays  and  Deallocate_SAMSON_arrays

   Implicit None
   Integer ::  jpar

   !  Parameter zero is special:
   Xparam(0)%Samson_vlO => Null()    ! Unused  for param  zero
   Xparam(0)%Samson vll => Null()    ! Unused  for param  zero

   !  Deallocate arrays for each parameter.
   Do jpar = 1, f_end
      Deallocate(Xparam(jpar)%Samson vl0)

      If ((f_EHR <= jpar) .And.  (jpar <= f_DHR)) Then
         Deallocate (Xparam (jpar) %S amis on vll)
      End If

   End Do
   Implicit None
   Integer,          Intent(Out)  :: Jin
   Character(Len=*), Intent(In)   :: Zfile  ! e.g., d:\AHFiles\13873_91.
   !  Decompress data file and open it. See Assumption[5].

   Call FileNameParts(Zfile, ypath, yname, ytype)
   Call Temp File Name(tname, NamePrologue=yname)
                                                                303
-------
   Call IORead(Jin, tname)
End Subroutine Decompress and Open File


Subroutine Compare_SAMSON_Headers(WF10, WF11)

   !  Compare SAMSON vl.0  and vl.1 headers.

   Implicit None
   Type(Filelnfo), Intent(In) :: WF10, WF11
   Logical                    :: ok

   If  (WF10%Head%WBAN /= WFll%Head%WBAN) Then
      Write (ULog, '(lx,4a)') '?? WBANs do not match:  ',  &
            Trim(WF10%Head%WBAN), ';  ', Trim(WFll%Head%WBAN)
   End If

   If  (.Not. String_Eq(WF10%Head%Text, WFll%Head%Text))  Then
      Write (ULog, '(lx,4a)') '?? WBANs do not match:  ',  &
            Trim(WF10%Head%Text), ';  ', Trim(WFll%Head%Text)
   End If

   ok = (String_Eq(WF10%Head%Lat%Letter, WFll%Head%Lat%Letter))  .And.  &
          (WF10%Head%Lat%degrees == WFll%Head%Lat%degrees)  .And.  &
          (WF10%Head%Lat%minutes == WFll%Head%Lat%degrees)
   If  (.Not. ok) Then
      Write (ULog, '(a,2(2x,a2,10,Ix,10,:,"; "))')  '??  Latitudes do  not  match:  ',  &
            WF10%Head%Lat%Letter, WF10%Head%Lat%degrees,  WF10%Head%Lat%minutes,  &
            WFll%Head%Lat%Letter, WFll%Head%Lat%degrees,  WFll%Head%Lat%minutes
   End If

   ok = (String_Eq(WF10%Head%Lon%Letter, WFll%Head%Lon%Letter))  .And.  &
          (WF10%Head%Lon%degrees == WFll%Head%Lon%degrees)  .And.  &
          (WF10%Head%Lon%minutes == WFll%Head%Lon%degrees)
   If  (.Not. ok) Then
      Write (ULog, '(a,2(2x,a2,10,Ix,10,:,"; "))')  '??  Longitudes  do not match:  ',  &
            WF10%Head%Lon%Letter, WF10%Head%Lon%degrees,  WF10%Head%Lon%minutes,  &
            WFll%Head%Lon%Letter, WFll%Head%Lon%degrees,  WFll%Head%Lon%minutes
   End If
   If (Abs(WF10%Head%Elev - WFll%Head%Elev) > EpsO)  Then
      !  WF10%Head%Elev /= WFll%Head%Elev
      Write (ULog, '(a,Ipgl4.6,3x,Ipgl4.6)')  '??  Elevations  do  not  match:  ',  &
            WF10%Head%Elev , WF10%Head%Elev
   End If
                                                                304
-------
   End If

End Subroutine Compare_SAMSON_Headers
   Implicit None
   Type(Site_Info),  Target, Intent(In)   :: xWBAN
   Integer,                 Intent(In)   :: Julian_Day
   Logical,                 Intent(Out)  :: Xfound
   Real,                     Intent(Out)  :: Elevation
   If (Nelev == 0) Return

   !  The Julian Day limits in Elev Directives are such that
   !  Note
   !  * Jd(i) = Elev_Directives(i)%Julian_Day
   !  ^ Jd(Nelev+l) is defined to be +Infinity, i.e., present day
   Do ielev = Nelev, 1, -1
      If (Elev_Directives(ielev)%Julian_Day <= Julian_Day)  Then
         Xfound = .True.
         Elevation = Elev_Directives(ielev)%Elevation_meter
         Return
                                                               305
-------
      End If
   End Do
End Subroutine GetElevation
Subroutine Set Hours since JdO()
   !  See 

   Implicit None
   Integer ::  y4

   If (HsJDO_unset) Then
      HsJDO_unset = .False.
      Do y4 = MinYear, MaxYear
         HsJDO(y4) =  (Jd(y4,01,01) - JdO) * Nhours
      End Do
   End If
   I
   !  Examples: Assume JdO = Julian_Day 1961-01-01
   !   YYYY  Hours_since_JdO
   !   1961  0
   !   1962  365 * Nhours
   !   1963  365*2 * Nhours
   !   1964  365*3 * Nhours
   !   1965  (365*3 + 366) * Nhours
   I   ;      ;
   I
   !  See 
   Implicit None
   Integer, Intent(In)
   Integer
                                                               306
-------
End Function Hours since JdO
   Implicit None
   Integer, Intent(In)  :: jday
   Character(Len=l8)  :: str Jd to ymd
   !                          1
   !                 123456789012345678
   !                 2451545 2000-01-01
   str Jd to ymd =  'iiiiiii yyyy-mm-dd'
   Call Jd to ymd (jday, j yyyy, jmm, jdd)
   xstr = itoa(j mm)
   str_Jd_to_ymd(14:15) = Adjustr(xstr(1:2))
   If (str_Jd_to_ymd(14:14)  ==  '') Then
      str_Jd_to_ymd(14:14) = '0'
   End If

   xstr = itoa(jdd)
   str_Jd_to_ymd(17 :18) = Adjustr(xstr(1:2))
   If (str_Jd_to_ymd(17:17)  ==  '') Then
      str_Jd_to_ymd(17:17) = '0'
   End If

End Function str Jd to  ymd
Function str iv to ymdh(iv)
                                                                307
-------
   Implicit None
   Integer, Intent(In) :: iv
   Character(Len=21)   :: str_iv_to_ymdh

   Character(Len(str_iv_to_ymdh))  :: xstr
   Integer ::  jyyyy,  jmm, jdd, jhh

   !                           1         2
   !                  123456789012345678901
   !                  223676 1985-07-01  Ih
   str iv to ymdh = 'iiiiii yyyy-mm-dd HHh'
   Call iv_to_ymdh(iv, jyyyy, jmm, jdd, jhh)
   xstr = itoa (jmm)
   str_iv_to_ymdh(13:14)  = Adjustr(xstr(1:2))
   If (str_iv_to_ymdh(13:13) ==  '') Then
      str_iv_to_ymdh(13:13) = '0'
   End If

   xstr = itoa(jdd)
   str_iv_to_ymdh(16:17)  = Adjustr(xstr(1:2))
   If (str_iv_to_ymdh(16:16) ==  '') Then
      str_iv_to_ymdh(16:16) = '0'
   End If
End Function str iv to ymdh
                                                                308
-------
                                   24     25    Nhours = 2J
!  See 
!       iv  Date            nperiods  ymax
I  	  	  	  	
!        0  1960-12-31 25h
!        1  1961-01-01  Ih
!   273924  1990-12-31 24h
I   gggggg  2070-07-07 24h
Implicit None
Integer,           Intent(In)  :
Integer,           Intent(Out) :
Integer, Optional, Intent(Out) :

Integer ::  jv, jdoy, nbase

!  Get the year
i v = i v
Do yyyy = MaxYear, MinYear, -1
   !nbase = Hours_since_JdO(yyyy)
   nbase = HsJDO(yyyy)
   If (jv > nbase) Exit
End Do
If (yyyy < MinYear) Then
   Stop '?? Internal error in iv_to_ymdh: yyyy < MinYear1
End If
                                                            309
-------
                                      24     25    Nhours = 25
                                    9124
                                    9149
   Implicit None
   Integer,           Intent(In)
   Integer,           Intent(Out)
   Integer, Optional, Intent(Out)
   !nbase = Hours since JdO(yyyy)
   nbase = HsJDO(yyyy)
   iv = (jdoy-1)*Nhours + hh + nbase
End Subroutine ymdh to iv
                                                               310
-------
!  Compute the number of multiples of  INum  that  appear
!  in the interval  [Kmin, Kmax],  0 < Kmin <=  Kmax.
                   Nmultiples
                      0
                      1
                      2
                      1
!     33       33      1
!     33       39      3

Implicit None
Integer, Intent(In)  :
Integer              :

Integer ::  i, j
Logical ::  ok
Real    ::  rnum
!  If iNum == 0 we should not be  here  in  the  first  place.
If (iNum == 0) Return
                                                             311
-------
End Function Multiples_of


Function Pythag(a, b) Result(Rval)

   !  Computes Sgrt(a^*2 + b*^2) without destructive  overflow or  underflow.
   I
   !  History:
   !  = [Isr] Tue Dec 18 16:37:05 2001
   !    .  processed by "to_f90" on Tue Dec  18  16:37:05  2001
   !    .  Adapted from SLATEC/Pythag; ported to  f95
   I
   !***LIBRARY   SLATEC
   l***TYpE      SINGLE PRECISION  (Pythag-S)
   !***AUTHOR   (UNKNOWN)
   !***REVISION HISTORY   (YYMMDD)
   !    811101  DATE WRITTEN
   !    890531  Changed all specific intrinsics  to generic.   (WRB)
   !    891214  Prologue converted to Version  4.0 format.   (BAB)
   !    900402  Added TYPE section.   (WRB)

   Implicit None
   Real,  Intent(In)  ::  a
   Real,  Intent(In)  ::  b
   Real              : :  Rval

   Real ::p,g,r,s,t
   Real,  Parameter :: Two  = 2.0eO
   Real,  Parameter :: Four = 4.OeO
   Real,  Parameter :: eps  = Tiny(Two)
   !  The algorithm converges in at most three  iterations,
   !  assuming unit roundoff >= le-20.

   If (g <= eps) Then   !  (g == Zero)  ?
      Rval = p
      Return
   End If
                                                                312
-------
   Do
      r = (q/p) ** 2
      t = Four + r
      If (Abs(t-Four) <= eps)  Then   !  (t == Four) ?
         Rval = p
         Exit
      End If

      s = r / t
      p = p + Two*p*s
      q = q * s
   End Do

End Function Pythag
   Implicit None
   Integer, Intent(In) ::  TimeZone
   Integer             ::  Central Meridian

   Select Case(TimeZone)
   Case(4)     !  Letter Q, Atlantic
      Central Meridian = 60    ! 60W

   Case(5)     !  Letter R, Eastern
      Central Meridian = 75
   Case(7)     !  Letter T, Mountain
      Central_Meridian = 105

   Case(8)     !  Letter U, Pacific
      Central Meridian = 120
   Case(10)    !  Letter W, Hawaii-Aleutian
      Central Meridian = 150
                                                               313
-------
      Central_Meridian = -150     ! -150W is equivalent to  150E

   Case Default
      Central_Meridian = TimeZone * 15
   End Select

End Function TimeZone to Central Meridian
Subroutine Es_and_Delta(Tc, e_s, Delta)

   !  Tc     Temperature [°C]
   !  e s    saturation water vapor pressure  [kPa] at temperature  Tc;  Ref[1:36]
   !  Delta  slope of saturation water vapor pressure  [kPa/°C]
   Implicit None
   Real, Intent(In)  ::  Tc
   Real, Intent (Out) ::  e_s
   Real, Intent (Out) ::  Delta
   !  Propagate changes in the parameters
   !  to Es_and_Delta and DewPointF
   !  [FAO, Page 36, eq. 11]
   I
   !      eO(T) = es_cl * Exp(es_c2 * T /  (es_c3 + T))
   tmpC = Exp(es_c2 * Tc /  (es_c3+Tc))
   e_s  = es_cl * tmpC
   Delta = es_cl * es_c2 * es_c3 * tmpO /  (es_c3+Tc)**2
                    Cp * P

                 eps ^ lambda
                                                               314
-------
   Real, Parameter ::  Cp = 1.013     ! KJ Kg~-l K~-l
   Real, Parameter ::  Eps = 0.622    ! dimensionless
   Real ::  LambdaF
End Function GammaF



!Function LambdaF(Tdew) Result(LambdaV)
I
!    !   
I    I
!    !  Tdew      Dew point temperature  [ °C]
!    !  LambdaV   Latent heat (enthalpy) of vaporazation  [KiloJoules/Kg]
!    Implicit None
!    Real, Intent(In) :: Tdew
!    Real             :: LambdaV
I
!    LambdaV = 2501  - 2.361*Tdew
I
!End Function LambdaF
Function Wind_Speed_F(ulO, T_Height) Result(ux)

   !  ulO       Wind Speed in  [m/s] at z=10 meters
   !  T_Height  Height indicator
   !  ux        Wind Speed in  [m/s] at z indicated by T_Height
   Implicit None
   Real,    Intent(In)  ::  ulO
   Integer, Intent(In)  ::  T_Height
   Real                ::  ux
   !  
   !  On input, Wind Speed in meters/sec was normalized to  z=10 meters.
   !   Height   Height indicator  h x
                                                               315
-------
                              5.81  == Ln((10-0)/O.03)
                              4.87
                              4.89
                              3.56
                              1. 05
!  u_c :  wind speed at height z_c  (m)
!  d c :  zero plane displacement  (m)
!  z Oc:  surface roughness length or roughness height  (m)
I
!  For Open Flat Terrain  (used for Metereological Stations):
!      zO = 0.03 meters
!      dO = 0
!      z = 10 meters  (reference height)
tu = ulO / 5.81
Select Case(T_Height)
Case(T_ulO)
   !  Height = 10 m
   ux = ulO
Case (T_u4 )
   !  Height = 4 m
   ux = tu * 4.89
Case (T_upl )
   !  Height = 0.1 m
   ux = tu * 1 . 05

Case Default
   Write  (6, *)   '?? Wind_Speed_F: unknown wind indicator ==  ',  T_Height
                                                            316
-------
      Write (ULog, *) '?? Wind_Speed_F: unknown wind  indicator  ==  ',  T_Height
      Stop '?? Wind Speed F: unknown wind indicator1
   End Select

End Function Wind_Speed_F
   !  Estimate dewpoint from inversion of eq. 14,  FAO,  Page  37.
   I
   !  Ta        Air temperature  [°C]
   !  RH        Relative humidity  [%]
   !  Tdew      Dew point temperature  [°C]
   Implicit None
   Real, Intent(In) ::  Ta
   Real, Intent(In) ::  RH
   Real             ::  Tdew

   !  e_s    saturation water vapor pressure  [kPa] at temperature  Tc;  Ref[l:36]
   !  e_a    Atmospheric water vapor pressure; actual water  vapor  pressure,  [kPa]
   !  Delta  slope of saturation water vapor pressure  [kPa/°C]
   Real ::  e_s, Delta,  e_a

   !  e_s = eO(Ta)
   Call Es and Delta(Ta, e s, Delta)    ! Delta unused.
   !  Propagate changes in the parameters
   !  to Es_and_Delta and DewPointF
   !  [FAO, Page 36, eq. 11]
                                                                317
-------
Subroutine Generate File names()

   !  Generate the names of all files associated with the current wban number.
   !  
   !  
   Implicit None

   Character(MaxNamLen) :: tdir, tname
   Integer ::  yyyy, n
   Character(Len(pWBAN%WBAN)+1) :: W_Wban
   Character(Len=5)::  W_State

   !  Output directory of the form: v:\rO\\14914\
   !      where  is the two letter abbreviation of
   !      state where the station is located,  .e.g,
   !            v:\rO\AK\25501\
   W_State = pWBAN%State
   R0_full = Trim(RO_root) // Trim(W_State) // DirDelim // Trim(pWBAN%WBAN)
   Call STD_dir(R0_full)
   tdir = RO full
   End Do

   !  name_met == v:\rO\ND\14914\wl4914.dvf
   !  name_txt == v:\rO\ND\14914\wl4914.txt
   tname = Trim(tdir) // W_Wban(l:n)
   name_met = Trim(tname) // '.dvf
   name_txt = Trim(tname) // '.txt'

   !  Generate filenames:
   !  Daily Precipitation files:
   !      v:\precip\03940.d
   !      v:\precip\03940g.d          ! with gaps in the yearly record.
   !  Hourly Precipitation files:
   !      v:\precip\03940.h
   !      v:\precip\03940g.h
                                                               318
-------
   !  Daily evaporation file:
   !      v:\evaporation\T_14914.evp
   name Daily Evap = Trim(Raw Data dir) //  'evaporation1  //  &
         DirDelim // 'T_' // Trim(pWBAN%WBAN) //  '.evp'

End Subroutine Generate File names
Subroutine Initialize Output Directory()
   Character(Len(pWBAN%WBAN))  :: Wban
   Character(MaxNamLen) :: tdir
   Integer ::  yyyy, kO, kl, tlen
   Logical ::  have file
   !  If the output directory does not exist, exit.
   !  Output directory of the form: v:\r0.by.State\AK\25501\
   !  IQsDirMake will not create directory path x:\a\b\c\
   !  if, for example, directories a or b do not exist.
   !  We have to check and create each component individually  —  bummer.

   tdir = R0_full
   Call STD_dir(tdir)       ! Make sure tdir has a trailing delimiter
   tlen = Len_Trim(tdir)
   kl = 1

   do
      If (kl > tlen) Exit
      If (.Not. lOsDirExists(tdir(l:kO))
         Call IQsDirMake(tdir(l:kO))
         If  (.Not. lOsDirExists(tdir(l:kO))) Then
            Write(ULog, *)  '?? Could not  create Directory  ',  Trim(tdir(1:kO)
            Stop            '?? Stopping --  Could not  create  Directory.'
             !Return
                                                                319
-------
      End If
   End If
   kl = kO + 1 !  Skip over previous delimiter
End Do
!  Hourly Values Files
Do yyyy = MinYear, MaxYear
   Inquire(File=name_rO(yyyy), Exist=have_flie)
   If (have_file)  Then
      Call lOsDeleteFile(name_rO(yyyy))
   End If
End Do

!  Later vintage: Winteracter does not  complain if
!      the file does not exist.
Call lOsDeleteFile(name_met)
Call lOsDeleteFile(name txt)
!  http://www.spc.noaa.gov/fag/tornado/beaufort.html
!  gyre.umeoce.maine.edu/data/gomoos/php/variable description.php?variable=wind  speed
!      -- Warning:  the m/s quantities in gyre.umeoce.maine.edu  are wrong!
!  http://whale.wheelock.edu/whalenet-stuff/beaufort.html
Implicit None
Real,             Intent(In)  :: Wind Speed   ! in meters/second
Integer,          Intent(Out) :: Vforce       ! Beaufort Force
Character(Len=*),  Intent(Out) :: Vtext        ! explanation

Type ::  BF
   Real  ::  Wind_Speed   !  Lower limit of range, in meters/second
   Character(Len=80) :: WMO_Classification =  ''
   Character(Len=80) :: SeaText =  ''
   Character(Len=80) :: LandText =  ''
End Type BF

Integer  ::  i
Type(BF),  Dimension(0:12), Parameter :: VInfo =  (/ &
      BF(  0.0, 'Calm',   'Sea surface smooth and mirror-like',  'Smoke  rises  vertically'),  &
      BF(  0.3, 'Light air',  'Scaly ripples, no foam crests', &
      'Smoke drift indicates wind direction,  still wind vanes'), &
      BF(  1.6, 'Light Breeze',  'Small wavelets, crests glassy, no breaking',  &
      'Wind felt on face,  leaves rustle, vanes begin to move'), &
      BF(  3.4, 'Gentle Breeze',  'Large wavelets, crests begin  to break,  scattered  whitecaps',  &
      'Leaves and small twigs constantly moving, light flags extended  '),  &


                                                            320
-------
            BF( 5.5, 'Moderate Breeze1,  'Small waves 1-4 ft. becoming  longer,  numerous  whitecaps',  &
            'Dust,  leaves, and loose paper lifted, small tree branches move'),  &
            BF( 8.0, 'Fresh Breeze', 'Moderate waves 4-8 ft taking  longer  form, many whitecaps,  some  spray',  &
            'Small  trees in leaf begin to sway'), &
            BF(10.8, 'Strong Breeze',  'Larger waves 8-13 ft, whitecaps common,  more  spray',  &
            'Larger tree branches moving, whistling in wires'),  &
            BF(13.9, 'Moderate Gale',  'Sea heaps up, waves 13-20 ft, white  foam streaks off  breakers',  &
            'Whole  trees moving, resistance felt walking against wind'), &
            BF(17.2, 'Fresh Gale',  'Moderately high (13-20 ft) waves of  greater length,  edgesS
            & of crests begin to break into spindrift, foam blown in streaks',  &
            'Twigs  broken off trees, walking against wind very difficult'),  &
            BF(20.8, 'Strong Gale',  'High waves  (20 ft), sea begins to roll,  denseS
            & streaks of foam, spray may reduce visibility', &
            'Slight structural damage occurs, slate blows off roofs'), &
            BF(24.5, 'Storm', 'Very high waves (20-30 ft) with overhanging  crests,&
            & sea white with densely blown foam,  heavy rolling,  lowered  visibility',  &
            'Seldom experienced on land, trees broken or uprooted,  "considerable  structural  damage"'),  &
            BF(28.5, 'Violent Storm',  'Exceptionally high  (30-45 ft) waves,  foam  patchesS
            & cover sea, visibility more reduced', &
            'Widespread damage,  very rare occurence'), &
            BF(32.7, 'Hurricane',  'Air filled with foam, waves over 45 ft,  sea  completelyS
            & white with driving spray, visibility greatly reduced', &
            'Violent destruction') /)

      Do i = Ubound(VInfo,l), Lbound(VInfo,1), -1
         If (VInfo(i)%Wind_Speed <= Wind_Speed) Then
            Vforce  = i
            Vtext = VInfo(i)%LandText
            Return
         End If
      End Do

      Vforce = -1
      Write (Vtext,  9130) Wind_Speed
9130  Format ('?? Beaufort_Wind_Scale:  incorrect WindSpeed =  ',  Ipgl4.6)
   End Subroutine Beaufort Wind Scale
   Subroutine Meta_Data_File()

      Implicit None

      Integer ::  j, kO, kl, uu, fO, fl
      Logical ::  xok
      Character(Len=80) :: tbuf
                                                                  321
-------
         Errors_Detected = .True.
         Return
      End If

      j  = Index(pWBAN%Text, ',')
      kO = j - 1    !  City
      kl = j + 2    !  State
      j  = Index(pWBAN%TZ,  '(') - 1

      Write (uu,  9130) 'Station WBAN Number:  ', Trim(pWBAN%WBAN)
      Write (uu,  9130) 'Station Name:  ', pWBAN%Text(1:kO)
      Write (uu,  9130) 'Station Location  (State):  ', pWBAN%Text(kl:kl+1)
      Write (uu,  9130) 'Station Time Zone:  ', Trim(pWBAN%TZ)
9130  Format (a,  a)
      Write (uu, 9150) 'Station Latitude:   ', &
            pWBAN%Lat%Letter, pWBAN%Lat%degrees, pWBAN%Lat%minutes
      Write (uu, 9150) 'Station Longitude:  ', &
            pWBAN%Lon%Letter, pWBAN%Lon%degrees, pWBAN%Lon%minutes
9150  Format (a, al, 15,  '  degrees  ', 12,  ' minutes')
      Write (uu, 9130) 'File generation date:  ', Trim(TimeStamp)

      Call Str_years(tbuf)
      Write (uu, '(a,a)') 'Years present:', Trim(tbuf)

      fO = 1 + Index (name_met, DirDelim, Back=.True.)
      fl = Len_trim(name_met)
      Write (uu, 9190) name_met(f0:f1)
9190  Format (&
         1!',  /, &
         '!  The meteorological Daily Values File "', a,  &
         '" has the following format:')
      Call lOClose(uu)

   End Subroutine Meta Data File
                                                                   322
-------
!  Copy contents of Uin to Uout.
Implicit None
Integer, Intent(In) :: Uin, Uout
                      iostatus
                      tbuf
Read a Line: Do
   Read (Uin, '(a)', iostat=iostatus) tbuf
   If (iostatus /= 0) Exit Read_a_Line
   Write (Uout,  '(a)') Trim(tbuf)
End Do Read a Line
                                                            323
-------
Utils2
   !Use Binary Tree
   !Use Date_Module
   !Use FileStuff
   !Use Floating Point Comparisons
   !Use GetNumbers
   !Use loSubs
   !Use Linked_List
   !Use Read_Info
   !Use Reallocate Module
   !Use SAMSON
   !Use Strings
   !Use UtilsO
   !Use Utilsl
   Use ETO
   Use Fix_Data_Records
   Use Global Variables
   Use Precipitation module
   Use Process_Gaps
   Use Stats
   Use Utils4
   Implicit None

   Type ::  XQuadrant
      Integer ::  n = 0
      Integer, Dimension(1:24) ::  h = 0
      Real    : :  ws_max = Zero
      Integer ::  ws_d!2 = 0
      Real    ::  ws mean = Zero
   End Type XQuadrant

   Type ::  XPerSeg
      Type(XQuadrant), Dimension(:), Pointer  :: Quads
      Integer, Dimension(:), Pointer :: Tied  List
      Integer ::  Tied_N
      Integer ::  isub, imod
      Real    ::  rdiv
   End Type XPerSeg
            Do k = 1, f_SAMSON
               Select Case(k)
                  Case(f_EHR)
                  Case(f_EDNR)
                  Case(f GHR)
                                                                  324
-------
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
I I I
      Case(f_DNR)
      Case(f_DHR)
      Case(f_TSC)
      Case(f_OSC)
      Case(f_DBT)
      Case(f_DPT)
      Case(f_RH)
      Case(f_SP)
      Case(f_WD)
      Case(f_WS)
      Case(f_HV)
      Case(f_CH)
      Case(f_pH2O)
      Case(f baod)
      Case(f_SD)
      Case(f_DSLS)
      Case(f_HP)
      Case(f_OI)
      Case Default
         Write(6,*;
         Stop
   End Select
End Do
!  Direct  Normal  Radiation
!  Diffuse Horizontal Radiation
!  Total  Sky Cover
!  Opaque  Sky Cover
!  Dry Bulb Temperature
!  Dew Point Temperature
!  Relative Humidity
!  Station Pressure
!  Wind Direction
!  Wind Speed
!  Horizontal Visibility
!  Ceiling Height
!  Precipitable Water
!  Broadband Aerosol Optical Depth
!  Snow Depth
!  Days since last Snowfall
!  Hourly  Precipitation (value + flags)
!  Observation Indicator / Present Weather
      !  
      Integer ::  yyyy,  ybase,  from beg,  from end, to beg, to end
      Logical ::  okay
      Integer ::  k,  kl,  iv,  jday,  hh25,  j, vdim
      Integer ::  ierr
      Type(Val_and_Flag),  Dimension(:),  Pointer  :: HV, CH, HP, DSLS, vf
      !  Transfer data SAMSON v 1.1 to SAMSON v 1.0
      Xparam(f_GHR )%Samson_vlO = Xparam(f_GHR )%Samson_vll
      Xparam(f_EHR )%Samson_vlO = Xparam(f_EHR )%Samson_vll
      Xparam(f_EDNR)%Samson_vlO = Xparam(f_EDNR)%Samson_vll
      Xparam(f_DNR )%Samson_vlO = Xparam(f_DNR )%Samson_vll
                                                                  325
-------
Xparam(f_DHR )%Samson_vlO = Xparam(f_DHR  )%Samson_vll

!  Read observed ppt data
Call Read_Hourly_Ppt(okay)
If  (.Not. okay) Then
   Errors Detected = .True.
End If

Call Read_Daily_Ppt(okay)
If  (.Not. okay) Then
   Errors_Detected = .True.
End If

!    
!  See also 
!  if some years are missing, fill the missing years with data
!  from an existing year. We will delete the  added data when
!  generating the rO files and the MET records.

Do yyyy = MinYear, MaxYear
    ! If the SAMSON version 1.0 file is missing, then we  will
    ! say that everyting is missing, even  if  SAMSON version 1.1
    ! is present.
   If (Year_Data(yyyy)%SAMSON_vlO == 0) Then
      !  For non-leap years, copy year = 1963
      !  For leap years, copy year = 1964
      !  These years are always present.
      If (IsLeapYear(yyyy)) Then
         ybase = 1964
      Else
         yb ase = 1963
      End If

      !  My previous comment notwithstanding, verify that the
      !  data for the stated base year exists.
      If (Year_Data(ybase)%SAMSON_vlO ==  0)  Then
         Write(*,     *)  '?? Missing base  year  ', yyyy,  '. Stopping
         Write(ULog,  *)  '?? Missing base  year  ', yyyy,  '. Stopping
         Stop  '?? Missing base year '
      End If

      Call ymdh to iv(ybase, mm=01, dd=01, hh=01,     iv=from beg)
      Call ymdh to iv(ybase, mm=12, dd=31, hh=Nhours, iv=from end)
      Call ymdh_to_iv(yyyy,  mm=01, dd=01, hh=01,     iv=to_beg)
      Call ymdh_to_iv(yyyy,  mm=12, dd=31, hh=Nhours, iv=to_end)

      Write (ULog, 9130) yyyy, ybase, yyyy
      Format (/,  &
            Ix, '## Data for ', 14, &
            1  is missing and was filled with data from  ', 14, &
                                                             326
-------
            1  for analysis purposes. ' , /, &
            Ix,  '    The year  ', 14,  &
            1  will not be present in the final suite of  files.'

      !  Copy all records.
      Do k = 1,  f_SAMSON
         Xparam(k)%Samson vlO(to beg:to end) = &
               Xparam(k)%Samson_vlO(from_beg:from_end)
      End Do
      Obs ppt(to beg:to end) = Obs ppt(from beg:from end)
   End If
End Do

Call Standardize ppt(HP, Accum Samson, okay)
If (.Not. okay)  Then
   Errors_Detected = .True.
End If

If (Have_ppt_Obs_hourly_data) Then
   Call  Standard!ze_ppt (Obs_ppt, Accum_EI, okay)
   If (.Not. okay)  Then
      Errors Detected = .True.
   End If
End If

!  Fix SAMSON performs manual correction of the data records.
!  Be careful when fixing precipitation records, in particular,
!  with runs of missing, deleted, or  accumulated values.
!  Make sure the beginning or end of  such a run is not  lost
!  on transfer.
Call Fix_SAMSON(okay)
If (.Not. okay)  Then
   Errors_Detected = .True.
End If
!  #1.1   Process BAOD first. For some sites, BAOD is
!            missing for nighhtime  (in particular, hh = 24).
!  #3. Interpolate, fill gaps, and otherwise process the
!      hourly data as needed.
I
!  #4. THEN fill the 25th hour with the daily values.
!      Compute other parameters as needed.
!      Note that if we compute the daily values first
!      and then fill gaps (invert steps #3 and #4), the
!      interpolation scheme would have to determine if
                                                            327
-------
!      the interpolation boundary or the interpolation
!      range contains a "25th" hour. Do not use nor
!      fill a 25th hour during interpolation.

!  Missing values for BAOD reguire special treatment.
Call Process_BAOD(okay)
If  (.Not. okay) Then
   Errors_Detected = .True.
End If

!! Use Fill-Gaps algorithms. 12 Mar 2002  2:08 pm
!! Wind Speed: Fill missing hourly values with the monthly mean
MCall Set_Hourly_Values (f_WS, okay)
!!If (.Not. okay) Then
!!   Errors_Detected = .True.
!!End If

!  Set the 25th hour to NaN. We will see these on output,
!  unless set first.
!   6 May 2002  3:24 pm: Warning: according to If95,
!         Zero/Zero == NaN
!         and Nint(Xparam(1)%Samson_vlO(2*NHours)%v) ==  0,
!         i.e, Nint(NaN) == 0  !?

Do k = 1, f_SAMSON
   vf => Xparam(k)%Samson vlO
   vdim = Ubound(vf,l)
   vf(NHours:vdim:NHours)%v = Zero / Zero
End Do

Call ToTTy('Process_Set: Process_Days_since_last_Snowfall')
Call FLushAll()
Call Process_Days_since_last_Snowfall(okay)
If  (.Not. okay) Then
   Errors_Detected = .True.
End If

!  Convert "flag" values to numbers
      
         HREF="Onotes.txt#Note_15">
         HREF="Onotes.txt#Note_16">
Write(ULog, *)
Write(ULog, 9150)  '## Maximum Horizontal Visibility:
Write(ULog, 9150)  '## Maximum_Ceiling_Height  	:
Format (Ix, a, Ipgl4.6)
Maximum Horizontal Visibility
Maximum Ceiling Height
                                                            328
-------
!  Change the flag value of Unlimited visibility  (777.7)
!      to 110% of the maximum value attained.
!  Change the flag values of Unlimited ceiling height  (77777),
!      Cirroform  (88888) to 110% of the maximum attained.
Fieldlnfo(f_HV)%maximum_value = Maximum_Horizontal_Visibility  *  1.10
Fieldlnfo(f CH)%maximum value = Maximum Ceiling  Height  ^  1.10
Do iv = 1,  kl
   If (HV(iv)%s == TJJnlimited) Then
      HV(iv)%v = Fieldlnfo(f_HV)%maximum_value
   End If
   Select Case(CH(iv)%s)
   Case(T_Unlimited)
      CH(iv)%v = Fieldlnfo(f_CH)%maximum_value
   Case(T Cirroform)
      CH(iv)%v = Fieldlnfo(f_CH)%maximum_value
   End Select
End Do
Call ToTTy('Process_Set: Fill gaps et al.')
Call FLushAll()
!  Fill gaps et al.
Do k = 1, f_SAMSON

   !  Gaps anywhere.
   Select Case(k)
   Case(f_HP)
      !  Hourly precipitation must be processed after
      !  everybody else. We will process  HP manually.
      !Case(f_HV)  !  Horizontal Visibility
      !Case(f_CH)  !  Ceiling Height
      !  Also, be careful filling gaps when
      !  #1. Visibility == 777.7 = unlimited visibility.
      !  #2. Ceiling Height == 77777 = unlimited  ceiling  height,  or
      !                     == 88888 = Cirroform.
      !  We have this problem for 14914  (Fargo),  1965-01-01  12h-15h

   Case Default
      Call Find_Gaps(k)
   End Select
End Do
                                                             329
-------
!  Process precipitation.
Call Process Precipitation(okay)
If  (.Not. okay) Then
   Errors_Detected = .True.
End If

!  Estimate missing Dew Point observations.
Call Fill_Dew_Point(okay)
If  (.Not. okay) Then
   Errors_Detected = .True.
End If
Call ToTTy('Process_Set: Compute daily values.')
Do k = 1, f_SAMSON
   okay = .True.
         f_EHR,   &   ! Extraterrestrial Horizontal  Radiation
         f_EDNR,  &   ! Extraterrestrial Direct Normal  Radiation
         f_GHR,   &   ! Global Horizontal Radiation
         f_DNR,   &   ! Direct Normal Radiation
         f_DHR)       ! Diffuse Horizontal Radiation
      Call Daily Values(k, T Cumulative, okay)
         &  !  **•  	
         f_TSC,   &   ! Total Sky Cover
         f_OSC,   &   ! Opaque Sky Cover
         f_DBT,   &   ! Dry Bulb Temperature
         f_DPT,   &   ! Dew Point Temperature
         f_RH,    &   ! Relative Humidity
         f_SP,    &   ! Station Pressure
         f_HV,    &   ! Horizontal Visibility
         f_baod,  &   ! Broadband Aerosol Optical  Depth
         f_CH,    &   ! Ceiling Height
         f_pH2O,  &   ! Precipitable Water
         f SD)        ! Snow Depth
   Case(f_HP)         ! Hourly Precipitation  (value  +  flags)
      !  Do nothing. The daily value was  computed  by
      !  
      ICall Daily_Values(k, T_Cumulative, okay)
                                                             330
-------
   Case(f_WD)     !  Wind Direction
      !  Do nothing.  Wind Direction and Wind Speed must
      !  be done simultaneously. See f_WS below.

      !  = 29 Jan 2002  4:11 pm
      !    ^ since we are computing mean wind speed,
      !      we need to fill the 25-th hour with Zero.
      Call Daily_Values(k, T_Not_Applicable, okay)

   Case(f_WS)     !  Wind Speed
      i  *** 
      !  If a particle were transported ... **** Needs work
      i  *** Decompose into x- and y- components ...
      !  The daily value is the vector sum of the hourly  components.
      !  -- not anymore 29 Jan 2002  4:08 pm
      !  Call Daily_Wind_Speed(okay)  !  unused, 29 Jan 2002   4:08  pm
   Case(f_DSLS)   !  Days since last Snowfall
      !  Copy the 24h value to the 25h.
      hh25 = 0
      Do  jday = jdO, jdl      !  step by day
         hh25 = hh25 + NHours !  Index of the 25th hour of jday ==  (jday-jdO+1)*NHours
         j = hh25 - 1         !  the 24th hour of the current day  (jday)
         Select Case(DSLS(j)%s)
         Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
            !  Not a valid number.
            DSLS(hh25) = Val_and_Flag(T_Estimated, Zero,  '')
         Case Default
            DSLS(hh25) = Val_and_Flag(T_Estimated, DSLS(j)%v,  '')
         End Select
      End Do
      okay = .True.

   Case(f OI)      !  Observation Indicator / Present Weather
      Call Daily_Values(k,  T_Not_Applicable, okay)

   Case Default
      Write(6,*) 'Process_Set:  Internal error: no "CASE(f_k)" for  k=',  k
      Stop       '?? Stopping in Process_Set: Internal error: no  "CASE(f_x)"'
   End Select

   If (.Not. okay)  Then
      Errors Detected = .True.
   End If
   Call FLushAll()
End Do
                                                            331
-------
   !  Rs    (a + b[opaque_sky_cover]) * Ra
   I	=	
   !  Rso             a * Ra
   I
   !        (a + b[opaque_sky_cover])
   Call ToTTy('ETO_et_al'
   Call ETO_et_al(okay)
   Call FLushAll()
   !  Must be the last statement of the file.
   Call ToTTy('Process_Set:  Set_Missing_Flags')
   Call Set_Missing_Flags()

End Subroutine Process Set
   Implicit None
   Integer, Intent(In) :: k_id

   Integer, Pointer :: min obs per day
   Type(Val_and_Flag), Dimension(:), Pointer  :: xsd    ! X-Data
   !  Gaps anywhere.
   Select Case(k_id)
   Case(f_OI)
      !  Observation Indicator, Present weather
      !  It makes no sense to fill gaps in these parameters

      !Case(f_HV)   ! Horizontal Visibility
      !Case(f CH)   ! Ceiling Height
      !  Also, be careful filling gaps when
      !  #1. Visibility == 777.7 = unlimited visibility.
      !  #2. Ceiling Height == 77777 = unlimited ceiling height,  or
                                                               332
-------
      !                     == 88888 = cirroform.
      !  We have this problem for 14914  (Fargo), 1965  1  1  12h-15h

   Case Default
      Call Find_Gaps(k_id)
   End Select
End Subroutine Process Param
   !  
   !  Fill missing hourly values with the monthly mean

   Implicit None
   Integer, Intent(In)  :: k_id
   Logical, Intent(Out)  :: Xok

   Integer :: yyyy,  mm,  dd, hh, iv, jvO, jvl
   Integer :: ierr,  npoints, minN
   Real    :: xsum
   Type(Val_and_Flag), Dimension(:),  Pointer  :: vf, WD
   Integer, Dimension(:),  Pointer  :: Days_in_Month
                                     ! Wind Direction
         CheckThisMonth: Do iv = JvO, jvl
            If (Modulo(iv,25) == 0) Then
               !  Skip 25-th hour of the day.
               Cycle CheckThisMonth
            End If

            Select Case(vf(iv)%s)
            Case(T_Missing,  T_Not_Applicable, T_Undefined,  T_Perpetual_Darkness)
                                                                333
-------
               !  Not a valid number: Do nothing.
            Case Default
               npoints = npoints + 1
               xsum = xsum + vf(iv)%v
            End Select
         End Do CheckThisMonth

         !  Done with the month. Do we have points?
         If (npoints < minN) Then
            ierr = ierr + 1
            Write(ULog, 9130) Trim(Fieldlnfo(k_id)%Name), yyyy, mm,  npoints,  minN
            Format(Ix, '?? Set_Hourly_Values:  ',  a, Ix,  &
                  14,  '-', 12.2, ':  found ',  10,  ' points, need  ',  10)
            Cycle MonthLoop
         End If
         !  Set Values
         SetThisMonth: Do iv = jvO, jvl
            If (Modulo(iv,25) == 0) Then
               !  Skip 25-th hour of the day.
               Cycle SetThisMonth
            End If

            Select Case(vf(iv)%s)
            Case(T_Missing,  T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
               vf(iv)%v = xsum
               vf(iv)%s = T_Estimated
               vf(iv)%f = ''
               !  If we are dealing with Wind Speed,
               !  Then zero Wind Direction also.
               If  (k_id == f_WS) Then
                  WD(iv)%v = Zero
                  WD(iv)%s = T_Estimated
                  WD(iv)%f =  ''
               End If
            End Select
         End Do SetThisMonth

      End Do MonthLoop
   End Do

   Xok = (ierr == 0)

End Subroutine Set Hourly Values
Subroutine Daily_Wind_Speed(Xok)
                                                               334
-------
!  = 29 Jan 2002  4:05 pm
!    * module not used. Wind Speed daily value will be
!      a simple average.

!  Compute Mean Wind Speed over 24-hour periods.
!* 
Implicit None
Logical, Intent(Out)  :: Xok

Integer :: jday,  hhOl, hh24, hh25, hh
Integer :: minN,  nn,  ierr, ntt, jyyyy, jmm, jdd
Real    :: xsum,  ysum, resultant, Azimuth, Theta
Type(Val_and_Flag), Dimension!:),  Pointer :: WD
Type(Val_and_Flag), Dimension(:),  Pointer :: WS
Character(Len(Fieldlnfo(1)%Name)), Pointer :: txt
Type(Stat_Block)  :: daily_ws
Call Stat_Initialize(daily_ws,  'Wind Speed, daily values')

ierr = 0
WD => Xparam(f_WD)%Samson_vlO  ! Wind Direction in degrees
WS => Xparam(f_WS)%Samson_vlO  ! Wind Speed in m/s
minN = Fieldlnfo(f WD)%Minimum obs per day
txt => Fieldlnfo(f_WD)%Name
ntt = Len_trim(txt)

!  Wind Direction          0-360       Wind direction in  degrees.
!                                       (N = 0 or 360, E = 90,  S  =  180,
!                                      W = 270)
I
!  Wind Speed
I
!           0
!   Azimuth: Wind direction in degrees.
!            (N = 0 or 360, E =  90, S = 180, W =  270)
I
!   Theta: regular angle measured counterclockwise
                                                             335
-------
!  From Mathematica, for the test case:  (ArcTan(x/y) + Pi) == Azimuth
!  Note that Theta = ArcTan(y/x) + Pi
I
!  Subroutine Test Azimuth tests these formulae.

Do jday = jdO, jdl               !  step by day
   hhOl = (jday-jdO)*Nhours + 1  !  First hour of the day
   hh24 = hhOl + 23              !  Last hour of the day  (24th)
   hh25 = hh24 + 1               !  25th hour of jday ==  (jday-jdO+1)*NHours
   OneDay: Do hh = hhOl, hh24
      Select Case(WD(hh)%s)
      Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
         Cycle OneDay
      End Select
      Select Case(WS(hh)%s)
      Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
         Cycle OneDay
      End Select

      nn = nn + 1

      !  Convert Azimuth (measured in degrees) to
      !  Theta (measured in radians)
      Theta = Modulo(90-WD(hh)%v, 360) * Degrees_to_Radians
      xsum = xsum  +  WS(hh)%v * Cos(Theta)
      ysum = ysum  +  WS(hh)%v * Sin(Theta)
   End Do OneDay
                                                            336
-------
         WS(hh25)%v = resultant
         WS(hh25)%s = T_Estimated
         WS(hh25)%f = ''
         Call Stat_Add_Point(daily_ws, resultant)
      Else
         ierr = ierr +  1
         WD(hh25)%v = Missing_Data
         WD(hh25)%s = T_Missing
         WD(hh25)%f = ''

         WS(hh25)%v = Missing_Data
         WS(hh25)%s = T_Missing
         WS(hh25)%f = ''
         Call Jd to ymd(jday, j yyyy, jmm, jdd)
         Write(ULog, 9130) jyyyy, jmm, jdd, txt(1:ntt),  nn,  minN
         Format(lx, '?? Daily Values:  ', 14,  2('-',12.2),  Ix,  a,  '  found ',  10,  ',  need ',  10)
      End If
End Subroutine Daily Wind Speed
Subroutine Process Days since last Snowfall(Xok)

   !* 
   !  Correct the field Days since last Snowfall.
   !               Observation Indicator  (OI)
   !               |  Present_weather  (PW)
   !               |  |                 Days Since Last  Snowfall  (DSLS)
   !  yy mm dd hh  |  |
   ,  __ __ __ __  _	45	        	
                                     61
                                     62
                                     63
                                     63      ! hours  2-23
                                     63
                                ...   64      ! Counter  increments
                                                                337
-------
!  Days  Since  Last Snowfall counter increments on hour == 1.
  SAMSON information.  For a description of the SAMSON file format see
      
      [Isr]  Thu 19 Oct 2000  11:58:19
            This field appears to be
            column 96 of the input file.
            The manual provides no data
            to support this assertion.
      [Isr]  Wed Nov 21 09:33:59 2001
            Observation Indicator appears
            only in SAMSON v 1.0 files.
0 = Weather observation made.
9 = Weather observation not
made or missing.
If this field = 9 OR if field
13 (wind speed) = missing
(9999. or 99.0), then
fields 6, 7, 8, 10, 11, 17,
and 18 were all modeled and
not actually observed.
  Snow-related fields of Present_weather are 4 and 5.
   Field Number
               Contents
               I               Values
               I               |          Description
   (4)
                                        0 = Light snow
                                        1 = Moderate snow
                                        2 = Heavy snow
                                        3 = Light snow pellets
                                        4 = Moderate snow pellets
                                        5 = Heavy snow pellets
                                        6 = Light ice crystals
                                        7 = Moderate ice crystals
                                        8 = Heavy ice crystals
                                        9 = None if Observation
                                        Indicator element eguals
                                        0,  else unknown or
                                        missing if Observation
                                                            338
-------
                                        Indicator element
                                        equals 9.

                                        Notes:
                                        Beginning in April 1963, any
                                        occurrence of ice crystals
                                        is recorded as a 7.
Implicit None
Logical, Intent(Out)  ::  Xok

!  Relevant field numbers
Integer, Parameter ::  f4 = 4
Integer, Parameter ::  f5 = 5
                                        0 = Light snow showers
                                        1 = Moderate snow showers
                                        2 = Heavy snow showers
                                        3 = Light snow sguall
                                        4 = Moderate snow sguall
                                        5 = Heavy snow sguall
                                        9 = None if Observation
                                        Indicator element eguals 0,
                                        else unknown or
                                        missing if Observation
                                        Indicator element eguals 9.
Integer
Integer
Integer
Logical
Integer
Real
Logical
Integer

Integer
  jday,  hhOl,  hh24, hh25, hh
  ierr,  jyyyy,  jmm, jdd, jhh
  Observation Indicator
  DSLS_unknown,  observation_is_missing
  nDSLS,  hours_with_snow
  old_DSLS
and_Flag), Dimension(:), Pointer :: OI,  DSLS
                                                            339
-------
!  Start with Days Since Last Snowfall  (DSLS) == Missing,
!  because we do not know when the last snow occurred.
I
!  This is what SAMSON did for San Juan, P.R.  (WBAN=11641),
!  where it has not snow in recorded history.
nDSLS = -1                        ! Non sensical value.
Do jday = jdO, jdl                ! step by day
   hhOl = (jday-jdO)*Nhours + 1   ! First hour of the day
   hh24 = hhOl + 23               ! Last hour of the day  (24th)
   hh25 = hh24 + 1                ! 25th hour of jday ==  (jday-jdO+1)*NHours

   !Print_now = (hhOl == jvO)
   !If (print_now) Then
   !    Write(6,*)  'in dsls'
   !    Write(6,*)  'in dsls'
   !End If

   !  If at any time during the day DSLS(hh)%v holds
   !  a non-missing value, we want pDSLS to point to it.
   !  We will use this value for the 25th hour (the daily value).
   pDSLS = Tbogus
   OneDay: Do hh = hhOl, hh24
      !  Save the old value to test cognitive dissonances.
      old_DSLS = DSLS(hh)%v
      If  (DSLS(hh)%s /= T_Missing) Then
         nDSLS = Nint(old_DSLS)
         pDSLS = hh
         DSLS_unknown = .False.
      Else
         DSLS_unknown = .True.
      End If
                                                            340
-------
!If (Print_now) Then
!    Write (6, *) 'in Process Days since last Snowfall1
!End If

Observation_Indicator = Nint(OI(hh)%v)  ! 0 or  9
Select Case(Observation Indicator)
Case(9)  !  Weather observation not made or missing.
   observation_is_missing =  .True.

Case(O)  !  Weather observation made.
   !  It snow if
   !  a) (Present_weather, field #4 /=  9)   ! snow
   !       OR
   !  b) (Present weather, field #5 /=  9)   ! snow  showers
   observation is missing =  .False.
   If  ((OI(hh)%f(f4:f4)  /=  '9') .Or.  (OI(hh)%f(f5:f5)  /=  '9')
      hours_with_snow = hours_with_snow + 1
       !Call iv to ymdh(hh, jyyyy, jmm, jdd, jhh)
       IWrite  (ULog, 9310) hh, jyyyy, jmm, jdd, jhh, OI(hh)%f(f4:f5)
      Format  ('## Observation Indicator ==0:  ',  &
             1 for  ',  17, Ix, 14,  '-',  12.2,  '-',  12.2,  13,  'h',  &
             '; OI(hh)%f(f4:f5)  == "',  a, '"')
   End If

Case Default
   Call iv to ymdh(hh, jyyyy, jmm, jdd, jhh)
   Write (ULog, 9150)  Observation Indicator, hh,  jyyyy, jmm,  jdd, jhh
   Format ('?? Observation Indicator not 0 nor 9:  ',  10,  &
         1  for  ',  17,  Ix, 14,  '-', 12.2, '-',  12.2, 13,  'h')
   observation is missing =  .True.
End Select

!  If Days since last Snowfall is unknown, try  to  do something sensible.
If (DSLS_unknown)  Then
   !  If it snow during this fraction of a day, then Days  since  last  Snowfall  == 0.
   !  This inference is valid regardless of the value  of observation_is_missing.
   If  (hours_with_snow > 0)  Then
      nDSLS = 0
      DSLS(hh)%v = nDSLS
      DSLS(hh)%s = T_Estimated
      DSLS(hh)%f = ''
      pDSLS = hh
      DSLS_unknown = .False.
   Else If (observation_is_missing)  Then
       ! Nothing we can do. It may have snow  (or not).
      nDSLS = -1     ! Non sensical value.
   Else
       ! It has not snow.
      If (nDSLS >= 0)  Then
         !  We have an estimate.
                                                      341
-------
            DSLS(hh)%v = nDSLS
            DSLS(hh)%s = T_Estimated
            DSLS(hh)%f = ''
            pDSLS = hh
            DSLS_unknown = .False.
         Else
            !  We still do not know when the last snowfall occurred.
            DSLS(hh)%v = Missing_Data
            DSLS(hh)%s = T_Missing
            DSLS(hh)%f = ''
         End If
      End If
   Else
      !  Old value not unknown. Keep it. Nothing to do.
   End If
   !If (print_now)  Then
   !    Write (ULog, *) str_iv_to_ymdh(hh) , DSLS(hh)
   !End If
End Do OneDay

!  Now assign a daily value.  If we had a non-missing value
!  during the day,  use it.
If (pDSLS /= Tbogus) Then
   !  We had a good hour. Use it for the daily value
   DSLS(hh25)%v = DSLS(pDSLS)%v
   DSLS(hh25)%s = T_Estimated
   DSLS(hh25)%f =  ''
Else
   !  Else no good hours during this day. Missing.
   DSLS(hh25)%v = Missing_Data
   DSLS(hh25)%s = T_Missing
   DSLS(hh25)%f =  ''
End If
!If (print_now) Then
!    Write (ULog, *) str_iv_to_ymdh(hh25),  DSLS(hh25)
!End If

!  If the value of nDSLS is known, increment it.
!  The maximum value of this field is  88 days.
!  See SAMSON description above.
If (nDSLS >= 0) nDSLS = Min(nDSLS + 1,  88)
                                                         342
-------
!  SAMSON. BAOD is not present during nighttime. One value  (measured  or
!  estimated) was produced and replicated  for the day.  See  fragment
!  file below (13893_61.txt):
!      yy mm dd hh BAOD
!      61  1  1  1 99999.
!      61  1  1  : 99999.    ! hours 2-6
!      61  1  1  7 99999.
!      61  1  1  8    .034
!      61  1  1  :    .034    ! hours 9-16
!      61  1  2
!      61  1  2
I
!  Algorithm:
!  For every day: Starting at 1 h, find the  first  non-missing
!  value, call it "rv". Replace all missing  values  during  that
!  day with "rv".
Implicit None
Logical, Intent(Out)  :: Xok

Integer :: jday, hhOl, hh24, hh
Integer :: ierr, jyyyy, jmm, jdd
Real    : : rv
Logical : : xfound
Type(Val_and_Flag), Dimension!:),  Pointer  ::  BAOD
Do jday = jdO, jdl                ! step by day
   hhOl = (jday-jdO)*Nhours + 1   ! First hour of  the  day
   hh24 = hhOl + 23               ! Last hour of the day (24th)

   xfound = .False.
   FindRv: Do hh = hhOl, hh24
      Select Case(BAOD(hh)%s)
      Case(T_Missing, T_Not_Applicable, T_Undefined,  T_Perpetual_Darkness)
          ! Do nothing.
      Case Default
         rv = BAOD(hh)%v
         xfound =  .True.
         Exit FindRv
      End Select
                                                             343
-------
      End Do FindRv

      If (.Not. xfound) Then
         ierr = ierr + 1
         Call Jd to ymd(jday, j yyyy, jmm, jdd)
         Write(ULog, 9130) jyyyy, jmm, jdd
         Format(lx, '?? Process_BAOD: Values all missing for  ', 14,  2('-',12
         Cycle
      End If

      OneDay: Do hh = hhOl, hh24
         If  (BAOD(hh)%s == T_Missing) Then
            BAOD(hh)%v = rv
            BAOD(hh)%s = T_Estimated
            BAOD(hh)%f =  ''
         End If
      End Do OneDay
   End Do
   Xok = (ierr == 0)
Subroutine Daylight_Prevailing_Wind(Xok, MET_pwd, MET_pws, OnlyDaylight)

   !  Compute Daylight Prevailing Wind
   !  

   !  Xok — truth of "all entries in MET ^ not missing"
   !  MET_pwd -- prevailing wind direction
   !  MET_pws -- prevailing wind speed
   !  OnlyDaylight — Truth of "compute prevailing stuff using only daylight  hours'1
   !      The direction of wind is measured in terms of where the air
   !      is coming from. A northerly wind blows air from north to south.
   !      A southwesterly wind blows air from the southwest to the northeast.
   I
   !      The prevailing wind is the wind that blows most freguently across  a
   !      particularly region. Different regions on Earth have different
   !      prevailing wind directions which are dependent upon the nature of
   !      the general circulation of the atmosphere and the latitudinal wind
   !      zones.
   I
   !  Prevailing wind - The wind direction most freguently observed during a
   !  given period. The periods most freguently used are the observational day,
   !  month, season, and year. Methods of determination vary from a single count
                                                               344
-------
!  of periodic observations to the computation of  a wind  rose.

Implicit None
Logical,                                Intent(Out)  :: Xok
Type(Val_and_Flag), Dimension(jdO:jdl), Intent(Out)  :: MET_pwd,  MET_pws
Logical,                                Intent(In)   :: OnlyDaylight
Integer
Integer
Integer
Integer
Integer
Logical
Real
i, j, n, nO, JO, jl, ierr, jb, points_in_day
ig, idim, jt, ik, nmax, ndel, min d!2
jday, hhOl, hh24, hh
JyyyYf jmm, jdd, jhh
prevailing_guadrant, Prevailing_CoordSys, ncount
is daytime, N is even
xws,  xwd, median wd, mean ws, vmax
Integer, Parameter  :: CoordAx dim =  6
Type(XPerSeg), Dimension(CoordAx dim), Target,  Save  ::  CoordAx  !  Coordinate Axes
Type(XQuadrant), Pointer :: qik
Logical ::  have_quadrant
Integer, Dimension(:), Pointer  :: p2Hour
Integer, Pointer :: p2N
Logical, Save :: first_time = .True.

Logical ::  Print now = .False.
Integer ::  jul dayO, jul dayl
ierr = 0
WD => Xparam(f_WD)%Samson_vlO
WS => Xparam(f_WS)%Samson_vlO
Rs => Xparam(f_Rs)%Samson_vlO
                       ! Wind Direction in degrees
                       ! Wind Speed in m/s
                       ! Global Horizontal Radiation
MET_pwd = Val_and_Flag(T_Missing, Missing_Data,  '')
MET_pws = Val_and_Flag(T_Missing, Missing_Data,  '')
   !  Allocate only once.
   first_time = .False.

   !  Allocate Quadrant/HemiPlane arrays.
   !  isub, rdiv, imod define the function
   !      i = Modulo(Floor((x-isub)/rdiv),imod)  +  1
   !  imod = number of guadrants
   !  rdiv * imod = 360
                                                             345
-------
   !  Define 2 sets of coordinate axes  (qOO, q4 5 ) ,  each with  4  quadrants
   !  qOO — standard coordinate axes.
   !      i = Modulo(Floor((x)/90.0),4) + 1

   iq = 1
   idim = 4
   Allocate(CoordAx(iq)%Quads(idim) ,  CoordAx(iq)%Tied List(idim) )
   CoordAx(iq)%isub = 0
   CoordAx(iq)%imod = idim
   CoordAx(iq)%rdiv = 360.0 / idim

   !  q45 -- axes rotated  45°
   !      i = Modulo(Floor((x-45)/90.0),4) + 1
   iq = iq + 1
   idim = 4
   Allocate(CoordAx(iq)%Quads(idim),  CoordAx(iq)%Tied_List(idim))
   CoordAx(iq)%isub = 45
   CoordAx(iq)%imod = idim
   CoordAx(iq)%rdiv = 360.0 / idim

   !  hemiplanes: 2 "quadrants"
   Do i = 1,  4
      iq = iq + 1
      idim = 2
      Allocate(CoordAx(iq)%Quads(idim), CoordAx(iq)%Tied_List(idim))
      jb = (i-1) * 45   !  jb == 0, 45, 90, 135
      !i = Modulo(Floor((x-jb)/ISO.0),2) + 1
      CoordAx(iq)%isub =  jb
      CoordAx(iq)%imod =  idim
      CoordAx(iq)%rdiv =  360.0 / idim
   End Do

   !!  http://www.windpower.dk/tour/wres/rose.htm
   !!  Wind rose. Divide the compass  into 12 sectors  (European  Wind
   !!  Atlas standard), one for each  30 degrees of  the horizon.
   !!  A wind rose may also be drawn  for 8 or 16  sectors.
   !iq = iq + 1
   !idim = 12
   !Allocate(CoordAx(iq)%Quads(idim),  CoordAx(iq)%Tied_List(idim))
   ICoordAx(iq)%isub = 0
   !CoordAx(iq)%imod = idim
   !CoordAx(iq)%rdiv = 360.0 / idim
End If
ByJD: Do jday = jdO, jdl          ! step by day
   hhOl = (jday-jdO)*Nhours + 1   ! First hour of the day
   hh24 = hhOl + 23               ! Last hour of the day  (24th)

   !  #1. Find the quadrant with the most observations.


                                                             346
-------
    If tie: rotate axes 4J
                            and try again.
                                              q45
        (4)
              (1)
        (3)
              (2)
                                        22
                                                    13E
The formulae below make sure quadrants are wrapped around properly,
so that the resulting quadrant is always an integer in  [1,  4] .
See Mathematica notebook 
If there are still ties, cut into hemiplanes:
                                                       \
                                                        \
                                                       347
-------
                                             := Mod[Floor[(x)/ISO.0],2]+1
                                             := Mod[Floor[(x-45)/ISO.0],2]+1
                                             := Mod[Floor[(x-90)/ISO.0],2]+1
                                              :=  Mod[Floor[(x-135)/ISO.0],2]+1
   !                    XQuadrant(n, h,  max,      d!2,  mean)
   CoordAx(iq)%Quads = XQuadrant(0, 0,  Zero,  Huge(0),  Zero)
   CoordAx(iq)%Tied_List = 0
   CoordAx(iq)%Tied_N = 0
End Do
points in day = 0
   Select Case(Rs(hh)%s)
   Case(T_Missing, T_Not_Applicable, T_Undefined,  T_Perpetual_Darkness)
      Cycle OneDay
   End Select

   If (OnlyDaylight)  Then
      !  Skip non-daylight hours.
      is_daytime = (Rs(hh)%v > Zero)
      If (.Not. is_daytime) Then
         Cycle OneDay
      End If
   End If

   Select Case(WD(hh)%s)
   Case(T_Missing, T_Not_Applicable, T_Undefined,  T_Perpetual_Darkness)
      Cycle OneDay
   End Select
                                                          348
-------
   Select Case(WS(hh)%s)
   Case(T_Missing,  T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
      Cycle OneDay
   End Select

   points in day = points in day + 1
   xwd = WD(hh)%v
   xws = WS(hh)%v

   Do iq = 1, CoordAx dim
      !   (1):    ik = Modulo(Floor((xwd-0)/90.0),4) + 1
      !   (2):    ik = Modulo(Floor((xwd-45)/90.0),4) + 1
      !   (3-6): jb =  (j-1) *  45, j = 1..4,  jb  ==  0, 45,  90,  135
      !         ik = Modulo(Floor( (xwd-jb)/ISO.0) ,2) + 1
      !   (7):    ik = Modulo(Floor((xwd-0)/30.0),12) + 1
      n = qik%n + 1
      qik%n = n
      qik%h(n) = hh
      qik%ws_mean = qik%ws_mean + xws

      !  ndel — the absolute delta time from 12 noon
      ndel = Abs(hh - hhOl +1-12)

      If  ((xws-qik%ws_max) > EpsO) Then
          ! xws > maximum so far : Found a new maximum.
         qik%ws max = xws
         qik%ws_d!2 = ndel
      Else If (Abs(xws-qik%ws_max) < EpsO) Then
          ! xws == maximum wind speed
          ! We have a wind speed equal to the recorded maximum WS.
          ! If this wind speed falls in the same quadrant of  the
          ! recorded maximum, ok. Else we cannot determine the
          ! most frequent quadrant uniquely.
         If (ndel < qik%ws_d!2) Then
            qik%ws_d!2 = ndel
         End If
      End If
   End Do
End Do OneDay

If (points in day == 0) Then
   !  No data.
   ierr = ierr + 1
   Cycle ByJD
End If
                                                         349
-------
!  Compute mean wind speeds for each quadrant.
Do iq = 1, CoordAx dim
   Do ik = 1, CoordAx(iq)%imod
      n = CoordAx(iq)%Quads(ik)%n
      If  (n == 0) Cycle
      CoordAx(iq)%Quads(ik)%ws mean = CoordAx(iq)%Quads(ik)%ws mean  /  n
   End Do
End Do

have quadrant =  .False.
Do iq = 1, CoordAx dim
   !  prevailinq_quadrant -- the quadrant with the most observations.
   !                  This is the prevailinq wind quadrant.
   !  CoordAx(iq)%Quads(prevailinq quadrant)%n —
   !                  The number of elements the  fell
   !                  in prevailinq_quadrant.
   !  ncount > 1 ==> ties.
   prevailinq quadrant = Maxloc(CoordAx(iq)%Quads(:)%n, Dim=l)
   nmax = CoordAx(iq)%Quads(prevailinq quadrant)%n

   !  Tied_List is a list of the tied quadrants.
   ncount = 0
   Do ik = 1, CoordAx(iq)%imod
      If  (CoordAx(iq)%Quads(ik)%n == nmax)  Then
         ncount = ncount + 1
         CoordAx(iq)%Tied List(ncount) = ik
      End If
   End Do
   CoordAx(iq)%Tied_N = ncount

   If (ncount == 1) Then
      have_quadrant =  .True.
      Prevailinq_CoordSys = iq
      ik = prevailinq quadrant
      p2N => CoordAx(iq)%Quads(ik)%n
      p2Hour => CoordAx(iq)%Quads(ik)%h
      Selection_Criterion = 'quadrant with  the most observations'
      Exit
   End If
End Do
If (.Not. have_quadrant)  Then
   !  Amonq the tied quadrants, find the one with the larqest mean wind  speed.
   L41: Do iq = 1, CoordAx_dim
      ncount = 0
      vmax = -Huqe(Zero)
                                                         350
-------
         If (CoordAx(iq)%Quads(ik)%ws mean > vmax) Then
            ncount = 1
            vmax = CoordAx(iq)%Quads(ik)%ws_mean
            prevailing_quadrant = ik
         Else If (Abs(CoordAx(iq)%Quads(ik)%ws_mean - vmax) < EpsO) Then
            !  CoordAx(iq)%Quads(ik)%ws mean == vmax
            !  A tie. Note that we cannot qive up yet because vmax
            !  may still change.
            ncount = ncount + 1
         End If
      End Do L42

      If (ncount == 1)  Then
         have quadrant = .True.
         Prevailing CoordSys = iq
         ik = prevailing_quadrant
         p2N => CoordAx(iq)%Quads(ik)%n
         p2Hour => CoordAx(iq)%Quads(ik)%h
         Selection Criterion = 'tied quadrant with the largest mean wind  speed1
         Exit
      End If
   End Do L41
End If
If (.Not. have_quadrant)  Then
   !  Among the tied quadrants, select the quadrant where the
   !      maximum wind speed is closest to noon.
   L51:  Do iq = 1, CoordAx dim
      ncount = 0
      min_d!2 = Huge(0)

      L52: Do jt = 1,  CoordAx(iq)%Tied_N
         ik = CoordAx(iq)%Tied_List(jt)
         If  (CoordAx(iq)%Quads(ik)%ws_d!2 < min_d!2) Then
            ncount = 1
            min_dl2 = CoordAx(iq)%Quads(ik)%ws_d!2
            prevailing_quadrant = ik
         Else If  (CoordAx(iq)%Quads(ik)%ws_d!2 == min_d!2) Then
             ! A tie. Note that we cannot give up yet because min d!2
             ! may still change.
            ncount = ncount + 1
         End If
      End Do L52

      If  (ncount == 1) Then
         have_quadrant = .True.
         Prevailing CoordSys = iq
                                                         351
-------
         ik = prevailing_quadrant
         p2N => CoordAx(iq)%Quads(ik)%n
         p2Hour => CoordAx(iq)%Quads(ik)%h
         Selection_Criterion =  'tied quadrant with the maximum  wind  speed closest to noon'
         Exit
      End If
   End Do L51
End If
!  25 Apr 2002 11:21 am: Debuqqinq test.
!      For 26451: Anchoraqe, AK,
!      hhOl == 66701, 1968-04-22  Ih
!      Selection Criterion: tied quadrant with the  larqest  mean  wind  speed
!If (.Not. have_quadrant)  Then
If ((.Not. have_quadrant)  .Or.  (Print_now)) Then
   Call iv_to_ymdh(hhOl, jyyyy, jmm, jdd, jhh)
   If  (Print_now) Then
      Write(ULoq, 9130) &
          '?? Dayliqht Prevailing Wind: "Print now"  at  ',  &
         hhOl, jyyyy, jmm, jdd, jhh,  'h'
   Else
      Write(ULog, 9130) &
          '?? Daylight Prevailing Wind: No resolution at  ',  &
         hhOl, jyyyy, jmm, jdd, jhh,  'h'
   End If
   Format  (/, Ix, a, 17, Ix, 14, 2('-',i2.2), 13, a)

   Qerr: Do hh = hhOl, hh24
      Select Case(Rs(hh)%s)
      Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
         Cycle Qerr
      End Select

      If  (OnlyDaylight) Then
          ! Skip non-daylight hours.
         is_daytime = (Rs(hh)%v > Zero)
         If  (.Not.  is_daytime) Then
            Cycle Qerr
         End If
      End If

      Select Case(WD(hh)%s)
      Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
         Cycle Qerr
      End Select
      Select Case(WS(hh)%s)
                                                         352
-------
      Case(T_Missing, T_Not_Applicable, T_Undefined,  T_Perpetual_Darkness)
         Cycle Qerr
      End Select
      i = hh - hhOl + 1
      Write(ULog, 9150) &
               ', hh, jyyyy,
      Format (Ix, a, 17, Ix,
   End Do Qerr
   Write (ULog, *) '       have guadrant:  ', have guadrant
   If (have_guadrant)  Then
      Write (ULog, *)  'Selection_Criterion
      Write (ULog, *)  'Prevailing_CoordSys
      Write (ULog, ^)  'prevailing guadrant
      Write (ULog, *)  '                 p2N
      nO = Min(p2N, Ubound(CoordAx(1)%Quads(1)%h,1),  24)
      Write (ULog, *)  '              p2Hour: ', p2Hour(l:nO)
   End If
   Do ig = 1,  CoordAx_dim
      Write(ULog, *)
      Write(ULog, *)  '================================'
      Write(ULog, *)  'CoordAx(', ig, ')'
      n = CoordAx(ig)%Tied_N
      nO = Min(n, 4)
      Write(ULog, *)  '     %Tied_List:'
      Do ik = 1, CoordAx(ig)%imod
         n = CoordAx(ig)%Quads(ik)%n
         nO = Min(n,  Ubound(CoordAx(1)%Quads(1)%h,1
         Write(ULog,  *)
                     ' )   '   %Quads( ', ik,
                     <)   '             h: '
                                               Trim(Selection_Criterion)
                                               Prevailing  CoordSys
                                               prevailing  guadrant
                                               p2N
         Write(ULog,
         Write(ULog,
         Write(ULog,
         Write(ULog,
         Write(ULog,
      End Do
   End Do
   Call FLushAll()
End If
                                %ws_d!2:
                               %ws mean:
):  n == ',  n
CoordAx(ig)%Quads(ik)%h(l:nO)
CoordAx(ig)%Quads(ik)%ws_max
CoordAx(ig)%Quads(ik)%ws_d!2
CoordAx(ig)%Quads(ik)%ws mean
If (.Not. have_guadrant)
   ierr = ierr + 1
   Cycle ByJD
End If
!  The prevailing wind direction is the median of the
!  wind directions that fell in the most freguent guadrant.
                                                         353
-------
!  (at most 24 entries).
!  is problematic: The entries of WD  (hh01:hh24) are  (say)
!  137058:137067. On entry to Insertion_Sort_Real the addresses
!  of WD are 1:24. However, the values in pindex are still in
!  the range 137058:137067. So, references to WD(p2Hour(j)) will
!  be out of bounds *within* the subroutine. We need to pass the
!  address bounds of WD to the subroutine. This is more trouble
!  than it is worth, since the insertion sort is used only once
!  and the code is short. Therefore  ( 2 Jul 2002  1:29 pm) code in  line.

!  Insertion sort is best if the number of entries is less than
!  approximately 20 entries.
Do i = 1, p2N - 1
   Do j = i+1, p2N
      If (WD(p2Hour(j))%v < WD(p2Hour(i))%v) Then
         nO = p2Hour(i)
         p2Hour(i) = p2Hour(j)
         p2Hour(j) = nO
      End If
   End Do
End Do

If (Print_now) Then
   Write(ULog, *)
   Write(ULog, *)  '================================'
   nO = Min(p2N, Ubound(CoordAx(1)%Quads(1)%h, 1) , 24)
   Write(ULog, *)  'Sorted p2Hour: ', p2Hour(l:nO)
   Write(ULog, *)  'Sorted WD(p2Hour(1:nO))%v:  ', WD(p2Hour(1:nO))%v
   Write(ULog, *)
End If

!  Compute median
N_is_even = (Modulo(p2N,2) == 0)
If (N_is_even) Then
   i = p2N / 2
   j 0 = p2Hour(i)
   jl = p2Hour(i+l)
   median_wd =  (WD(jO)%v + WD(jl)%v) / 2
   If  (Print_now) Then
      Write(ULog, *)  'N is even:  i,   JO, jl:  ', i, JO, jl
   End If
Else
   i = (p2N + 1) / 2
   j 0 = p2Hour(i)
   median_wd = WD(jO)%v
                                                         354
-------
         If (Print_now) Then
            Write(ULog, *)  'N is odd: i, JO:  ', i, JO
         End If
      End If

      !!  The prevailing wind speed is the mean of the
      !!  wind speeds that fell in the prevailing guadrant.
      !mean_ws = Zero
      !Do i = 1, p2N
      !    j 0 = p2Hour(i)
      !    mean ws = mean ws + WS(jO)%v
      !End Do
      !mean_ws = mean_ws / p2N
      mean ws = CoordAx(Prevailing CoordSys)%Quads(prevailing  guadrant)%ws  mean

      If (Print_now) Then
         Write(ULog, *) 'median_wd:  ', median_wd
         Write(ULog, *) 'mean ws..:  ', mean ws
      End If

      MET_pwd(jday) = Val_and_Flag(T_Estimated, median_wd,  '')
      MET_pws(jday) = Val_and_Flag(T_Estimated, mean_ws,  '')
End Subroutine Daylight Prevailing Wind
Function a eg b(A, B)

   Implicit None
   Type(XQuadrant), Dimension(:), Intent(In)  :: A,
   Logical ::  a eg b
   If (sa /= sb) Return

   Do i = 1, sa
      If (A(i)%n /= B(i)%n) Then
         Return
      End If
                                                                355
-------
         Return
      End If
   End Do
   a_eq_b = .True.

End Function a eq b
                                                               356
-------
UtilsS
! ! ! 1
I I I 2
! ! ! 3
MI 4
III 5
! ! ! 6
! ! ! 7
! ! ! 8
I I I 9
! ! ! 10
! ! ! 11
! ! ! 12
III 13
! ! ! 14
! ! ! 15
! ! ! 16
I I I 17
! ! ! 18
! ! ! 19
! ! ! 20
! ! ! 21
I I I 22
! ! ! 23
! ! ! 24
III 25
16- 22
24- 30
32- 40
42- 50
52- 60
62- 65
67- 70
72- 78
80- 86
88- 92
94-100
102-106
108-114
116-123
125-132
134-136
138-148
150-154
156-163
165-170
172-176
178-186
188-197
199-208
210-
                       Print Cols
                       Extraterrestrial  Horizontal  Radiation
                       Extraterrestrial  Direct  Normal  Radiation
                       Global Horizontal  Radiation
                       Direct Normal  Radiation
                       Diffuse Horizontal  Radiation
                       Total Sky_Cover
                       Opaque Sky Cover
                       Dry Bulb Temperature
                       Dew_Point Temperature
                       Relative Humidity
                       Station Pressure
                       Wind Direction
                       Wind Speed
                       Visibility
                       Ceiling Height
                       Observation  Indicator
                       Present_weather
                       Precipitable Water
                       Broadband Aerosol  Optical_Depth
                       Snow_Depth
                       Days Since Last Snowfall
                       Hourly Precipitation
                       FAO Short Grass PET
                       K-P FWS Evaporation
                       Pan Evaporation
   !Use Binary_Tree
   !Use FileStuff
   !Use GetNumbers
   !Use Linked_List
   !Use Read_Info
   !Use SAMSON
   Use Strings
   !Use UtilsO
   !Use Utilsl
   !Use Date_Module
   Use Global_Variables
   !Use loSubs
   !Use Utils2
   !Use Winteracter
   Implicit None

Contains
                                                                   357
-------
Subroutine Print_Cols(Col_Text, kO, kl, Last, Icount, Initialize)

   !  Call Print_Cols('Extraterrestrial Horizontal Radiation',  kO,  kl,  Icount=l)
   Implicit None
   Character(Len=*), Intent(In) :: Col_Text
   Integer,          Intent(In) :: kO, kl

   !  The value of "Last" is unimportant.
   !  We check only for the presence/absence of the variable.
   Logical, Optional, Intent(In)  :: Last
   Integer, Optional, Intent(In)  :: Icount
   Logical, Optional, Intent(In)  :: Initialize
   If (Present(Initialize))  Then
      !  By increasing 'uu' we will be able to store
      !  different seguences in different files.
      uu = uu + 1
      do return = .False.
      Return
   End If

   If (do_return) Then
      Return
   End If

   If (Present(Icount))  Then
      Kcount = Icount - 1
   End If

   If (Present(Last))  Then
      do_return = .True.
      Return
   End If
End Subroutine Print Cols
                                                               358
-------
      Implicit None
      Integer,          Intent(In) :: kO
      Character(Len=*), Intent(In) :: xFMT

      !  The value of "Last" is unimportant.
      !  We check only for the presence/absence of the variable.
      Logical, Optional, Intent(In)  :: Last

      Integer, Save ::  ip = 1
      Logical, Save ::  do return = .False.

      Integer : :  j 0, j1

      If (do_return) Then
         Return
      End If

      If (Present(Last)) Then
         do return = .True.
         Write (ULog,  '(/, 2a, /)')  '## Daily values file  format:  ',  Trim(FMT_dvf)
         Return
         !  Stop '## Stoping in "dvf_MkFMT" as reguested'
      End If
      JO = 2
      jl = Len_trim(xFMT) - 1
      If (ip > 1)  Then
         FMT_dvf(ip:i
         ip = ip + 2
      End If
9130  Format ('t', 10, ',', a)

   End Subroutine dvf_MkFMT



   Subroutine dvf_Cols(Col_Text, kO, kl, Last, Icount, Initialize)

      !  Call dvf Cols('Extraterrestrial Horizontal Radiation1,  kO,  kl,  Icount=l)
      Implicit None
      Character(Len=*),  Intent(In)  :: Col_Text
      Integer,           Intent(In)  :: kO, kl
                                                                  359
-------
   !  The value of "Last" is unimportant.
   !  We check only for the presence/absence of the variable.
   Logical, Optional, Intent(In)  :: Last
   Integer, Optional, Intent(In)  :: Icount
   Logical, Optional, Intent(In)  :: Initialize

   Character(132)  :: qbuf
   Integer, Save  :: uu = 9010
   Integer, Save  :: Kcount = 0
   Logical, Save  :: do return =  .False.

   If (Present(Initialize))  Then
      !  By increasing 'uu' we will be able to store
      !  different sequences in different files.
      uu = ULog
      do_return = .False.
      Return
   End If

   If (do_return)  Then
      Return
   End If

   If (Present(Icount))  Then
      Kcount = Icount - 1
   End If

   If (Present(Last)) Then
      do_return = .True.
      Return
      !  Stop '## Stoping in "dvf  Cols" as requested1
   End If
   Write (ULog, '(lx,a)') Trim(qbuf)
End Subroutine dvf Cols
Subroutine hvf_Cols(Col_Text, kO, kl, Xfmt, Last, Icount,  Initialize)

   !  Call hvf_Cols('Extraterrestrial Horizontal Radiation',  kO,  kl,  Icount=l)
   Implicit None
   Character(Len=*),  Intent(In)  :: Col_Text
   Integer,          Intent(In)  :: kO, kl
   Character(Len=*),  Intent(In)  :: Xfmt
                                                               360
-------
!  The value of "Last" is unimportant.
!  We check only for the presence/absence of the variable.
Logical, Optional, Intent(In)  :: Last
Integer, Optional, Intent(In)  :: Icount
Logical, Optional, Intent(In)  :: Initialize
Character(Len=132)   :: qbuf
Character(Len=50)   :: wfmt, wtype
Integer :  : j 0, j1
Integer,  Save :: ip = 1

uu = ULog
If (Present(Initialize)) Then
   do return = .False.
   Return
End If

If (do_return) Then
   Return
End If

If (Present(Icount)) Then
   Kcount = Icount  - 1
End If

If (Present(Last))   Then
   do return = .True.
   Write  (ULog,  '(/, 2a, /)')  '## Hourly values  file  format:  ',  Trim(FMT_hvf)
   Return
   !  Stop '## Stoping in "hvf_MkFMT" as requested'
End If
!  We assume xFMT with leading and trailing parenthesis.
!  We will not check.
wfmt = Xfmt
Call Collapse(wfmt, NewLen=j1)
JO = 2
jl = jl - 1
Select Case(wfmt(j0:j0))
Case('f')
   wtype =  'Real'
Case( '!' )
   wtype =  'Integer'
Case Default
                                                             361
-------
         wtype = ''
      End Select

      If (ip > 1) Then
         FMT_hvf(ip:ip+1)  = ', '
         ip = ip + 2
      End If
End Module UtilsS
                                                                  362
-------
Utils4

!      Last change:  LSR  16 May 2002    3:21 pm

Module Utils4

   Use Global Variables
   Use Date_Module
   Use Utilsl
   Use UtilsS
   Implicit None
      Implicit None
      Integer,          Intent(In)   :: k_id
      Character(Len=*), Intent(In)   :: T_code  ! Daily value  code.
      Logical,          Intent(Out)  :: Xok

      Integer ::  jday,  hhOl, hh24, hh25, iv
      Integer ::  nn, ierr
      Real    ::  xsum
      Type(Val_and_Flag), Dimension(:),  Pointer  :: VF
      Character(Len(Fieldlnfo(1)%Name)), Pointer  :: txt

      ierr = 0
      VF => Xparam(k_id)%Samson_vlO
      txt => Fieldlnfo(k_id)%Name

      Do jday = jdO, jdl                ! step by  day
         hhOl = (jday-jdO)*Nhours +  1   ! First hour of the day
         hh24 = hhOl + 23               ! Last hour of the day  (24th)
         hh25 = hh24 + 1                ! 25th hour of jday ==  (jday-jdO+1)*NHours

         If  (T_code == T_Not_Applicable) Then
            VF(hh25) = Val_and_Flag(T_Not_Applicable, Zero,  '')
            Cycle
         End If

         !  xsum = Sum(VF(hh01:hh24)%v, Mask=(VF(hhOl:hh24)%s /= T_Missing))
         !  nn   = Count(Mask=(VF(hhOl:hh24)%s /=  T_Missing))
         xsum = Zero
         nn = 0
         Do iv = hhOl,  hh24
            Select Case(VF(iv)%s)
            Case(T_Missing, T_Not_Applicable, T_Undefined, T_Perpetual_Darkness)
               !  Do nothing.


                                                                  363
-------
         Case Default
            xsum = xsum + VF(iv)%v
            nn = nn + 1
         End Select
      End Do
      Else If (T_code == T_Cumulative)  Then
         !  Daily value is cumulative.
         VF(hh25) = Val_and_Flag(T_Estimated, xsum,  ''
      End If
End Subroutine Daily Values
Subroutine Set_Missing_Flags()

   !  
   !  
   !                         1     n
   !     Sample variance = 	  Sum  (x i-x mean)^2
   !                       n - 1  1=1
   !  Reference:
   !  [2]  Nicholas J. Higham. 1996. Accuracy and Stability of Numerical
   !      Algorithms. SIAM (Society for Industrial & Applied Mathematics)
   !      ISBN 0-89871-355-2. Page 13.
   I
   !  Accumulate:
   I
   !           1    k
   !     M_k = - •
   !           k
   I
   I            k
                                                               364
-------
!  Updating formulae:
!     M_k = M_{k-l}  +
I
!     Q_l = 0
I
!     Q_k = Q_{k-l}  +
I
!  After which:
I
!     Sample Mean = M n
!  Note  that the updating formulae can be written:
I
!     M_0  = 0
I

I
!     Q  0  = 0
                             k
Implicit None
Integer
Integer
Integer
Integer
Integer
Integer
Logical
Real
Real
Real
           iv,  jpar,  yyyy,  mm,  dd,  hh
           npts,  k
           n missing,  n nan,  n out  of range, n undefined
           n_Perpetual_Darkness
           n_l_24, n_25
           loop min,  loop max,  loop inc
           erase value, Have  Precip Data
           minV,  maxV
           M_k,  Q_k,  M_kml,  x_k
           v mean, v variance,  v std dev, v min, v max
Type(Val and Flag), Dimension(:), Pointer  :: vf

Call Station_With_Missing_Data(pWBAN%WBAN, Have_Precip_Data)

Write (ULog, '(//)')

Loop_Jpar: Do jpar = 1, f_end
                                                             365
-------
Select Case(jpar)
Case Default
   Case(f_EHR, f_EDNR, f_BAOD,  f_GHR,  f_DNR,  f_TSC,  f_OSC,  &
         f_DBT, f_DPT, f_RH,  f_SP,  f_WD,  f_WS,  f_HV,  f_CH,  &
         f_pH2O, f_SD, f_DSLS)
   loop_min = 1
   loop_max = Ubound(vf,1)
   loop inc = 1

Case( &
      f_FAO_SG_PET,            &   !  FAO Short  Grass  PET,  mm/day
      f Ep)                        !  Class  A  pan  Evaporation,  mm/day
   !  Loop only through daily  values.
   loop_min = NHours
   loop_max = Ubound(vf,l)
   loop inc = NHours
Case( f_KP_FWS_Evaporation)       ! K-P  FWS  Evaporation,  mm/day
   !   8 Feb 2002  5:41 pm: until we develop a  better formulation,
   !     kill KP_FWS_Evaporation.
   !  Do nothing.
   Cycle Loop_Jpar
npts = 0
n_missing = 0
n_nan = 0
npts = 0
n_l_24 = 0
n_25 = 0
n_out_of_range = 0
n undefined = 0
n Perpetual Darkness = 0
minV = Fieldlnfo(jpar)%minimum_value
maxV = Fieldlnfo(jpar)%maximum_value
                ! Number of points.
                                                          366
-------
            npts = npts + 1
            erase value = .False.

I I I I
I I I I
I I I I
!!!             If (IsNaN(vf(iv)%v))  Then
! ! !                erase_value = .True.
!!!                n_nan = n_nan +  1
! ! !                Call iv to ymdh(iv, yyyy, mm, old, hh)
!!!                Write (ULog,  9150)  Trim(Fieldlnfo(jpar)%Name), yyyy, mm, dd, hh
I I I
!!!             Else
!!!                Select Case(vf(iv)%s)
!!!                Case(T_Missing)
! ! !                   erase_value = .True.
!!!                   n_missing = n_missing + 1
!!!                Case(T_Not_Applicable)
!!!                   !  Do nothing.
!!!                Case (TJJndefined)
!!!                   n_undefined = n_undefined + 1
!!!                Case(T_Perpetual_Darkness)
!!!                   n_Perpetual_Darkness = n_Perpetual_Darkness + 1
I I I
! ! !                Case Default
!!!                   in_range = ((minV <= vf(iv)%v) .And.   (vf(iv)%v <= maxV))
!!!                   If (in_range)  Then
!!!                      !  We have  a  value
! ! !                      k = k + 1
!!!                      x_k = VF(iv)%v
!!!                      M_kml = M_k
!!!                      M_k = M_kml  + (x_k-M_kml)/Real(k)
!!!                      Q_k = Q_k  +   (Real(k-1)/Real(k))*(x_k-M_kml)**2
!!!                      v min = Min(x k,  v min)
!!!                      v max = Max(x k,  v max)
!!!                      ICall Stat_Add_Point(Xp_ranges(jpar) , vf(iv)%v)
!!!                   Else
!!!                      n out of range = n out of range + 1
!!!                      erase_value  = .True.
!!!                      Call iv_to_ymdh(iv, yyyy,  mm, dd,  hh)
!!!                      Write (ULog,  9170)  Trim(Fieldlnfo(jpar)%Name), yyyy, mm, dd, hh, vf(i\
!!!                   End If
! ! !                End Select
!!!             End If

            !  19 Mar 2002 12:10 pm:  It is faster (by about 5 seconds)


                                                                  367
-------
!  to perform all the checks with IFs statements,  rather
!  than breaking the if-sequence by using  "Case  Select(vf(iv)%s)"
!  and then returning to IFs.

If (IsNaN(vf(iv)%v))  Then
   !  Produced, by example, by the operation Zero/Zero
   erase_value = .True.
   n_nan = n_nan + 1
   Call iv to ymdh(iv, yyyy, mm, dd, hh)
   Write (ULog, 9150) Trim(Fieldlnfo(jpar)%Name),  &
         iv, yyyy,  mm, dd, hh
   Format(Ix,  6x, a,   ' NaN value for  ', &
         17, Ix, 14,   '-', 12.2, '-', 12.2, 13,  'h')

Else If (vf(iv)%s == T_Missing) Then
   erase_value = .True.
   n_missing = n_missing + 1
   If (Modulo(iv,25)  /= 0) Then
      n_l_24 = n_l_24 + 1
   Else
      n_25 = n_25 + 1
         Call iv to ymdh(iv, yyyy, mm, dd, hh)
         vf(iv) = Val_and_Flag(T_Estimated, Zero,  '')
         Write  (ULog, 9160) Trim(Fieldlnfo(jpar)%Name),  &
               iv,  yyyy, mm, dd, hh
         Format(Ix, 6x, a, ' h25 missing  for  ',  &
               17,  Ix, 14, '-', 12.2,  '-', 12.2,  13,  'h;  value  zeroed.')
   End If

Else If (vf(iv)%s == T_Not_Applicable) Then
   !  Do nothing.

Else If (vf(iv)%s == TJJndefined)  Then
   n undefined = n undefined + 1
Else If ((minV <= vf(iv)%v)  .And.  (vf(iv)%v <= maxV))  Then
   !  Value in range; we have a value.
   k = k + 1
   x_k = VF(iv)%v
   M_kml = M_k
   M_k = M_kml +  (x_k-M_kml)/Real(k)
   Q_k = Q_k + (Real(k-1)/Real(k))*(x_k-M_kml)**2
   v min = Min(x k, v min)
   v max = Max(x k, v max)
   ICall Stat_Add_Point(Xp_ranges(jpar), vf(iv)%v)

Else
                                                       368
-------
      n out of range = n out of  range  +  1
      erase value =  .True.
      Call iv_to_ymdh(iv, yyyy,  mm,  dd,  hh)
      Write (ULog, 9170) Trim(Fieldlnfo(jpar)%Name),  &
            iv, yyyy, mm, dd,  hh,  vf(iv)%v
      Format(Ix, 6x, a,  ' Out-of-range value  for ',  &
            17, Ix,  14,  '-', 12.2,  '-',  12.2,  13,  'h', 3x,  Ipgl4.6)
   End If

   If (erase_value)  Then
      vf(iv)%v = 0
      vf(iv)%s = T_Missing
      vf(iv)%f = ''
         If (jpar == f_HP) Then
            Call iv  to ymdh(iv,  yyyy,  mm,  dd,  hh)
            Write  (ULog, 9130) Trim(Fieldlnfo(jpar)%Name),  iv,  yyyy, mm, dd, hh
            Format(Ix, 6x, a,  '  missing  value  for  ',  &
                  17, Ix, 14,  '-', 12.2,  '-',  12.2,  13,  'h')
         End If
   End If
End Do Loop_iv
!  Compute mean and variance
v_mean = M_k
If (k >= 2) Then
   v_variance = Q_k / Real(k-l)
   v_std_dev = Sqrt(v_variance)
Else
   !  Variance not defined  for  k<=l
   v variance = Huge(Zero)
   v_std_dev = Huge(Zero)
End If

Write(ULog, 9190) k, v_mean, v_variance
Format (  &
      Ix,  '   n  ....: ', 10, /,  &
      Ix,  '   Mean  .: ', Ipgl4.6, /,  &
      Ix,  '   Var ..: ', Ipgl4.6)
Write(ULog, 9210) v_std_dev
Format (Ix, '    StdDev:  ', Ipgl4.6)
If (n missing > 0) Then
   Write  (ULog, 9250) Trim(Fieldlnfo(jpar)%Name),  &
         n_missing, npts
   Format  (Ix, 3x, '?? Missing values  for  ',  a,  &
          ' =  ', 10,  '/', 10)
                                                          369
-------
            If  (n_l_24 >  0) Write  (ULog,  9270)  n_l_24
            If  (n_25 > 0) Write  (ULog,  9290)  n_25
            Format  (ix, 3x,  '    *  Ih  -  24h hours missing: ', 10)
            Format  (Ix, 3x,  '    *  Summary of  the day (h25) missing:  ', 10)
         End If

         If (n_nan > 0) Then
            Write  (ULog,  9310) Trim(Fieldlnfo(jpar)%Name), &
                  n_nan,  npts
            Format  (Ix, 3x,  '??  NaN values for ', a, '  =  ',  10,  '/', 10)
         End If

         If (n_out_of_range >  0) Then
            Write  (ULog,  9330) Trim(Fieldlnfo(jpar)%Name), &
                  n out of range,  npts
            Format  (Ix, 3x,  '??  Out-of-range  values  for  ', a,  '
         End If

         If (n_undefined  > 0)  Then
            Write  (ULog,  9350) Trim(Fieldlnfo(jpar)%Name), &
                  n_undefined, npts
            Format  (Ix, 3x,  '??  Undefined values for ',  a,  ' =
         End If

         If (n_Perpetual_Darkness  > 0)  Then
            Write  (ULog,  9370) Trim(Fieldlnfo(jpar)%Name), &
                  n Perpetual  Darkness,  npts
            Format  (Ix, 3x,  '??  Perpetual Darkness values for  ', a,  ' =  ', 10,  '/',  10)
         End If

      End Do Loop Jpar
   End Subroutine Set_Missing_Flags

End Module Utils4
                                                                   370
-------
UtilsS
!      Last change:  LSR   4 Jun 2002

Module Utils5
Contains
   Subroutine Station_With_Missing_Data(WBAN, Have_Precip_Data)
      Implicit None
      Character(Len=*
      Logical,
WBAN
Have_Precip_Data
      Select Case(WBAN)
      Case Default
          ! Default:
          ! * All stations have precipitation data
         Have_Precip_Data =  .True.

          ! STATIONS WITH LITTLE OR NO HOURLY PRECIPITATION  DATA:
          ! See:
          ! -------
                   &    !  Cedar City UT
                   &    !  Washington-Dulles VA
                   &    !  Lufkin TX
         '94725')        !  Massena NY
      !  = 26 Apr 2002  2:40 pm
      !    ^ make all hourly precipitation missing, even when
      !      present. Fill daily value record  (hh == 25) with
      !      the summary of the day.
      Have_Precip_Data = .False.

   Case( '22516')        !  Kahului HI
      !  Special case. SAMSON identified this station
      !  "with little or no hourly ppt data" but we
      !  augmented the precipitation data with Earthlnfo
      !  hourly and summary of the day data.
      Have_Precip_Data = .True.

   End Select

End Subroutine Station With Missing Data
   !  The following stations have unfixable gaps in
   !  the precipitation record. We will not issue a year
   !  if the year's precipitation record is incomplete.
   !  

   !  This routine should be called after all the data files
   !  have been read and before data processing starts. This
   !  routine consolidates the information gotten from the
   !  files read variable Year_Data(yyyy)%SAMSON_vlO)  with
   !  its internal information, e.g.,
   !      Issue This Year(1965:1990) = .True.
   Implicit None
   Logical, Intent(Out) ::  Some Years Missing, All Years Missing
   Integer ::
                                                               372
-------
Case( '23184')    !  Prescott, AZ
   !  Only the years 1961-1968 are complete.
   !  Too few years.
   Issue_This_Year = .False.    ! Kill all years.
Case( '94185')    !  Burns, OR
   !  Only the years 1983-1988 are complete.
   !  Too few years.
   Issue This Year = .False.    ! Kill all years.
!!!   4 Jun 2002 10:34 am — precipitation  files
!!!   corrected. We have all years.
!Case( '03927')    !  Fort Worth, TX
!    !  Only the years 1975-1990 are complete.
!    !  Too few years.
!    Issue This Year = .False.    ! Kill all years.
                                                             373
-------
   Do yyyy = MinYear, MaxYear
      If (Year_Data(yyyy)%SAMSON_vlO == 0) Then
         !  SAMSON input routines determined that this year
         !  is missing. Do not keep this year.
         Issue_This_Year(yyyy) = .False.
      End If
   End Do
End Subroutine Issue Years
   !  Output: a string suitable for:
   !   ## Years present:  1961-1990
   !   ## Years present:  ** none **
   !   ## Years present:  1965-1988

   Implicit None
   Character(Len=*), Intent(Out) :: Xstr
   ymax = Ubound(Issue_This_Year,1)  + 1
   in_gap = .False.
   n_issued = .False.
   Xstr = ''
   tlen = 1

   Do yyyy = MinYear, ymax
      If (yyyy < ymax) Then
         entry ok = Issue This Year(yyyy)
      Else
         !  yyyy == ymax
         !  The point is not missing — it does not exist.
         entry ok = .False.
      End If

      If (in_gap)  Then
                                                               374
-------
         If (entry_ok) Then
            !  Nothing to do.
         Else
            !  The gap run just ended.
            Write (Xstr(tlen:),  '(14)') yyyy-1
            tlen = Len trim(Xstr) + 1
            in gap =  .False.
            n_issued = .True.
         End If
      Else
         If (entry_ok) Then
            !  Start of a new gap
            Write (Xstr(tlen:),  '(Ix,14,"-")') yyyy
            tlen = Len trim(Xstr) + 1
            in gap =  .True.
         Else
            !  No missing value and no gap.
            !  Do nothing.
         End If
      End If
   End Do

   If (.Not. n_issued) Then
      Write (Xstr(tlen:), '(lx,a)')  '** none **'
   End If
End Subroutine Str years
                                                               375
-------
Test Data for Laramie, Wyoming: average values for August 1987(BurmanandPochop 1994:221)
 Element



 Wind movement



 Solar radiation



 Relative Humidity



 Air temperature



 Dew-point temperature



 Elevation



 Station pressure



 Vapor pressure deficit



 Saturation vapor pressure



 Actual vapor pressure



 A



 ap (for class A evap pan)



 a



 Daily pan evaporation



 Daily FWS evaporation
S.I.



261 km/day



5964 Wh/m2/day



43.7%



15.2C



3.0C



2200m



78.1kPa



0.972 kPa



1.727kPa



0.755 kPa



0.1110kPa/°C



0.1225kPa/°C



0.0519 kPa/°C



7.32mm



0.06 mm
English



163 mi/day



514Ly/day



43.7%



59.4F



37.4F



7218 feet



23.04 inches Hg



0.2869 inches Hg



0.5095 inches of Hg



0.2227 inches of Hg



0.0182 inches Hg/°F



0.02007 inches Hg/°F



 0.00846 inches Hg/°F



0.29 inches



0.0025 inches
                                         376
-------
                                  SAMSON Station Locations
Weather Bureau Army Navy (WBAN) number, station location (City and State), geographic coordinates (latitude and
longitude) and elevation (mM.S.L.) of the 234 stations available for coordinated climatological dataset for AgDisp,
PRZM, and EXAMS (see ?). Primary stations (those with measured solar radiation data for at least one year) are in bold
type; stations lacking hourly precipitation data are italicized.
 WBAN
                Station
State
Latitude
Longitude   Elevation (m)
03103
03812
03813
03820
03822
03856
03860
03870
03927
03928
03937
03940
03945
03947
04725
04751
11641
12834
12836
12839
12842
Flagstaff
Asheville
Macon
Augusta
Savannah
Huntsville
Huntington
Greenville
Fort Worth
Wichita
Lake Charles
Jackson
Columbia
Kansas City
Binghamton
Bradford
San Juan
Daytona Beach
Key West
Miami
Tampa
AZ
NC
GA
GA
GA
AL
WV
SC
TX
KS
LA
MS
MO
MO
NY
PA
PR
FL
FL
FL
FL
35.1
35.4
32.7
33.4
32.1
34.7
38.4
34.9
32.8
37.7
30.1
32.3
38.8
39.3
42.2
41.8
18.4
29.2
24.6
25.8
28.0
-111.7
-82.5
-83.7
-82.0
-81.2
-86.8
-82.6
-82.2
-97.1
-97.4
-93.2
-90.1
-92.2
-94.7
-76.0
-78.6
-66.0
-81.1
-81.8
-80.3
-82.5
2135
661
110
45
16
190
255
296
164
408
o
3
101
270
315
499
600
19
12
1
2
3
                                                 377
-------
WBAN
12844
12912
12916
12917
12919
12921
12924
12960
13722
13723
13729
13733
13737
13739
13740
13741
13748
13781
13865
13866
13873
13874
13876
13877
13880
13881
13882
13883
13889
13891
Station
West Palm
Beach
Victoria
New Orleans
Port Arthur
Brownsville
San Antonio
Corpus Christi
Houston
Raleigh
Greensboro
Elkins
Lynchburg
Norfolk
Philadelphia
Richmond
Roanoke
Wilmington
Wilmington
Meridian
Charleston
Athens
Atlanta
Birmingham
Bristol
Charleston
Charlotte
Chattanooga
Columbia
Jacksonville
Knoxville
State
FL
TX
LA
TX
TX
TX
TX
TX
NC
NC
wv
VA
VA
PA
VA
VA
NC
DE
MS
WV
GA
GA
AL
TN
SC
NC
TN
SC
FL
TN
Latitude
26.7
28.9
30.0
30.0
25.9
29.5
27.8
30.0
35.9
36.1
38.9
37.3
36.9
39.9
37.5
37.3
34.3
39.7
32.3
38.4
34.0
33.7
33.6
36.5
32.9
35.2
35.0
34.0
30.5
35.8
Longitude
-80.1
-96.9
-90.3
-94.0
-97.4
-98.5
-97.5
-95.4
-78.8
-80.0
-79.9
-79.2
-76.2
-75.3
-77.3
-80.0
-77.9
-75.6
-88.8
-81.6
-83.3
-84.4
-86.8
-82.4
-80.0
-80.9
-85.2
-81.1
-81.7
-84.0
Elevation (m)
6
32
3
7
6
242
13
33
134
270
594
279
9
9
50
358
9
24
94
290
244
315
192
459
12
234
210
69
9
299
378
-------
WBAN
13893
13894
13895
13897
13957
13958
13959
13962
13963
13964
13966
13967
13968
13970
13985
13994
13995
13996
14607
14733
14734
14735
14737
14739
14740
14742
14745
14751
14764
14765
Station
Memphis
Mobile
Montgomery
Nashville
Shreveport
Austin
Waco
Abilene
Little Rock
Fort Smith
Wichita Falls
Oklahoma
City
Tulsa
Baton Rouge
Dodge City
St. Louis
Springfield
Topeka
Caribou
Buffalo
Newark
Albany
Allentown
Boston
Hartford
Burlington
Concord
Harrisburg
Portland
Providence
State
TN
AL
AL
TN
LA
TX
TX
TX
AR
AR
TX
OK
OK
LA
KS
MO
MO
KS
ME
NY
NJ
NY
PA
MA
CT
VT
NH
PA
ME
RI
Latitude
35.1
30.7
32.3
36.1
32.5
30.3
31.6
32.4
34.7
35.3
34.0
35.4
36.2
30.5
37.8
38.8
37.2
39.1
46.9
42.9
40.7
42.8
40.7
42.4
41.9
44.5
43.2
40.2
43.7
41.7
Longitude
-90.0
-88.3
-86.4
-86.7
-93.8
-97.7
-97.2
-99.7
-92.2
-94.4
-98.5
-97.6
-95.9
-91.2
-100.0
-90.4
-93.4
-95.6
-68.0
-78.7
-74.2
-73.8
-75.4
-71.0
-72.7
-73.2
-71.5
-76.9
-70.3
-71.4
Elevation (m)
87
67
62
180
79
189
155
534
81
141
314
397
206
23
787
172
387
270
190
215
9
89
117
5
55
104
105
106
19
19
379
-------
WBAN
               Station
State
Latitude      Longitude   Elevation (m)
14768
14771
14777
14778
14820
14821
14826
14827
14836
14837
14839
14840
14842
14847
14848
14850
14852
14860
14891
14895
14898
14913
14914
14918
14920
14922
14923
14925
14926
14933
Rochester
Syracuse
Wilkes-Barre
Williamsport
Cleveland
Columbus
Flint
Fort Wayne
Lansing
Madison
Milwaukee
Muskegon
Peoria
Sault Ste. Marie
South Bend
Traverse City
Youngstown
Erie
Mansfield
Akron
Green Bay
Duluth
Fargo
International
Falls
La Crosse
Minneapolis
Moline
Rochester
Saint Cloud
Des Moines
NY
NY
PA
PA
OH
OH
MI
IN
MI
WI
WI
MI
IL
MI
IN
MI
OH
PA
OH
OH
WI
MN
ND
MN
WI
MN
IL
MN
MN
IA
43.1
43.1
41.3
41.3
41.4
40.0
43.0
41.0
42.8
43.1
43.0
43.2
40.7
46.5
41.7
44.7
41.3
42.1
40.8
40.9
44.5
46.8
46.9
48.6
43.9
44.9
41.5
43.9
45.6
41.5
-77.7
-76.1
-75.7
-77.1
-81.9
-82.9
-83.7
-85.2
-84.6
-89.3
-87.9
-86.3
-89.7
-84.4
-86.3
-85.6
-80.7
-80.2
-82.5
-81.4
-88.1
-92.2
-96.8
-93.4
-91.3
-93.2
-90.5
-92.5
-94.1
-93.7
169
124
289
243
245
254
233
252
256
262
211
191
199
221
236
192
361
225
395
377
214
432
274
361
205
255
181
402
313
294
                                                  380
-------
WBAN
               Station
State
Latitude      Longitude   Elevation (m)
14935
14936
14940
14941
14943
14944
14991
21504
22516
22521
22536
23023
23034
23042
23044
23047
23050
23061
23065
23066
23129
23153
23154
23155
23160
23161
23169
23174
23183
23184
Grand Island
Huron
Mason City
Norfolk
Sioux City
Sioux Falls
Eau Claire
Hilo
Kahului
Honolulu
Lihue
Midland/Odessa
San Angelo
Lubbock
El Paso
Amarillo
Albuquerque
Alamosa
Goodland
Grand Junction
Long Beach
Tonopah
Ely
Bakersfield
Tucson
Daggett
Las Vegas
Los Angeles
Phoenix
Prescott
NE
SD
IA
NE
IA
SD
WI
HI
HI
HI
HI
TX
TX
TX
TX
TX
NM
CO
KS
CO
CA
NV
NV
CA
AZ
CA
NV
CA
AZ
AZ
41.0
44.4
43.2
42.0
42.4
43.6
44.9
19.7
20.9
21.3
22.0
31.9
31.4
33.7
31.8
35.2
35.1
37.5
39.4
39.1
33.8
38.1
39.3
35.4
32.1
34.9
36.1
33.9
33.4
34.7
-98.3
-98.2
-93.3
-97.4
-96.4
-96.7
-91.5
-155.1
-156.4
-157.9
-159.4
-102.2
-100.5
-101.8
-106.4
-101.7
-106.6
-105.9
-101.7
-108.5
-118.2
-117.1
-114.9
-119.1
-110.9
-116.8
-115.2
-118.4
-112.0
-112.4
566
393
373
471
336
435
273
11
15
5
45
871
582
988
1194
1098
1619
2297
1124
1475
17
1653
1906
150
779
588
664
32
339
1531
                                                  381
-------
WBAN
23185
23188
23232
23234
23273
24011
24013
24018
24021
24023
24025
24027
24028
24029
24033
24089
24090
24121
24127
24128
24131
24143
24144
24146
24153
24155
24156
24157
24221
24225
Station
Reno
San Diego
Sacramento
San
Francisco
Santa Maria
Bismarck
Minot
Cheyenne
Lander
North Platte
Pierre
Rock Springs
Scottsbluff
Sheridan
Billings
Casper
Rapid City
Elko
Salt Lake City
Winnemucca
Boise
Great Falls
Helena
Kalispell
Missoula
Pendleton
Pocatello
Spokane
Eugene
Medford
State
NV
CA
CA
CA
CA
ND
ND
WY
WY
NE
SD
WY
NE
WY
MT
WY
SD
NV
UT
NV
ID
MT
MT
MT
MT
OR
ID
WA
OR
OR
Latitude
39.5
32.7
38.5
37.6
34.9
46.8
48.3
41.2
42.8
41.1
44.4
41.6
41.9
44.8
45.8
42.9
44.1
40.8
40.8
40.9
43.6
47.5
46.6
48.3
46.9
45.7
42.9
47.6
44.1
42.4
Longitude Elevation (m)
-119.8
-117.2
-121.5
-122.4
-120.5
-100.8
-101.3
-104.8
-108.7
-100.7
-100.3
-109.1
-103.6
-107.0
-108.5
-106.5
-103.1
-115.8
-112.0
-117.8
-116.2
-111.4
-112.0
-114.3
-114.1
-118.9
-112.6
-117.5
-123.2
-122.9
1341
9
8
5
72
502
522
1872
1696
849
526
2056
1206
1209
1088
1612
966
1547
1288
1323
874
1116
1188
904
972
456
1365
721
109
396
382
-------
WBAN
24227
24229
24230
24232
24233
24243
24283
24284
25308
25339
25501
25503
25624
25713
26411
26415
26425
26451
26510
26528
26533
26615
26616
26617
27502
41415
93037
93058
93129
93193
Station
Olympia
Portland
Redmond/Bend
Salem
Seattle/Tacoma
Yakima
Arcata
North Bend
Annette
Yakutat
Kodiak
King Salmon
Cold Bay
St Paul Is.
Fairbanks
Big Delta
Gulkana
Anchorage
Mcgrath
Talkeetna
Settles
Bethel
Kotzebue
Nome
Barrow
Guam
Colorado Springs
Pueblo
Cedar City
Fresno
State
WA
OR
OR
OR
WA
WA
CA
OR
AK
AK
AK
AK
AK
AK
AK
AK
AK
AK
AK
AK
AK
AK
AK
AK
AK
PI
CO
CO
UT
CA
Latitude
47.0
45.6
44.3
44.9
47.5
46.6
41.0
43.4
55.0
59.5
57.8
58.7
55.2
57.2
64.8
64.0
62.2
61.2
63.0
62.3
66.9
60.8
66.9
64.5
71.3
13.6
38.8
38.3
37.7
36.8
Longitude
-122.9
-122.6
-121.2
-123.0
-122.3
-120.5
-124.1
-124.3
-131.6
-139.7
-152.3
-156.7
-162.7
-170.2
-147.9
-145.7
-145.5
-150.0
-155.6
-150.1
-151.5
-161.8
-162.6
-165.4
-156.8
-144.8
-104.7
-104.5
-113.1
-119.7
Elevation (m)
61
12
940
61
122
325
69
5
34
9
34
15
29
7
138
388
481
35
103
105
205
46
5
7
4
110
1881
1439
1712
100
383
-------
WBAN
               Station
State
Latitude      Longitude   Elevation (m)
93721
93729
93730
93738
93805
93814
93815
93817
93819
93820
93821
93822
93842
93987
94008
94018/23062
94185
94224
94240
94702
94725
94728/14732
94746
94814
94822
94823
94830
94846
94847
94849
Baltimore
Cape Hatteras
Atlantic City
Sterling (Washington-Dulles Airpt.)
Tallahassee/Apalachicola
Covington
Dayton
Evansville
Indianapolis
Lexington
Louisville
Springfield
Columbus
Lufkin
Glasgow
Boulder/Denver
Burns
Astoria
Quillayute
Bridgeport
Massena
New York (LaGuardia Airpt.)
Worcester
Houghton
Rockford
Pittsburgh
Toledo
Chicago
Detroit
Alpena
MD
NC
NJ
VA
FL
KY
OH
IN
IN
KY
KY
IL
GA
TX
MT
CO
OR
OR
WA
CT
NY
NY
MA
MI
IL
PA
OH
IL
MI
MI
39.2
35.3
39.5
39.0
30.4
39.1
39.9
38.1
39.7
38.0
38.2
39.8
32.5
31.2
48.2
39.8
43.6
46.2
48.0
41.2
44.9
40.8
42.3
47.2
42.2
40.5
41.6
41.8
42.4
45.1
-76.7
-75.6
-74.6
-77.5
-84.4
-84.7
-84.2
-87.5
-86.3
-84.6
-85.7
-89.7
-85.0
-94.8
-106.6
-104.9
-119.1
-123.9
-124.6
-73.1
-74.9
-73.9
-71.9
-88.5
-89.1
-80.2
-83.8
-87.8
-83.0
-83.6
47
2
20
82
21
271
306
118
246
301
149
187
136
96
700
1610
1271
7
55
2
63
11
301
329
221
373
211
190
191
210
                                                  384
-------
WBAN         Station                             State        Latitude     Longitude   Elevation (m)



94860         Grand Rapids                        MI             42.9          -85.5           245



94910         Waterloo                           IA             42.6          -92.4           265



94918/14942   Omaha                             NE             41.3          -95.9           298
                                               385
-------
                                     References
Allen, R. G. 1996. Assessing integrity of weather data for reference evapotranspiration estimation.
       Journal of Irrigation and Drainage Engineering 122:97-106.
Allen, R. G. 2000. REF-ET: Reference Evapotranspiration Calculation Software for FAO and ASCE
       Standardized Equations, Version 2.0. University of Idaho, Kimberly.
Allen, R. G., L. S. Pereira, D. Raes, and M. Smith. 1998. Crop evapotranspiration: Guidelines for
       computing crop water requirements.  FAO Irrigation and Drainage Paper 56, Food and
       Agriculture Organization of the United Nations, Rome.
ASCE. 1996. Hydrology Handbook (Manual No. 28), Second edition. American Society of Civil
       Engineers, New York.
Brutsaert, W. 1982. Evaporation into the Atmosphere: Theory, History, and Applications. D. Reidel
       Publishing Co., Dordrecht, The Netherlands.
Burman, R., andL. O. Pochop. 1994. Evaporation, Evapotranspiration and Climatic Data. Elsevier,
       Amsterdam.
Burns, L. A. 2000.  Exposure Analysis Modeling System  (Exams):  User Manual  and  System
       Documentation. EPA/600/R-00/081, U.S. Environmental Protection Agency, Office of
       Research  and Development, National Exposure Research Laboratory, Research Triangle
       Park, North Carolina, USA.
Carousel, R. F., J. C. Imhoff, P. R. Hummel, J. M. Cheplick, and A. S. Donigian, Jr. 2005. PRZM-3,
       A Model for Predicting Pesticide and Nitrogen Fate in the Crop Root and Unsaturated Soil
       Zones: Users Manual for Release 3.12.2. Athens, Georgia.
EPA.  2000. Meteorological Monitoring Guidance for Regulatory Modeling Applications. EPA-
       454/R-99-005, U.S. Environmental Protection Agency, Office of Air Quality Planning and
       Standards, Research Triangle Park.
Farnsworth, R. K., E.  S. Thompson, and E. L. Peck. 1982. Evaporation Atlas for the Contiguous 48
       United  States. NOAA Technical Report NWS 33, Office of Hydrology, National Weather
       Service, Washington.
Hanson, C. L.,  K. A. Cumming, D. A. Woolhiser, and C. W. Richardson. 1993. Program for Daily
       Weather Simulation. Water Resources Investigations Rep. 93-4018,U.S. Geological  Survey,
       Denver.
Hanson, C. L., K. A.  Cumming, D. A. Woolhiser, and C. W. Richardson. 1994. Microcomputer
       Program for Daily Weather Simulation in  the Contiguous United States.  Agricultural
       Research  Service ARS-114, U.S. Department of Agriculture, Boise.
Harbeck, G. E., andF. W. Kennon. 1954. Lake Hefner Studies Technical Report. Professional Paper
       269, U.S.  Geological Survey, Washington.
Harrison, L. P. 1963. Fundamental concepts and definitions relating to humidity. Pages 3-80 in A.
       Wexler, editor. Humidity and Moisture. Reinhold Publishing Company, New  York.
Johnson, G.  L., C. L. Hanson, S.  P.  Hardegree, and E. B.  Ballard.  1996. Stochastic weather
       simulation: Overview and analysis of two commonly used models. Journal of Applied
       Meteorology 35:1878-1896.
Kohler, M. A., T. J. Nordenson, and W. E. Fox. 1955. Evaporation from Pans and Lakes. Research
       Paper 38,  U.S. Department of Commerce, Weather Bureau, Washington.
Kohler, M. A., and L. H. Parmele. 1967. Generalized estimates of free-water evaporation. Water

                                          386
-------
       Resources Research 3:997-1005.
Lamoreux, W. W. 1962. Modern evaporation formulae adapted to computer use. Monthly Weather
       Review 90:26-28.
Merkel, W. H. 1988. Appendix A, Revision of Reservoir Operations Study Computer Program &
       User Manual. Technical Release 210-VI-TR-19A, U.S. Department of Agriculture, Soil
       Conservation Service, Washington.
Nicks, A. D., and G. A. Gander. 1994. CLIGEN: A weather generator for climate inputs to water
       resource and  other models, in  Proceedings of the Fifth  International  Conference on
       Computers in Agriculture. American  Society of Agricultural Engineers, Orlando.
Penman, H. L. 1948. Natural evaporation from open water, bare soil and grass. Proceedings of the
       Royal Society of London, Series A: Mathematical and Physical Sciences 193:120-145.
Penman, H. L.  1963. Vegetation and Hydrology. Technical Communication 53,  Commonwealth
       Agricultural Bureaux, Farnham Royal, Bucks, England.
Richardson, C. W.,  and D. A. Wright.  1984. WGEN:  A Model for Generating Daily Weather
       Variables.  Agricultural  Research Service ARS-8, U.S.  Department  of  Agriculture,
       Washington.
Semenov, M. A., andE. M. Barrow. 1997. Use of a stochastic weather generator in the development
       of climate change scenarios. Climate  Change 35:397-414.
Semenov, M. A., R. J. Brooks, E. M. Barrow, and C.  W. Richardson. 1998. Comparison of the
       WGEN and LARS-WG stochastic weather generators for diverse climates. Climate Research
       10:95-107.
                                         387
-------
vvEPA
      United States
      Environmental Protection
      Agency
      Office of Research
      and Development (8101R)
      Washington, DC 20460
      Official Business
      Penalty for Private Use
      $300
      EPA 600/R-07/053
      May 2007
      www.epa.gov
Please make all necessary changes on the below label,
detach or copy, and return to the address in the upper
left-hand corner.

If you do not wish to receive these reports CHECK HERE

D; detach, or copy this cover, and return to the address in
the upper left-hand corner.
PRESORTED STANDARD
 POSTAGE & FEES PAID
          EPA
    PERMIT No. G-35
                                                   Recycled/Recyclable
                                                   Printed with vegetable-based ink on
                                                   paper that contains a minimum of
                                                   50% post-consumer fiber content
                                                   processed chlorine free
-------