FMS  2024.03
Flexible Modeling System
sat_vapor_pres_k.inc
1 !***********************************************************************
2 !* GNU Lesser General Public License
3 !*
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
5 !*
6 !* FMS is free software: you can redistribute it and/or modify it under
7 !* the terms of the GNU Lesser General Public License as published by
8 !* the Free Software Foundation, either version 3 of the License, or (at
9 !* your option) any later version.
10 !*
11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14 !* for more details.
15 !*
16 !* You should have received a copy of the GNU Lesser General Public
17 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
18 !***********************************************************************
19 !> @addtogroup sat_vapor_pres_k_mod
20 !> @brief Kernel module to be used by @ref sat_vapor_pres_mod for
21 !> @{
22 
23 !! table lookups and calculations
24 
25 !> This routine has been generalized to return tables for any temperature range and resolution
26 !! The TABLEs for saturation vapor pressure are computed with r8_kind precision since
27 !! these TABLES are module level variables that are decared as r8_kind.
28 !! The subroutines compute_es_k, compute_es_k, compute_es_liq_k, and compute_es_liq_ice_k
29 !! seem to be mostly used to compute the TABLE values (and thus all variables within them can be declared
30 !! as r8_kind). However, these compute* subroutines have been modified to accept both r4_kind and r8_kind arguments
31 !! for general usage and the math can be conducted in either r4_kind and r8_kind.
32 !! In this initialization routine, r8_kind arguments are passed to these compute* subroutines.
33 !! This routine does not assume the passed in arguments are in r8_precision.
34 !! Thus all variables used for the computation of the TABLES (e.g. TABLE, DTABLE*, D2TABLE*) are promoted
35 !! to r8_kind precision. All local variables used for computation are in r8_kind precision
36 !! Thus the TABLEs are constructed as accurately as possible and are promoted down to r4_kind when users
37 !! pass in r4_kind arguments to the LOOKUP* subroutines.
38  subroutine sat_vapor_pres_init_k_(table_size, tcmin, tcmax, TFREEZE, HLV, RVGAS, ES0, err_msg, &
39  use_exact_qs_input, do_simple, &
40  construct_table_wrt_liq, &
41  construct_table_wrt_liq_and_ice, &
42  teps, tmin, dtinv)
43 
44  integer, intent(in) :: table_size
45  real(kind=fms_svp_kind_), intent(in) :: tcmin !< TABLE(1) = sat vapor pressure at temperature tcmin (deg C)
46  real(kind=fms_svp_kind_), intent(in) :: tcmax !< TABLE(table_size) = sat vapor pressure at temperature tcmax (deg C)
47  real(kind=fms_svp_kind_), intent(in) :: tfreeze !< Conversion to Kelvin
48  real(kind=fms_svp_kind_), intent(in) :: hlv !< Latent heat of evaporation [J/kg]
49  real(kind=fms_svp_kind_), intent(in) :: rvgas !< Gas constant for water vapor
50  real(kind=fms_svp_kind_), intent(in) :: es0 !< Humidity factor [dimensionless]
51  logical, intent(in) :: use_exact_qs_input
52  logical, intent(in) :: do_simple
53  logical, intent(in) :: construct_table_wrt_liq
54  logical, intent(in) :: construct_table_wrt_liq_and_ice
55  character(len=*), intent(out) :: err_msg
56  real(kind=fms_svp_kind_), intent(out), optional :: teps
57  real(kind=fms_svp_kind_), intent(out), optional :: tmin
58  real(kind=fms_svp_kind_), intent(out), optional :: dtinv
59 
60 
61 !> increment used to generate derivative table
62 !! the following variables are used in the computation
63 !! of the *TABLES* (which is defined in r8_kind in sat_vapor_pres_mod)
64 !! Thus these variables are declared with r8_kind
65  real(kind=r8_kind), dimension(3) :: tem(3), es(3)
66  real(kind=r8_kind) :: hdtinv, tinrc, tfact
67  integer :: i
68 
69  err_msg = ''
70 
71  if (module_is_initialized) return
72 
73  if(allocated(table) .or. allocated(dtable) .or. allocated(d2table)) then
74  err_msg = 'Attempt to allocate sat vapor pressure tables when already allocated'
75  return
76  else
77  allocate(table(table_size), dtable(table_size), d2table(table_size))
78  endif
79 
80  if (construct_table_wrt_liq) then
81  if(allocated(table2) .or. allocated(dtable2) .or. allocated(d2table2)) then
82  err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated'
83  return
84  else
85  allocate(table2(table_size), dtable2(table_size), d2table2(table_size))
86  endif
87  endif
88 
89  if (construct_table_wrt_liq_and_ice) then
90  if(allocated(table3) .or. allocated(dtable3) .or. allocated(d2table3)) then
91  err_msg = 'Attempt to allocate sat vapor pressure table2s when already allocated'
92  return
93  else
94  allocate(table3(table_size), dtable3(table_size), d2table3(table_size))
95  endif
96  endif
97 
98  table_siz = table_size
99  dtres = (real(tcmax,r8_kind)-real(tcmin,r8_kind))/real(table_size-1,r8_kind)
100  tminl = real(tcmin,r8_kind)+real(tfreeze,r8_kind) ! minimum valid temp in table
101  dtinvl = 1.0_r8_kind/dtres
102  tepsl = 0.5_r8_kind*dtres
103  tinrc = 0.1_r8_kind*dtres
104  if(present(teps )) teps =real(tepsl, fms_svp_kind_)
105  if(present(tmin )) tmin =real(tminl, fms_svp_kind_)
106  if(present(dtinv)) dtinv=real(dtinvl, fms_svp_kind_)
107 
108 !> To be able to compute tables for any temperature range and resolution,
109 !! and at the same time exactly reproduce answers from memphis revision,
110 !! it is necessary to compute ftact differently than it is in memphis.
111  tfact = 5.0_r8_kind*dtinvl
112 
113  hdtinv = 0._r8_kind*dtinvl
114 
115 !> compute es tables from tcmin to tcmax
116 !> estimate es derivative with small +/- difference
117 
118  if (do_simple) then
119 
120  !> TABLE = 610.78ES0*exp(-HLV/RGAS[1/tem - 1.TFREEZE])
121  !> DTABLE = HLV(TABLE/RVGAS)^2
122  do i = 1, table_size
123  tem(1) = tminl + dtres*real(i-1,r8_kind)
124  table(i) = real(es0,r8_kind)*610.78_r8_kind* &
125  exp( -real(hlv,r8_kind)/real(rvgas,r8_kind) * (1.0_r8_kind/tem(1) - 1._r8_kind/real(tfreeze,r8_kind)) )
126  dtable(i) = real(hlv,r8_kind)*table(i)/real(rvgas,r8_kind)/tem(1)**2._r8_kind
127  enddo
128 
129  else
130 
131  do i = 1, table_size
132  tem(1) = tminl + dtres*real(i-1,r8_kind)
133  tem(2) = tem(1)-tinrc
134  tem(3) = tem(1)+tinrc
135  es = compute_es_k(tem, real(tfreeze,r8_kind))
136  table(i) = es(1)
137  dtable(i) = (es(3)-es(2))*tfact
138  enddo
139 
140  endif !if (do_simple)
141 
142 !> compute one-half second derivative using centered differences
143 !! differencing des values in the table
144 
145  do i = 2, table_size-1
146  d2table(i) = 0.25_r8_kind*dtinvl*(dtable(i+1)-dtable(i-1))
147  enddo
148 !> one-sided derivatives at boundaries
149 
150  d2table(1) = 0.50_r8_kind*dtinvl*(dtable(2)-dtable(1))
151 
152  d2table(table_size) = 0.50_r8_kind*dtinvl*(dtable(table_size)-dtable(table_size-1))
153 
154  if (construct_table_wrt_liq) then
155 !> compute es tables from tcmin to tcmax
156 !> estimate es derivative with small +/- difference
157 
158  do i = 1, table_size
159  tem(1) = tminl + dtres*real(i-1,r8_kind)
160  tem(2) = tem(1)-tinrc
161  tem(3) = tem(1)+tinrc
162 !> pass in flag to force all values to be wrt liquid
163  es = compute_es_liq_k(tem, real(tfreeze,r8_kind))
164  table2(i) = es(1)
165  dtable2(i) = (es(3)-es(2))*tfact
166  enddo
167 
168 !> compute one-half second derivative using centered differences
169 !! differencing des values in the table
170 
171  do i = 2, table_size-1
172  d2table2(i) = 0.25_r8_kind*dtinvl*(dtable2(i+1)-dtable2(i-1))
173  enddo
174 !> one-sided derivatives at boundaries
175 
176  d2table2(1) = 0.50_r8_kind*dtinvl*(dtable2(2)-dtable2(1))
177 
178  d2table2(table_size) = 0.50_r8_kind*dtinvl*(dtable2(table_size)-dtable2(table_size-1))
179  endif
180 
181 
182  if (construct_table_wrt_liq_and_ice) then
183 !> compute es tables from tcmin to tcmax
184 !> estimate es derivative with small +/- difference
185 
186  do i = 1, table_size
187  tem(1) = tminl + dtres*real(i-1,r8_kind)
188  tem(2) = tem(1)-tinrc
189  tem(3) = tem(1)+tinrc
190 !> pass in flag to force all values to be wrt liquid
191  es = compute_es_liq_ice_k(tem, real(tfreeze,r8_kind))
192  table3(i) = es(1)
193  dtable3(i) = (es(3)-es(2))*tfact
194  enddo
195 
196 !> compute one-half second derivative using centered differences
197 !! differencing des values in the table
198 
199  do i = 2, table_size-1
200  d2table3(i) = 0.25_r8_kind*dtinvl*(dtable3(i+1)-dtable3(i-1))
201  enddo
202 !> one-sided derivatives at boundaries
203 
204  d2table3(1) = 0.50_r8_kind*dtinvl*(dtable3(2)-dtable3(1))
205 
206  d2table3(table_size) = 0.50_r8_kind*dtinvl*(dtable3(table_size)-dtable3(table_size-1))
207  endif
208 
209  use_exact_qs = use_exact_qs_input
210  module_is_initialized = .true.
211 
212  end subroutine sat_vapor_pres_init_k_
213 
214 !#######################################################################
215 
216  function compute_es_k_(tem, TFREEZE) result (es)
217  real(kind=fms_svp_kind_), intent(in) :: tem(:) !< temperature
218  real(kind=fms_svp_kind_), intent(in) :: tfreeze !< conversion to Kelvin
219  real(kind=fms_svp_kind_) :: es(size(tem,1)) !< saturation vapor pressure
220 
221  real(kind=fms_svp_kind_) :: x
222  real(kind=fms_svp_kind_) :: esice
223  real(kind=fms_svp_kind_) :: esh2o
224  real(kind=fms_svp_kind_) :: tbasw
225  real(kind=fms_svp_kind_) :: tbasi
226  integer :: i
227 
228  integer, parameter :: lkind=fms_svp_kind_ !< local kind parameter
229 
230  real(kind=fms_svp_kind_), parameter :: esbasw = 101324.60_lkind
231  real(kind=fms_svp_kind_), parameter :: esbasi = 610.71_lkind
232 
233  !> one and ten are declared for code readability. For example, one is easier to read
234  !! then 1.0_lkind where lkind=FMS_SVP_KIND_ throughout the code
235  real(fms_svp_kind_), parameter :: one=1.0_lkind
236  real(fms_svp_kind_), parameter :: ten=10.0_lkind
237 
238  tbasw = tfreeze+100.0_lkind !to Kelvin
239  tbasi = tfreeze
240 
241  do i = 1, size(tem)
242 
243 !> compute es over ice
244 
245  !> x = -9.09718(TBASI/tem-1) - 3.56654log(TBASI/tem) + 0.876793(1-tem/TBASI) + log(ESBASI)
246  !! the coded equation below is the commented equation above
247  if (tem(i) < tbasi) then
248  x = -9.09718_lkind*(tbasi/tem(i)-one) &
249  -3.56654_lkind*log10(tbasi/tem(i)) &
250  +0.876793_lkind*(one-tem(i)/tbasi) + log10(esbasi)
251  esice =ten**(x)
252  else
253  esice = 0.0_lkind
254  endif
255 
256 !> compute es over water greater than -20 c.
257 !! values over 100 c may not be valid
258 !! see smithsonian meteorological tables page 350.
259 
260  !> x = -7.90298(TBASW/tem-1) + 5.02808log(TBASW/tem)
261  !! -1.3816d-07*10^[11.344(1-tem/TBASW)-1]
262  !! +8.1328d-03*10^[-3.49149(TBASW/tem-1)-1] + log(ESBASW)
263  !! the coded equation below is the commented equation above
264  if (tem(i) > -20.0_lkind+tbasi) then
265  x = -7.90298_lkind*(tbasw/tem(i)-one) &
266  +5.02808_lkind*log10(tbasw/tem(i)) &
267  -1.3816e-07_lkind*(ten**((one-tem(i)/tbasw)*11.344_lkind)-one) &
268  +8.1328e-03_lkind*(ten**((tbasw/tem(i)-one)*(-3.49149_lkind))-one) &
269  +log10(esbasw)
270  esh2o = ten**(x)
271  else
272  esh2o = 0.0_lkind
273  endif
274 
275 !> derive blended es over ice and supercooled water between -20c and 0c
276 
277  !> es = 0.05*[esice*(TBASI-10)+esh2o*(tem-TBASI+20)]
278  !! the coded equation below is the commented equation above
279  if (tem(i) <= -20.0_lkind+tbasi) then
280  es(i) = esice
281  else if (tem(i) >= tbasi) then
282  es(i) = esh2o
283  else
284  es(i) = 0.05_lkind*((tbasi-tem(i))*esice + (tem(i)-tbasi+20.0_lkind)*esh2o)
285  endif
286 
287  enddo
288 
289  end function compute_es_k_
290 
291 !#######################################################################
292 
293  function compute_es_liq_k_(tem, TFREEZE) result (es)
294  real(kind=fms_svp_kind_), intent(in) :: tem(:) !< temperature
295  real(kind=fms_svp_kind_), intent(in) :: tfreeze !< conversion to Kelvin
296  real(kind=fms_svp_kind_) :: es(size(tem,1)) !< saturation vapor pressure
297 
298  real(kind=fms_svp_kind_) :: x
299  real(kind=fms_svp_kind_) :: esh2o
300  real(kind=fms_svp_kind_) :: tbasw
301  integer :: i
302 
303  !> local kind variable
304  !! one and ten are declared for code readability. For example, one is easier to read
305  !! then 1.0_lkind where lkind=FMS_SVP_KIND_ throughout the code
306  integer, parameter :: lkind=fms_svp_kind_
307  real(kind=fms_svp_kind_), parameter :: one=1.0_lkind
308  real(kind=fms_svp_kind_), parameter :: ten=10.0_lkind
309  real(kind=fms_svp_kind_), parameter :: esbasw = 101324.60_lkind
310 
311  tbasw = tfreeze+100.0_lkind
312 
313  do i = 1, size(tem)
314 
315 !> compute es over water for all temps.
316 !! values over 100 c may not be valid
317 !! see smithsonian meteorological tables page 350.
318 
319  !> x = -7.90298(TBASW/tem-1) + 5.02808log(TBASW/tem)
320  !! -1.3816d-07*10^[11.344(1-tem/TBASW)-1]
321  !! +8.1328d-03*10^[-3.49149(TBASW/tem-1)-1] + log(ESBASW)
322  !! the coded equation below is the commented equation above
323  x = -7.90298_lkind*(tbasw/tem(i)-one) &
324  +5.02808_lkind*log10(tbasw/tem(i)) &
325  -1.3816e-07_lkind*(ten**((one-tem(i)/tbasw)*11.344_lkind)-one) &
326  +8.1328e-03_lkind*(ten**((tbasw/tem(i)-one)*(-3.49149_lkind))-one)&
327  +log10(esbasw)
328  esh2o = ten**(x)
329 
330  es(i) = esh2o
331 
332  enddo
333 
334  end function compute_es_liq_k_
335 
336 !#######################################################################
337 
338  function compute_es_liq_ice_k_(tem, TFREEZE) result (es)
339  real(kind=fms_svp_kind_), intent(in) :: tem(:) !< temperature
340  real(kind=fms_svp_kind_), intent(in) :: tfreeze !< conversion to Kelvin
341  real(kind=fms_svp_kind_) :: es(size(tem,1)) !< saturation vapor pressure
342 
343  real(kind=fms_svp_kind_) :: x
344  real(kind=fms_svp_kind_) :: tbasw
345  real(kind=fms_svp_kind_) :: tbasi
346  integer :: i
347 
348  integer, parameter :: lkind=fms_svp_kind_
349  real(kind=fms_svp_kind_), parameter :: esbasw = 101324.60_lkind
350  real(kind=fms_svp_kind_), parameter :: esbasi = 610.71_lkind
351  !> one and ten are declared for code readability. For example, one is easier to read
352  !! then 1.0_lkind where lkind=FMS_SVP_KIND_ throughout the code
353  real(kind=fms_svp_kind_), parameter :: one=1.0_lkind
354  real(kind=fms_svp_kind_), parameter :: ten=10.0_lkind
355 
356  tbasw = tfreeze+100.0_lkind
357  tbasi = tfreeze
358 
359  do i = 1, size(tem)
360 
361  if (tem(i) < tbasi) then
362 
363 !> compute es over ice
364  !> x= -9.09718(TBASI/tem-1) -3.56654log(TBASI/tem) +0.87679(1-tem/TBASI)+log(EBASI)
365  !! the coded equation below is the commented equation above
366  x = -9.09718_lkind*(tbasi/tem(i)-one) &
367  -3.56654_lkind*log10(tbasi/tem(i)) &
368  +0.876793_lkind*(one-tem(i)/tbasi) + log10(esbasi)
369  es(i) =ten**(x)
370  else
371 
372 !> compute es over water
373 !! values over 100 c may not be valid
374 !! see smithsonian meteorological tables page 350.
375  !> x = -7.90298(TBASW/tem-1) + 5.02808log(TBASW/tem)
376  !! -1.3816d-07*10^[11.344(1-tem/TBASW)-1]
377  !! +8.1328d-03*10^[-3.49149(TBASW/tem-1)-1] + log(ESBASW)
378  !! the coded equation below is the commented equation above
379  x = -7.90298_lkind*(tbasw/tem(i)-one) &
380  +5.02808_lkind*log10(tbasw/tem(i)) &
381  -1.3816e-07_lkind*(ten**((one-tem(i)/tbasw)*11.344_lkind)-one) &
382  +8.1328e-03_lkind*(ten**((tbasw/tem(i)-one)*(-3.49149_lkind))-one) &
383  +log10(esbasw)
384  es(i) = ten**(x)
385  endif
386  enddo
387 
388  end function compute_es_liq_ice_k_
389 
390 !#######################################################################
391 
392  subroutine compute_qs_k_3d_ (temp, press, eps, zvir, qs, nbad, q, hc, &
393  dqsdT, esat, es_over_liq, es_over_liq_and_ice)
394 
395  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
396  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: press !< pressure
397  real(kind=fms_svp_kind_), intent(in) :: eps !< EPSILO
398  real(kind=fms_svp_kind_), intent(in) :: zvir !< ZVIR
399  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: qs !< specific humidity
400  integer, intent(out) :: nbad !< if temperature is out of range
401  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:), optional :: q !< vapor relative humidity
402  real(kind=fms_svp_kind_), intent(in), optional :: hc !< relative humidity
403  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:), optional :: dqsdt !< d(qs)/dT
404  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:), optional :: esat !< saturation vapor pressure
405  logical,intent(in), optional :: es_over_liq !< use es table wrt liquid only
406  logical,intent(in), optional :: es_over_liq_and_ice
407 
408  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_, either r4_kind or r8_kind
409 
410  real(kind=fms_svp_kind_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: esloc
411  real(kind=fms_svp_kind_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: desat
412  real(kind=fms_svp_kind_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: denom
413  integer :: i, j, k
414  real(kind=fms_svp_kind_) :: hc_loc
415 
416  if (present(hc)) then
417  hc_loc = hc
418  else
419  hc_loc = 1.0_lkind
420  endif
421  if (present(es_over_liq)) then
422  if (present (dqsdt)) then
423  call lookup_es2_des2_k (temp, esloc, desat, nbad)
424  desat = desat*hc_loc
425  else
426  call lookup_es2_k (temp, esloc, nbad)
427  endif
428  else if (present(es_over_liq_and_ice)) then
429  if (present (dqsdt)) then
430  call lookup_es3_des3_k (temp, esloc, desat, nbad)
431  desat = desat*hc_loc
432  else
433  call lookup_es3_k (temp, esloc, nbad)
434  endif
435  else
436  if (present (dqsdt)) then
437  call lookup_es_des_k (temp, esloc, desat, nbad)
438  desat = desat*hc_loc
439  else
440  call lookup_es_k (temp, esloc, nbad)
441  endif
442  endif
443  esloc = esloc*hc_loc
444  if (present (esat)) then
445  esat = esloc
446  endif
447  if (nbad == 0) then
448  if (present (q) .and. use_exact_qs) then
449  qs = (1.0_lkind + zvir*q)*eps*esloc/press
450  if (present (dqsdt)) then
451  dqsdt = (1.0_lkind + zvir*q)*eps*desat/press
452  endif
453  else ! (present(q))
454  denom = press - (1.0_lkind - eps)*esloc
455  do k=1,size(qs,3)
456  do j=1,size(qs,2)
457  do i=1,size(qs,1)
458  if (denom(i,j,k) > 0.0_lkind) then
459  qs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k)
460  else
461  qs(i,j,k) = eps
462  endif
463  end do
464  end do
465  end do
466  if (present (dqsdt)) then
467  dqsdt = eps*press*desat/denom**2
468  endif
469  endif ! (present(q))
470  else ! (nbad = 0)
471  qs = -999.0_lkind
472  if (present (dqsdt)) then
473  dqsdt = -999.0_lkind
474  endif
475  if (present (esat)) then
476  esat = -999.0_lkind
477  endif
478  endif ! (nbad = 0)
479 
480 
481  end subroutine compute_qs_k_3d_
482 
483 !#######################################################################
484 
485  subroutine compute_qs_k_2d_ (temp, press, eps, zvir, qs, nbad, q, hc, &
486  dqsdT, esat, es_over_liq, es_over_liq_and_ice)
487 
488  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
489  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: press !< pressure
490  real(kind=fms_svp_kind_), intent(in) :: eps !< EPSILO
491  real(kind=fms_svp_kind_), intent(in) :: zvir !< ZVIR
492  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: qs !< specific humidity
493  integer, intent(out) :: nbad !< if temperature is out of range
494  real(kind=fms_svp_kind_), intent(in), dimension(:,:), optional :: q !< vapor specific humidty
495  real(kind=fms_svp_kind_), intent(in), optional :: hc !< relative humidity
496  real(kind=fms_svp_kind_), intent(out), dimension(:,:), optional :: dqsdt !< d(qs)/dT
497  real(kind=fms_svp_kind_), intent(out), dimension(:,:), optional :: esat !<saturation vapor pressure
498  logical,intent(in), optional :: es_over_liq
499  logical,intent(in), optional :: es_over_liq_and_ice
500 
501  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
502 
503  real(kind=fms_svp_kind_), dimension(size(temp,1), size(temp,2)) :: esloc
504  real(kind=fms_svp_kind_), dimension(size(temp,1), size(temp,2)) :: desat
505  real(kind=fms_svp_kind_), dimension(size(temp,1), size(temp,2)) :: denom
506  integer :: i, j
507  real(kind=fms_svp_kind_) :: hc_loc
508 
509  if (present(hc)) then
510  hc_loc = hc
511  else
512  hc_loc = 1.0_lkind
513  endif
514 
515  if (present(es_over_liq)) then
516  if (present (dqsdt)) then
517  call lookup_es2_des2_k (temp, esloc, desat, nbad)
518  desat = desat*hc_loc
519  else
520  call lookup_es2_k (temp, esloc, nbad)
521  endif
522  else if (present(es_over_liq_and_ice)) then
523  if (present (dqsdt)) then
524  call lookup_es3_des3_k (temp, esloc, desat, nbad)
525  desat = desat*hc_loc
526  else
527  call lookup_es3_k (temp, esloc, nbad)
528  endif
529  else
530  if (present (dqsdt)) then
531  call lookup_es_des_k (temp, esloc, desat, nbad)
532  desat = desat*hc_loc
533  else
534  call lookup_es_k (temp, esloc, nbad)
535  endif
536  endif
537  esloc = esloc*hc_loc
538  if (present (esat)) then
539  esat = esloc
540  endif
541  if (nbad == 0) then
542  if (present (q) .and. use_exact_qs) then
543  qs = (1.0_lkind + zvir*q)*eps*esloc/press
544  if (present (dqsdt)) then
545  dqsdt = (1.0_lkind + zvir*q)*eps*desat/press
546  endif
547  else ! (present(q))
548  denom = press - (1.0_lkind - eps)*esloc
549  do j=1,size(qs,2)
550  do i=1,size(qs,1)
551  if (denom(i,j) > 0.0_lkind) then
552  qs(i,j) = eps*esloc(i,j)/denom(i,j)
553  else
554  qs(i,j) = eps
555  endif
556  end do
557  end do
558  if (present (dqsdt)) then
559  dqsdt = eps*press*desat/denom**2
560  endif
561  endif ! (present(q))
562  else ! (nbad = 0)
563  qs = -999.0_lkind
564  if (present (dqsdt)) then
565  dqsdt = -999.0_lkind
566  endif
567  if (present (esat)) then
568  esat = -999.0_lkind
569  endif
570  endif ! (nbad = 0)
571 
572 
573  end subroutine compute_qs_k_2d_
574 
575 !#######################################################################
576 
577  subroutine compute_qs_k_1d_ (temp, press, eps, zvir, qs, nbad, q, hc, &
578  dqsdT, esat, es_over_liq, es_over_liq_and_ice)
579 
580  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
581  real(kind=fms_svp_kind_), intent(in), dimension(:) :: press !< pressure
582  real(kind=fms_svp_kind_), intent(in) :: eps !< EPSILO
583  real(kind=fms_svp_kind_), intent(in) :: zvir !< ZVIR
584  real(kind=fms_svp_kind_), intent(out), dimension(:) :: qs !< specific humidity
585  integer, intent(out) :: nbad !< if temperature is out of range
586  real(kind=fms_svp_kind_), intent(in), dimension(:), optional :: q !< vapor specific humidity
587  real(kind=fms_svp_kind_), intent(in), optional :: hc !< relative humidity
588  real(kind=fms_svp_kind_), intent(out), dimension(:), optional :: dqsdt !< d(qs)/dt
589  real(kind=fms_svp_kind_), intent(out), dimension(:), optional :: esat !< saturation vapor pressure
590  logical,intent(in), optional :: es_over_liq
591  logical,intent(in), optional :: es_over_liq_and_ice
592 
593  integer, parameter :: lkind=fms_svp_kind_
594 
595  real(kind=fms_svp_kind_), dimension(size(temp,1)) :: esloc
596  real(kind=fms_svp_kind_), dimension(size(temp,1)) :: desat
597  real(kind=fms_svp_kind_), dimension(size(temp,1)) :: denom
598  integer :: i
599  real(kind=fms_svp_kind_) :: hc_loc
600 
601  if (present(hc)) then
602  hc_loc = hc
603  else
604  hc_loc = 1.0_lkind
605  endif
606 
607  if (present(es_over_liq)) then
608  if (present (dqsdt)) then
609  call lookup_es2_des2_k (temp, esloc, desat, nbad)
610  desat = desat*hc_loc
611  else
612  call lookup_es2_k (temp, esloc, nbad)
613  endif
614  else if (present(es_over_liq_and_ice)) then
615  if (present (dqsdt)) then
616  call lookup_es3_des3_k (temp, esloc, desat, nbad)
617  desat = desat*hc_loc
618  else
619  call lookup_es3_k (temp, esloc, nbad)
620  endif
621  else
622  if (present (dqsdt)) then
623  call lookup_es_des_k (temp, esloc, desat, nbad)
624  desat = desat*hc_loc
625  else
626  call lookup_es_k (temp, esloc, nbad)
627  endif
628  endif
629  esloc = esloc*hc_loc
630  if (present (esat)) then
631  esat = esloc
632  endif
633  if (nbad == 0) then
634  if (present (q) .and. use_exact_qs) then
635  qs = (1.0_lkind + zvir*q)*eps*esloc/press
636  if (present (dqsdt)) then
637  dqsdt = (1.0_lkind + zvir*q)*eps*desat/press
638  endif
639  else ! (present(q))
640  denom = press - (1.0_lkind - eps)*esloc
641  do i=1,size(qs,1)
642  if (denom(i) > 0.0_lkind) then
643  qs(i) = eps*esloc(i)/denom(i)
644  else
645  qs(i) = eps
646  endif
647  end do
648  if (present (dqsdt)) then
649  dqsdt = eps*press*desat/denom**2
650  endif
651  endif ! (present(q))
652  else ! (nbad = 0)
653  qs = -999.0_lkind
654  if (present (dqsdt)) then
655  dqsdt = -999.0_lkind
656  endif
657  if (present (esat)) then
658  esat = -999.0_lkind
659  endif
660  endif ! (nbad = 0)
661 
662 
663  end subroutine compute_qs_k_1d_
664 
665 !#######################################################################
666 
667  subroutine compute_qs_k_0d_ (temp, press, eps, zvir, qs, nbad, q, hc, &
668  dqsdT, esat, es_over_liq, es_over_liq_and_ice)
669 
670  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
671  real(kind=fms_svp_kind_), intent(in) :: press !< pressure
672  real(kind=fms_svp_kind_), intent(in) :: eps !< EPSILO
673  real(kind=fms_svp_kind_), intent(in) :: zvir !< ZVIR
674  real(kind=fms_svp_kind_), intent(out) :: qs !< specific humidity
675  integer, intent(out) :: nbad !< if temperature is out of range
676  real(kind=fms_svp_kind_), intent(in), optional :: q !< vapor specific humidity
677  real(kind=fms_svp_kind_), intent(in), optional :: hc !< relative humidity
678  real(kind=fms_svp_kind_), intent(out), optional :: dqsdt !< d(qs)/dT
679  real(kind=fms_svp_kind_), intent(out), optional :: esat !< saturation vapor pressure
680  logical,intent(in), optional :: es_over_liq
681  logical,intent(in), optional :: es_over_liq_and_ice
682 
683  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
684 
685  real(kind=fms_svp_kind_) :: esloc
686  real(kind=fms_svp_kind_) :: desat
687  real(kind=fms_svp_kind_) :: denom
688  real(kind=fms_svp_kind_) :: hc_loc
689 
690  if (present(hc)) then
691  hc_loc = hc
692  else
693  hc_loc = 1.0_lkind
694  endif
695 
696  if (present(es_over_liq)) then
697  if (present (dqsdt)) then
698  call lookup_es2_des2_k (temp, esloc, desat, nbad)
699  desat = desat*hc_loc
700  else
701  call lookup_es2_k (temp, esloc, nbad)
702  endif
703  else if (present(es_over_liq_and_ice)) then
704  if (present (dqsdt)) then
705  call lookup_es3_des3_k (temp, esloc, desat, nbad)
706  desat = desat*hc_loc
707  else
708  call lookup_es3_k (temp, esloc, nbad)
709  endif
710  else
711  if (present (dqsdt)) then
712  call lookup_es_des_k (temp, esloc, desat, nbad)
713  desat = desat*hc_loc
714  else
715  call lookup_es_k (temp, esloc, nbad)
716  endif
717  endif
718  esloc = esloc*hc_loc
719  if (present (esat)) then
720  esat = esloc
721  endif
722  if (nbad == 0) then
723  if (present (q) .and. use_exact_qs) then
724  qs = (1.0_lkind + zvir*q)*eps*esloc/press
725  if (present (dqsdt)) then
726  dqsdt = (1.0_lkind + zvir*q)*eps*desat/press
727  endif
728  else ! (present(q))
729  denom = press - (1.0_lkind - eps)*esloc
730  if (denom > 0.0_lkind) then
731  qs = eps*esloc/denom
732  else
733  qs = eps
734  endif
735  if (present (dqsdt)) then
736  dqsdt = eps*press*desat/denom**2
737  endif
738  endif ! (present(q))
739  else ! (nbad = 0)
740  qs = -999.0_lkind
741  if (present (dqsdt)) then
742  dqsdt = -999.0_lkind
743  endif
744  if (present (esat)) then
745  esat = -999.0_lkind
746  endif
747  endif ! (nbad = 0)
748 
749 
750  end subroutine compute_qs_k_0d_
751 
752 !#######################################################################
753 
754  subroutine compute_mrs_k_3d_ (temp, press, eps, zvir, mrs, nbad, &
755  mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice)
756 
757  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
758  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: press !< pressure
759  real(kind=fms_svp_kind_), intent(in) :: eps !< EPSILO
760  real(kind=fms_svp_kind_), intent(in) :: zvir !< ZVIR
761  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: mrs !< mixing ratio at relative humidity
762  integer, intent(out) :: nbad !< if temperature is out of range
763  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:), optional :: mr !< vapor mixing ratio
764  real(kind=fms_svp_kind_), intent(in), optional :: hc !< relative humidity
765  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:), optional :: dmrsdt !< d(mrs)/dT
766  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:), optional :: esat !< saturation vapor pressure
767  logical,intent(in), optional :: es_over_liq
768  logical,intent(in), optional :: es_over_liq_and_ice
769 
770  real(FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: esloc
771  real(FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: desat
772  real(FMS_SVP_KIND_), dimension(size(temp,1), size(temp,2), size(temp,3)) :: denom
773 
774  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
775 
776  integer :: i, j, k
777  real(FMS_SVP_KIND_) :: hc_loc
778 
779  if (present(hc)) then
780  hc_loc = hc
781  else
782  hc_loc = 1.0_lkind
783  endif
784 
785  if (present (es_over_liq)) then
786  if (present (dmrsdt)) then
787  call lookup_es2_des2_k (temp, esloc, desat, nbad)
788  desat = desat*hc_loc
789  else
790  call lookup_es2_k (temp, esloc, nbad)
791  endif
792  else if (present(es_over_liq_and_ice)) then
793  if (present (dmrsdt)) then
794  call lookup_es3_des3_k (temp, esloc, desat, nbad)
795  desat = desat*hc_loc
796  else
797  call lookup_es3_k (temp, esloc, nbad)
798  endif
799  else
800  if (present (dmrsdt)) then
801  call lookup_es_des_k (temp, esloc, desat, nbad)
802  desat = desat*hc_loc
803  else
804  call lookup_es_k (temp, esloc, nbad)
805  endif
806  endif
807  esloc = esloc*hc_loc
808  if (present (esat)) then
809  esat = esloc
810  endif
811  if (nbad == 0) then
812  if (present (mr) .and. use_exact_qs) then
813  mrs = (eps + mr)*esloc/press
814  if (present (dmrsdt)) then
815  dmrsdt = (eps + mr)*desat/press
816  endif
817  else ! (present (mr))
818  denom = press - esloc
819  do k=1,size(mrs,3)
820  do j=1,size(mrs,2)
821  do i=1,size(mrs,1)
822  if (denom(i,j,k) > 0.0_lkind) then
823  mrs(i,j,k) = eps*esloc(i,j,k)/denom(i,j,k)
824  else
825  mrs(i,j,k) = eps
826  endif
827  end do
828  end do
829  end do
830  if (present (dmrsdt)) then
831  dmrsdt = eps*press*desat/denom**2
832  endif
833  endif !(present (mr))
834  else
835  mrs = -999.0_lkind
836  if (present (dmrsdt)) then
837  dmrsdt = -999.0_lkind
838  endif
839  if (present (esat)) then
840  esat = -999.0_lkind
841  endif
842  endif
843 
844  end subroutine compute_mrs_k_3d_
845 
846 !#######################################################################
847 
848  subroutine compute_mrs_k_2d_ (temp, press, eps, zvir, mrs, nbad, &
849  mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice)
850 
851  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
852  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: press !< pressure
853  real(kind=fms_svp_kind_), intent(in) :: eps !< EPSILO
854  real(kind=fms_svp_kind_), intent(in) :: zvir !< ZVIR
855  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: mrs !< mixing ratio at relative humidity
856  integer, intent(out) :: nbad !< if temperature is out of range
857  real(kind=fms_svp_kind_), intent(in), dimension(:,:), optional :: mr !< vapor mixing ratio
858  real(kind=fms_svp_kind_), intent(in), optional :: hc !< relative humidity
859  real(kind=fms_svp_kind_), intent(out), dimension(:,:), optional :: dmrsdt !< d(mrs)/dT
860  real(kind=fms_svp_kind_), intent(out), dimension(:,:), optional :: esat !< saturation vapor pressure
861  logical,intent(in), optional :: es_over_liq
862  logical,intent(in), optional :: es_over_liq_and_ice
863 
864  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
865 
866  real(kind=fms_svp_kind_), dimension(size(temp,1), size(temp,2)) :: esloc
867  real(kind=fms_svp_kind_), dimension(size(temp,1), size(temp,2)) :: desat
868  real(kind=fms_svp_kind_), dimension(size(temp,1), size(temp,2)) :: denom
869  integer :: i, j
870  real(kind=fms_svp_kind_) :: hc_loc
871 
872  if (present(hc)) then
873  hc_loc = hc
874  else
875  hc_loc = 1.0_lkind
876  endif
877 
878  if (present (es_over_liq)) then
879  if (present (dmrsdt)) then
880  call lookup_es2_des2_k (temp, esloc, desat, nbad)
881  desat = desat*hc_loc
882  else
883  call lookup_es2_k (temp, esloc, nbad)
884  endif
885  else if (present(es_over_liq_and_ice)) then
886  if (present (dmrsdt)) then
887  call lookup_es3_des3_k (temp, esloc, desat, nbad)
888  desat = desat*hc_loc
889  else
890  call lookup_es3_k (temp, esloc, nbad)
891  endif
892  else
893  if (present (dmrsdt)) then
894  call lookup_es_des_k (temp, esloc, desat, nbad)
895  desat = desat*hc_loc
896  else
897  call lookup_es_k (temp, esloc, nbad)
898  endif
899  endif
900  esloc = esloc*hc_loc
901  if (present (esat)) then
902  esat = esloc
903  endif
904  if (nbad == 0) then
905  if (present (mr) .and. use_exact_qs) then
906  mrs = (eps + mr)*esloc/press
907  if (present (dmrsdt)) then
908  dmrsdt = (eps + mr)*desat/press
909  endif
910  else ! (present (mr))
911  denom = press - esloc
912  do j=1,size(mrs,2)
913  do i=1,size(mrs,1)
914  if (denom(i,j) > 0.0_lkind) then
915  mrs(i,j) = eps*esloc(i,j)/denom(i,j)
916  else
917  mrs(i,j) = eps
918  endif
919  end do
920  end do
921  if (present (dmrsdt)) then
922  dmrsdt = eps*press*desat/denom**2
923  endif
924  endif !(present (mr))
925  else
926  mrs = -999.0_lkind
927  if (present (dmrsdt)) then
928  dmrsdt = -999.0_lkind
929  endif
930  if (present (esat)) then
931  esat = -999.0_lkind
932  endif
933  endif
934 
935 
936  end subroutine compute_mrs_k_2d_
937 
938 !#######################################################################
939 
940  subroutine compute_mrs_k_1d_ (temp, press, eps, zvir, mrs, nbad, &
941  mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice)
942 
943  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
944  real(kind=fms_svp_kind_), intent(in), dimension(:) :: press !< pressure
945  real(kind=fms_svp_kind_), intent(in) :: eps !< EPSILO
946  real(kind=fms_svp_kind_), intent(in) :: zvir !< ZVIR
947  real(kind=fms_svp_kind_), intent(out), dimension(:) :: mrs !< mixing ratio at relative humidity
948  integer, intent(out) :: nbad !< if temperature is out of range
949  real(kind=fms_svp_kind_), intent(in), dimension(:), optional :: mr !< vapor mixing ratio
950  real(kind=fms_svp_kind_), intent(in), optional :: hc !< relative humidity
951  real(kind=fms_svp_kind_), intent(out), dimension(:), optional :: dmrsdt !< d(mrs)/dT
952  real(kind=fms_svp_kind_), intent(out), dimension(:), optional :: esat !< saturation vapor pressure
953  logical,intent(in), optional :: es_over_liq
954  logical,intent(in), optional :: es_over_liq_and_ice
955 
956  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
957 
958  real(kind=fms_svp_kind_), dimension(size(temp,1)) :: esloc
959  real(kind=fms_svp_kind_), dimension(size(temp,1)) :: desat
960  real(kind=fms_svp_kind_), dimension(size(temp,1)) :: denom
961  integer :: i
962  real(kind=fms_svp_kind_) :: hc_loc
963 
964  if (present(hc)) then
965  hc_loc = hc
966  else
967  hc_loc = 1.0_lkind
968  endif
969 
970  if (present (es_over_liq)) then
971  if (present (dmrsdt)) then
972  call lookup_es2_des2_k (temp, esloc, desat, nbad)
973  desat = desat*hc_loc
974  else
975  call lookup_es2_k (temp, esloc, nbad)
976  endif
977  else if (present(es_over_liq_and_ice)) then
978  if (present (dmrsdt)) then
979  call lookup_es3_des3_k (temp, esloc, desat, nbad)
980  desat = desat*hc_loc
981  else
982  call lookup_es3_k (temp, esloc, nbad)
983  endif
984  else
985  if (present (dmrsdt)) then
986  call lookup_es_des_k (temp, esloc, desat, nbad)
987  desat = desat*hc_loc
988  else
989  call lookup_es_k (temp, esloc, nbad)
990  endif
991  endif
992  esloc = esloc*hc_loc
993  if (present (esat)) then
994  esat = esloc
995  endif
996  if (nbad == 0) then
997  if (present (mr) .and. use_exact_qs) then
998  mrs = (eps + mr)*esloc/press
999  if (present (dmrsdt)) then
1000  dmrsdt = (eps + mr)*desat/press
1001  endif
1002  else ! (present (mr))
1003  denom = press - esloc
1004  do i=1,size(mrs,1)
1005  if (denom(i) > 0.0_lkind) then
1006  mrs(i) = eps*esloc(i)/denom(i)
1007  else
1008  mrs(i) = eps
1009  endif
1010  end do
1011  if (present (dmrsdt)) then
1012  dmrsdt = eps*press*desat/denom**2
1013  endif
1014  endif !(present (mr))
1015  else
1016  mrs = -999.0_lkind
1017  if (present (dmrsdt)) then
1018  dmrsdt = -999.0_lkind
1019  endif
1020  if (present (esat)) then
1021  esat = -999.0_lkind
1022  endif
1023  endif
1024 
1025 
1026  end subroutine compute_mrs_k_1d_
1027 
1028 !#######################################################################
1029 
1030  subroutine compute_mrs_k_0d_ (temp, press, eps, zvir, mrs, nbad, &
1031  mr, hc, dmrsdT, esat,es_over_liq, es_over_liq_and_ice)
1032 
1033  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
1034  real(kind=fms_svp_kind_), intent(in) :: press !< pressure
1035  real(kind=fms_svp_kind_), intent(in) :: eps !< EPSILO
1036  real(kind=fms_svp_kind_), intent(in) :: zvir !< ZVIR
1037  real(kind=fms_svp_kind_), intent(out) :: mrs !< mixing ratio at relative humidity
1038  integer, intent(out) :: nbad !< if temperature is out of range
1039  real(kind=fms_svp_kind_), intent(in), optional :: mr !< vapor mixing ratio
1040  real(kind=fms_svp_kind_), intent(in), optional :: hc !< relative humidity
1041  real(kind=fms_svp_kind_), intent(out), optional :: dmrsdt !< d(mrs)/dT
1042  real(kind=fms_svp_kind_), intent(out), optional :: esat !< saturation vapor pressure
1043  logical,intent(in), optional :: es_over_liq
1044  logical,intent(in), optional :: es_over_liq_and_ice
1045 
1046  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1047 
1048  real(kind=fms_svp_kind_) :: esloc
1049  real(kind=fms_svp_kind_) :: desat
1050  real(kind=fms_svp_kind_) :: denom
1051  real(kind=fms_svp_kind_) :: hc_loc
1052 
1053  if (present(hc)) then
1054  hc_loc = hc
1055  else
1056  hc_loc = 1.0_lkind
1057  endif
1058 
1059  if (present (es_over_liq)) then
1060  if (present (dmrsdt)) then
1061  call lookup_es2_des2_k (temp, esloc, desat, nbad)
1062  desat = desat*hc_loc
1063  else
1064  call lookup_es2_k (temp, esloc, nbad)
1065  endif
1066  else if (present(es_over_liq_and_ice)) then
1067  if (present (dmrsdt)) then
1068  call lookup_es3_des3_k (temp, esloc, desat, nbad)
1069  desat = desat*hc_loc
1070  else
1071  call lookup_es3_k (temp, esloc, nbad)
1072  endif
1073  else
1074  if (present (dmrsdt)) then
1075  call lookup_es_des_k (temp, esloc, desat, nbad)
1076  desat = desat*hc_loc
1077  else
1078  call lookup_es_k (temp, esloc, nbad)
1079  endif
1080  endif
1081  esloc = esloc*hc_loc
1082  if (present (esat)) then
1083  esat = esloc
1084  endif
1085  if (nbad == 0) then
1086  if (present (mr) .and. use_exact_qs) then
1087  mrs = (eps + mr)*esloc/press
1088  if (present (dmrsdt)) then
1089  dmrsdt = (eps + mr)*desat/press
1090  endif
1091  else ! (present (mr))
1092  denom = press - esloc
1093  if (denom > 0.0_lkind) then
1094  mrs = eps*esloc/denom
1095  else
1096  mrs = eps
1097  endif
1098  if (present (dmrsdt)) then
1099  dmrsdt = eps*press*desat/denom**2
1100  endif
1101  endif !(present (mr))
1102  else
1103  mrs = -999.0_lkind
1104  if (present (dmrsdt)) then
1105  dmrsdt = -999.0_lkind
1106  endif
1107  if (present (esat)) then
1108  esat = -999.0_lkind
1109  endif
1110  endif
1111 
1112 
1113  end subroutine compute_mrs_k_0d_
1114 
1115 
1116 !#######################################################################
1117 
1118  subroutine lookup_es_des_k_3d_ (temp, esat, desat, nbad)
1119  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
1120  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: esat !<saturation vapor pressure
1121  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: desat !< derivative of saturation vapor pressure
1122  integer, intent(out) :: nbad !< if temperature is out of range
1123 
1124  real(kind=fms_svp_kind_) :: tmp !< temp-TMIN
1125  real(kind=fms_svp_kind_) :: del !< delta T
1126  integer :: ind, i, j, k
1127  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1128  !! for precision consistency and for code readability, the *ll variables are declared
1129  !! and used
1130  real(kind=fms_svp_kind_) :: dtresl
1131  real(kind=fms_svp_kind_) :: tepsll
1132  real(kind=fms_svp_kind_) :: tminll
1133  real(kind=fms_svp_kind_) :: dtinvll
1134  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1135 
1136  dtresl=real(dtres, fms_svp_kind_)
1137  tminll=real(tminl, fms_svp_kind_)
1138  tepsll=real(tepsl, fms_svp_kind_)
1139  dtinvll=real(dtinvl, fms_svp_kind_)
1140 
1141  nbad = 0
1142  do k = 1, size(temp,3)
1143  do j = 1, size(temp,2)
1144  do i = 1, size(temp,1)
1145  tmp = temp(i,j,k)-tminll
1146  ind = int(dtinvll*(tmp+tepsll))
1147  if (ind < 0 .or. ind >= table_siz) then
1148  nbad = nbad+1
1149  else
1150  del = tmp-real(dtresl,fms_svp_kind_)*real(ind,fms_svp_kind_)
1151  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1152  !! the coded equation below is the commented equation above
1153  esat(i,j,k) = real(table(ind+1),fms_svp_kind_) &
1154  + del*( real(dtable(ind+1),fms_svp_kind_) &
1155  + del*real(d2table(ind+1),fms_svp_kind_) )
1156  !> desat = DTABLE + 2del*D2TABLE
1157  !! the coded equation below is the commented equation above
1158  desat(i,j,k) = real(dtable(ind+1), fms_svp_kind_) &
1159  + 2.0_lkind*del*real(d2table(ind+1),fms_svp_kind_)
1160  endif
1161  enddo
1162  enddo
1163  enddo
1164 
1165  end subroutine lookup_es_des_k_3d_
1166 
1167 !#######################################################################
1168 
1169  subroutine lookup_es_des_k_2d_ (temp, esat, desat, nbad)
1170  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
1171  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure
1172  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: desat !< derivative of the saturation vapor pressure
1173  integer, intent(out) :: nbad !< if temperature is out of range
1174  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1175  real(kind=fms_svp_kind_) :: del !< delta T
1176  integer :: ind, i, j
1177  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1178  !! for precision consistency and for code readability, the *ll variables are declared
1179  !! and used
1180  real(kind=fms_svp_kind_) :: dtresl
1181  real(kind=fms_svp_kind_) :: tepsll
1182  real(kind=fms_svp_kind_) :: tminll
1183  real(kind=fms_svp_kind_) :: dtinvll
1184  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1185 
1186  dtresl=real(dtres, fms_svp_kind_)
1187  tminll=real(tminl, fms_svp_kind_)
1188  tepsll=real(tepsl, fms_svp_kind_)
1189  dtinvll=real(dtinvl, fms_svp_kind_)
1190 
1191 
1192  nbad = 0
1193  do j = 1, size(temp,2)
1194  do i = 1, size(temp,1)
1195  tmp = temp(i,j)-tminll
1196  ind = int(dtinvll*(tmp+tepsll))
1197  if (ind < 0 .or. ind >= table_siz) then
1198  nbad = nbad+1
1199  else
1200  del = tmp-dtresl*real(ind,fms_svp_kind_)
1201  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1202  !! the coded equation below is the commented equation above
1203  esat(i,j) = real(table(ind+1),fms_svp_kind_) &
1204  + del*( real(dtable(ind+1),fms_svp_kind_) &
1205  + del*real(d2table(ind+1),fms_svp_kind_) )
1206  !> desat = DTABLE + 2del*D2TABLE
1207  !! the coded equation below is the commented equation above
1208  desat(i,j) = real(dtable(ind+1),fms_svp_kind_) &
1209  + 2.0_lkind*del*real(d2table(ind+1),fms_svp_kind_)
1210  endif
1211  enddo
1212  enddo
1213 
1214  end subroutine lookup_es_des_k_2d_
1215 
1216 !#######################################################################
1217 
1218  subroutine lookup_es_des_k_1d_ (temp, esat, desat, nbad)
1219  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
1220  real(kind=fms_svp_kind_), intent(out), dimension(:) :: esat !< saturation vapor pressure
1221  real(kind=fms_svp_kind_), intent(out), dimension(:) :: desat !< derivative of the saturation vapor pressure
1222  integer, intent(out) :: nbad !< if temperature is out of range
1223 
1224  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1225  real(kind=fms_svp_kind_) :: del !< delta T
1226  integer :: ind, i
1227  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1228  !! for precision consistency and for code readability, the *ll variables are declared
1229  !! and used
1230  real(kind=fms_svp_kind_) :: dtresl
1231  real(kind=fms_svp_kind_) :: tepsll
1232  real(kind=fms_svp_kind_) :: tminll
1233  real(kind=fms_svp_kind_) :: dtinvll
1234  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1235 
1236  dtresl=real(dtres, fms_svp_kind_)
1237  tminll=real(tminl, fms_svp_kind_)
1238  tepsll=real(tepsl, fms_svp_kind_)
1239  dtinvll=real(dtinvl, fms_svp_kind_)
1240 
1241 
1242  nbad = 0
1243  do i = 1, size(temp,1)
1244  tmp = temp(i)-tminll
1245  ind = int(dtinvll*(tmp+tepsll))
1246  if (ind < 0 .or. ind >= table_siz) then
1247  nbad = nbad+1
1248  else
1249  del = tmp-dtresl*real(ind,fms_svp_kind_)
1250  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1251  !! the coded equation below is the commented equation above
1252  esat(i) = real(table(ind+1),fms_svp_kind_) &
1253  + del*( real(dtable(ind+1),fms_svp_kind_) &
1254  + del*real(d2table(ind+1),fms_svp_kind_) )
1255  !> desat = DTABLE + 2del*D2TABLE
1256  !! the coded equation below is the commented equation above
1257  desat(i) = real(dtable(ind+1),fms_svp_kind_) &
1258  + 2.0_lkind*del*real(d2table(ind+1),fms_svp_kind_)
1259  endif
1260  enddo
1261 
1262  end subroutine lookup_es_des_k_1d_
1263 
1264 !#######################################################################
1265 
1266  subroutine lookup_es_des_k_0d_ (temp, esat, desat, nbad)
1267  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
1268  real(kind=fms_svp_kind_), intent(out) :: esat !< saturation vapor pressure
1269  real(kind=fms_svp_kind_), intent(out) :: desat !< derivative of the saturation vapor pressure
1270  integer, intent(out) :: nbad !< if temperature is out of range
1271 
1272  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1273  real(kind=fms_svp_kind_) :: del !< delta T
1274  integer :: ind
1275  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1276  !! for precision consistency and for code readability, the *ll variables are declared
1277  !! and used
1278  real(kind=fms_svp_kind_) :: dtresl
1279  real(kind=fms_svp_kind_) :: tepsll
1280  real(kind=fms_svp_kind_) :: tminll
1281  real(kind=fms_svp_kind_) :: dtinvll
1282  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1283 
1284  dtresl=real(dtres, fms_svp_kind_)
1285  tminll=real(tminl, fms_svp_kind_)
1286  tepsll=real(tepsl, fms_svp_kind_)
1287  dtinvll=real(dtinvl, fms_svp_kind_)
1288 
1289  nbad = 0
1290  tmp = temp-tminll
1291  ind = int(dtinvll*(tmp+tepsll))
1292  if (ind < 0 .or. ind >= table_siz) then
1293  nbad = nbad+1
1294  else
1295  del = tmp-dtresl*real(ind,fms_svp_kind_)
1296  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1297  !! the coded equation below is the commented equation above
1298  esat = real(table(ind+1),fms_svp_kind_) &
1299  + del*( real(dtable(ind+1),fms_svp_kind_) &
1300  + del*real(d2table(ind+1),fms_svp_kind_) )
1301  !> desat = DTABLE + 2del*D2TABLE
1302  !! the coded equation below is the commented equation above
1303  desat = real(dtable(ind+1),fms_svp_kind_) &
1304  + 2.0_lkind*del*real(d2table(ind+1),fms_svp_kind_)
1305  endif
1306 
1307  end subroutine lookup_es_des_k_0d_
1308 
1309 !#######################################################################
1310 
1311  subroutine lookup_es_k_3d_(temp, esat, nbad)
1312  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
1313  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: esat !< saturavation vapor pressure
1314  integer, intent(out) :: nbad !< if temperature is out of range
1315  real(kind=fms_svp_kind_) :: tmp !< temp - TMINLL
1316  real(kind=fms_svp_kind_) :: del !< delta T
1317  integer :: ind, i, j, k
1318  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1319  !! for precision consistency and for code readability, the *ll variables are declared
1320  !! and used
1321  real(kind=fms_svp_kind_) :: dtresl
1322  real(kind=fms_svp_kind_) :: tepsll
1323  real(kind=fms_svp_kind_) :: tminll
1324  real(kind=fms_svp_kind_) :: dtinvll
1325 
1326  dtresl=real(dtres, fms_svp_kind_)
1327  tminll=real(tminl, fms_svp_kind_)
1328  tepsll=real(tepsl, fms_svp_kind_)
1329  dtinvll=real(dtinvl, fms_svp_kind_)
1330 
1331  nbad = 0
1332  do k = 1, size(temp,3)
1333  do j = 1, size(temp,2)
1334  do i = 1, size(temp,1)
1335  tmp = temp(i,j,k)-tminll
1336  ind = int(dtinvll*(tmp+tepsll))
1337  if (ind < 0 .or. ind >= table_siz) then
1338  nbad = nbad+1
1339  else
1340  del = tmp-dtresl*real(ind,fms_svp_kind_)
1341  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1342  !! the coded equation below is the commented equation above
1343  esat(i,j,k) = real(table(ind+1),fms_svp_kind_) &
1344  + del*( real(dtable(ind+1),fms_svp_kind_) &
1345  + del*real(d2table(ind+1),fms_svp_kind_) )
1346  endif
1347  enddo
1348  enddo
1349  enddo
1350 
1351  end subroutine lookup_es_k_3d_
1352 
1353 !#######################################################################
1354 
1355  subroutine lookup_des_k_3d_(temp, desat, nbad)
1356  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
1357  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: desat !< derivative of sat vapor pressure
1358  integer, intent(out) :: nbad !< if temperature is out of range
1359  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1360  real(kind=fms_svp_kind_) :: del !< delta T
1361  integer :: ind, i, j, k
1362  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1363  !! for precision consistency and for code readability, the *ll variables are declared
1364  !! and used
1365  real(kind=fms_svp_kind_) :: dtresl
1366  real(kind=fms_svp_kind_) :: tepsll
1367  real(kind=fms_svp_kind_) :: tminll
1368  real(kind=fms_svp_kind_) :: dtinvll
1369  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1370 
1371  dtresl=real(dtres, fms_svp_kind_)
1372  tminll=real(tminl, fms_svp_kind_)
1373  tepsll=real(tepsl, fms_svp_kind_)
1374  dtinvll=real(dtinvl, fms_svp_kind_)
1375 
1376  nbad = 0
1377  do k = 1, size(temp,3)
1378  do j = 1, size(temp,2)
1379  do i = 1, size(temp,1)
1380  tmp = temp(i,j,k)-tminll
1381  ind = int(dtinvll*(tmp+tepsll))
1382  if (ind < 0 .or. ind >= table_siz) then
1383  nbad = nbad+1
1384  else
1385  del = tmp-dtresl*real(ind,fms_svp_kind_)
1386  !> desat = DTABLE + 2del*D2TABLE
1387  !! the coded equation below is the commented equation above
1388  desat(i,j,k) = real(dtable(ind+1),fms_svp_kind_) &
1389  + 2.0_lkind*del*real(d2table(ind+1),fms_svp_kind_)
1390  endif
1391  enddo
1392  enddo
1393  enddo
1394 
1395  end subroutine lookup_des_k_3d_
1396 
1397 !#######################################################################
1398  subroutine lookup_des_k_2d_(temp, desat, nbad)
1399  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
1400  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure
1401  integer, intent(out) :: nbad !< if temperature is out of range
1402  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1403  real(kind=fms_svp_kind_) :: del !< delta T
1404  integer :: ind, i, j
1405 
1406  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1407  !! for precision consistency and for code readability, the *ll variables are declared
1408  !! and used
1409  real(kind=fms_svp_kind_) :: dtresl
1410  real(kind=fms_svp_kind_) :: tepsll
1411  real(kind=fms_svp_kind_) :: tminll
1412  real(kind=fms_svp_kind_) :: dtinvll
1413  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1414 
1415  dtresl=real(dtres, fms_svp_kind_)
1416  tminll=real(tminl, fms_svp_kind_)
1417  tepsll=real(tepsl, fms_svp_kind_)
1418  dtinvll=real(dtinvl, fms_svp_kind_)
1419 
1420  nbad = 0
1421  do j = 1, size(temp,2)
1422  do i = 1, size(temp,1)
1423  tmp = temp(i,j)-tminll
1424  ind = int(dtinvll*(tmp+tepsll))
1425  if (ind < 0 .or. ind >= table_siz) then
1426  nbad = nbad+1
1427  else
1428  del = tmp-dtresl*real(ind,fms_svp_kind_)
1429  !> desat = DTABLE + 2del*D2TABLE
1430  !! the coded equation below is the commented equation above
1431  desat(i,j) = real(dtable(ind+1),fms_svp_kind_) &
1432  + 2.0_lkind*del*real(d2table(ind+1),fms_svp_kind_)
1433  endif
1434  enddo
1435  enddo
1436 
1437  end subroutine lookup_des_k_2d_
1438 !#######################################################################
1439  subroutine lookup_es_k_2d_(temp, esat, nbad)
1440  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
1441  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure
1442  integer, intent(out) :: nbad !< if temperature is out of range
1443  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1444  real(kind=fms_svp_kind_) :: del !< delta T
1445  integer :: ind, i, j
1446  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1447  !! for precision consistency and for code readability, the *ll variables are declared
1448  !! and used
1449  real(kind=fms_svp_kind_) :: dtresl
1450  real(kind=fms_svp_kind_) :: tepsll
1451  real(kind=fms_svp_kind_) :: tminll
1452  real(kind=fms_svp_kind_) :: dtinvll
1453 
1454  dtresl=real(dtres, fms_svp_kind_)
1455  tminll=real(tminl, fms_svp_kind_)
1456  tepsll=real(tepsl, fms_svp_kind_)
1457  dtinvll=real(dtinvl, fms_svp_kind_)
1458 
1459 
1460  nbad = 0
1461  do j = 1, size(temp,2)
1462  do i = 1, size(temp,1)
1463  tmp = temp(i,j)-tminll
1464  ind = int(dtinvll*(tmp+tepsll))
1465  if (ind < 0 .or. ind >= table_siz) then
1466  nbad = nbad+1
1467  else
1468  del = tmp-dtresl*real(ind,fms_svp_kind_)
1469  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1470  !! the coded equation below is the commented equation above
1471  esat(i,j) = real(table(ind+1),fms_svp_kind_) &
1472  + del*(real(dtable(ind+1),fms_svp_kind_) &
1473  + del*real(d2table(ind+1),fms_svp_kind_) )
1474  endif
1475  enddo
1476  enddo
1477 
1478  end subroutine lookup_es_k_2d_
1479 !#######################################################################
1480  subroutine lookup_des_k_1d_(temp, desat, nbad)
1481  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
1482  real(kind=fms_svp_kind_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure
1483  integer, intent(out) :: nbad !< if temperature is out of range
1484  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1485  real(kind=fms_svp_kind_) :: del !< delta T
1486  integer :: ind, i
1487  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1488  !! for precision consistency and for code readability, the *ll variables are declared
1489  !! and used
1490  real(kind=fms_svp_kind_) :: dtresl
1491  real(kind=fms_svp_kind_) :: tepsll
1492  real(kind=fms_svp_kind_) :: tminll
1493  real(kind=fms_svp_kind_) :: dtinvll
1494  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1495 
1496  dtresl=real(dtres, fms_svp_kind_)
1497  tminll=real(tminl, fms_svp_kind_)
1498  tepsll=real(tepsl, fms_svp_kind_)
1499  dtinvll=real(dtinvl, fms_svp_kind_)
1500 
1501  nbad = 0
1502  do i = 1, size(temp,1)
1503  tmp = temp(i)-tminll
1504  ind = int(dtinvll*(tmp+tepsll))
1505  if (ind < 0 .or. ind >= table_siz) then
1506  nbad = nbad+1
1507  else
1508  del = tmp-dtresl*real(ind,fms_svp_kind_)
1509  !> desat = DTABLE + 2del*D2TABLE
1510  !! the coded equation below is the commented equation above
1511  desat(i) = real(dtable(ind+1),fms_svp_kind_) &
1512  + 2.0_lkind*del*real(d2table(ind+1),fms_svp_kind_)
1513  endif
1514  enddo
1515 
1516  end subroutine lookup_des_k_1d_
1517 !#######################################################################
1518  subroutine lookup_es_k_1d_(temp, esat, nbad)
1519  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
1520  real(kind=fms_svp_kind_), intent(out), dimension(:) :: esat !< saturation vapor pressure
1521  integer, intent(out) :: nbad !< if temperature is out of range
1522  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1523  real(kind=fms_svp_kind_) :: del !< delta T
1524  integer :: ind, i
1525  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1526  !! for precision consistency and for code readability, the *ll variables are declared
1527  !! and used
1528  real(kind=fms_svp_kind_) :: dtresl
1529  real(kind=fms_svp_kind_) :: tepsll
1530  real(kind=fms_svp_kind_) :: tminll
1531  real(kind=fms_svp_kind_) :: dtinvll
1532 
1533  dtresl=real(dtres, fms_svp_kind_)
1534  tminll=real(tminl, fms_svp_kind_)
1535  tepsll=real(tepsl, fms_svp_kind_)
1536  dtinvll=real(dtinvl, fms_svp_kind_)
1537 
1538  nbad = 0
1539  do i = 1, size(temp,1)
1540  tmp = temp(i)-tminll
1541  ind = int(dtinvll*(tmp+tepsll))
1542  if (ind < 0 .or. ind >= table_siz) then
1543  nbad = nbad+1
1544  else
1545  del = tmp-dtresl*real(ind,fms_svp_kind_)
1546  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1547  !! the coded equation below is the commented equation above
1548  esat(i) = real(table(ind+1),fms_svp_kind_) &
1549  + del*(real(dtable(ind+1),fms_svp_kind_) &
1550  + del*real(d2table(ind+1),fms_svp_kind_) )
1551  endif
1552  enddo
1553 
1554  end subroutine lookup_es_k_1d_
1555 !#######################################################################
1556  subroutine lookup_des_k_0d_(temp, desat, nbad)
1557  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
1558  real(kind=fms_svp_kind_), intent(out) :: desat !< derivative of sat vapor pressure
1559  integer, intent(out) :: nbad !< if temperature is out of range
1560  real(kind=fms_svp_kind_) :: tmp !< temp - TMINLL
1561  real(kind=fms_svp_kind_) :: del !< delta T
1562  integer :: ind
1563  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1564  !! for precision consistency and for code readability, the *ll variables are declared
1565  !! and used
1566  real(kind=fms_svp_kind_) :: dtresl
1567  real(kind=fms_svp_kind_) :: tepsll
1568  real(kind=fms_svp_kind_) :: tminll
1569  real(kind=fms_svp_kind_) :: dtinvll
1570  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1571 
1572  dtresl=real(dtres, fms_svp_kind_)
1573  tminll=real(tminl, fms_svp_kind_)
1574  tepsll=real(tepsl, fms_svp_kind_)
1575  dtinvll=real(dtinvl, fms_svp_kind_)
1576 
1577  nbad = 0
1578  tmp = temp-tminll
1579  ind = int(dtinvll*(tmp+tepsll))
1580  if (ind < 0 .or. ind >= table_siz) then
1581  nbad = nbad+1
1582  else
1583  del = tmp-dtresl*real(ind,fms_svp_kind_)
1584  !> desat = DTABLE + 2del*D2TABLE
1585  !! the coded equation below is the commented equation above
1586  desat = real(dtable(ind+1),fms_svp_kind_) &
1587  + 2.0_lkind*del*real(d2table(ind+1),fms_svp_kind_)
1588  endif
1589 
1590  end subroutine lookup_des_k_0d_
1591 !#######################################################################
1592  subroutine lookup_es_k_0d_(temp, esat, nbad)
1593  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
1594  real(kind=fms_svp_kind_), intent(out) :: esat !< saturation vapor pressure
1595  integer, intent(out) :: nbad !< if temperature is out of range
1596  real(kind=fms_svp_kind_) :: tmp !< temp - TMINLL
1597  real(kind=fms_svp_kind_) :: del !< delta T
1598  integer :: ind
1599  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1600  !! for precision consistency and for code readability, the *ll variables are declared
1601  !! and used
1602  real(kind=fms_svp_kind_) :: dtresl
1603  real(kind=fms_svp_kind_) :: tepsll
1604  real(kind=fms_svp_kind_) :: tminll
1605  real(kind=fms_svp_kind_) :: dtinvll
1606 
1607  dtresl=real(dtres, fms_svp_kind_)
1608  tminll=real(tminl, fms_svp_kind_)
1609  tepsll=real(tepsl, fms_svp_kind_)
1610  dtinvll=real(dtinvl, fms_svp_kind_)
1611 
1612  nbad = 0
1613  tmp = temp-tminll
1614  ind = int(dtinvll*(tmp+tepsll))
1615  if (ind < 0 .or. ind >= table_siz) then
1616  nbad = nbad+1
1617  else
1618  del = tmp-dtresl*real(ind,fms_svp_kind_)
1619  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1620  !! the coded equation below is the commented equation above
1621  esat = real(table(ind+1),fms_svp_kind_) &
1622  + del*( real(dtable(ind+1),fms_svp_kind_) &
1623  + del*real(d2table(ind+1),fms_svp_kind_) )
1624  endif
1625 
1626  end subroutine lookup_es_k_0d_
1627 !#######################################################################
1628 
1629  subroutine lookup_es2_des2_k_3d_ (temp, esat, desat, nbad)
1630  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
1631  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure
1632  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: desat !< derivative of sat vapor pressure
1633  integer, intent(out) :: nbad !< if temperature is out of range
1634 
1635  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1636  real(kind=fms_svp_kind_) :: del !< delta T
1637  integer :: ind, i, j, k
1638  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1639  !! for precision consistency and for code readability, the *ll variables are declared
1640  !! and used
1641  real(kind=fms_svp_kind_) :: dtresl
1642  real(kind=fms_svp_kind_) :: tepsll
1643  real(kind=fms_svp_kind_) :: tminll
1644  real(kind=fms_svp_kind_) :: dtinvll
1645  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1646 
1647  dtresl=real(dtres, fms_svp_kind_)
1648  tminll=real(tminl, fms_svp_kind_)
1649  tepsll=real(tepsl, fms_svp_kind_)
1650  dtinvll=real(dtinvl, fms_svp_kind_)
1651 
1652  nbad = 0
1653  do k = 1, size(temp,3)
1654  do j = 1, size(temp,2)
1655  do i = 1, size(temp,1)
1656  tmp = temp(i,j,k)-tminll
1657  ind = int(dtinvll*(tmp+tepsll))
1658  if (ind < 0 .or. ind >= table_siz) then
1659  nbad = nbad+1
1660  else
1661  del = tmp-dtresl*real(ind,fms_svp_kind_)
1662  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1663  !! the coded equation below is the commented equation above
1664  esat(i,j,k) = real(table2(ind+1),fms_svp_kind_) &
1665  + del*( real(dtable2(ind+1),fms_svp_kind_) &
1666  + del*real(d2table2(ind+1),fms_svp_kind_) )
1667  !> desat = DTABLE + 2del*D2TABLE
1668  !! the coded equation below is the commented equation above
1669  desat(i,j,k) = real(dtable2(ind+1),fms_svp_kind_) &
1670  + 2.0_lkind*del*real(d2table2(ind+1),fms_svp_kind_)
1671  endif
1672  enddo
1673  enddo
1674  enddo
1675 
1676  end subroutine lookup_es2_des2_k_3d_
1677 
1678 !#######################################################################
1679 
1680  subroutine lookup_es2_des2_k_2d_ (temp, esat, desat, nbad)
1681  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
1682  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure
1683  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure
1684  integer, intent(out) :: nbad !< if temperature is out of range
1685 
1686  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1687  real(kind=fms_svp_kind_) :: del !< delta T
1688  integer :: ind, i, j
1689  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1690  !! for precision consistency and for code readability, the *ll variables are declared
1691  !! and used
1692  real(kind=fms_svp_kind_) :: dtresl
1693  real(kind=fms_svp_kind_) :: tepsll
1694  real(kind=fms_svp_kind_) :: tminll
1695  real(kind=fms_svp_kind_) :: dtinvll
1696  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1697 
1698  dtresl=real(dtres, fms_svp_kind_)
1699  tminll=real(tminl, fms_svp_kind_)
1700  tepsll=real(tepsl, fms_svp_kind_)
1701  dtinvll=real(dtinvl, fms_svp_kind_)
1702 
1703  nbad = 0
1704  do j = 1, size(temp,2)
1705  do i = 1, size(temp,1)
1706  tmp = temp(i,j)-tminll
1707  ind = int(dtinvll*(tmp+tepsll))
1708  if (ind < 0 .or. ind >= table_siz) then
1709  nbad = nbad+1
1710  else
1711  del = tmp-dtresl*real(ind,fms_svp_kind_)
1712  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1713  !! the coded equation below is the commented equation above
1714  esat(i,j) = real(table2(ind+1),fms_svp_kind_) &
1715  + del*( real(dtable2(ind+1),fms_svp_kind_) &
1716  + del*real(d2table2(ind+1),fms_svp_kind_) )
1717  !> desat = DTABLE + 2del*D2TABLE
1718  !! the coded equation below is the commented equation above
1719  desat(i,j) = real(dtable2(ind+1),fms_svp_kind_) &
1720  + 2.0_lkind*del*real(d2table2(ind+1),fms_svp_kind_)
1721  endif
1722  enddo
1723  enddo
1724 
1725  end subroutine lookup_es2_des2_k_2d_
1726 
1727 !#######################################################################
1728 
1729  subroutine lookup_es2_des2_k_1d_ (temp, esat, desat, nbad)
1730  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
1731  real(kind=fms_svp_kind_), intent(out), dimension(:) :: esat !< saturation vapor pressure
1732  real(kind=fms_svp_kind_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure
1733  integer, intent(out) :: nbad !< if temperature is out of range
1734 
1735  real(kind=fms_svp_kind_) :: tmp !< temp - TMINLL
1736  real(kind=fms_svp_kind_) :: del !< delta T
1737  integer :: ind, i
1738  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1739  !! for precision consistency and for code readability, the *ll variables are declared
1740  !! and used
1741  real(kind=fms_svp_kind_) :: dtresl
1742  real(kind=fms_svp_kind_) :: tepsll
1743  real(kind=fms_svp_kind_) :: tminll
1744  real(kind=fms_svp_kind_) :: dtinvll
1745  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1746 
1747  dtresl=real(dtres, fms_svp_kind_)
1748  tminll=real(tminl, fms_svp_kind_)
1749  tepsll=real(tepsl, fms_svp_kind_)
1750  dtinvll=real(dtinvl, fms_svp_kind_)
1751 
1752  nbad = 0
1753  do i = 1, size(temp,1)
1754  tmp = temp(i)-tminll
1755  ind = int(dtinvll*(tmp+tepsll))
1756  if (ind < 0 .or. ind >= table_siz) then
1757  nbad = nbad+1
1758  else
1759  del = tmp-dtresl*real(ind,fms_svp_kind_)
1760  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1761  !! the coded equation below is the commented equation above
1762  esat(i) = real(table2(ind+1),fms_svp_kind_) &
1763  + del*( real(dtable2(ind+1),fms_svp_kind_) &
1764  + del*real(d2table2(ind+1),fms_svp_kind_) )
1765  !> desat = DTABLE + 2del*D2TABLE
1766  desat(i) = real(dtable2(ind+1),fms_svp_kind_) &
1767  + 2.0_lkind*del*real(d2table2(ind+1),fms_svp_kind_)
1768  endif
1769  enddo
1770 
1771  end subroutine lookup_es2_des2_k_1d_
1772 
1773 !#######################################################################
1774 
1775  subroutine lookup_es2_des2_k_0d_ (temp, esat, desat, nbad)
1776  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
1777  real(kind=fms_svp_kind_), intent(out) :: esat !< saturation vapor pressure
1778  real(kind=fms_svp_kind_), intent(out) :: desat !< derivative of sat vapor pressure
1779  integer, intent(out) :: nbad !< if temperature is out of range
1780 
1781  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1782  real(kind=fms_svp_kind_) :: del !< delta T
1783  integer :: ind
1784  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1785  !! for precision consistency and for code readability, the *ll variables are declared
1786  !! and used
1787  real(kind=fms_svp_kind_) :: dtresl
1788  real(kind=fms_svp_kind_) :: tepsll
1789  real(kind=fms_svp_kind_) :: tminll
1790  real(kind=fms_svp_kind_) :: dtinvll
1791  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1792 
1793  dtresl=real(dtres, fms_svp_kind_)
1794  tminll=real(tminl, fms_svp_kind_)
1795  tepsll=real(tepsl, fms_svp_kind_)
1796  dtinvll=real(dtinvl, fms_svp_kind_)
1797 
1798 
1799  nbad = 0
1800  tmp = temp-tminll
1801  ind = int(dtinvll*(tmp+tepsll))
1802  if (ind < 0 .or. ind >= table_siz) then
1803  nbad = nbad+1
1804  else
1805  del = tmp-dtresl*real(ind,fms_svp_kind_)
1806  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1807  !! the coded equation below is the commented equation above
1808  esat = real(table2(ind+1),fms_svp_kind_) &
1809  + del*( real(dtable2(ind+1),fms_svp_kind_) &
1810  + del*real(d2table2(ind+1),fms_svp_kind_) )
1811  !> desat = DTABLE + 2del*D2TABLE
1812  !! the coded equation below is the commented equation above
1813  desat = real(dtable2(ind+1),fms_svp_kind_) &
1814  + 2.0_lkind*del*real(d2table2(ind+1),fms_svp_kind_)
1815  endif
1816 
1817  end subroutine lookup_es2_des2_k_0d_
1818 
1819 !#######################################################################
1820 
1821  subroutine lookup_es2_k_3d_(temp, esat, nbad)
1822  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
1823  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure
1824  integer, intent(out) :: nbad !< if temperature is out of range
1825  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1826  real(kind=fms_svp_kind_) :: del !< delta T
1827  integer :: ind, i, j, k
1828  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1829  !! for precision consistency and for code readability, the *ll variables are declared
1830  !! and used
1831  real(kind=fms_svp_kind_) :: dtresl
1832  real(kind=fms_svp_kind_) :: tepsll
1833  real(kind=fms_svp_kind_) :: tminll
1834  real(kind=fms_svp_kind_) :: dtinvll
1835 
1836  dtresl=real(dtres, fms_svp_kind_)
1837  tminll=real(tminl, fms_svp_kind_)
1838  tepsll=real(tepsl, fms_svp_kind_)
1839  dtinvll=real(dtinvl, fms_svp_kind_)
1840 
1841  nbad = 0
1842  do k = 1, size(temp,3)
1843  do j = 1, size(temp,2)
1844  do i = 1, size(temp,1)
1845  tmp = temp(i,j,k)-tminll
1846  ind = int(dtinvll*(tmp+tepsll))
1847  if (ind < 0 .or. ind >= table_siz) then
1848  nbad = nbad+1
1849  else
1850  del = tmp-dtresl*real(ind,fms_svp_kind_)
1851  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1852  !! the coded equation below is the commented equation above
1853  esat(i,j,k) = real(table2(ind+1),fms_svp_kind_) &
1854  + del*( real(dtable2(ind+1),fms_svp_kind_) &
1855  + del*real(d2table2(ind+1),fms_svp_kind_) )
1856  endif
1857  enddo
1858  enddo
1859  enddo
1860 
1861  end subroutine lookup_es2_k_3d_
1862 
1863 !#######################################################################
1864 
1865  subroutine lookup_des2_k_3d_(temp, desat, nbad)
1866  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
1867  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: desat !< derivative of sat vapor pressure
1868  integer, intent(out) :: nbad !< if temperature is out of range
1869  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1870  real(kind=fms_svp_kind_) :: del !< delta T
1871  integer :: ind, i, j, k
1872  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1873  !! for precision consistency and for code readability, the *ll variables are declared
1874  !! and used
1875  real(kind=fms_svp_kind_) :: dtresl
1876  real(kind=fms_svp_kind_) :: tepsll
1877  real(kind=fms_svp_kind_) :: tminll
1878  real(kind=fms_svp_kind_) :: dtinvll
1879  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1880 
1881  dtresl=real(dtres, fms_svp_kind_)
1882  tminll=real(tminl, fms_svp_kind_)
1883  tepsll=real(tepsl, fms_svp_kind_)
1884  dtinvll=real(dtinvl, fms_svp_kind_)
1885 
1886  nbad = 0
1887  do k = 1, size(temp,3)
1888  do j = 1, size(temp,2)
1889  do i = 1, size(temp,1)
1890  tmp = temp(i,j,k)-tminll
1891  ind = int(dtinvll*(tmp+tepsll))
1892  if (ind < 0 .or. ind >= table_siz) then
1893  nbad = nbad+1
1894  else
1895  del = tmp-dtresl*real(ind,fms_svp_kind_)
1896  !> desat = DTABLE + 2del*D2TABLE
1897  !! the coded equation below is the commented equation above
1898  desat(i,j,k) = real(dtable2(ind+1),fms_svp_kind_) &
1899  + 2.0_lkind*del*real(d2table2(ind+1),fms_svp_kind_)
1900  endif
1901  enddo
1902  enddo
1903  enddo
1904 
1905  end subroutine lookup_des2_k_3d_
1906 
1907 !#######################################################################
1908  subroutine lookup_des2_k_2d_(temp, desat, nbad)
1909  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
1910  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure
1911  integer, intent(out) :: nbad !< if temperature is out of range
1912  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1913  real(kind=fms_svp_kind_) :: del !< delta T
1914  integer :: ind, i, j
1915  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1916  !! for precision consistency and for code readability, the *ll variables are declared
1917  !! and used
1918  real(kind=fms_svp_kind_) :: dtresl
1919  real(kind=fms_svp_kind_) :: tepsll
1920  real(kind=fms_svp_kind_) :: tminll
1921  real(kind=fms_svp_kind_) :: dtinvll
1922  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
1923 
1924  dtresl=real(dtres, fms_svp_kind_)
1925  tminll=real(tminl, fms_svp_kind_)
1926  tepsll=real(tepsl, fms_svp_kind_)
1927  dtinvll=real(dtinvl, fms_svp_kind_)
1928 
1929  nbad = 0
1930  do j = 1, size(temp,2)
1931  do i = 1, size(temp,1)
1932  tmp = temp(i,j)-tminll
1933  ind = int(dtinvll*(tmp+tepsll))
1934  if (ind < 0 .or. ind >= table_siz) then
1935  nbad = nbad+1
1936  else
1937  del = tmp-dtresl*real(ind,fms_svp_kind_)
1938  !> desat = DTABLE + 2del*D2TABLE
1939  !! the coded equation below is the commented equation above
1940  desat(i,j) = real(dtable2(ind+1),fms_svp_kind_) &
1941  + 2.0_lkind*del*real(d2table2(ind+1),fms_svp_kind_)
1942  endif
1943  enddo
1944  enddo
1945 
1946  end subroutine lookup_des2_k_2d_
1947 !#######################################################################
1948  subroutine lookup_es2_k_2d_(temp, esat, nbad)
1949  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
1950  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure
1951  integer, intent(out) :: nbad !< if temperature is out of range
1952  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1953  real(kind=fms_svp_kind_) :: del !< delta T
1954  integer :: ind, i, j
1955  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1956  !! for precision consistency and for code readability, the *ll variables are declared
1957  !! and used
1958  real(kind=fms_svp_kind_) :: dtresl
1959  real(kind=fms_svp_kind_) :: tepsll
1960  real(kind=fms_svp_kind_) :: tminll
1961  real(kind=fms_svp_kind_) :: dtinvll
1962 
1963  dtresl=real(dtres, fms_svp_kind_)
1964  tminll=real(tminl, fms_svp_kind_)
1965  tepsll=real(tepsl, fms_svp_kind_)
1966  dtinvll=real(dtinvl, fms_svp_kind_)
1967 
1968  nbad = 0
1969  do j = 1, size(temp,2)
1970  do i = 1, size(temp,1)
1971  tmp = temp(i,j)-tminll
1972  ind = int(dtinvll*(tmp+tepsll))
1973  if (ind < 0 .or. ind >= table_siz) then
1974  nbad = nbad+1
1975  else
1976  del = tmp-dtresl*real(ind,kind=fms_svp_kind_)
1977  !> esat = TABLE + del*(TABLE + del*D2TABLE)
1978  !! the coded equation below is the commented equation above
1979  esat(i,j) = real(table2(ind+1),fms_svp_kind_) &
1980  + del*( real(dtable2(ind+1),fms_svp_kind_) &
1981  + del*real(d2table2(ind+1),fms_svp_kind_) )
1982  endif
1983  enddo
1984  enddo
1985 
1986  end subroutine lookup_es2_k_2d_
1987 !#######################################################################
1988  subroutine lookup_des2_k_1d_(temp, desat, nbad)
1989  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
1990  real(kind=fms_svp_kind_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure
1991  integer, intent(out) :: nbad !< if temperature is out of range
1992  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
1993  real(kind=fms_svp_kind_) :: del !< delta T
1994  integer :: ind, i
1995  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
1996  !! for precision consistency and for code readability, the *ll variables are declared
1997  !! and used
1998  real(kind=fms_svp_kind_) :: dtresl
1999  real(kind=fms_svp_kind_) :: tepsll
2000  real(kind=fms_svp_kind_) :: tminll
2001  real(kind=fms_svp_kind_) :: dtinvll
2002  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2003 
2004  dtresl=real(dtres, fms_svp_kind_)
2005  tminll=real(tminl, fms_svp_kind_)
2006  tepsll=real(tepsl, fms_svp_kind_)
2007  dtinvll=real(dtinvl, fms_svp_kind_)
2008 
2009  nbad = 0
2010  do i = 1, size(temp,1)
2011  tmp = temp(i)-tminll
2012  ind = int(dtinvll*(tmp+tepsll))
2013  if (ind < 0 .or. ind >= table_siz) then
2014  nbad = nbad+1
2015  else
2016  del = tmp-dtresl*real(ind,fms_svp_kind_)
2017  !> desat = DTABLE + 2del*D2TABLE
2018  !! the coded equation below is the commented equation above
2019  desat(i) = real(dtable2(ind+1),fms_svp_kind_) &
2020  + 2.0_lkind*del*real(d2table2(ind+1),fms_svp_kind_)
2021  endif
2022  enddo
2023 
2024  end subroutine lookup_des2_k_1d_
2025 !#######################################################################
2026  subroutine lookup_es2_k_1d_(temp, esat, nbad)
2027  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
2028  real(kind=fms_svp_kind_), intent(out), dimension(:) :: esat !< saturation vapor pressure
2029  integer, intent(out) :: nbad !< if temperature is out of range
2030  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2031  real(kind=fms_svp_kind_) :: del !< delta T
2032  integer :: ind, i
2033  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2034  !! for precision consistency and for code readability, the *ll variables are declared
2035  !! and used
2036  real(kind=fms_svp_kind_) :: dtresl
2037  real(kind=fms_svp_kind_) :: tepsll
2038  real(kind=fms_svp_kind_) :: tminll
2039  real(kind=fms_svp_kind_) :: dtinvll
2040 
2041  dtresl=real(dtres, fms_svp_kind_)
2042  tminll=real(tminl, fms_svp_kind_)
2043  tepsll=real(tepsl, fms_svp_kind_)
2044  dtinvll=real(dtinvl, fms_svp_kind_)
2045 
2046  nbad = 0
2047  do i = 1, size(temp,1)
2048  tmp = temp(i)-tminll
2049  ind = int(dtinvll*(tmp+tepsll))
2050  if (ind < 0 .or. ind >= table_siz) then
2051  nbad = nbad+1
2052  else
2053  del = tmp-dtresl*real(ind,fms_svp_kind_)
2054  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2055  !! the coded equation below is the commented equation above
2056  esat(i) = real(table2(ind+1),fms_svp_kind_) &
2057  + del*( real(dtable2(ind+1),fms_svp_kind_) &
2058  + del*real(d2table2(ind+1),fms_svp_kind_) )
2059  endif
2060  enddo
2061 
2062  end subroutine lookup_es2_k_1d_
2063 !#######################################################################
2064  subroutine lookup_des2_k_0d_(temp, desat, nbad)
2065  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
2066  real(kind=fms_svp_kind_), intent(out) :: desat !< derivative of sat vapor pressure
2067  integer, intent(out) :: nbad !< if temperature is out of range
2068  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2069  real(kind=fms_svp_kind_) :: del !< delta T
2070  integer :: ind
2071  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2072  !! for precision consistency and for code readability, the *ll variables are declared
2073  !! and used
2074  real(kind=fms_svp_kind_) :: dtresl
2075  real(kind=fms_svp_kind_) :: tepsll
2076  real(kind=fms_svp_kind_) :: tminll
2077  real(kind=fms_svp_kind_) :: dtinvll
2078  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2079 
2080  dtresl=real(dtres, fms_svp_kind_)
2081  tminll=real(tminl, fms_svp_kind_)
2082  tepsll=real(tepsl, fms_svp_kind_)
2083  dtinvll=real(dtinvl, fms_svp_kind_)
2084 
2085  nbad = 0
2086  tmp = temp-tminll
2087  ind = int(dtinvll*(tmp+tepsll))
2088  if (ind < 0 .or. ind >= table_siz) then
2089  nbad = nbad+1
2090  else
2091  del = tmp-dtresl*real(ind,fms_svp_kind_)
2092  !> desat = DTABLE + 2del*D2TABLE
2093  !! the coded equation below is the commented equation above
2094  desat = real(dtable2(ind+1),fms_svp_kind_) &
2095  + 2.0_lkind*del*real(d2table2(ind+1),fms_svp_kind_)
2096  endif
2097 
2098  end subroutine lookup_des2_k_0d_
2099 !#######################################################################
2100  subroutine lookup_es2_k_0d_(temp, esat, nbad)
2101  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
2102  real(kind=fms_svp_kind_), intent(out) :: esat !< saturation vapor pressure
2103  integer, intent(out) :: nbad !< if temperature is out of range
2104  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2105  real(kind=fms_svp_kind_) :: del !< delta T
2106  integer :: ind
2107  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2108  !! for precision consistency and for code readability, the *ll variables are declared
2109  !! and used
2110  real(kind=fms_svp_kind_) :: dtresl
2111  real(kind=fms_svp_kind_) :: tepsll
2112  real(kind=fms_svp_kind_) :: tminll
2113  real(kind=fms_svp_kind_) :: dtinvll
2114 
2115  dtresl=real(dtres, fms_svp_kind_)
2116  tminll=real(tminl, fms_svp_kind_)
2117  tepsll=real(tepsl, fms_svp_kind_)
2118  dtinvll=real(dtinvl, fms_svp_kind_)
2119 
2120  nbad = 0
2121  tmp = temp-tminll
2122  ind = int(dtinvll*(tmp+tepsll))
2123  if (ind < 0 .or. ind >= table_siz) then
2124  nbad = nbad+1
2125  else
2126  del = tmp-dtresl*real(ind,fms_svp_kind_)
2127  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2128  !! the coded equation below is the commented equation above
2129  esat = real(table2(ind+1),fms_svp_kind_) &
2130  + del*( real(dtable2(ind+1),fms_svp_kind_) &
2131  + del*real(d2table2(ind+1),fms_svp_kind_) )
2132  endif
2133 
2134  end subroutine lookup_es2_k_0d_
2135 !#######################################################################
2136 
2137 !#######################################################################
2138 
2139  subroutine lookup_es3_des3_k_3d_ (temp, esat, desat, nbad)
2140  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
2141  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure
2142  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: desat !< derivative of esat
2143  integer, intent(out) :: nbad !< if temperature is out of range
2144 
2145  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2146  real(kind=fms_svp_kind_) :: del !< delta T
2147  integer :: ind, i, j, k
2148  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2149  !! for precision consistency and for code readability, the *ll variables are declared
2150  !! and used
2151  real(kind=fms_svp_kind_) :: dtresl
2152  real(kind=fms_svp_kind_) :: tepsll
2153  real(kind=fms_svp_kind_) :: tminll
2154  real(kind=fms_svp_kind_) :: dtinvll
2155  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2156 
2157  dtresl=real(dtres, fms_svp_kind_)
2158  tminll=real(tminl, fms_svp_kind_)
2159  tepsll=real(tepsl, fms_svp_kind_)
2160  dtinvll=real(dtinvl, fms_svp_kind_)
2161 
2162  nbad = 0
2163  do k = 1, size(temp,3)
2164  do j = 1, size(temp,2)
2165  do i = 1, size(temp,1)
2166  tmp = temp(i,j,k)-tminll
2167  ind = int(dtinvll*(tmp+tepsll))
2168  if (ind < 0 .or. ind >= table_siz) then
2169  nbad = nbad+1
2170  else
2171  del = tmp-dtresl*real(ind,fms_svp_kind_)
2172  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2173  !! the coded equation below is the commented equation above
2174  esat(i,j,k) = real(table3(ind+1),fms_svp_kind_) &
2175  + del*( real(dtable3(ind+1),fms_svp_kind_) &
2176  + del*real(d2table3(ind+1),fms_svp_kind_) )
2177  !> desat = DTABLE + 2del*D2TABLE
2178  !! the coded equation below is the commented equation above
2179  desat(i,j,k) = real(dtable3(ind+1),fms_svp_kind_) &
2180  + 2.0_lkind*del*real(d2table3(ind+1),fms_svp_kind_)
2181  endif
2182  enddo
2183  enddo
2184  enddo
2185 
2186  end subroutine lookup_es3_des3_k_3d_
2187 
2188 !#######################################################################
2189 
2190  subroutine lookup_es3_des3_k_2d_ (temp, esat, desat, nbad)
2191  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
2192  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure
2193  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: desat !< derivative of desat
2194  integer, intent(out) :: nbad !< if temperature is out of range
2195 
2196  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2197  real(kind=fms_svp_kind_) :: del !< delta T
2198  integer :: ind, i, j
2199  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2200  !! for precision consistency and for code readability, the *ll variables are declared
2201  !! and used
2202  real(kind=fms_svp_kind_) :: dtresl
2203  real(kind=fms_svp_kind_) :: tepsll
2204  real(kind=fms_svp_kind_) :: tminll
2205  real(kind=fms_svp_kind_) :: dtinvll
2206  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2207 
2208  dtresl=real(dtres, fms_svp_kind_)
2209  tminll=real(tminl, fms_svp_kind_)
2210  tepsll=real(tepsl, fms_svp_kind_)
2211  dtinvll=real(dtinvl, fms_svp_kind_)
2212 
2213  nbad = 0
2214  do j = 1, size(temp,2)
2215  do i = 1, size(temp,1)
2216  tmp = temp(i,j)-tminll
2217  ind = int(dtinvll*(tmp+tepsll))
2218  if (ind < 0 .or. ind >= table_siz) then
2219  nbad = nbad+1
2220  else
2221  del = tmp-dtresl*real(ind,fms_svp_kind_)
2222  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2223  !! the coded equation below is the commented equation above
2224  esat(i,j) = real(table3(ind+1),fms_svp_kind_) &
2225  + del*( real(dtable3(ind+1),fms_svp_kind_) &
2226  + del*real(d2table3(ind+1),fms_svp_kind_) )
2227  !> desat = DTABLE + 2del*D2TABLE
2228  !! the coded equation below is the commented equation above
2229  desat(i,j) = real(dtable3(ind+1),fms_svp_kind_) &
2230  + 2.0_lkind*del*real(d2table3(ind+1),fms_svp_kind_)
2231  endif
2232  enddo
2233  enddo
2234 
2235  end subroutine lookup_es3_des3_k_2d_
2236 
2237 !#######################################################################
2238 
2239  subroutine lookup_es3_des3_k_1d_ (temp, esat, desat, nbad)
2240  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
2241  real(kind=fms_svp_kind_), intent(out), dimension(:) :: esat !< saturation vapor pressure
2242  real(kind=fms_svp_kind_), intent(out), dimension(:) :: desat !< derivative of esat
2243  integer, intent(out) :: nbad !< if temperature is out of range
2244 
2245  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2246  real(kind=fms_svp_kind_) :: del !< delta T
2247  integer :: ind, i
2248  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2249  !! for precision consistency and for code readability, the *ll variables are declared
2250  !! and used
2251  real(kind=fms_svp_kind_) :: dtresl
2252  real(kind=fms_svp_kind_) :: tepsll
2253  real(kind=fms_svp_kind_) :: tminll
2254  real(kind=fms_svp_kind_) :: dtinvll
2255  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2256 
2257  dtresl=real(dtres, fms_svp_kind_)
2258  tminll=real(tminl, fms_svp_kind_)
2259  tepsll=real(tepsl, fms_svp_kind_)
2260  dtinvll=real(dtinvl, fms_svp_kind_)
2261 
2262  nbad = 0
2263  do i = 1, size(temp,1)
2264  tmp = temp(i)-tminll
2265  ind = int(dtinvll*(tmp+tepsll))
2266  if (ind < 0 .or. ind >= table_siz) then
2267  nbad = nbad+1
2268  else
2269  del = tmp-dtresl*real(ind,fms_svp_kind_)
2270  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2271  !! the coded equation below is the commented equation above
2272  esat(i) = real(table3(ind+1),fms_svp_kind_) &
2273  + del*( real(dtable3(ind+1),fms_svp_kind_) &
2274  + del*real(d2table3(ind+1),fms_svp_kind_) )
2275  !> desat = DTABLE + 2del*D2TABLE
2276  !! the coded equation below is the commented equation above
2277  desat(i) = real(dtable3(ind+1),fms_svp_kind_) &
2278  + 2.0_lkind*del*real(d2table3(ind+1),fms_svp_kind_)
2279  endif
2280  enddo
2281 
2282  end subroutine lookup_es3_des3_k_1d_
2283 
2284 !#######################################################################
2285 
2286  subroutine lookup_es3_des3_k_0d_ (temp, esat, desat, nbad)
2287  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
2288  real(kind=fms_svp_kind_), intent(out) :: esat !< saturation vapor pressure
2289  real(kind=fms_svp_kind_), intent(out) :: desat !< derivative of esat
2290  integer, intent(out) :: nbad !< if temperature is out of range
2291 
2292  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2293  real(kind=fms_svp_kind_) :: del !< delta T
2294  integer :: ind
2295  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2296  !! for precision consistency and for code readability, the *ll variables are declared
2297  !! and used
2298  real(kind=fms_svp_kind_) :: dtresl
2299  real(kind=fms_svp_kind_) :: tepsll
2300  real(kind=fms_svp_kind_) :: tminll
2301  real(kind=fms_svp_kind_) :: dtinvll
2302  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2303 
2304  dtresl=real(dtres, fms_svp_kind_)
2305  tminll=real(tminl, fms_svp_kind_)
2306  tepsll=real(tepsl, fms_svp_kind_)
2307  dtinvll=real(dtinvl, fms_svp_kind_)
2308 
2309  nbad = 0
2310  tmp = temp-tminll
2311  ind = int(dtinvll*(tmp+tepsll))
2312  if (ind < 0 .or. ind >= table_siz) then
2313  nbad = nbad+1
2314  else
2315  del = tmp-dtresl*real(ind,fms_svp_kind_)
2316  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2317  !! the coded equation below is the commented equation above
2318  esat = real(table3(ind+1),fms_svp_kind_) &
2319  + del*( real(dtable3(ind+1),fms_svp_kind_) &
2320  + del*real(d2table3(ind+1),fms_svp_kind_) )
2321  !> desat = DTABLE + 2del*D2TABLE
2322  !! the coded equation below is the commented equation above
2323  desat = real(dtable3(ind+1),fms_svp_kind_) &
2324  + 2.0_lkind*del*real(d2table3(ind+1),fms_svp_kind_)
2325  endif
2326 
2327  end subroutine lookup_es3_des3_k_0d_
2328 
2329 !#######################################################################
2330 
2331  subroutine lookup_es3_k_3d_(temp, esat, nbad)
2332  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
2333  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: esat !< saturation vapor pressure
2334  integer, intent(out) :: nbad !< if temperature is out of range
2335  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2336  real(kind=fms_svp_kind_) :: del !< delta T
2337  integer :: ind, i, j, k
2338  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2339  !! for precision consistency and for code readability, the *ll variables are declared
2340  !! and used
2341  real(kind=fms_svp_kind_) :: dtresl
2342  real(kind=fms_svp_kind_) :: tepsll
2343  real(kind=fms_svp_kind_) :: tminll
2344  real(kind=fms_svp_kind_) :: dtinvll
2345 
2346  dtresl=real(dtres, fms_svp_kind_)
2347  tminll=real(tminl, fms_svp_kind_)
2348  tepsll=real(tepsl, fms_svp_kind_)
2349  dtinvll=real(dtinvl, fms_svp_kind_)
2350 
2351  nbad = 0
2352  do k = 1, size(temp,3)
2353  do j = 1, size(temp,2)
2354  do i = 1, size(temp,1)
2355  tmp = temp(i,j,k)-tminll
2356  ind = int(dtinvll*(tmp+tepsll))
2357  if (ind < 0 .or. ind >= table_siz) then
2358  nbad = nbad+1
2359  else
2360  del = tmp-dtresl*real(ind,fms_svp_kind_)
2361  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2362  !! the coded equation below is the commented equation above
2363  esat(i,j,k) = real(table3(ind+1),fms_svp_kind_) &
2364  + del*( real(dtable3(ind+1),fms_svp_kind_) &
2365  + del*real(d2table3(ind+1),fms_svp_kind_) )
2366  endif
2367  enddo
2368  enddo
2369  enddo
2370 
2371  end subroutine lookup_es3_k_3d_
2372 
2373 !#######################################################################
2374 
2375  subroutine lookup_des3_k_3d_(temp, desat, nbad)
2376  real(kind=fms_svp_kind_), intent(in), dimension(:,:,:) :: temp !< temperature
2377  real(kind=fms_svp_kind_), intent(out), dimension(:,:,:) :: desat!< derivatove of saturation vap pressure
2378  integer, intent(out) :: nbad !< if temperature is out of range
2379  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2380  real(kind=fms_svp_kind_) :: del !< delta T
2381  integer :: ind, i, j, k
2382  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2383  !! for precision consistency and for code readability, the *ll variables are declared
2384  !! and used
2385  real(kind=fms_svp_kind_) :: dtresl
2386  real(kind=fms_svp_kind_) :: tepsll
2387  real(kind=fms_svp_kind_) :: tminll
2388  real(kind=fms_svp_kind_) :: dtinvll
2389  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2390 
2391  dtresl=real(dtres, fms_svp_kind_)
2392  tminll=real(tminl, fms_svp_kind_)
2393  tepsll=real(tepsl, fms_svp_kind_)
2394  dtinvll=real(dtinvl, fms_svp_kind_)
2395 
2396  nbad = 0
2397  do k = 1, size(temp,3)
2398  do j = 1, size(temp,2)
2399  do i = 1, size(temp,1)
2400  tmp = temp(i,j,k)-tminll
2401  ind = int(dtinvll*(tmp+tepsll))
2402  if (ind < 0 .or. ind >= table_siz) then
2403  nbad = nbad+1
2404  else
2405  del = tmp-dtresl*real(ind,fms_svp_kind_)
2406  !> desat = DTABLE + 2del*D2TABLE
2407  !! the coded equation below is the commented equation above
2408  desat(i,j,k) = real(dtable3(ind+1),fms_svp_kind_) &
2409  + 2.0_lkind*del*real(d2table3(ind+1),fms_svp_kind_)
2410  endif
2411  enddo
2412  enddo
2413  enddo
2414 
2415  end subroutine lookup_des3_k_3d_
2416 
2417 !#######################################################################
2418  subroutine lookup_des3_k_2d_(temp, desat, nbad)
2419  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
2420  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: desat !< derivative of sat vapor pressure
2421  integer, intent(out) :: nbad !< if temperature is out of range
2422  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2423  real(kind=fms_svp_kind_) :: del !< delta T
2424  integer :: ind, i, j
2425  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2426  !! for precision consistency and for code readability, the *ll variables are declared
2427  !! and used
2428  real(kind=fms_svp_kind_) :: dtresl
2429  real(kind=fms_svp_kind_) :: tepsll
2430  real(kind=fms_svp_kind_) :: tminll
2431  real(kind=fms_svp_kind_) :: dtinvll
2432  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2433 
2434  dtresl=real(dtres, fms_svp_kind_)
2435  tminll=real(tminl, fms_svp_kind_)
2436  tepsll=real(tepsl, fms_svp_kind_)
2437  dtinvll=real(dtinvl, fms_svp_kind_)
2438 
2439  nbad = 0
2440  do j = 1, size(temp,2)
2441  do i = 1, size(temp,1)
2442  tmp = temp(i,j)-tminll
2443  ind = int(dtinvll*(tmp+tepsll))
2444  if (ind < 0 .or. ind >= table_siz) then
2445  nbad = nbad+1
2446  else
2447  del = tmp-dtresl*real(ind,fms_svp_kind_)
2448  !> desat = DTABLE + 2del*D2TABLE
2449  !! the coded equation below is the commented equation above
2450  desat(i,j) = real(dtable3(ind+1),fms_svp_kind_) &
2451  + 2.0_lkind*del*real(d2table3(ind+1),fms_svp_kind_)
2452  endif
2453  enddo
2454  enddo
2455 
2456  end subroutine lookup_des3_k_2d_
2457 !#######################################################################
2458  subroutine lookup_es3_k_2d_(temp, esat, nbad)
2459  real(kind=fms_svp_kind_), intent(in), dimension(:,:) :: temp !< temperature
2460  real(kind=fms_svp_kind_), intent(out), dimension(:,:) :: esat !< saturation vapor pressure
2461  integer, intent(out) :: nbad !< if temperature is out of range
2462  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2463  real(kind=fms_svp_kind_) :: del !< delta T
2464  integer :: ind, i, j
2465  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2466  !! for precision consistency and for code readability, the *ll variables are declared
2467  !! and used
2468  real(kind=fms_svp_kind_) :: dtresl
2469  real(kind=fms_svp_kind_) :: tepsll
2470  real(kind=fms_svp_kind_) :: tminll
2471  real(kind=fms_svp_kind_) :: dtinvll
2472 
2473  dtresl=real(dtres, fms_svp_kind_)
2474  tminll=real(tminl, fms_svp_kind_)
2475  tepsll=real(tepsl, fms_svp_kind_)
2476  dtinvll=real(dtinvl, fms_svp_kind_)
2477 
2478  nbad = 0
2479  do j = 1, size(temp,2)
2480  do i = 1, size(temp,1)
2481  tmp = temp(i,j)-tminll
2482  ind = int(dtinvll*(tmp+tepsll))
2483  if (ind < 0 .or. ind >= table_siz) then
2484  nbad = nbad+1
2485  else
2486  del = tmp-dtresl*real(ind,fms_svp_kind_)
2487  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2488  !! the coded equation below is the commented equation above
2489  esat(i,j) = real(table3(ind+1),fms_svp_kind_) &
2490  + del*( real(dtable3(ind+1),fms_svp_kind_) &
2491  + del*real(d2table3(ind+1),fms_svp_kind_) )
2492  endif
2493  enddo
2494  enddo
2495 
2496  end subroutine lookup_es3_k_2d_
2497 !#######################################################################
2498  subroutine lookup_des3_k_1d_(temp, desat, nbad)
2499  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
2500  real(kind=fms_svp_kind_), intent(out), dimension(:) :: desat !< derivative of sat vapor pressure
2501  integer, intent(out) :: nbad !< if temperature is out of range
2502  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2503  real(kind=fms_svp_kind_) :: del !< delta T
2504  integer :: ind, i
2505  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2506  !! for precision consistency and for code readability, the *ll variables are declared
2507  !! and used
2508  real(kind=fms_svp_kind_) :: dtresl
2509  real(kind=fms_svp_kind_) :: tepsll
2510  real(kind=fms_svp_kind_) :: tminll
2511  real(kind=fms_svp_kind_) :: dtinvll
2512  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2513 
2514  dtresl=real(dtres, fms_svp_kind_)
2515  tminll=real(tminl, fms_svp_kind_)
2516  tepsll=real(tepsl, fms_svp_kind_)
2517  dtinvll=real(dtinvl, fms_svp_kind_)
2518 
2519  nbad = 0
2520  do i = 1, size(temp,1)
2521  tmp = temp(i)-tminll
2522  ind = int(dtinvll*(tmp+tepsll))
2523  if (ind < 0 .or. ind >= table_siz) then
2524  nbad = nbad+1
2525  else
2526  del = tmp-dtresl*real(ind,fms_svp_kind_)
2527  !> desat = DTABLE + 2del*D2TABLE
2528  !! the coded equation below is the commented equation above
2529  desat(i) = real(dtable3(ind+1),fms_svp_kind_) &
2530  + 2.0_lkind*del*real(d2table3(ind+1),fms_svp_kind_)
2531  endif
2532  enddo
2533 
2534  end subroutine lookup_des3_k_1d_
2535 !#######################################################################
2536  subroutine lookup_es3_k_1d_(temp, esat, nbad)
2537  real(kind=fms_svp_kind_), intent(in), dimension(:) :: temp !< temperature
2538  real(kind=fms_svp_kind_), intent(out), dimension(:) :: esat !< saturation vapor pressure
2539  integer, intent(out) :: nbad !< if temperature is out of range
2540  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2541  real(kind=fms_svp_kind_) :: del !< delta T
2542  integer :: ind, i
2543  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2544  !! for precision consistency and for code readability, the *ll variables are declared
2545  !! and used
2546  real(kind=fms_svp_kind_) :: dtresl
2547  real(kind=fms_svp_kind_) :: tepsll
2548  real(kind=fms_svp_kind_) :: tminll
2549  real(kind=fms_svp_kind_) :: dtinvll
2550 
2551  dtresl=real(dtres, fms_svp_kind_)
2552  tminll=real(tminl, fms_svp_kind_)
2553  tepsll=real(tepsl, fms_svp_kind_)
2554  dtinvll=real(dtinvl, fms_svp_kind_)
2555 
2556  nbad = 0
2557  do i = 1, size(temp,1)
2558  tmp = temp(i)-tminll
2559  ind = int(dtinvll*(tmp+tepsll))
2560  if (ind < 0 .or. ind >= table_siz) then
2561  nbad = nbad+1
2562  else
2563  del = tmp-dtresl*real(ind,fms_svp_kind_)
2564  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2565  !! the coded equation below is the commented equation above
2566  esat(i) = real(table3(ind+1),fms_svp_kind_) &
2567  + del*( real(dtable3(ind+1),fms_svp_kind_) &
2568  + del*real(d2table3(ind+1),fms_svp_kind_) )
2569  endif
2570  enddo
2571 
2572  end subroutine lookup_es3_k_1d_
2573 !#######################################################################
2574  subroutine lookup_des3_k_0d_(temp, desat, nbad)
2575  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
2576  real(kind=fms_svp_kind_), intent(out) :: desat !< derivative of sat vapor pressure
2577  integer, intent(out) :: nbad !< if temperature is out of range
2578  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2579  real(kind=fms_svp_kind_) :: del !< delta T
2580  integer :: ind
2581  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2582  !! for precision consistency and for code readability, the *ll variables are declared
2583  !! and used
2584  real(kind=fms_svp_kind_) :: dtresl
2585  real(kind=fms_svp_kind_) :: tepsll
2586  real(kind=fms_svp_kind_) :: tminll
2587  real(kind=fms_svp_kind_) :: dtinvll
2588  integer, parameter :: lkind=fms_svp_kind_ !< local FMS_SVP_KIND_
2589 
2590  dtresl=real(dtres, fms_svp_kind_)
2591  tminll=real(tminl, fms_svp_kind_)
2592  tepsll=real(tepsl, fms_svp_kind_)
2593  dtinvll=real(dtinvl, fms_svp_kind_)
2594 
2595  nbad = 0
2596  tmp = temp-tminll
2597  ind = int(dtinvll*(tmp+tepsll))
2598  if (ind < 0 .or. ind >= table_siz) then
2599  nbad = nbad+1
2600  else
2601  del = tmp-dtresl*real(ind,fms_svp_kind_)
2602  !> desat = DTABLE + 2del*D2TABLE
2603  !! the coded equation below is the commented equation above
2604  desat = real(dtable3(ind+1),fms_svp_kind_) &
2605  + 2.0_lkind*del*real(d2table3(ind+1),fms_svp_kind_)
2606  endif
2607 
2608  end subroutine lookup_des3_k_0d_
2609 !#######################################################################
2610  subroutine lookup_es3_k_0d_(temp, esat, nbad)
2611  real(kind=fms_svp_kind_), intent(in) :: temp !< temperature
2612  real(kind=fms_svp_kind_), intent(out) :: esat !< saturation vapor pressure
2613  integer, intent(out) :: nbad !< if temperature is out of range
2614  real(kind=fms_svp_kind_) :: tmp !< temp-TMINLL
2615  real(kind=fms_svp_kind_) :: del !< delta T
2616  integer :: ind
2617  !> dtres, tminl, tepsl, dtinvl are module level variables declared in r8_kind precision
2618  !! for precision consistency and for code readability, the *ll variables are declared
2619  !! and used
2620  real(kind=fms_svp_kind_) :: dtresl
2621  real(kind=fms_svp_kind_) :: tepsll
2622  real(kind=fms_svp_kind_) :: tminll
2623  real(kind=fms_svp_kind_) :: dtinvll
2624 
2625  dtresl=real(dtres, fms_svp_kind_)
2626  tminll=real(tminl, fms_svp_kind_)
2627  tepsll=real(tepsl, fms_svp_kind_)
2628  dtinvll=real(dtinvl, fms_svp_kind_)
2629 
2630  nbad = 0
2631  tmp = temp-tminll
2632  ind = int(dtinvll*(tmp+tepsll))
2633  if (ind < 0 .or. ind >= table_siz) then
2634  nbad = nbad+1
2635  else
2636  del = tmp-dtresl*real(ind,fms_svp_kind_)
2637  !> esat = TABLE + del*(TABLE + del*D2TABLE)
2638  !! the coded equation below is the commented equation above
2639  esat = real(table3(ind+1),fms_svp_kind_) &
2640  + del*( real(dtable3(ind+1),fms_svp_kind_) &
2641  + del*real(d2table3(ind+1),fms_svp_kind_) )
2642  endif
2643 
2644  end subroutine lookup_es3_k_0d_
2645 !#######################################################################
2646 !> @}
2647 ! close documentation grouping
lookup_es2_k_3d_
subroutine lookup_es2_k_3d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:1822
lookup_es3_des3_k_1d_
subroutine lookup_es3_des3_k_1d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:2240
lookup_es2_k_2d_
subroutine lookup_es2_k_2d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:1949
lookup_es2_des2_k_0d_
subroutine lookup_es2_des2_k_0d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:1776
compute_qs_k_2d_
subroutine compute_qs_k_2d_(temp, press, eps, zvir, qs, nbad, q, hc, dqsdT, esat, es_over_liq, es_over_liq_and_ice)
Definition: sat_vapor_pres_k.inc:487
lookup_es_des_k_3d_
subroutine lookup_es_des_k_3d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:1119
lookup_es3_k_2d_
subroutine lookup_es3_k_2d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:2459
compute_qs_k_1d_
subroutine compute_qs_k_1d_(temp, press, eps, zvir, qs, nbad, q, hc, dqsdT, esat, es_over_liq, es_over_liq_and_ice)
Definition: sat_vapor_pres_k.inc:579
compute_qs_k_0d_
subroutine compute_qs_k_0d_(temp, press, eps, zvir, qs, nbad, q, hc, dqsdT, esat, es_over_liq, es_over_liq_and_ice)
Definition: sat_vapor_pres_k.inc:669
lookup_des_k_3d_
subroutine lookup_des_k_3d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:1356
lookup_es3_k_0d_
subroutine lookup_es3_k_0d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:2611
lookup_es3_des3_k_2d_
subroutine lookup_es3_des3_k_2d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:2191
lookup_es_k_2d_
subroutine lookup_es_k_2d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:1440
lookup_es3_k_1d_
subroutine lookup_es3_k_1d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:2537
lookup_es2_des2_k_3d_
subroutine lookup_es2_des2_k_3d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:1630
lookup_es_k_3d_
subroutine lookup_es_k_3d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:1312
lookup_des2_k_2d_
subroutine lookup_des2_k_2d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:1909
lookup_des2_k_0d_
subroutine lookup_des2_k_0d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:2065
lookup_es_des_k_2d_
subroutine lookup_es_des_k_2d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:1170
lookup_es_des_k_0d_
subroutine lookup_es_des_k_0d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:1267
lookup_es_des_k_1d_
subroutine lookup_es_des_k_1d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:1219
lookup_des_k_0d_
subroutine lookup_des_k_0d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:1557
lookup_es2_des2_k_2d_
subroutine lookup_es2_des2_k_2d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:1681
lookup_des2_k_1d_
subroutine lookup_des2_k_1d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:1989
compute_qs_k_3d_
subroutine compute_qs_k_3d_(temp, press, eps, zvir, qs, nbad, q, hc, dqsdT, esat, es_over_liq, es_over_liq_and_ice)
Definition: sat_vapor_pres_k.inc:394
lookup_es2_k_1d_
subroutine lookup_es2_k_1d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:2027
lookup_es3_des3_k_0d_
subroutine lookup_es3_des3_k_0d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:2287
lookup_es_k_0d_
subroutine lookup_es_k_0d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:1593
lookup_es3_k_3d_
subroutine lookup_es3_k_3d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:2332
lookup_es3_des3_k_3d_
subroutine lookup_es3_des3_k_3d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:2140
lookup_des_k_1d_
subroutine lookup_des_k_1d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:1481
compute_es_liq_k_
real(kind=fms_svp_kind_) function, dimension(size(tem, 1)) compute_es_liq_k_(tem, TFREEZE)
Definition: sat_vapor_pres_k.inc:294
lookup_es2_k_0d_
subroutine lookup_es2_k_0d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:2101
lookup_des_k_2d_
subroutine lookup_des_k_2d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:1399
compute_es_liq_ice_k_
real(kind=fms_svp_kind_) function, dimension(size(tem, 1)) compute_es_liq_ice_k_(tem, TFREEZE)
Definition: sat_vapor_pres_k.inc:339
lookup_des3_k_2d_
subroutine lookup_des3_k_2d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:2419
lookup_es2_des2_k_1d_
subroutine lookup_es2_des2_k_1d_(temp, esat, desat, nbad)
Definition: sat_vapor_pres_k.inc:1730
lookup_des3_k_3d_
subroutine lookup_des3_k_3d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:2376
lookup_es_k_1d_
subroutine lookup_es_k_1d_(temp, esat, nbad)
Definition: sat_vapor_pres_k.inc:1519
compute_mrs_k_0d_
subroutine compute_mrs_k_0d_(temp, press, eps, zvir, mrs, nbad, mr, hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice)
Definition: sat_vapor_pres_k.inc:1032
lookup_des3_k_1d_
subroutine lookup_des3_k_1d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:2499
compute_mrs_k_1d_
subroutine compute_mrs_k_1d_(temp, press, eps, zvir, mrs, nbad, mr, hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice)
Definition: sat_vapor_pres_k.inc:942
sat_vapor_pres_init_k_
subroutine sat_vapor_pres_init_k_(table_size, tcmin, tcmax, TFREEZE, HLV, RVGAS, ES0, err_msg, use_exact_qs_input, do_simple, construct_table_wrt_liq, construct_table_wrt_liq_and_ice, teps, tmin, dtinv)
This routine has been generalized to return tables for any temperature range and resolution The TABLE...
Definition: sat_vapor_pres_k.inc:43
compute_mrs_k_2d_
subroutine compute_mrs_k_2d_(temp, press, eps, zvir, mrs, nbad, mr, hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice)
Definition: sat_vapor_pres_k.inc:850
compute_es_k_
real(kind=fms_svp_kind_) function, dimension(size(tem, 1)) compute_es_k_(tem, TFREEZE)
Definition: sat_vapor_pres_k.inc:217
lookup_des2_k_3d_
subroutine lookup_des2_k_3d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:1866
lookup_des3_k_0d_
subroutine lookup_des3_k_0d_(temp, desat, nbad)
Definition: sat_vapor_pres_k.inc:2575
compute_mrs_k_3d_
subroutine compute_mrs_k_3d_(temp, press, eps, zvir, mrs, nbad, mr, hc, dmrsdT, esat, es_over_liq, es_over_liq_and_ice)
Definition: sat_vapor_pres_k.inc:756