Line data Source code
1 : module oldcloud_optics
2 :
3 : !------------------------------------------------------------------------------------------------
4 : !------------------------------------------------------------------------------------------------
5 :
6 : use shr_kind_mod, only: r8 => shr_kind_r8
7 : use ppgrid, only: pcols, pver, pverp
8 : use physics_types, only: physics_state
9 : use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field
10 : use constituents, only: cnst_get_ind
11 : use physconst, only: gravit
12 : use radconstants, only: nlwbands
13 : use ebert_curry_ice_optics, only: scalefactor
14 :
15 : use cam_abortutils, only: endrun
16 :
17 : implicit none
18 : private
19 : save
20 :
21 : public :: &
22 : oldcloud_init, &
23 : oldcloud_lw, &
24 : old_liq_get_rad_props_lw, &
25 : old_ice_get_rad_props_lw
26 :
27 : integer :: nmu, nlambda
28 : real(r8), allocatable :: g_mu(:) ! mu samples on grid
29 : real(r8), allocatable :: g_lambda(:,:) ! lambda scale samples on grid
30 : real(r8), allocatable :: ext_sw_liq(:,:,:)
31 : real(r8), allocatable :: ssa_sw_liq(:,:,:)
32 : real(r8), allocatable :: asm_sw_liq(:,:,:)
33 : real(r8), allocatable :: abs_lw_liq(:,:,:)
34 :
35 : integer :: n_g_d
36 : real(r8), allocatable :: g_d_eff(:) ! radiative effective diameter samples on grid
37 : real(r8), allocatable :: ext_sw_ice(:,:)
38 : real(r8), allocatable :: ssa_sw_ice(:,:)
39 : real(r8), allocatable :: asm_sw_ice(:,:)
40 : real(r8), allocatable :: abs_lw_ice(:,:)
41 :
42 : ! Minimum cloud amount (as a fraction of the grid-box area) to
43 : ! distinguish from clear sky
44 : real(r8), parameter :: cldmin = 1.0e-80_r8
45 :
46 : ! Decimal precision of cloud amount (0 -> preserve full resolution;
47 : ! 10^-n -> preserve n digits of cloud amount)
48 : real(r8), parameter :: cldeps = 0.0_r8
49 :
50 : ! indexes into pbuf
51 : integer :: iciwp_idx = 0
52 : integer :: iclwp_idx = 0
53 : integer :: cld_idx = 0
54 : integer :: rel_idx = 0
55 : integer :: rei_idx = 0
56 :
57 : ! indexes into constituents for old optics
58 : integer :: &
59 : ixcldice, & ! cloud ice water index
60 : ixcldliq ! cloud liquid water index
61 :
62 :
63 : !==============================================================================
64 : contains
65 : !==============================================================================
66 :
67 1536 : subroutine oldcloud_init()
68 :
69 :
70 : integer :: err
71 :
72 1536 : iciwp_idx = pbuf_get_index('ICIWP',errcode=err)
73 1536 : iclwp_idx = pbuf_get_index('ICLWP',errcode=err)
74 1536 : cld_idx = pbuf_get_index('CLD')
75 1536 : rel_idx = pbuf_get_index('REL')
76 1536 : rei_idx = pbuf_get_index('REI')
77 :
78 : ! old optics
79 1536 : call cnst_get_ind('CLDICE', ixcldice)
80 1536 : call cnst_get_ind('CLDLIQ', ixcldliq)
81 :
82 1536 : end subroutine oldcloud_init
83 :
84 : !==============================================================================
85 :
86 0 : subroutine oldcloud_lw(state,pbuf,cld_abs_od,oldwp)
87 :
88 : type(physics_state), intent(in) :: state
89 : type(physics_buffer_desc),pointer :: pbuf(:)
90 : real(r8), intent(out) :: cld_abs_od(nlwbands,pcols,pver) ! [fraction] absorption optical depth, per layer
91 : logical,intent(in) :: oldwp ! use old definition of waterpath
92 :
93 :
94 : real(r8) :: gicewp(pcols,pver)
95 : real(r8) :: gliqwp(pcols,pver)
96 : real(r8) :: cicewp(pcols,pver)
97 : real(r8) :: cliqwp(pcols,pver)
98 : real(r8) :: ficemr(pcols,pver)
99 : real(r8) :: cwp(pcols,pver)
100 : real(r8) :: cldtau(pcols,pver)
101 :
102 0 : real(r8), pointer, dimension(:,:) :: cldn
103 0 : real(r8), pointer, dimension(:,:) :: rei
104 : integer :: ncol, itim_old, lwband, i, k, lchnk
105 0 : real(r8), pointer, dimension(:,:) :: iclwpth, iciwpth
106 :
107 : real(r8) :: kabs, kabsi
108 : real(r8), parameter :: kabsl = 0.090361_r8 ! longwave liquid absorption coeff (m**2/g)
109 :
110 :
111 0 : ncol = state%ncol
112 0 : lchnk = state%lchnk
113 :
114 0 : itim_old = pbuf_old_tim_idx()
115 0 : call pbuf_get_field(pbuf, rei_idx, rei)
116 0 : call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/))
117 :
118 0 : if (oldwp) then
119 0 : do k=1,pver
120 0 : do i = 1,ncol
121 0 : gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path.
122 0 : gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path.
123 0 : cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path.
124 0 : cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path.
125 : ficemr(i,k) = state%q(i,k,ixcldice) / &
126 0 : max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq)))
127 : end do
128 : end do
129 0 : cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
130 : else
131 0 : if (iclwp_idx<=0 .or. iciwp_idx<=0) then
132 0 : call endrun('oldcloud_lw: oldwp must be set to true since ICIWP and/or ICLWP were not found in pbuf')
133 : endif
134 0 : call pbuf_get_field(pbuf, iclwp_idx, iclwpth)
135 0 : call pbuf_get_field(pbuf, iciwp_idx, iciwpth)
136 0 : do k=1,pver
137 0 : do i = 1,ncol
138 0 : cwp(i,k) = 1000.0_r8 *iclwpth(i,k) + 1000.0_r8 *iciwpth(i, k)
139 0 : ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k)))
140 : end do
141 : end do
142 : endif
143 :
144 0 : do k=1,pver
145 0 : do i=1,ncol
146 :
147 : !note that optical properties for ice valid only
148 : !in range of 13 > rei > 130 micron (Ebert and Curry 92)
149 0 : kabsi = 0.005_r8 + 1._r8/min(max(13._r8,scalefactor*rei(i,k)),130._r8)
150 0 : kabs = kabsl*(1._r8-ficemr(i,k)) + kabsi*ficemr(i,k)
151 0 : cldtau(i,k) = kabs*cwp(i,k)
152 : end do
153 : end do
154 : !
155 0 : do lwband = 1,nlwbands
156 0 : cld_abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver)
157 : enddo
158 :
159 0 : end subroutine oldcloud_lw
160 :
161 : !==============================================================================
162 :
163 0 : subroutine old_liq_get_rad_props_lw(state, pbuf, abs_od, oldliqwp)
164 :
165 : type(physics_state), intent(in) :: state
166 : type(physics_buffer_desc),pointer :: pbuf(:)
167 : real(r8), intent(out) :: abs_od(nlwbands,pcols,pver)
168 : logical, intent(in) :: oldliqwp
169 :
170 : real(r8) :: gicewp(pcols,pver)
171 : real(r8) :: gliqwp(pcols,pver)
172 : real(r8) :: cicewp(pcols,pver)
173 : real(r8) :: cliqwp(pcols,pver)
174 : real(r8) :: ficemr(pcols,pver)
175 : real(r8) :: cwp(pcols,pver)
176 : real(r8) :: cldtau(pcols,pver)
177 :
178 0 : real(r8), pointer, dimension(:,:) :: cldn
179 0 : real(r8), pointer, dimension(:,:) :: rei
180 : integer :: ncol, itim_old, lwband, i, k, lchnk
181 :
182 : real(r8) :: kabs, kabsi
183 : real(r8), parameter :: kabsl = 0.090361_r8 ! longwave liquid absorption coeff (m**2/g)
184 :
185 0 : real(r8), pointer, dimension(:,:) :: iclwpth, iciwpth
186 :
187 0 : ncol=state%ncol
188 0 : lchnk = state%lchnk
189 :
190 0 : itim_old = pbuf_old_tim_idx()
191 0 : call pbuf_get_field(pbuf, rei_idx, rei)
192 0 : call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/))
193 :
194 0 : if (oldliqwp) then
195 0 : do k=1,pver
196 0 : do i = 1,ncol
197 0 : gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path.
198 0 : gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path.
199 0 : cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path.
200 0 : cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path.
201 : ficemr(i,k) = state%q(i,k,ixcldice) / &
202 0 : max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq)))
203 : end do
204 : end do
205 0 : cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
206 : else
207 0 : if (iclwp_idx<=0 .or. iciwp_idx<=0) then
208 0 : call endrun('old_liq_get_rad_props_lw: oldliqwp must be set to true since ICIWP and/or ICLWP were not found in pbuf')
209 : endif
210 0 : call pbuf_get_field(pbuf, iclwp_idx, iclwpth)
211 0 : call pbuf_get_field(pbuf, iciwp_idx, iciwpth)
212 0 : do k=1,pver
213 0 : do i = 1,ncol
214 0 : cwp(i,k) = 1000.0_r8 *iclwpth(i,k) + 1000.0_r8 *iciwpth(i, k)
215 0 : ficemr(i,k) = 1000.0_r8 * iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k)))
216 : end do
217 : end do
218 : endif
219 :
220 :
221 0 : do k=1,pver
222 0 : do i=1,ncol
223 :
224 : ! Note from Andrew Conley:
225 : ! Optics for RK no longer supported, This is constructed to get
226 : ! close to bit for bit. Otherwise we could simply use liquid water path
227 : !note that optical properties for ice valid only
228 : !in range of 13 > rei > 130 micron (Ebert and Curry 92)
229 0 : kabsi = 0.005_r8 + 1._r8/min(max(13._r8,scalefactor*rei(i,k)),130._r8)
230 0 : kabs = kabsl*(1._r8-ficemr(i,k)) ! + kabsi*ficemr(i,k)
231 0 : cldtau(i,k) = kabs*cwp(i,k)
232 : end do
233 : end do
234 :
235 0 : do lwband = 1,nlwbands
236 0 : abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver)
237 : enddo
238 :
239 :
240 0 : end subroutine old_liq_get_rad_props_lw
241 :
242 : !==============================================================================
243 :
244 0 : subroutine old_ice_get_rad_props_lw(state, pbuf, abs_od, oldicewp)
245 :
246 : type(physics_state), intent(in) :: state
247 : type(physics_buffer_desc),pointer :: pbuf(:)
248 : real(r8), intent(out) :: abs_od(nlwbands,pcols,pver)
249 : logical, intent(in) :: oldicewp
250 :
251 : real(r8) :: gicewp(pcols,pver)
252 : real(r8) :: gliqwp(pcols,pver)
253 : real(r8) :: cicewp(pcols,pver)
254 : real(r8) :: cliqwp(pcols,pver)
255 : real(r8) :: ficemr(pcols,pver)
256 : real(r8) :: cwp(pcols,pver)
257 : real(r8) :: cldtau(pcols,pver)
258 :
259 0 : real(r8), pointer, dimension(:,:) :: cldn
260 0 : real(r8), pointer, dimension(:,:) :: rei
261 : integer :: ncol, itim_old, lwband, i, k, lchnk
262 :
263 : real(r8) :: kabs, kabsi
264 : real(r8), parameter :: kabsl = 0.090361_r8 ! longwave liquid absorption coeff (m**2/g)
265 :
266 0 : real(r8), pointer, dimension(:,:) :: iclwpth, iciwpth
267 :
268 :
269 0 : ncol = state%ncol
270 0 : lchnk = state%lchnk
271 :
272 0 : itim_old = pbuf_old_tim_idx()
273 0 : call pbuf_get_field(pbuf, rei_idx, rei)
274 0 : call pbuf_get_field(pbuf, cld_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/))
275 :
276 0 : if(oldicewp) then
277 0 : do k=1,pver
278 0 : do i = 1,ncol
279 0 : gicewp(i,k) = state%q(i,k,ixcldice)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box ice water path.
280 0 : gliqwp(i,k) = state%q(i,k,ixcldliq)*state%pdel(i,k)/gravit*1000.0_r8 ! Grid box liquid water path.
281 0 : cicewp(i,k) = gicewp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud ice water path.
282 0 : cliqwp(i,k) = gliqwp(i,k) / max(0.01_r8,cldn(i,k)) ! In-cloud liquid water path.
283 : ficemr(i,k) = state%q(i,k,ixcldice) / &
284 0 : max(1.e-10_r8,(state%q(i,k,ixcldice)+state%q(i,k,ixcldliq)))
285 : end do
286 : end do
287 0 : cwp(:ncol,:pver) = cicewp(:ncol,:pver) + cliqwp(:ncol,:pver)
288 : else
289 0 : if (iclwp_idx<=0 .or. iciwp_idx<=0) then
290 0 : call endrun('old_ice_get_rad_props_lw: oldicewp must be set to true since ICIWP and/or ICLWP were not found in pbuf')
291 : endif
292 0 : call pbuf_get_field(pbuf, iclwp_idx, iclwpth)
293 0 : call pbuf_get_field(pbuf, iciwp_idx, iciwpth)
294 0 : do k=1,pver
295 0 : do i = 1,ncol
296 0 : cwp(i,k) = 1000.0_r8 *iciwpth(i,k) + 1000.0_r8 *iclwpth(i,k)
297 0 : ficemr(i,k) = 1000.0_r8*iciwpth(i,k)/(max(1.e-18_r8,cwp(i,k)))
298 : end do
299 : end do
300 : endif
301 :
302 0 : do k=1,pver
303 0 : do i=1,ncol
304 :
305 : ! Note from Andrew Conley:
306 : ! Optics for RK no longer supported, This is constructed to get
307 : ! close to bit for bit. Otherwise we could simply use ice water path
308 : !note that optical properties for ice valid only
309 : !in range of 13 > rei > 130 micron (Ebert and Curry 92)
310 0 : kabsi = 0.005_r8 + 1._r8/min(max(13._r8,scalefactor*rei(i,k)),130._r8)
311 0 : kabs = kabsi*ficemr(i,k) ! kabsl*(1._r8-ficemr(i,k)) + kabsi*ficemr(i,k)
312 0 : cldtau(i,k) = kabs*cwp(i,k)
313 : end do
314 : end do
315 :
316 0 : do lwband = 1,nlwbands
317 0 : abs_od(lwband,1:ncol,1:pver)=cldtau(1:ncol,1:pver)
318 : enddo
319 :
320 0 : end subroutine old_ice_get_rad_props_lw
321 :
322 : !==============================================================================
323 :
324 : end module oldcloud_optics
|
