Line data Source code
1 : module pkg_cldoptics
2 :
3 : !---------------------------------------------------------------------------------
4 : ! Purpose:
5 : !
6 : ! Compute cloud optical properties: liquid and ice partical size; emissivity
7 : !
8 : ! Author: Byron Boville Sept 06, 2002, assembled from existing subroutines
9 : !
10 : !---------------------------------------------------------------------------------
11 :
12 : use shr_kind_mod, only: r8=>shr_kind_r8
13 : use ppgrid, only: pcols, pver, pverp
14 :
15 : implicit none
16 : private
17 : save
18 :
19 : public :: cldefr, cldems, cldovrlap, cldclw, reitab, reltab
20 :
21 : contains
22 :
23 : !===============================================================================
24 0 : subroutine cldefr(lchnk ,ncol , &
25 : landfrac,t ,rel ,rei ,ps ,pmid , landm, icefrac, snowh)
26 : !-----------------------------------------------------------------------
27 : !
28 : ! Purpose:
29 : ! Compute cloud water and ice particle size
30 : !
31 : ! Method:
32 : ! use empirical formulas to construct effective radii
33 : !
34 : ! Author: J.T. Kiehl, B. A. Boville, P. Rasch
35 : !
36 : !-----------------------------------------------------------------------
37 :
38 : !------------------------------Arguments--------------------------------
39 : !
40 : ! Input arguments
41 : !
42 : integer, intent(in) :: lchnk ! chunk identifier
43 : integer, intent(in) :: ncol ! number of atmospheric columns
44 :
45 : real(r8), intent(in) :: landfrac(pcols) ! Land fraction
46 : real(r8), intent(in) :: icefrac(pcols) ! Ice fraction
47 : real(r8), intent(in) :: t(pcols,pver) ! Temperature
48 : real(r8), intent(in) :: ps(pcols) ! Surface pressure
49 : real(r8), intent(in) :: pmid(pcols,pver) ! Midpoint pressures
50 : real(r8), intent(in) :: landm(pcols)
51 : real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
52 : !
53 : ! Output arguments
54 : !
55 : real(r8), intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
56 : real(r8), intent(out) :: rei(pcols,pver) ! Ice effective drop size (microns)
57 : !
58 : ! following Kiehl
59 0 : call reltab(ncol, t, landfrac, landm, icefrac, rel, snowh)
60 :
61 : ! following Kristjansson and Mitchell
62 0 : call reitab(ncol, t, rei)
63 :
64 0 : return
65 : end subroutine cldefr
66 :
67 : !===============================================================================
68 0 : subroutine cldems(lchnk ,ncol ,clwp ,fice ,rei ,emis ,cldtau)
69 : !-----------------------------------------------------------------------
70 : !
71 : ! Purpose:
72 : ! Compute cloud emissivity using cloud liquid water path (g/m**2)
73 : !
74 : ! Method:
75 : ! <Describe the algorithm(s) used in the routine.>
76 : ! <Also include any applicable external references.>
77 : !
78 : ! Author: J.T. Kiehl
79 : !
80 : !-----------------------------------------------------------------------
81 :
82 : use phys_control, only: phys_getopts
83 :
84 : !------------------------------Parameters-------------------------------
85 : !
86 : real(r8) kabsl ! longwave liquid absorption coeff (m**2/g)
87 : parameter (kabsl = 0.090361_r8)
88 : !
89 : !------------------------------Arguments--------------------------------
90 : !
91 : ! Input arguments
92 : !
93 : integer, intent(in) :: lchnk ! chunk identifier
94 : integer, intent(in) :: ncol ! number of atmospheric columns
95 :
96 : real(r8), intent(in) :: clwp(pcols,pver) ! cloud liquid water path (g/m**2)
97 : real(r8), intent(in) :: rei(pcols,pver) ! ice effective drop size (microns)
98 : real(r8), intent(in) :: fice(pcols,pver) ! fractional ice content within cloud
99 : !
100 : ! Output arguments
101 : !
102 : real(r8), intent(out) :: emis(pcols,pver) ! cloud emissivity (fraction)
103 : real(r8), intent(out) :: cldtau(pcols,pver) ! cloud optical depth
104 : !
105 : !---------------------------Local workspace-----------------------------
106 : !
107 : integer i,k ! longitude, level indices
108 : real(r8) kabs ! longwave absorption coeff (m**2/g)
109 : real(r8) kabsi ! ice absorption coefficient
110 :
111 : character(len=16) :: microp_scheme ! microphysics scheme
112 : !-----------------------------------------------------------------------
113 : !
114 0 : call phys_getopts(microp_scheme_out=microp_scheme)
115 :
116 0 : do k=1,pver
117 0 : do i=1,ncol
118 :
119 : !note that optical properties for ice valid only
120 : !in range of 13 > rei > 130 micron (Ebert and Curry 92)
121 0 : if ( microp_scheme == 'RK' .or. microp_scheme == 'SPCAM_sam1mom') then
122 0 : kabsi = 0.005_r8 + 1._r8/rei(i,k)
123 : else
124 0 : kabsi = 0.005_r8 + 1._r8/min(max(13._r8,rei(i,k)),130._r8)
125 : end if
126 0 : kabs = kabsl*(1._r8-fice(i,k)) + kabsi*fice(i,k)
127 0 : emis(i,k) = 1._r8 - exp(-1.66_r8*kabs*clwp(i,k))
128 0 : cldtau(i,k) = kabs*clwp(i,k)
129 : end do
130 : end do
131 : !
132 0 : return
133 : end subroutine cldems
134 :
135 : !===============================================================================
136 1489176 : subroutine cldovrlap(lchnk ,ncol ,pint ,cld ,nmxrgn ,pmxrgn )
137 : !-----------------------------------------------------------------------
138 : !
139 : ! Purpose:
140 : ! Partitions each column into regions with clouds in neighboring layers.
141 : ! This information is used to implement maximum overlap in these regions
142 : ! with random overlap between them.
143 : ! On output,
144 : ! nmxrgn contains the number of regions in each column
145 : ! pmxrgn contains the interface pressures for the lower boundaries of
146 : ! each region!
147 : ! Method:
148 :
149 : !
150 : ! Author: W. Collins
151 : !
152 : !-----------------------------------------------------------------------
153 :
154 : !
155 : ! Input arguments
156 : !
157 : integer, intent(in) :: lchnk ! chunk identifier
158 : integer, intent(in) :: ncol ! number of atmospheric columns
159 :
160 : real(r8), intent(in) :: pint(pcols,pverp) ! Interface pressure
161 : real(r8), intent(in) :: cld(pcols,pver) ! Fractional cloud cover
162 : !
163 : ! Output arguments
164 : !
165 : integer, intent(out) :: nmxrgn(pcols) ! Number of maximally overlapped regions
166 : real(r8), intent(out) :: pmxrgn(pcols,pverp)! Maximum values of pressure for each
167 : ! maximally overlapped region.
168 : ! 0->pmxrgn(i,1) is range of pressure for
169 : ! 1st region,pmxrgn(i,1)->pmxrgn(i,2) for
170 : ! 2nd region, etc
171 : !
172 : !---------------------------Local variables-----------------------------
173 : !
174 : integer i ! Longitude index
175 : integer k ! Level index
176 : integer n ! Max-overlap region counter
177 :
178 : real(r8) pnm(pcols,pverp) ! Interface pressure
179 :
180 : logical cld_found ! Flag for detection of cloud
181 : logical cld_layer(pver) ! Flag for cloud in layer
182 : !
183 : !------------------------------------------------------------------------
184 : !
185 :
186 24865776 : do i = 1, ncol
187 23376600 : cld_found = .false.
188 2197400400 : cld_layer(:) = cld(i,:) > 0.0_r8
189 2220777000 : pmxrgn(i,:) = 0.0_r8
190 2220777000 : pnm(i,:)=pint(i,:)*10._r8
191 : n = 1
192 2070211888 : do k = 1, pver
193 2086169820 : if (cld_layer(k) .and. .not. cld_found) then
194 : cld_found = .true.
195 2027583075 : else if ( .not. cld_layer(k) .and. cld_found) then
196 536403899 : cld_found = .false.
197 536403899 : if (count(cld_layer(k:pver)) == 0) then
198 : exit
199 : endif
200 13062811 : pmxrgn(i,n) = pnm(i,k)
201 13062811 : n = n + 1
202 : endif
203 : end do
204 23376600 : pmxrgn(i,n) = pnm(i,pverp)
205 24865776 : nmxrgn(i) = n
206 : end do
207 :
208 1489176 : return
209 : end subroutine cldovrlap
210 :
211 : !===============================================================================
212 1489176 : subroutine cldclw(lchnk ,ncol ,zi ,clwp ,tpw ,hl )
213 : !-----------------------------------------------------------------------
214 : !
215 : ! Purpose:
216 : ! Evaluate cloud liquid water path clwp (g/m**2)
217 : !
218 : ! Method:
219 : ! <Describe the algorithm(s) used in the routine.>
220 : ! <Also include any applicable external references.>
221 : !
222 : ! Author: J.T. Kiehl
223 : !
224 : !-----------------------------------------------------------------------
225 :
226 :
227 : !
228 : ! Input arguments
229 : !
230 : integer, intent(in) :: lchnk ! chunk identifier
231 : integer, intent(in) :: ncol ! number of atmospheric columns
232 :
233 : real(r8), intent(in) :: zi(pcols,pverp) ! height at layer interfaces(m)
234 : real(r8), intent(in) :: tpw(pcols) ! total precipitable water (mm)
235 : !
236 : ! Output arguments
237 : !
238 : real(r8), intent(out) :: clwp(pcols,pver) ! cloud liquid water path (g/m**2)
239 : real(r8), intent(out) :: hl(pcols) ! liquid water scale height
240 :
241 : !
242 : !---------------------------Local workspace-----------------------------
243 : !
244 : integer :: i,k ! longitude, level indices
245 : real(r8) :: clwc0 ! reference liquid water concentration (g/m**3)
246 : real(r8) :: emziohl(pcols,pverp) ! exp(-zi/hl)
247 : real(r8) :: rhl(pcols) ! 1/hl
248 : !
249 : !-----------------------------------------------------------------------
250 : !
251 : ! Set reference liquid water concentration
252 : !
253 1489176 : clwc0 = 0.21_r8
254 : !
255 : ! Diagnose liquid water scale height from precipitable water
256 : !
257 24865776 : do i=1,ncol
258 23376600 : hl(i) = 700.0_r8*log(max(tpw(i)+1.0_r8,1.0_r8))
259 24865776 : rhl(i) = 1.0_r8/hl(i)
260 : end do
261 : !
262 : ! Evaluate cloud liquid water path (vertical integral of exponential fn)
263 : !
264 141471720 : do k=1,pverp
265 2338872120 : do i=1,ncol
266 2337382944 : emziohl(i,k) = exp(-zi(i,k)*rhl(i))
267 : end do
268 : end do
269 139982544 : do k=1,pver
270 2314006344 : do i=1,ncol
271 2312517168 : clwp(i,k) = clwc0*hl(i)*(emziohl(i,k+1) - emziohl(i,k))
272 : end do
273 : end do
274 : !
275 1489176 : return
276 : end subroutine cldclw
277 :
278 :
279 : !===============================================================================
280 0 : subroutine reltab(ncol, t, landfrac, landm, icefrac, rel, snowh)
281 : !-----------------------------------------------------------------------
282 : !
283 : ! Purpose:
284 : ! Compute cloud water size
285 : !
286 : ! Method:
287 : ! analytic formula following the formulation originally developed by J. T. Kiehl
288 : !
289 : ! Author: Phil Rasch
290 : !
291 : !-----------------------------------------------------------------------
292 : use physconst, only: tmelt
293 : !------------------------------Arguments--------------------------------
294 : !
295 : ! Input arguments
296 : !
297 : integer, intent(in) :: ncol
298 : real(r8), intent(in) :: landfrac(pcols) ! Land fraction
299 : real(r8), intent(in) :: icefrac(pcols) ! Ice fraction
300 : real(r8), intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
301 : real(r8), intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean
302 : real(r8), intent(in) :: t(pcols,pver) ! Temperature
303 :
304 : !
305 : ! Output arguments
306 : !
307 : real(r8), intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
308 : !
309 : !---------------------------Local workspace-----------------------------
310 : !
311 : integer i,k ! Lon, lev indices
312 : real(r8) rliqland ! liquid drop size if over land
313 : real(r8) rliqocean ! liquid drop size if over ocean
314 : real(r8) rliqice ! liquid drop size if over sea ice
315 : !
316 : !-----------------------------------------------------------------------
317 : !
318 0 : rliqocean = 14.0_r8
319 0 : rliqice = 14.0_r8
320 0 : rliqland = 8.0_r8
321 0 : do k=1,pver
322 0 : do i=1,ncol
323 : ! jrm Reworked effective radius algorithm
324 : ! Start with temperature-dependent value appropriate for continental air
325 : ! Note: findmcnew has a pressure dependence here
326 0 : rel(i,k) = rliqland + (rliqocean-rliqland) * min(1.0_r8,max(0.0_r8,(tmelt-t(i,k))*0.05_r8))
327 : ! Modify for snow depth over land
328 0 : rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0_r8,max(0.0_r8,snowh(i)*10._r8))
329 : ! Ramp between polluted value over land to clean value over ocean.
330 0 : rel(i,k) = rel(i,k) + (rliqocean-rel(i,k)) * min(1.0_r8,max(0.0_r8,1.0_r8-landm(i)))
331 : ! Ramp between the resultant value and a sea ice value in the presence of ice.
332 0 : rel(i,k) = rel(i,k) + (rliqice-rel(i,k)) * min(1.0_r8,max(0.0_r8,icefrac(i)))
333 : ! end jrm
334 : end do
335 : end do
336 0 : end subroutine reltab
337 :
338 : !===============================================================================
339 0 : subroutine reitab(ncol, t, re)
340 :
341 : integer, intent(in) :: ncol
342 : real(r8), intent(out) :: re(pcols,pver)
343 : real(r8), intent(in) :: t(pcols,pver)
344 : integer , parameter :: len_retab = 138
345 : real(r8), parameter :: min_retab = 136._r8
346 : real(r8) retab(len_retab)
347 : real(r8) corr
348 : integer i
349 : integer k
350 : integer index
351 : !
352 : ! Tabulated values of re(T) in the temperature interval
353 : ! 180 K -- 274 K; hexagonal columns assumed:
354 : !
355 : ! Modified for pmc formation: 136K -- 274K
356 : !
357 : data retab / &
358 : 0.05_r8, 0.05_r8, 0.05_r8, 0.05_r8, 0.05_r8, 0.05_r8, &
359 : 0.055_r8, 0.06_r8, 0.07_r8, 0.08_r8, 0.09_r8, 0.1_r8, &
360 : 0.2_r8, 0.3_r8, 0.40_r8, 0.50_r8, 0.60_r8, 0.70_r8, &
361 : 0.8_r8 , 0.9_r8, 1.0_r8, 1.1_r8, 1.2_r8, 1.3_r8, &
362 : 1.4_r8, 1.5_r8, 1.6_r8, 1.8_r8, 2.0_r8, 2.2_r8, &
363 : 2.4_r8, 2.6_r8, 2.8_r8, 3.0_r8, 3.2_r8, 3.5_r8, &
364 : 3.8_r8, 4.1_r8, 4.4_r8, 4.7_r8, 5.0_r8, 5.3_r8, &
365 : 5.6_r8, &
366 : 5.92779_r8, 6.26422_r8, 6.61973_r8, 6.99539_r8, 7.39234_r8, &
367 : 7.81177_r8, 8.25496_r8, 8.72323_r8, 9.21800_r8, 9.74075_r8, 10.2930_r8, &
368 : 10.8765_r8, 11.4929_r8, 12.1440_r8, 12.8317_r8, 13.5581_r8, 14.2319_r8, &
369 : 15.0351_r8, 15.8799_r8, 16.7674_r8, 17.6986_r8, 18.6744_r8, 19.6955_r8, &
370 : 20.7623_r8, 21.8757_r8, 23.0364_r8, 24.2452_r8, 25.5034_r8, 26.8125_r8, &
371 : 27.7895_r8, 28.6450_r8, 29.4167_r8, 30.1088_r8, 30.7306_r8, 31.2943_r8, &
372 : 31.8151_r8, 32.3077_r8, 32.7870_r8, 33.2657_r8, 33.7540_r8, 34.2601_r8, &
373 : 34.7892_r8, 35.3442_r8, 35.9255_r8, 36.5316_r8, 37.1602_r8, 37.8078_r8, &
374 : 38.4720_r8, 39.1508_r8, 39.8442_r8, 40.5552_r8, 41.2912_r8, 42.0635_r8, &
375 : 42.8876_r8, 43.7863_r8, 44.7853_r8, 45.9170_r8, 47.2165_r8, 48.7221_r8, &
376 : 50.4710_r8, 52.4980_r8, 54.8315_r8, 57.4898_r8, 60.4785_r8, 63.7898_r8, &
377 : 65.5604_r8, 71.2885_r8, 75.4113_r8, 79.7368_r8, 84.2351_r8, 88.8833_r8, &
378 : 93.6658_r8, 98.5739_r8, 103.603_r8, 108.752_r8, 114.025_r8, 119.424_r8, &
379 : 124.954_r8, 130.630_r8, 136.457_r8, 142.446_r8, 148.608_r8, 154.956_r8, &
380 : 161.503_r8, 168.262_r8, 175.248_r8, 182.473_r8, 189.952_r8, 197.699_r8, &
381 : 205.728_r8, 214.055_r8, 222.694_r8, 231.661_r8, 240.971_r8, 250.639_r8/
382 : !
383 : save retab
384 : !
385 :
386 0 : do k=1,pver
387 0 : do i=1,ncol
388 0 : index = int(t(i,k)-min_retab)
389 0 : index = min(max(index,1),len_retab-1)
390 0 : corr = t(i,k) - int(t(i,k))
391 0 : re(i,k) = retab(index)*(1._r8-corr) &
392 0 : +retab(index+1)*corr
393 : ! re(i,k) = amax1(amin1(re(i,k),30.),10.)
394 : end do
395 : end do
396 : !
397 0 : return
398 : end subroutine reitab
399 :
400 : end module pkg_cldoptics
|
