PageRenderTime 79ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/phys/module_gfs_funcphys.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 2935 lines | 838 code | 0 blank | 2097 comment | 10 complexity | 517cea571067e7bd1bea44ea1624eb52 MD5 | raw file
Possible License(s): AGPL-1.0

Large files files are truncated, but you can click here to view the full file

  1. !-------------------------------------------------------------------------------
  2. module module_gfs_funcphys
  3. !$$$ Module Documentation Block
  4. !
  5. ! Module: funcphys API for basic thermodynamic physics
  6. ! Author: Iredell Org: W/NX23 Date: 1999-03-01
  7. !
  8. ! Abstract: This module provides an Application Program Interface
  9. ! for computing basic thermodynamic physics functions, in particular
  10. ! (1) saturation vapor pressure as a function of temperature,
  11. ! (2) dewpoint temperature as a function of vapor pressure,
  12. ! (3) equivalent potential temperature as a function of temperature
  13. ! and scaled pressure to the kappa power,
  14. ! (4) temperature and specific humidity along a moist adiabat
  15. ! as functions of equivalent potential temperature and
  16. ! scaled pressure to the kappa power,
  17. ! (5) scaled pressure to the kappa power as a function of pressure, and
  18. ! (6) temperature at the lifting condensation level as a function
  19. ! of temperature and dewpoint depression.
  20. ! The entry points required to set up lookup tables start with a "g".
  21. ! All the other entry points are functions starting with an "f" or
  22. ! are subroutines starting with an "s". These other functions and
  23. ! subroutines are elemental; that is, they return a scalar if they
  24. ! are passed only scalars, but they return an array if they are passed
  25. ! an array. These other functions and subroutines can be inlined, too.
  26. !
  27. ! Program History Log:
  28. ! 1999-03-01 Mark Iredell
  29. ! 1999-10-15 Mark Iredell SI unit for pressure (Pascals)
  30. ! 2001-02-26 Mark Iredell Ice phase changes of Hong and Moorthi
  31. !
  32. ! Public Variables:
  33. ! krealfp Integer parameter kind or length of reals (=kind_phys)
  34. !
  35. ! Public Subprograms:
  36. ! gpvsl Compute saturation vapor pressure over liquid table
  37. !
  38. ! fpvsl Elementally compute saturation vapor pressure over liquid
  39. ! function result Real(krealfp) saturation vapor pressure in Pascals
  40. ! t Real(krealfp) temperature in Kelvin
  41. !
  42. ! fpvslq Elementally compute saturation vapor pressure over liquid
  43. ! function result Real(krealfp) saturation vapor pressure in Pascals
  44. ! t Real(krealfp) temperature in Kelvin
  45. !
  46. ! fpvslx Elementally compute saturation vapor pressure over liquid
  47. ! function result Real(krealfp) saturation vapor pressure in Pascals
  48. ! t Real(krealfp) temperature in Kelvin
  49. !
  50. ! gpvsi Compute saturation vapor pressure over ice table
  51. !
  52. ! fpvsi Elementally compute saturation vapor pressure over ice
  53. ! function result Real(krealfp) saturation vapor pressure in Pascals
  54. ! t Real(krealfp) temperature in Kelvin
  55. !
  56. ! fpvsiq Elementally compute saturation vapor pressure over ice
  57. ! function result Real(krealfp) saturation vapor pressure in Pascals
  58. ! t Real(krealfp) temperature in Kelvin
  59. !
  60. ! fpvsix Elementally compute saturation vapor pressure over ice
  61. ! function result Real(krealfp) saturation vapor pressure in Pascals
  62. ! t Real(krealfp) temperature in Kelvin
  63. !
  64. ! gpvs Compute saturation vapor pressure table
  65. !
  66. ! fpvs Elementally compute saturation vapor pressure
  67. ! function result Real(krealfp) saturation vapor pressure in Pascals
  68. ! t Real(krealfp) temperature in Kelvin
  69. !
  70. ! fpvsq Elementally compute saturation vapor pressure
  71. ! function result Real(krealfp) saturation vapor pressure in Pascals
  72. ! t Real(krealfp) temperature in Kelvin
  73. !
  74. ! fpvsx Elementally compute saturation vapor pressure
  75. ! function result Real(krealfp) saturation vapor pressure in Pascals
  76. ! t Real(krealfp) temperature in Kelvin
  77. !
  78. ! gtdpl Compute dewpoint temperature over liquid table
  79. !
  80. ! ftdpl Elementally compute dewpoint temperature over liquid
  81. ! function result Real(krealfp) dewpoint temperature in Kelvin
  82. ! pv Real(krealfp) vapor pressure in Pascals
  83. !
  84. ! ftdplq Elementally compute dewpoint temperature over liquid
  85. ! function result Real(krealfp) dewpoint temperature in Kelvin
  86. ! pv Real(krealfp) vapor pressure in Pascals
  87. !
  88. ! ftdplx Elementally compute dewpoint temperature over liquid
  89. ! function result Real(krealfp) dewpoint temperature in Kelvin
  90. ! pv Real(krealfp) vapor pressure in Pascals
  91. !
  92. ! ftdplxg Elementally compute dewpoint temperature over liquid
  93. ! function result Real(krealfp) dewpoint temperature in Kelvin
  94. ! t Real(krealfp) guess dewpoint temperature in Kelvin
  95. ! pv Real(krealfp) vapor pressure in Pascals
  96. !
  97. ! gtdpi Compute dewpoint temperature table over ice
  98. !
  99. ! ftdpi Elementally compute dewpoint temperature over ice
  100. ! function result Real(krealfp) dewpoint temperature in Kelvin
  101. ! pv Real(krealfp) vapor pressure in Pascals
  102. !
  103. ! ftdpiq Elementally compute dewpoint temperature over ice
  104. ! function result Real(krealfp) dewpoint temperature in Kelvin
  105. ! pv Real(krealfp) vapor pressure in Pascals
  106. !
  107. ! ftdpix Elementally compute dewpoint temperature over ice
  108. ! function result Real(krealfp) dewpoint temperature in Kelvin
  109. ! pv Real(krealfp) vapor pressure in Pascals
  110. !
  111. ! ftdpixg Elementally compute dewpoint temperature over ice
  112. ! function result Real(krealfp) dewpoint temperature in Kelvin
  113. ! t Real(krealfp) guess dewpoint temperature in Kelvin
  114. ! pv Real(krealfp) vapor pressure in Pascals
  115. !
  116. ! gtdp Compute dewpoint temperature table
  117. !
  118. ! ftdp Elementally compute dewpoint temperature
  119. ! function result Real(krealfp) dewpoint temperature in Kelvin
  120. ! pv Real(krealfp) vapor pressure in Pascals
  121. !
  122. ! ftdpq Elementally compute dewpoint temperature
  123. ! function result Real(krealfp) dewpoint temperature in Kelvin
  124. ! pv Real(krealfp) vapor pressure in Pascals
  125. !
  126. ! ftdpx Elementally compute dewpoint temperature
  127. ! function result Real(krealfp) dewpoint temperature in Kelvin
  128. ! pv Real(krealfp) vapor pressure in Pascals
  129. !
  130. ! ftdpxg Elementally compute dewpoint temperature
  131. ! function result Real(krealfp) dewpoint temperature in Kelvin
  132. ! t Real(krealfp) guess dewpoint temperature in Kelvin
  133. ! pv Real(krealfp) vapor pressure in Pascals
  134. !
  135. ! gthe Compute equivalent potential temperature table
  136. !
  137. ! fthe Elementally compute equivalent potential temperature
  138. ! function result Real(krealfp) equivalent potential temperature in Kelvin
  139. ! t Real(krealfp) LCL temperature in Kelvin
  140. ! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power
  141. !
  142. ! ftheq Elementally compute equivalent potential temperature
  143. ! function result Real(krealfp) equivalent potential temperature in Kelvin
  144. ! t Real(krealfp) LCL temperature in Kelvin
  145. ! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power
  146. !
  147. ! fthex Elementally compute equivalent potential temperature
  148. ! function result Real(krealfp) equivalent potential temperature in Kelvin
  149. ! t Real(krealfp) LCL temperature in Kelvin
  150. ! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power
  151. !
  152. ! gtma Compute moist adiabat tables
  153. !
  154. ! stma Elementally compute moist adiabat temperature and moisture
  155. ! the Real(krealfp) equivalent potential temperature in Kelvin
  156. ! pk Real(krealfp) pressure over 1e5 Pa to the kappa power
  157. ! tma Real(krealfp) parcel temperature in Kelvin
  158. ! qma Real(krealfp) parcel specific humidity in kg/kg
  159. !
  160. ! stmaq Elementally compute moist adiabat temperature and moisture
  161. ! the Real(krealfp) equivalent potential temperature in Kelvin
  162. ! pk Real(krealfp) pressure over 1e5 Pa to the kappa power
  163. ! tma Real(krealfp) parcel temperature in Kelvin
  164. ! qma Real(krealfp) parcel specific humidity in kg/kg
  165. !
  166. ! stmax Elementally compute moist adiabat temperature and moisture
  167. ! the Real(krealfp) equivalent potential temperature in Kelvin
  168. ! pk Real(krealfp) pressure over 1e5 Pa to the kappa power
  169. ! tma Real(krealfp) parcel temperature in Kelvin
  170. ! qma Real(krealfp) parcel specific humidity in kg/kg
  171. !
  172. ! stmaxg Elementally compute moist adiabat temperature and moisture
  173. ! tg Real(krealfp) guess parcel temperature in Kelvin
  174. ! the Real(krealfp) equivalent potential temperature in Kelvin
  175. ! pk Real(krealfp) pressure over 1e5 Pa to the kappa power
  176. ! tma Real(krealfp) parcel temperature in Kelvin
  177. ! qma Real(krealfp) parcel specific humidity in kg/kg
  178. !
  179. ! gpkap Compute pressure to the kappa table
  180. !
  181. ! fpkap Elementally raise pressure to the kappa power.
  182. ! function result Real(krealfp) p over 1e5 Pa to the kappa power
  183. ! p Real(krealfp) pressure in Pascals
  184. !
  185. ! fpkapq Elementally raise pressure to the kappa power.
  186. ! function result Real(krealfp) p over 1e5 Pa to the kappa power
  187. ! p Real(krealfp) pressure in Pascals
  188. !
  189. ! fpkapo Elementally raise pressure to the kappa power.
  190. ! function result Real(krealfp) p over 1e5 Pa to the kappa power
  191. ! p Real(krealfp) surface pressure in Pascals
  192. !
  193. ! fpkapx Elementally raise pressure to the kappa power.
  194. ! function result Real(krealfp) p over 1e5 Pa to the kappa power
  195. ! p Real(krealfp) pressure in Pascals
  196. !
  197. ! grkap Compute pressure to the 1/kappa table
  198. !
  199. ! frkap Elementally raise pressure to the 1/kappa power.
  200. ! function result Real(krealfp) pressure in Pascals
  201. ! pkap Real(krealfp) p over 1e5 Pa to the 1/kappa power
  202. !
  203. ! frkapq Elementally raise pressure to the kappa power.
  204. ! function result Real(krealfp) pressure in Pascals
  205. ! pkap Real(krealfp) p over 1e5 Pa to the kappa power
  206. !
  207. ! frkapx Elementally raise pressure to the kappa power.
  208. ! function result Real(krealfp) pressure in Pascals
  209. ! pkap Real(krealfp) p over 1e5 Pa to the kappa power
  210. !
  211. ! gtlcl Compute LCL temperature table
  212. !
  213. ! ftlcl Elementally compute LCL temperature.
  214. ! function result Real(krealfp) temperature at the LCL in Kelvin
  215. ! t Real(krealfp) temperature in Kelvin
  216. ! tdpd Real(krealfp) dewpoint depression in Kelvin
  217. !
  218. ! ftlclq Elementally compute LCL temperature.
  219. ! function result Real(krealfp) temperature at the LCL in Kelvin
  220. ! t Real(krealfp) temperature in Kelvin
  221. ! tdpd Real(krealfp) dewpoint depression in Kelvin
  222. !
  223. ! ftlclo Elementally compute LCL temperature.
  224. ! function result Real(krealfp) temperature at the LCL in Kelvin
  225. ! t Real(krealfp) temperature in Kelvin
  226. ! tdpd Real(krealfp) dewpoint depression in Kelvin
  227. !
  228. ! ftlclx Elementally compute LCL temperature.
  229. ! function result Real(krealfp) temperature at the LCL in Kelvin
  230. ! t Real(krealfp) temperature in Kelvin
  231. ! tdpd Real(krealfp) dewpoint depression in Kelvin
  232. !
  233. ! gfuncphys Compute all physics function tables
  234. !
  235. ! Attributes:
  236. ! Language: Fortran 90
  237. !
  238. !$$$
  239. use module_gfs_machine,only:kind_phys
  240. use module_gfs_physcons
  241. implicit none
  242. private
  243. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  244. ! Public Variables
  245. ! integer,public,parameter:: krealfp=selected_real_kind(15,45)
  246. integer,public,parameter:: krealfp=kind_phys
  247. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  248. ! Private Variables
  249. real(krealfp),parameter:: psatb=con_psat*1.e-5
  250. integer,parameter:: nxpvsl=7501
  251. real(krealfp) c1xpvsl,c2xpvsl,tbpvsl(nxpvsl)
  252. integer,parameter:: nxpvsi=7501
  253. real(krealfp) c1xpvsi,c2xpvsi,tbpvsi(nxpvsi)
  254. integer,parameter:: nxpvs=7501
  255. real(krealfp) c1xpvs,c2xpvs,tbpvs(nxpvs)
  256. integer,parameter:: nxtdpl=5001
  257. real(krealfp) c1xtdpl,c2xtdpl,tbtdpl(nxtdpl)
  258. integer,parameter:: nxtdpi=5001
  259. real(krealfp) c1xtdpi,c2xtdpi,tbtdpi(nxtdpi)
  260. integer,parameter:: nxtdp=5001
  261. real(krealfp) c1xtdp,c2xtdp,tbtdp(nxtdp)
  262. integer,parameter:: nxthe=241,nythe=151
  263. real(krealfp) c1xthe,c2xthe,c1ythe,c2ythe,tbthe(nxthe,nythe)
  264. integer,parameter:: nxma=151,nyma=121
  265. real(krealfp) c1xma,c2xma,c1yma,c2yma,tbtma(nxma,nyma),tbqma(nxma,nyma)
  266. ! integer,parameter:: nxpkap=5501
  267. integer,parameter:: nxpkap=11001
  268. real(krealfp) c1xpkap,c2xpkap,tbpkap(nxpkap)
  269. integer,parameter:: nxrkap=5501
  270. real(krealfp) c1xrkap,c2xrkap,tbrkap(nxrkap)
  271. integer,parameter:: nxtlcl=151,nytlcl=61
  272. real(krealfp) c1xtlcl,c2xtlcl,c1ytlcl,c2ytlcl,tbtlcl(nxtlcl,nytlcl)
  273. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  274. ! Public Subprograms
  275. public gpvsl,fpvsl,fpvslq,fpvslx
  276. public gpvsi,fpvsi,fpvsiq,fpvsix
  277. public gpvs,fpvs,fpvsq,fpvsx
  278. public gtdpl,ftdpl,ftdplq,ftdplx,ftdplxg
  279. public gtdpi,ftdpi,ftdpiq,ftdpix,ftdpixg
  280. public gtdp,ftdp,ftdpq,ftdpx,ftdpxg
  281. public gthe,fthe,ftheq,fthex
  282. public gtma,stma,stmaq,stmax,stmaxg
  283. public gpkap,fpkap,fpkapq,fpkapo,fpkapx
  284. public grkap,frkap,frkapq,frkapx
  285. public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx
  286. public gfuncphys
  287. contains
  288. !-------------------------------------------------------------------------------
  289. subroutine gpvsl
  290. !$$$ Subprogram Documentation Block
  291. !
  292. ! Subprogram: gpvsl Compute saturation vapor pressure table over liquid
  293. ! Author: N Phillips W/NMC2X2 Date: 30 dec 82
  294. !
  295. ! Abstract: Computes saturation vapor pressure table as a function of
  296. ! temperature for the table lookup function fpvsl.
  297. ! Exact saturation vapor pressures are calculated in subprogram fpvslx.
  298. ! The current implementation computes a table with a length
  299. ! of 7501 for temperatures ranging from 180. to 330. Kelvin.
  300. !
  301. ! Program History Log:
  302. ! 91-05-07 Iredell
  303. ! 94-12-30 Iredell expand table
  304. ! 1999-03-01 Iredell f90 module
  305. !
  306. ! Usage: call gpvsl
  307. !
  308. ! Subprograms called:
  309. ! (fpvslx) inlinable function to compute saturation vapor pressure
  310. !
  311. ! Attributes:
  312. ! Language: Fortran 90.
  313. !
  314. !$$$
  315. implicit none
  316. integer jx
  317. real(krealfp) xmin,xmax,xinc,x,t
  318. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  319. xmin=180.0_krealfp
  320. xmax=330.0_krealfp
  321. xinc=(xmax-xmin)/(nxpvsl-1)
  322. ! c1xpvsl=1.-xmin/xinc
  323. c2xpvsl=1./xinc
  324. c1xpvsl=1.-xmin*c2xpvsl
  325. do jx=1,nxpvsl
  326. x=xmin+(jx-1)*xinc
  327. t=x
  328. tbpvsl(jx)=fpvslx(t)
  329. enddo
  330. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  331. end subroutine
  332. !-------------------------------------------------------------------------------
  333. ! elemental function fpvsl(t)
  334. function fpvsl(t)
  335. !$$$ Subprogram Documentation Block
  336. !
  337. ! Subprogram: fpvsl Compute saturation vapor pressure over liquid
  338. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  339. !
  340. ! Abstract: Compute saturation vapor pressure from the temperature.
  341. ! A linear interpolation is done between values in a lookup table
  342. ! computed in gpvsl. See documentation for fpvslx for details.
  343. ! Input values outside table range are reset to table extrema.
  344. ! The interpolation accuracy is almost 6 decimal places.
  345. ! On the Cray, fpvsl is about 4 times faster than exact calculation.
  346. ! This function should be expanded inline in the calling routine.
  347. !
  348. ! Program History Log:
  349. ! 91-05-07 Iredell made into inlinable function
  350. ! 94-12-30 Iredell expand table
  351. ! 1999-03-01 Iredell f90 module
  352. !
  353. ! Usage: pvsl=fpvsl(t)
  354. !
  355. ! Input argument list:
  356. ! t Real(krealfp) temperature in Kelvin
  357. !
  358. ! Output argument list:
  359. ! fpvsl Real(krealfp) saturation vapor pressure in Pascals
  360. !
  361. ! Attributes:
  362. ! Language: Fortran 90.
  363. !
  364. !$$$
  365. implicit none
  366. real(krealfp) fpvsl
  367. real(krealfp),intent(in):: t
  368. integer jx
  369. real(krealfp) xj
  370. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  371. xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp))
  372. jx=min(xj,nxpvsl-1._krealfp)
  373. fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx))
  374. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  375. end function
  376. !-------------------------------------------------------------------------------
  377. ! elemental function fpvslq(t)
  378. function fpvslq(t)
  379. !$$$ Subprogram Documentation Block
  380. !
  381. ! Subprogram: fpvslq Compute saturation vapor pressure over liquid
  382. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  383. !
  384. ! Abstract: Compute saturation vapor pressure from the temperature.
  385. ! A quadratic interpolation is done between values in a lookup table
  386. ! computed in gpvsl. See documentation for fpvslx for details.
  387. ! Input values outside table range are reset to table extrema.
  388. ! The interpolation accuracy is almost 9 decimal places.
  389. ! On the Cray, fpvslq is about 3 times faster than exact calculation.
  390. ! This function should be expanded inline in the calling routine.
  391. !
  392. ! Program History Log:
  393. ! 91-05-07 Iredell made into inlinable function
  394. ! 94-12-30 Iredell quadratic interpolation
  395. ! 1999-03-01 Iredell f90 module
  396. !
  397. ! Usage: pvsl=fpvslq(t)
  398. !
  399. ! Input argument list:
  400. ! t Real(krealfp) temperature in Kelvin
  401. !
  402. ! Output argument list:
  403. ! fpvslq Real(krealfp) saturation vapor pressure in Pascals
  404. !
  405. ! Attributes:
  406. ! Language: Fortran 90.
  407. !
  408. !$$$
  409. implicit none
  410. real(krealfp) fpvslq
  411. real(krealfp),intent(in):: t
  412. integer jx
  413. real(krealfp) xj,dxj,fj1,fj2,fj3
  414. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  415. xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp))
  416. jx=min(max(nint(xj),2),nxpvsl-1)
  417. dxj=xj-jx
  418. fj1=tbpvsl(jx-1)
  419. fj2=tbpvsl(jx)
  420. fj3=tbpvsl(jx+1)
  421. fpvslq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2
  422. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  423. end function
  424. !-------------------------------------------------------------------------------
  425. ! elemental function fpvslx(t)
  426. function fpvslx(t)
  427. !$$$ Subprogram Documentation Block
  428. !
  429. ! Subprogram: fpvslx Compute saturation vapor pressure over liquid
  430. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  431. !
  432. ! Abstract: Exactly compute saturation vapor pressure from temperature.
  433. ! The water model assumes a perfect gas, constant specific heats
  434. ! for gas and liquid, and neglects the volume of the liquid.
  435. ! The model does account for the variation of the latent heat
  436. ! of condensation with temperature. The ice option is not included.
  437. ! The Clausius-Clapeyron equation is integrated from the triple point
  438. ! to get the formula
  439. ! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr))
  440. ! where tr is ttp/t and other values are physical constants.
  441. ! This function should be expanded inline in the calling routine.
  442. !
  443. ! Program History Log:
  444. ! 91-05-07 Iredell made into inlinable function
  445. ! 94-12-30 Iredell exact computation
  446. ! 1999-03-01 Iredell f90 module
  447. !
  448. ! Usage: pvsl=fpvslx(t)
  449. !
  450. ! Input argument list:
  451. ! t Real(krealfp) temperature in Kelvin
  452. !
  453. ! Output argument list:
  454. ! fpvslx Real(krealfp) saturation vapor pressure in Pascals
  455. !
  456. ! Attributes:
  457. ! Language: Fortran 90.
  458. !
  459. !$$$
  460. implicit none
  461. real(krealfp) fpvslx
  462. real(krealfp),intent(in):: t
  463. real(krealfp),parameter:: dldt=con_cvap-con_cliq
  464. real(krealfp),parameter:: heat=con_hvap
  465. real(krealfp),parameter:: xpona=-dldt/con_rv
  466. real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp)
  467. real(krealfp) tr
  468. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  469. tr=con_ttp/t
  470. fpvslx=con_psat*(tr**xpona)*exp(xponb*(1.-tr))
  471. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  472. end function
  473. !-------------------------------------------------------------------------------
  474. subroutine gpvsi
  475. !$$$ Subprogram Documentation Block
  476. !
  477. ! Subprogram: gpvsi Compute saturation vapor pressure table over ice
  478. ! Author: N Phillips W/NMC2X2 Date: 30 dec 82
  479. !
  480. ! Abstract: Computes saturation vapor pressure table as a function of
  481. ! temperature for the table lookup function fpvsi.
  482. ! Exact saturation vapor pressures are calculated in subprogram fpvsix.
  483. ! The current implementation computes a table with a length
  484. ! of 7501 for temperatures ranging from 180. to 330. Kelvin.
  485. !
  486. ! Program History Log:
  487. ! 91-05-07 Iredell
  488. ! 94-12-30 Iredell expand table
  489. ! 1999-03-01 Iredell f90 module
  490. ! 2001-02-26 Iredell ice phase
  491. !
  492. ! Usage: call gpvsi
  493. !
  494. ! Subprograms called:
  495. ! (fpvsix) inlinable function to compute saturation vapor pressure
  496. !
  497. ! Attributes:
  498. ! Language: Fortran 90.
  499. !
  500. !$$$
  501. implicit none
  502. integer jx
  503. real(krealfp) xmin,xmax,xinc,x,t
  504. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  505. xmin=180.0_krealfp
  506. xmax=330.0_krealfp
  507. xinc=(xmax-xmin)/(nxpvsi-1)
  508. ! c1xpvsi=1.-xmin/xinc
  509. c2xpvsi=1./xinc
  510. c1xpvsi=1.-xmin*c2xpvsi
  511. do jx=1,nxpvsi
  512. x=xmin+(jx-1)*xinc
  513. t=x
  514. tbpvsi(jx)=fpvsix(t)
  515. enddo
  516. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  517. end subroutine
  518. !-------------------------------------------------------------------------------
  519. ! elemental function fpvsi(t)
  520. function fpvsi(t)
  521. !$$$ Subprogram Documentation Block
  522. !
  523. ! Subprogram: fpvsi Compute saturation vapor pressure over ice
  524. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  525. !
  526. ! Abstract: Compute saturation vapor pressure from the temperature.
  527. ! A linear interpolation is done between values in a lookup table
  528. ! computed in gpvsi. See documentation for fpvsix for details.
  529. ! Input values outside table range are reset to table extrema.
  530. ! The interpolation accuracy is almost 6 decimal places.
  531. ! On the Cray, fpvsi is about 4 times faster than exact calculation.
  532. ! This function should be expanded inline in the calling routine.
  533. !
  534. ! Program History Log:
  535. ! 91-05-07 Iredell made into inlinable function
  536. ! 94-12-30 Iredell expand table
  537. ! 1999-03-01 Iredell f90 module
  538. ! 2001-02-26 Iredell ice phase
  539. !
  540. ! Usage: pvsi=fpvsi(t)
  541. !
  542. ! Input argument list:
  543. ! t Real(krealfp) temperature in Kelvin
  544. !
  545. ! Output argument list:
  546. ! fpvsi Real(krealfp) saturation vapor pressure in Pascals
  547. !
  548. ! Attributes:
  549. ! Language: Fortran 90.
  550. !
  551. !$$$
  552. implicit none
  553. real(krealfp) fpvsi
  554. real(krealfp),intent(in):: t
  555. integer jx
  556. real(krealfp) xj
  557. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  558. xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp))
  559. jx=min(xj,nxpvsi-1._krealfp)
  560. fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx))
  561. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  562. end function
  563. !-------------------------------------------------------------------------------
  564. ! elemental function fpvsiq(t)
  565. function fpvsiq(t)
  566. !$$$ Subprogram Documentation Block
  567. !
  568. ! Subprogram: fpvsiq Compute saturation vapor pressure over ice
  569. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  570. !
  571. ! Abstract: Compute saturation vapor pressure from the temperature.
  572. ! A quadratic interpolation is done between values in a lookup table
  573. ! computed in gpvsi. See documentation for fpvsix for details.
  574. ! Input values outside table range are reset to table extrema.
  575. ! The interpolation accuracy is almost 9 decimal places.
  576. ! On the Cray, fpvsiq is about 3 times faster than exact calculation.
  577. ! This function should be expanded inline in the calling routine.
  578. !
  579. ! Program History Log:
  580. ! 91-05-07 Iredell made into inlinable function
  581. ! 94-12-30 Iredell quadratic interpolation
  582. ! 1999-03-01 Iredell f90 module
  583. ! 2001-02-26 Iredell ice phase
  584. !
  585. ! Usage: pvsi=fpvsiq(t)
  586. !
  587. ! Input argument list:
  588. ! t Real(krealfp) temperature in Kelvin
  589. !
  590. ! Output argument list:
  591. ! fpvsiq Real(krealfp) saturation vapor pressure in Pascals
  592. !
  593. ! Attributes:
  594. ! Language: Fortran 90.
  595. !
  596. !$$$
  597. implicit none
  598. real(krealfp) fpvsiq
  599. real(krealfp),intent(in):: t
  600. integer jx
  601. real(krealfp) xj,dxj,fj1,fj2,fj3
  602. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  603. xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp))
  604. jx=min(max(nint(xj),2),nxpvsi-1)
  605. dxj=xj-jx
  606. fj1=tbpvsi(jx-1)
  607. fj2=tbpvsi(jx)
  608. fj3=tbpvsi(jx+1)
  609. fpvsiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2
  610. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  611. end function
  612. !-------------------------------------------------------------------------------
  613. ! elemental function fpvsix(t)
  614. function fpvsix(t)
  615. !$$$ Subprogram Documentation Block
  616. !
  617. ! Subprogram: fpvsix Compute saturation vapor pressure over ice
  618. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  619. !
  620. ! Abstract: Exactly compute saturation vapor pressure from temperature.
  621. ! The water model assumes a perfect gas, constant specific heats
  622. ! for gas and ice, and neglects the volume of the ice.
  623. ! The model does account for the variation of the latent heat
  624. ! of condensation with temperature. The liquid option is not included.
  625. ! The Clausius-Clapeyron equation is integrated from the triple point
  626. ! to get the formula
  627. ! pvsi=con_psat*(tr**xa)*exp(xb*(1.-tr))
  628. ! where tr is ttp/t and other values are physical constants.
  629. ! This function should be expanded inline in the calling routine.
  630. !
  631. ! Program History Log:
  632. ! 91-05-07 Iredell made into inlinable function
  633. ! 94-12-30 Iredell exact computation
  634. ! 1999-03-01 Iredell f90 module
  635. ! 2001-02-26 Iredell ice phase
  636. !
  637. ! Usage: pvsi=fpvsix(t)
  638. !
  639. ! Input argument list:
  640. ! t Real(krealfp) temperature in Kelvin
  641. !
  642. ! Output argument list:
  643. ! fpvsix Real(krealfp) saturation vapor pressure in Pascals
  644. !
  645. ! Attributes:
  646. ! Language: Fortran 90.
  647. !
  648. !$$$
  649. implicit none
  650. real(krealfp) fpvsix
  651. real(krealfp),intent(in):: t
  652. real(krealfp),parameter:: dldt=con_cvap-con_csol
  653. real(krealfp),parameter:: heat=con_hvap+con_hfus
  654. real(krealfp),parameter:: xpona=-dldt/con_rv
  655. real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp)
  656. real(krealfp) tr
  657. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  658. tr=con_ttp/t
  659. fpvsix=con_psat*(tr**xpona)*exp(xponb*(1.-tr))
  660. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  661. end function
  662. !-------------------------------------------------------------------------------
  663. subroutine gpvs
  664. !$$$ Subprogram Documentation Block
  665. !
  666. ! Subprogram: gpvs Compute saturation vapor pressure table
  667. ! Author: N Phillips W/NMC2X2 Date: 30 dec 82
  668. !
  669. ! Abstract: Computes saturation vapor pressure table as a function of
  670. ! temperature for the table lookup function fpvs.
  671. ! Exact saturation vapor pressures are calculated in subprogram fpvsx.
  672. ! The current implementation computes a table with a length
  673. ! of 7501 for temperatures ranging from 180. to 330. Kelvin.
  674. !
  675. ! Program History Log:
  676. ! 91-05-07 Iredell
  677. ! 94-12-30 Iredell expand table
  678. ! 1999-03-01 Iredell f90 module
  679. ! 2001-02-26 Iredell ice phase
  680. !
  681. ! Usage: call gpvs
  682. !
  683. ! Subprograms called:
  684. ! (fpvsx) inlinable function to compute saturation vapor pressure
  685. !
  686. ! Attributes:
  687. ! Language: Fortran 90.
  688. !
  689. !$$$
  690. implicit none
  691. integer jx
  692. real(krealfp) xmin,xmax,xinc,x,t
  693. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  694. xmin=180.0_krealfp
  695. xmax=330.0_krealfp
  696. xinc=(xmax-xmin)/(nxpvs-1)
  697. ! c1xpvs=1.-xmin/xinc
  698. c2xpvs=1./xinc
  699. c1xpvs=1.-xmin*c2xpvs
  700. do jx=1,nxpvs
  701. x=xmin+(jx-1)*xinc
  702. t=x
  703. tbpvs(jx)=fpvsx(t)
  704. enddo
  705. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  706. end subroutine
  707. !-------------------------------------------------------------------------------
  708. ! elemental function fpvs(t)
  709. function fpvs(t)
  710. !$$$ Subprogram Documentation Block
  711. !
  712. ! Subprogram: fpvs Compute saturation vapor pressure
  713. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  714. !
  715. ! Abstract: Compute saturation vapor pressure from the temperature.
  716. ! A linear interpolation is done between values in a lookup table
  717. ! computed in gpvs. See documentation for fpvsx for details.
  718. ! Input values outside table range are reset to table extrema.
  719. ! The interpolation accuracy is almost 6 decimal places.
  720. ! On the Cray, fpvs is about 4 times faster than exact calculation.
  721. ! This function should be expanded inline in the calling routine.
  722. !
  723. ! Program History Log:
  724. ! 91-05-07 Iredell made into inlinable function
  725. ! 94-12-30 Iredell expand table
  726. ! 1999-03-01 Iredell f90 module
  727. ! 2001-02-26 Iredell ice phase
  728. !
  729. ! Usage: pvs=fpvs(t)
  730. !
  731. ! Input argument list:
  732. ! t Real(krealfp) temperature in Kelvin
  733. !
  734. ! Output argument list:
  735. ! fpvs Real(krealfp) saturation vapor pressure in Pascals
  736. !
  737. ! Attributes:
  738. ! Language: Fortran 90.
  739. !
  740. !$$$
  741. implicit none
  742. real(krealfp) fpvs
  743. real(krealfp),intent(in):: t
  744. integer jx
  745. real(krealfp) xj
  746. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  747. xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp))
  748. jx=min(xj,nxpvs-1._krealfp)
  749. fpvs=tbpvs(jx)+(xj-jx)*(tbpvs(jx+1)-tbpvs(jx))
  750. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  751. end function
  752. !-------------------------------------------------------------------------------
  753. ! elemental function fpvsq(t)
  754. function fpvsq(t)
  755. !$$$ Subprogram Documentation Block
  756. !
  757. ! Subprogram: fpvsq Compute saturation vapor pressure
  758. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  759. !
  760. ! Abstract: Compute saturation vapor pressure from the temperature.
  761. ! A quadratic interpolation is done between values in a lookup table
  762. ! computed in gpvs. See documentation for fpvsx for details.
  763. ! Input values outside table range are reset to table extrema.
  764. ! The interpolation accuracy is almost 9 decimal places.
  765. ! On the Cray, fpvsq is about 3 times faster than exact calculation.
  766. ! This function should be expanded inline in the calling routine.
  767. !
  768. ! Program History Log:
  769. ! 91-05-07 Iredell made into inlinable function
  770. ! 94-12-30 Iredell quadratic interpolation
  771. ! 1999-03-01 Iredell f90 module
  772. ! 2001-02-26 Iredell ice phase
  773. !
  774. ! Usage: pvs=fpvsq(t)
  775. !
  776. ! Input argument list:
  777. ! t Real(krealfp) temperature in Kelvin
  778. !
  779. ! Output argument list:
  780. ! fpvsq Real(krealfp) saturation vapor pressure in Pascals
  781. !
  782. ! Attributes:
  783. ! Language: Fortran 90.
  784. !
  785. !$$$
  786. implicit none
  787. real(krealfp) fpvsq
  788. real(krealfp),intent(in):: t
  789. integer jx
  790. real(krealfp) xj,dxj,fj1,fj2,fj3
  791. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  792. xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp))
  793. jx=min(max(nint(xj),2),nxpvs-1)
  794. dxj=xj-jx
  795. fj1=tbpvs(jx-1)
  796. fj2=tbpvs(jx)
  797. fj3=tbpvs(jx+1)
  798. fpvsq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2
  799. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  800. end function
  801. !-------------------------------------------------------------------------------
  802. ! elemental function fpvsx(t)
  803. function fpvsx(t)
  804. !$$$ Subprogram Documentation Block
  805. !
  806. ! Subprogram: fpvsx Compute saturation vapor pressure
  807. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  808. !
  809. ! Abstract: Exactly compute saturation vapor pressure from temperature.
  810. ! The saturation vapor pressure over either liquid and ice is computed
  811. ! over liquid for temperatures above the triple point,
  812. ! over ice for temperatures 20 degress below the triple point,
  813. ! and a linear combination of the two for temperatures in between.
  814. ! The water model assumes a perfect gas, constant specific heats
  815. ! for gas, liquid and ice, and neglects the volume of the condensate.
  816. ! The model does account for the variation of the latent heat
  817. ! of condensation and sublimation with temperature.
  818. ! The Clausius-Clapeyron equation is integrated from the triple point
  819. ! to get the formula
  820. ! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr))
  821. ! where tr is ttp/t and other values are physical constants.
  822. ! The reference for this computation is Emanuel(1994), pages 116-117.
  823. ! This function should be expanded inline in the calling routine.
  824. !
  825. ! Program History Log:
  826. ! 91-05-07 Iredell made into inlinable function
  827. ! 94-12-30 Iredell exact computation
  828. ! 1999-03-01 Iredell f90 module
  829. ! 2001-02-26 Iredell ice phase
  830. !
  831. ! Usage: pvs=fpvsx(t)
  832. !
  833. ! Input argument list:
  834. ! t Real(krealfp) temperature in Kelvin
  835. !
  836. ! Output argument list:
  837. ! fpvsx Real(krealfp) saturation vapor pressure in Pascals
  838. !
  839. ! Attributes:
  840. ! Language: Fortran 90.
  841. !
  842. !$$$
  843. implicit none
  844. real(krealfp) fpvsx
  845. real(krealfp),intent(in):: t
  846. real(krealfp),parameter:: tliq=con_ttp
  847. real(krealfp),parameter:: tice=con_ttp-20.0
  848. real(krealfp),parameter:: dldtl=con_cvap-con_cliq
  849. real(krealfp),parameter:: heatl=con_hvap
  850. real(krealfp),parameter:: xponal=-dldtl/con_rv
  851. real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp)
  852. real(krealfp),parameter:: dldti=con_cvap-con_csol
  853. real(krealfp),parameter:: heati=con_hvap+con_hfus
  854. real(krealfp),parameter:: xponai=-dldti/con_rv
  855. real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp)
  856. real(krealfp) tr,w,pvl,pvi
  857. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  858. tr=con_ttp/t
  859. if(t.ge.tliq) then
  860. fpvsx=con_psat*(tr**xponal)*exp(xponbl*(1.-tr))
  861. elseif(t.lt.tice) then
  862. fpvsx=con_psat*(tr**xponai)*exp(xponbi*(1.-tr))
  863. else
  864. w=(t-tice)/(tliq-tice)
  865. pvl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr))
  866. pvi=con_psat*(tr**xponai)*exp(xponbi*(1.-tr))
  867. fpvsx=w*pvl+(1.-w)*pvi
  868. endif
  869. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  870. end function
  871. !-------------------------------------------------------------------------------
  872. subroutine gtdpl
  873. !$$$ Subprogram Documentation Block
  874. !
  875. ! Subprogram: gtdpl Compute dewpoint temperature over liquid table
  876. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  877. !
  878. ! Abstract: Compute dewpoint temperature table as a function of
  879. ! vapor pressure for inlinable function ftdpl.
  880. ! Exact dewpoint temperatures are calculated in subprogram ftdplxg.
  881. ! The current implementation computes a table with a length
  882. ! of 5001 for vapor pressures ranging from 1 to 10001 Pascals
  883. ! giving a dewpoint temperature range of 208 to 319 Kelvin.
  884. !
  885. ! Program History Log:
  886. ! 91-05-07 Iredell
  887. ! 94-12-30 Iredell expand table
  888. ! 1999-03-01 Iredell f90 module
  889. !
  890. ! Usage: call gtdpl
  891. !
  892. ! Subprograms called:
  893. ! (ftdplxg) inlinable function to compute dewpoint temperature over liquid
  894. !
  895. ! Attributes:
  896. ! Language: Fortran 90.
  897. !
  898. !$$$
  899. implicit none
  900. integer jx
  901. real(krealfp) xmin,xmax,xinc,t,x,pv
  902. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  903. xmin=1
  904. xmax=10001
  905. xinc=(xmax-xmin)/(nxtdpl-1)
  906. c1xtdpl=1.-xmin/xinc
  907. c2xtdpl=1./xinc
  908. t=208.0
  909. do jx=1,nxtdpl
  910. x=xmin+(jx-1)*xinc
  911. pv=x
  912. t=ftdplxg(t,pv)
  913. tbtdpl(jx)=t
  914. enddo
  915. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  916. end subroutine
  917. !-------------------------------------------------------------------------------
  918. ! elemental function ftdpl(pv)
  919. function ftdpl(pv)
  920. !$$$ Subprogram Documentation Block
  921. !
  922. ! Subprogram: ftdpl Compute dewpoint temperature over liquid
  923. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  924. !
  925. ! Abstract: Compute dewpoint temperature from vapor pressure.
  926. ! A linear interpolation is done between values in a lookup table
  927. ! computed in gtdpl. See documentation for ftdplxg for details.
  928. ! Input values outside table range are reset to table extrema.
  929. ! The interpolation accuracy is better than 0.0005 Kelvin
  930. ! for dewpoint temperatures greater than 250 Kelvin,
  931. ! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin.
  932. ! On the Cray, ftdpl is about 75 times faster than exact calculation.
  933. ! This function should be expanded inline in the calling routine.
  934. !
  935. ! Program History Log:
  936. ! 91-05-07 Iredell made into inlinable function
  937. ! 94-12-30 Iredell expand table
  938. ! 1999-03-01 Iredell f90 module
  939. !
  940. ! Usage: tdpl=ftdpl(pv)
  941. !
  942. ! Input argument list:
  943. ! pv Real(krealfp) vapor pressure in Pascals
  944. !
  945. ! Output argument list:
  946. ! ftdpl Real(krealfp) dewpoint temperature in Kelvin
  947. !
  948. ! Attributes:
  949. ! Language: Fortran 90.
  950. !
  951. !$$$
  952. implicit none
  953. real(krealfp) ftdpl
  954. real(krealfp),intent(in):: pv
  955. integer jx
  956. real(krealfp) xj
  957. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  958. xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp))
  959. jx=min(xj,nxtdpl-1._krealfp)
  960. ftdpl=tbtdpl(jx)+(xj-jx)*(tbtdpl(jx+1)-tbtdpl(jx))
  961. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  962. end function
  963. !-------------------------------------------------------------------------------
  964. ! elemental function ftdplq(pv)
  965. function ftdplq(pv)
  966. !$$$ Subprogram Documentation Block
  967. !
  968. ! Subprogram: ftdplq Compute dewpoint temperature over liquid
  969. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  970. !
  971. ! Abstract: Compute dewpoint temperature from vapor pressure.
  972. ! A quadratic interpolation is done between values in a lookup table
  973. ! computed in gtdpl. see documentation for ftdplxg for details.
  974. ! Input values outside table range are reset to table extrema.
  975. ! the interpolation accuracy is better than 0.00001 Kelvin
  976. ! for dewpoint temperatures greater than 250 Kelvin,
  977. ! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin.
  978. ! On the Cray, ftdplq is about 60 times faster than exact calculation.
  979. ! This function should be expanded inline in the calling routine.
  980. !
  981. ! Program History Log:
  982. ! 91-05-07 Iredell made into inlinable function
  983. ! 94-12-30 Iredell quadratic interpolation
  984. ! 1999-03-01 Iredell f90 module
  985. !
  986. ! Usage: tdpl=ftdplq(pv)
  987. !
  988. ! Input argument list:
  989. ! pv Real(krealfp) vapor pressure in Pascals
  990. !
  991. ! Output argument list:
  992. ! ftdplq Real(krealfp) dewpoint temperature in Kelvin
  993. !
  994. ! Attributes:
  995. ! Language: Fortran 90.
  996. !
  997. !$$$
  998. implicit none
  999. real(krealfp) ftdplq
  1000. real(krealfp),intent(in):: pv
  1001. integer jx
  1002. real(krealfp) xj,dxj,fj1,fj2,fj3
  1003. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1004. xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp))
  1005. jx=min(max(nint(xj),2),nxtdpl-1)
  1006. dxj=xj-jx
  1007. fj1=tbtdpl(jx-1)
  1008. fj2=tbtdpl(jx)
  1009. fj3=tbtdpl(jx+1)
  1010. ftdplq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2
  1011. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1012. end function
  1013. !-------------------------------------------------------------------------------
  1014. ! elemental function ftdplx(pv)
  1015. function ftdplx(pv)
  1016. !$$$ Subprogram Documentation Block
  1017. !
  1018. ! Subprogram: ftdplx Compute dewpoint temperature over liquid
  1019. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  1020. !
  1021. ! Abstract: exactly compute dewpoint temperature from vapor pressure.
  1022. ! An approximate dewpoint temperature for function ftdplxg
  1023. ! is obtained using ftdpl so gtdpl must be already called.
  1024. ! See documentation for ftdplxg for details.
  1025. !
  1026. ! Program History Log:
  1027. ! 91-05-07 Iredell made into inlinable function
  1028. ! 94-12-30 Iredell exact computation
  1029. ! 1999-03-01 Iredell f90 module
  1030. !
  1031. ! Usage: tdpl=ftdplx(pv)
  1032. !
  1033. ! Input argument list:
  1034. ! pv Real(krealfp) vapor pressure in Pascals
  1035. !
  1036. ! Output argument list:
  1037. ! ftdplx Real(krealfp) dewpoint temperature in Kelvin
  1038. !
  1039. ! Subprograms called:
  1040. ! (ftdpl) inlinable function to compute dewpoint temperature over liquid
  1041. ! (ftdplxg) inlinable function to compute dewpoint temperature over liquid
  1042. !
  1043. ! Attributes:
  1044. ! Language: Fortran 90.
  1045. !
  1046. !$$$
  1047. implicit none
  1048. real(krealfp) ftdplx
  1049. real(krealfp),intent(in):: pv
  1050. real(krealfp) tg
  1051. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1052. tg=ftdpl(pv)
  1053. ftdplx=ftdplxg(tg,pv)
  1054. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1055. end function
  1056. !-------------------------------------------------------------------------------
  1057. ! elemental function ftdplxg(tg,pv)
  1058. function ftdplxg(tg,pv)
  1059. !$$$ Subprogram Documentation Block
  1060. !
  1061. ! Subprogram: ftdplxg Compute dewpoint temperature over liquid
  1062. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  1063. !
  1064. ! Abstract: Exactly compute dewpoint temperature from vapor pressure.
  1065. ! A guess dewpoint temperature must be provided.
  1066. ! The water model assumes a perfect gas, constant specific heats
  1067. ! for gas and liquid, and neglects the volume of the liquid.
  1068. ! The model does account for the variation of the latent heat
  1069. ! of condensation with temperature. The ice option is not included.
  1070. ! The Clausius-Clapeyron equation is integrated from the triple point
  1071. ! to get the formula
  1072. ! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr))
  1073. ! where tr is ttp/t and other values are physical constants.
  1074. ! The formula is inverted by iterating Newtonian approximations
  1075. ! for each pvs until t is found to within 1.e-6 Kelvin.
  1076. ! This function can be expanded inline in the calling routine.
  1077. !
  1078. ! Program History Log:
  1079. ! 91-05-07 Iredell made into inlinable function
  1080. ! 94-12-30 Iredell exact computation
  1081. ! 1999-03-01 Iredell f90 module
  1082. !
  1083. ! Usage: tdpl=ftdplxg(tg,pv)
  1084. !
  1085. ! Input argument list:
  1086. ! tg Real(krealfp) guess dewpoint temperature in Kelvin
  1087. ! pv Real(krealfp) vapor pressure in Pascals
  1088. !
  1089. ! Output argument list:
  1090. ! ftdplxg Real(krealfp) dewpoint temperature in Kelvin
  1091. !
  1092. ! Attributes:
  1093. ! Language: Fortran 90.
  1094. !
  1095. !$$$
  1096. implicit none
  1097. real(krealfp) ftdplxg
  1098. real(krealfp),intent(in):: tg,pv
  1099. real(krealfp),parameter:: terrm=1.e-6
  1100. real(krealfp),parameter:: dldt=con_cvap-con_cliq
  1101. real(krealfp),parameter:: heat=con_hvap
  1102. real(krealfp),parameter:: xpona=-dldt/con_rv
  1103. real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp)
  1104. real(krealfp) t,tr,pvt,el,dpvt,terr
  1105. integer i
  1106. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1107. t=tg
  1108. do i=1,100
  1109. tr=con_ttp/t
  1110. pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr))
  1111. el=heat+dldt*(t-con_ttp)
  1112. dpvt=el*pvt/(con_rv*t**2)
  1113. terr=(pvt-pv)/dpvt
  1114. t=t-terr
  1115. if(abs(terr).le.terrm) exit
  1116. enddo
  1117. ftdplxg=t
  1118. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1119. end function
  1120. !-------------------------------------------------------------------------------
  1121. subroutine gtdpi
  1122. !$$$ Subprogram Documentation Block
  1123. !
  1124. ! Subprogram: gtdpi Compute dewpoint temperature over ice table
  1125. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  1126. !
  1127. ! Abstract: Compute dewpoint temperature table as a function of
  1128. ! vapor pressure for inlinable function ftdpi.
  1129. ! Exact dewpoint temperatures are calculated in subprogram ftdpixg.
  1130. ! The current implementation computes a table with a length
  1131. ! of 5001 for vapor pressures ranging from 0.1 to 1000.1 Pascals
  1132. ! giving a dewpoint temperature range of 197 to 279 Kelvin.
  1133. !
  1134. ! Program History Log:
  1135. ! 91-05-07 Iredell
  1136. ! 94-12-30 Iredell expand table
  1137. ! 1999-03-01 Iredell f90 module
  1138. ! 2001-02-26 Iredell ice phase
  1139. !
  1140. ! Usage: call gtdpi
  1141. !
  1142. ! Subprograms called:
  1143. ! (ftdpixg) inlinable function to compute dewpoint temperature over ice
  1144. !
  1145. ! Attributes:
  1146. ! Language: Fortran 90.
  1147. !
  1148. !$$$
  1149. implicit none
  1150. integer jx
  1151. real(krealfp) xmin,xmax,xinc,t,x,pv
  1152. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1153. xmin=0.1
  1154. xmax=1000.1
  1155. xinc=(xmax-xmin)/(nxtdpi-1)
  1156. c1xtdpi=1.-xmin/xinc
  1157. c2xtdpi=1./xinc
  1158. t=197.0
  1159. do jx=1,nxtdpi
  1160. x=xmin+(jx-1)*xinc
  1161. pv=x
  1162. t=ftdpixg(t,pv)
  1163. tbtdpi(jx)=t
  1164. enddo
  1165. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1166. end subroutine
  1167. !-------------------------------------------------------------------------------
  1168. ! elemental function ftdpi(pv)
  1169. function ftdpi(pv)
  1170. !$$$ Subprogram Documentation Block
  1171. !
  1172. ! Subprogram: ftdpi Compute dewpoint temperature over ice
  1173. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  1174. !
  1175. ! Abstract: Compute dewpoint temperature from vapor pressure.
  1176. ! A linear interpolation is done between values in a lookup table
  1177. ! computed in gtdpi. See documentation for ftdpixg for details.
  1178. ! Input values outside table range are reset to table extrema.
  1179. ! The interpolation accuracy is better than 0.0005 Kelvin
  1180. ! for dewpoint temperatures greater than 250 Kelvin,
  1181. ! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin.
  1182. ! On the Cray, ftdpi is about 75 times faster than exact calculation.
  1183. ! This function should be expanded inline in the calling routine.
  1184. !
  1185. ! Program History Log:
  1186. ! 91-05-07 Iredell made into inlinable function
  1187. ! 94-12-30 Iredell expand table
  1188. ! 1999-03-01 Iredell f90 module
  1189. ! 2001-02-26 Iredell ice phase
  1190. !
  1191. ! Usage: tdpi=ftdpi(pv)
  1192. !
  1193. ! Input argument list:
  1194. ! pv Real(krealfp) vapor pressure in Pascals
  1195. !
  1196. ! Output argument list:
  1197. ! ftdpi Real(krealfp) dewpoint temperature in Kelvin
  1198. !
  1199. ! Attributes:
  1200. ! Language: Fortran 90.
  1201. !
  1202. !$$$
  1203. implicit none
  1204. real(krealfp) ftdpi
  1205. real(krealfp),intent(in):: pv
  1206. integer jx
  1207. real(krealfp) xj
  1208. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1209. xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp))
  1210. jx=min(xj,nxtdpi-1._krealfp)
  1211. ftdpi=tbtdpi(jx)+(xj-jx)*(tbtdpi(jx+1)-tbtdpi(jx))
  1212. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1213. end function
  1214. !-------------------------------------------------------------------------------
  1215. ! elemental function ftdpiq(pv)
  1216. function ftdpiq(pv)
  1217. !$$$ Subprogram Documentation Block
  1218. !
  1219. ! Subprogram: ftdpiq Compute dewpoint temperature over ice
  1220. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  1221. !
  1222. ! Abstract: Compute dewpoint temperature from vapor pressure.
  1223. ! A quadratic interpolation is done between values in a lookup table
  1224. ! computed in gtdpi. see documentation for ftdpixg for details.
  1225. ! Input values outside table range are reset to table extrema.
  1226. ! the interpolation accuracy is better than 0.00001 Kelvin
  1227. ! for dewpoint temperatures greater than 250 Kelvin,
  1228. ! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin.
  1229. ! On the Cray, ftdpiq is about 60 times faster than exact calculation.
  1230. ! This function should be expanded inline in the calling routine.
  1231. !
  1232. ! Program History Log:
  1233. ! 91-05-07 Iredell made into inlinable function
  1234. ! 94-12-30 Iredell quadratic interpolation
  1235. ! 1999-03-01 Iredell f90 module
  1236. ! 2001-02-26 Iredell ice phase
  1237. !
  1238. ! Usage: tdpi=ftdpiq(pv)
  1239. !
  1240. ! Input argument list:
  1241. ! pv Real(krealfp) vapor pressure in Pascals
  1242. !
  1243. ! Output argument list:
  1244. ! ftdpiq Real(krealfp) dewpoint temperature in Kelvin
  1245. !
  1246. ! Attributes:
  1247. ! Language: Fortran 90.
  1248. !
  1249. !$$$
  1250. implicit none
  1251. real(krealfp) ftdpiq
  1252. real(krealfp),intent(in):: pv
  1253. integer jx
  1254. real(krealfp) xj,dxj,fj1,fj2,fj3
  1255. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1256. xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp))
  1257. jx=min(max(nint(xj),2),nxtdpi-1)
  1258. dxj=xj-jx
  1259. fj1=tbtdpi(jx-1)
  1260. fj2=tbtdpi(jx)
  1261. fj3=tbtdpi(jx+1)
  1262. ftdpiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2
  1263. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1264. end function
  1265. !-------------------------------------------------------------------------------
  1266. ! elemental function ftdpix(pv)
  1267. function ftdpix(pv)
  1268. !$$$ Subprogram Documentation Block
  1269. !
  1270. ! Subprogram: ftdpix Compute dewpoint temperature over ice
  1271. ! Author: N Phillips w/NMC2X2 Date: 30 dec 82
  1272. !
  1273. ! Abstract: exactly compute dewpoint temperature from vapor pressure.
  1274. ! An approximate dewpoint temperature for function ftdpixg
  1275. ! is obtained using ftdpi so gtdpi must be already called.
  1276. ! See documentation for ftdpixg for details.
  1277. !
  1278. ! Program History Log:
  1279. ! 91-05-07 Iredell

Large files files are truncated, but you can click here to view the full file