Line data Source code
1 : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2 : ! Copyright (c) 2009, Lawrence Livemore National Security Limited Liability
3 : ! All rights reserved.
4 : !
5 : ! Redistribution and use in source and binary forms, with or without modification, are
6 : ! permitted provided that the following conditions are met:
7 : !
8 : ! 1. Redistributions of source code must retain the above copyright notice, this list of
9 : ! conditions and the following disclaimer.
10 : !
11 : ! 2. Redistributions in binary form must reproduce the above copyright notice, this list
12 : ! of conditions and the following disclaimer in the documentation and/or other
13 : ! materials provided with the distribution.
14 : !
15 : ! 3. Neither the name of the copyright holder nor the names of its contributors may be
16 : ! used to endorse or promote products derived from this software without specific prior
17 : ! written permission.
18 : !
19 : ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY
20 : ! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
21 : ! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
22 : ! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23 : ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
24 : ! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 : ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
26 : ! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
27 : ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28 : !
29 : ! History
30 : ! May 2015 - D. Swales - Modified for COSPv2.0
31 : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
32 : MODULE MOD_ICARUS
33 : USE COSP_KINDS, ONLY: wp
34 : USE COSP_PHYS_CONSTANTS, ONLY: amd,amw,avo,grav
35 : use MOD_COSP_STATS, ONLY: hist2D
36 : USE MOD_COSP_CONFIG, ONLY: R_UNDEF,numISCCPTauBins,numISCCPPresBins,isccp_histTau, &
37 : isccp_histPres
38 : implicit none
39 :
40 : ! Shared Parameters
41 : integer,parameter :: &
42 : ncolprint = 0 ! Flag for debug printing (set as parameter to increase performance)
43 :
44 : ! Cloud-top height determination
45 : integer :: &
46 : isccp_top_height, & ! Top height adjustment method
47 : isccp_top_height_direction ! Direction for finding atmosphere pressure level
48 :
49 : ! Parameters used by icarus
50 : real(wp),parameter :: &
51 : tauchk = -1._wp*log(0.9999999_wp), & ! Lower limit on optical depth
52 : isccp_taumin = 0.3_wp, & ! Minimum optical depth for joint-hostogram
53 : pstd = 1013250._wp, & ! Mean sea-level pressure (Pa)
54 : isccp_t0 = 296._wp, & ! Mean surface temperature (K)
55 : output_missing_value = -1.E+30 ! Missing values
56 :
57 : contains
58 : ! ##########################################################################
59 : ! ##########################################################################
60 0 : SUBROUTINE ICARUS(debug,debugcol,npoints,sunlit,nlev,ncol,pfull, &
61 0 : phalf,qv,cc,conv,dtau_s,dtau_c,th,thd,frac_out,skt,emsfc_lw,at,&
62 0 : dem_s,dem_c,fq_isccp,totalcldarea, meanptop,meantaucld, &
63 0 : meanalbedocld, meantb,meantbclr,boxtau,boxptop,levmatch)
64 :
65 : ! INPUTS
66 : INTEGER,intent(in) :: & !
67 : npoints, & ! Number of model points in the horizontal
68 : nlev, & ! Number of model levels in column
69 : ncol, & ! Number of subcolumns
70 : debug, & ! Debug flag
71 : debugcol ! Debug column flag
72 : INTEGER,intent(in),dimension(npoints) :: & !
73 : sunlit ! 1 for day points, 0 for night time
74 : REAL(WP),intent(in) :: & !
75 : emsfc_lw ! 10.5 micron emissivity of surface (fraction)
76 : REAL(WP),intent(in),dimension(npoints) :: & !
77 : skt ! Skin Temperature (K)
78 : REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: & !
79 : frac_out ! Boxes gridbox divided up into subcolumns
80 : REAL(WP),intent(in),dimension(npoints,nlev) :: & !
81 : pfull, & ! Pressure of full model levels (Pascals)
82 : qv, & ! Water vapor specific humidity (kg vapor/ kg air)
83 : cc, & ! Cloud cover in each model level (fraction)
84 : conv, & ! Convective cloud cover in each model
85 : at, & ! Temperature in each model level (K)
86 : dem_c, & ! Emissivity for convective clouds
87 : dem_s, & ! Emissivity for stratiform clouds
88 : dtau_c, & ! Optical depth for convective clouds
89 : dtau_s ! Optical depth for stratiform clouds
90 : REAL(WP),intent(in),dimension(npoints,nlev+1) :: & !
91 : phalf ! Pressure of half model levels (Pascals)!
92 : integer,intent(in) :: th,thd
93 :
94 : ! OUTPUTS
95 : REAL(WP),intent(out),dimension(npoints,7,7) :: &
96 : fq_isccp ! The fraction of the model grid box covered by clouds
97 : REAL(WP),intent(out),dimension(npoints) :: &
98 : totalcldarea, & ! The fraction of model grid box columns with cloud present
99 : meanptop, & ! Mean cloud top pressure (mb) - linear averaging
100 : meantaucld, & ! Mean optical thickness
101 : meanalbedocld, & ! Mean cloud albedo
102 : meantb, & ! Mean all-sky 10.5 micron brightness temperature
103 : meantbclr ! Mean clear-sky 10.5 micron brightness temperature
104 : REAL(WP),intent(out),dimension(npoints,ncol) :: &
105 : boxtau, & ! Optical thickness in each column
106 : boxptop ! Cloud top pressure (mb) in each column
107 : INTEGER,intent(out),dimension(npoints,ncol) :: &
108 : levmatch ! Used for icarus unit testing only
109 :
110 :
111 : ! INTERNAL VARIABLES
112 : CHARACTER(len=10) :: ftn09
113 0 : REAL(WP),dimension(npoints,ncol) :: boxttop
114 0 : REAL(WP),dimension(npoints,ncol,nlev) :: dtau,demIN
115 : INTEGER :: j,ilev,ibox
116 0 : INTEGER,dimension(nlev,ncol ) :: acc
117 :
118 : ! PARAMETERS
119 : character ,parameter, dimension(6) :: cchar=(/' ','-','1','+','I','+'/)
120 : character(len=1),parameter,dimension(6) :: cchar_realtops=(/ ' ',' ','1','1','I','I'/)
121 : ! ##########################################################################
122 :
123 0 : call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dem_c,dem_s,demIN)
124 0 : call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dtau_c,dtau_s,dtau)
125 :
126 : call ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demIN,skt,emsfc_lw,qv,at, &
127 0 : pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr)
128 :
129 : call ICARUS_COLUMN(npoints,ncol,boxtau,boxptop/100._wp,sunlit,boxttop,&
130 0 : fq_isccp,meanalbedocld,meanptop,meantaucld,totalcldarea,meantb)
131 :
132 : ! ##########################################################################
133 : ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM
134 : ! ##########################################################################
135 :
136 0 : if (debugcol.ne.0) then
137 0 : do j=1,npoints,debugcol
138 :
139 : ! Produce character output
140 0 : do ilev=1,nlev
141 0 : acc(ilev,1:ncol)=frac_out(j,1:ncol,ilev)*2
142 0 : where(levmatch(j,1:ncol) .eq. ilev) acc(ilev,1:ncol)=acc(ilev,1:ncol)+1
143 : enddo
144 :
145 0 : write(ftn09,11) j
146 : 11 format('ftn09.',i4.4)
147 0 : open(9, FILE=ftn09, FORM='FORMATTED')
148 :
149 0 : write(9,'(a1)') ' '
150 0 : write(9,'(10i5)') (ilev,ilev=5,nlev,5)
151 0 : write(9,'(a1)') ' '
152 :
153 0 : do ibox=1,ncol
154 : write(9,'(40(a1),1x,40(a1))') &
155 0 : (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev),&
156 0 : (cchar(acc(ilev,ibox)+1),ilev=1,nlev)
157 : end do
158 0 : close(9)
159 :
160 : enddo
161 : end if
162 :
163 0 : return
164 : end SUBROUTINE ICARUS
165 :
166 : ! ############################################################################
167 : ! ############################################################################
168 : ! ############################################################################
169 9288 : SUBROUTINE ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demiN,skt,emsfc_lw,qv,at, &
170 9288 : pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr)
171 : ! Inputs
172 : INTEGER, intent(in) :: &
173 : ncol, & ! Number of subcolumns
174 : npoints, & ! Number of horizontal gridpoints
175 : nlev ! Number of vertical levels
176 : INTEGER, intent(in), dimension(npoints) :: &
177 : sunlit ! 1=day 0=night
178 : REAL(WP),intent(in) :: &
179 : emsfc_lw ! 10.5 micron emissivity of surface (fraction)
180 : REAL(WP),intent(in), dimension(npoints) :: &
181 : skt ! Skin temperature
182 : REAL(WP),intent(in), dimension(npoints,nlev) :: &
183 : at, & ! Temperature
184 : pfull, & ! Presure
185 : qv ! Specific humidity
186 : REAL(WP),intent(in), dimension(npoints,ncol,nlev) :: &
187 : frac_out, & ! Subcolumn cloud cover
188 : dtau, & ! Subcolumn optical thickness
189 : demIN ! Subcolumn emissivity
190 : REAL(WP),intent(in), dimension(npoints,nlev+1) :: &
191 : phalf ! Pressure at model half levels
192 :
193 : ! Outputs
194 : REAL(WP),intent(inout),dimension(npoints) :: &
195 : meantbclr ! Mean clear-sky 10.5 micron brightness temperature
196 : REAL(WP),intent(inout),dimension(npoints,ncol) :: &
197 : boxtau, & ! Optical thickness in each column
198 : boxptop, & ! Cloud top pressure (mb) in each column
199 : boxttop ! Cloud top temperature in each column
200 : INTEGER, intent(inout),dimension(npoints,ncol) :: levmatch
201 :
202 : ! Local Variables
203 : INTEGER :: &
204 : j,ibox,ilev,k1,k2,icycle
205 : INTEGER,dimension(npoints) :: &
206 18576 : nmatch,itrop
207 : INTEGER,dimension(npoints,nlev-1) :: &
208 18576 : match
209 : REAL(WP) :: &
210 : logp,logp1,logp2,atd
211 : REAL(WP),dimension(npoints) :: &
212 18576 : bb,attropmin,attrop,ptrop,atmax,btcmin,transmax,tauir,taumin,fluxtopinit,press, &
213 18576 : dpress,atmden,rvh20,rhoave,rh20s,rfrgn,tmpexp,tauwv,wk,trans_layers_above_clrsky, &
214 18576 : fluxtop_clrsky
215 : REAL(WP),dimension(npoints,nlev) :: &
216 18576 : dem_wv
217 : REAL(WP),dimension(npoints,ncol) :: &
218 9288 : trans_layers_above,dem,tb,emcld,fluxtop,tau,ptop
219 :
220 : ! ####################################################################################
221 : ! Compute cloud optical depth for each column by summing up subcolumns
222 1560168 : tau(1:npoints,1:ncol) = 0._wp
223 124032168 : tau(1:npoints,1:ncol) = sum(dtau,dim=3)
224 :
225 : ! Set tropopause values
226 9288 : if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then
227 155088 : ptrop(1:npoints) = 5000._wp
228 155088 : attropmin(1:npoints) = 400._wp
229 155088 : atmax(1:npoints) = 0._wp
230 155088 : attrop(1:npoints) = 120._wp
231 155088 : itrop(1:npoints) = 1
232 :
233 789480 : do ilev=1,nlev
234 780192 : where(pfull(1:npoints,ilev) .lt. 40000. .and. &
235 : pfull(1:npoints,ilev) .gt. 5000. .and. &
236 62805672 : at(1:npoints,ilev) .lt. attropmin(1:npoints))
237 : ptrop(1:npoints) = pfull(1:npoints,ilev)
238 : attropmin(1:npoints) = at(1:npoints,ilev)
239 : attrop(1:npoints) = attropmin(1:npoints)
240 : itrop = ilev
241 : endwhere
242 : enddo
243 :
244 789480 : do ilev=1,nlev
245 780192 : atmax(1:npoints) = merge(at(1:npoints,ilev),atmax(1:npoints),&
246 13816872 : at(1:npoints,ilev) .gt. atmax(1:npoints) .and. ilev .ge. itrop(1:npoints))
247 : enddo
248 : end if
249 :
250 9288 : if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then
251 : ! ############################################################################
252 : ! Clear-sky radiance calculation
253 : !
254 : ! Compute water vapor continuum emissivity this treatment follows Schwarkzopf
255 : ! and Ramasamy JGR 1999,vol 104, pages 9467-9499. The emissivity is calculated
256 : ! at a wavenumber of 955 cm-1, or 10.47 microns
257 : ! ############################################################################
258 789480 : do ilev=1,nlev
259 13027392 : press(1:npoints) = pfull(1:npoints,ilev)*10._wp
260 13027392 : dpress(1:npoints) = (phalf(1:npoints,ilev+1)-phalf(1:npoints,ilev))*10
261 13027392 : atmden(1:npoints) = dpress(1:npoints)/(grav*100._wp)
262 13027392 : rvh20(1:npoints) = qv(1:npoints,ilev)*amd/amw
263 13027392 : wk(1:npoints) = rvh20(1:npoints)*avo*atmden/amd
264 13027392 : rhoave(1:npoints) = (press(1:npoints)/pstd)*(isccp_t0/at(1:npoints,ilev))
265 13027392 : rh20s(1:npoints) = rvh20(1:npoints)*rhoave(1:npoints)
266 13027392 : rfrgn(1:npoints) = rhoave(1:npoints)-rh20s(1:npoints)
267 13027392 : tmpexp(1:npoints) = exp(-0.02_wp*(at(1:npoints,ilev)-isccp_t0))
268 : tauwv(1:npoints) = wk(1:npoints)*1.e-20*((0.0224697_wp*rh20s(1:npoints)* &
269 13027392 : tmpexp(1:npoints))+(3.41817e-7*rfrgn(1:npoints)))*0.98_wp
270 13036680 : dem_wv(1:npoints,ilev) = 1._wp - exp( -1._wp * tauwv(1:npoints))
271 : enddo
272 :
273 155088 : fluxtop_clrsky(1:npoints) = 0._wp
274 155088 : trans_layers_above_clrsky(1:npoints) = 1._wp
275 789480 : do ilev=1,nlev
276 : ! Black body emission at temperature of the layer
277 13027392 : bb(1:npoints) = 1._wp / ( exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp )
278 :
279 : ! Increase TOA flux by flux emitted from layer times total transmittance in layers above
280 : fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + &
281 13027392 : dem_wv(1:npoints,ilev)*bb(1:npoints)*trans_layers_above_clrsky(1:npoints)
282 :
283 : ! Update trans_layers_above with transmissivity from this layer for next time around loop
284 : trans_layers_above_clrsky(1:npoints) = trans_layers_above_clrsky(1:npoints)*&
285 13036680 : (1.-dem_wv(1:npoints,ilev))
286 : enddo
287 :
288 : ! Add in surface emission
289 155088 : bb(1:npoints) = 1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp )
290 : fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + &
291 155088 : emsfc_lw * bb(1:npoints)*trans_layers_above_clrsky(1:npoints)
292 :
293 : ! Clear Sky brightness temperature
294 155088 : meantbclr(1:npoints) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop_clrsky(1:npoints))))
295 :
296 : ! #################################################################################
297 : ! All-sky radiance calculation
298 : ! #################################################################################
299 :
300 1560168 : fluxtop(1:npoints,1:ncol) = 0._wp
301 1560168 : trans_layers_above(1:npoints,1:ncol) = 1._wp
302 789480 : do ilev=1,nlev
303 : ! Black body emission at temperature of the layer
304 13027392 : bb=1._wp/(exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp)
305 :
306 8591400 : do ibox=1,ncol
307 : ! Emissivity
308 : dem(1:npoints,ibox) = merge(dem_wv(1:npoints,ilev), &
309 7801920 : 1._wp-(1._wp-demIN(1:npoints,ibox,ilev))*(1._wp-dem_wv(1:npoints,ilev)), &
310 138075840 : demIN(1:npoints,ibox,ilev) .eq. 0)
311 :
312 : ! Increase TOA flux emitted from layer
313 130273920 : fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + dem(1:npoints,ibox)*bb*trans_layers_above(1:npoints,ibox)
314 :
315 : ! Update trans_layer by emitted layer from above
316 131054112 : trans_layers_above(1:npoints,ibox) = trans_layers_above(1:npoints,ibox)*(1._wp-dem(1:npoints,ibox))
317 : enddo
318 : enddo
319 :
320 : ! Add in surface emission
321 155088 : bb(1:npoints)=1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp )
322 102168 : do ibox=1,ncol
323 1560168 : fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + emsfc_lw*bb(1:npoints)*trans_layers_above(1:npoints,ibox)
324 : end do
325 :
326 : ! All Sky brightness temperature
327 1560168 : boxttop(1:npoints,1:ncol) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop(1:npoints,1:ncol))))
328 :
329 : ! #################################################################################
330 : ! Cloud-Top Temperature
331 : !
332 : ! Now that you have the top of atmosphere radiance, account for ISCCP
333 : ! procedures to determine cloud top temperature account for partially
334 : ! transmitting cloud recompute flux ISCCP would see assuming a single layer
335 : ! cloud. *NOTE* choice here of 2.13, as it is primarily ice clouds which have
336 : ! partial emissivity and need the adjustment performed in this section. If it
337 : ! turns out that the cloud brightness temperature is greater than 260K, then
338 : ! the liquid cloud conversion factor of 2.56 is used. *NOTE* that this is
339 : ! discussed on pages 85-87 of the ISCCP D level documentation
340 : ! (Rossow et al. 1996)
341 : ! #################################################################################
342 :
343 : ! Compute minimum brightness temperature and optical depth
344 155088 : btcmin(1:npoints) = 1._wp / ( exp(1307.27_wp/(attrop(1:npoints)-5._wp)) - 1._wp )
345 :
346 102168 : do ibox=1,ncol
347 1550880 : transmax(1:npoints) = (fluxtop(1:npoints,ibox)-btcmin) /(fluxtop_clrsky(1:npoints)-btcmin(1:npoints))
348 1550880 : tauir(1:npoints) = tau(1:npoints,ibox)/2.13_wp
349 1550880 : taumin(1:npoints) = -log(max(min(transmax(1:npoints),0.9999999_wp),0.001_wp))
350 92880 : if (isccp_top_height .eq. 1) then
351 1550880 : do j=1,npoints
352 1550880 : if (transmax(j) .gt. 0.001 .and. transmax(j) .le. 0.9999999) then
353 1004637 : fluxtopinit(j) = fluxtop(j,ibox)
354 1004637 : tauir(j) = tau(j,ibox)/2.13_wp
355 : endif
356 : enddo
357 278640 : do icycle=1,2
358 3194640 : do j=1,npoints
359 3101760 : if (tau(j,ibox) .gt. (tauchk)) then
360 2144092 : if (transmax(j) .gt. 0.001 .and. transmax(j) .le. 0.9999999) then
361 2009274 : emcld(j,ibox) = 1._wp - exp(-1._wp * tauir(j) )
362 2009274 : fluxtop(j,ibox) = fluxtopinit(j) - ((1.-emcld(j,ibox))*fluxtop_clrsky(j))
363 2009274 : fluxtop(j,ibox)=max(1.E-06_wp,(fluxtop(j,ibox)/emcld(j,ibox)))
364 2009274 : tb(j,ibox)= 1307.27_wp / (log(1._wp + (1._wp/fluxtop(j,ibox))))
365 2009274 : if (tb(j,ibox) .gt. 260.) then
366 863294 : tauir(j) = tau(j,ibox) / 2.56_wp
367 : end if
368 : end if
369 : end if
370 : enddo
371 : enddo
372 : endif
373 :
374 : ! Cloud-top temperature
375 7382880 : where(tau(1:npoints,ibox) .gt. tauchk)
376 : tb(1:npoints,ibox)= 1307.27_wp/ (log(1. + (1._wp/fluxtop(1:npoints,ibox))))
377 : where (isccp_top_height .eq. 1 .and. tauir(1:npoints) .lt. taumin(1:npoints))
378 : tb(1:npoints,ibox) = attrop(1:npoints) - 5._wp
379 : tau(1:npoints,ibox) = 2.13_wp*taumin(1:npoints)
380 : endwhere
381 : endwhere
382 :
383 : ! Clear-sky brightness temperature
384 1560168 : where(tau(1:npoints,ibox) .le. tauchk)
385 : tb(1:npoints,ibox) = meantbclr(1:npoints)
386 : endwhere
387 : enddo
388 : else
389 0 : meantbclr(1:npoints) = output_missing_value
390 : end if
391 :
392 : ! ####################################################################################
393 : ! Cloud-Top Pressure
394 : !
395 : ! The 2 methods differ according to whether or not you use the physical cloud
396 : ! top pressure (isccp_top_height = 2) or the radiatively determined cloud top
397 : ! pressure (isccp_top_height = 1 or 3)
398 : ! ####################################################################################
399 102168 : do ibox=1,ncol
400 : !segregate according to optical thickness
401 92880 : if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then
402 :
403 : ! Find level whose temperature most closely matches brightness temperature
404 1550880 : nmatch(1:npoints)=0
405 7801920 : do k1=1,nlev-1
406 7709040 : ilev = merge(nlev-k1,k1,isccp_top_height_direction .eq. 2)
407 128815920 : do j=1,npoints
408 242028000 : if (ilev .ge. itrop(j) .and. &
409 121014000 : ((at(j,ilev) .ge. tb(j,ibox) .and. &
410 : at(j,ilev+1) .le. tb(j,ibox)) .or. &
411 : (at(j,ilev) .le. tb(j,ibox) .and. &
412 7709040 : at(j,ilev+1) .ge. tb(j,ibox)))) then
413 1643790 : nmatch(j)=nmatch(j)+1
414 1643790 : match(j,nmatch(j))=ilev
415 : endif
416 : enddo
417 : enddo
418 :
419 1550880 : do j=1,npoints
420 1550880 : if (nmatch(j) .ge. 1) then
421 1319426 : k1 = match(j,nmatch(j))
422 1319426 : k2 = k1 + 1
423 1319426 : logp1 = log(pfull(j,k1))
424 1319426 : logp2 = log(pfull(j,k2))
425 1319426 : atd = max(tauchk,abs(at(j,k2) - at(j,k1)))
426 1319426 : logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd
427 1319426 : ptop(j,ibox) = exp(logp)
428 1986004 : levmatch(j,ibox) = merge(k1,k2,abs(pfull(j,k1)-ptop(j,ibox)) .lt. abs(pfull(j,k2)-ptop(j,ibox)))
429 : else
430 138574 : if (tb(j,ibox) .le. attrop(j)) then
431 30436 : ptop(j,ibox)=ptrop(j)
432 30436 : levmatch(j,ibox)=itrop(j)
433 : end if
434 138574 : if (tb(j,ibox) .ge. atmax(j)) then
435 108138 : ptop(j,ibox)=pfull(j,nlev)
436 108138 : levmatch(j,ibox)=nlev
437 : end if
438 : end if
439 : enddo
440 : else
441 0 : ptop(1:npoints,ibox)=0.
442 0 : do ilev=1,nlev
443 0 : where((ptop(1:npoints,ibox) .eq. 0. ) .and.(frac_out(1:npoints,ibox,ilev) .ne. 0))
444 0 : ptop(1:npoints,ibox)=phalf(1:npoints,ilev)
445 : levmatch(1:npoints,ibox)=ilev
446 : endwhere
447 : end do
448 : end if
449 4476168 : where(tau(1:npoints,ibox) .le. tauchk)
450 : ptop(1:npoints,ibox)=0._wp
451 : levmatch(1:npoints,ibox)=0._wp
452 : endwhere
453 : enddo
454 :
455 : ! ####################################################################################
456 : ! Compute subcolumn pressure and optical depth
457 : ! ####################################################################################
458 1560168 : boxtau(1:npoints,1:ncol) = output_missing_value
459 1560168 : boxptop(1:npoints,1:ncol) = output_missing_value
460 102168 : do ibox=1,ncol
461 1560168 : do j=1,npoints
462 1550880 : if (tau(j,ibox) .gt. (tauchk) .and. ptop(j,ibox) .gt. 0.) then
463 1072046 : if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then
464 528901 : boxtau(j,ibox) = tau(j,ibox)
465 528901 : boxptop(j,ibox) = ptop(j,ibox)!/100._wp
466 : endif
467 : endif
468 : enddo
469 : enddo
470 :
471 9288 : end SUBROUTINE ICARUS_SUBCOLUMN
472 :
473 : ! ######################################################################################
474 : ! SUBROUTINE icarus_column
475 : ! ######################################################################################
476 9288 : SUBROUTINE ICARUS_column(npoints,ncol,boxtau,boxptop,sunlit,boxttop,fq_isccp, &
477 9288 : meanalbedocld,meanptop,meantaucld,totalcldarea,meantb)
478 : ! Inputs
479 : INTEGER, intent(in) :: &
480 : ncol, & ! Number of subcolumns
481 : npoints ! Number of horizontal gridpoints
482 : INTEGER, intent(in),dimension(npoints) :: &
483 : sunlit ! day=1 night=0
484 : REAL(WP),intent(in),dimension(npoints,ncol) :: &
485 : boxttop, & ! Subcolumn top temperature
486 : boxptop, & ! Subcolumn cloud top pressure
487 : boxtau ! Subcolumn optical depth
488 :
489 : ! Outputs
490 : REAL(WP),intent(inout),dimension(npoints) :: &
491 : meanalbedocld, & ! Gridmean cloud albedo
492 : meanptop, & ! Gridmean cloud top pressure (mb) - linear averaging
493 : meantaucld, & ! Gridmean optical thickness
494 : totalcldarea, & ! The fraction of model grid box columns with cloud present
495 : meantb ! Gridmean all-sky 10.5 micron brightness temperature
496 : REAL(WP),intent(inout),dimension(npoints,7,7) :: &
497 : fq_isccp ! The fraction of the model grid box covered by clouds
498 :
499 : ! Local Variables
500 : INTEGER :: j,ilev,ilev2
501 18576 : REAL(WP),dimension(npoints,ncol) :: albedocld
502 18576 : LOGICAL, dimension(npoints,ncol) :: box_cloudy
503 :
504 : ! Variables for new joint-histogram implementation
505 18576 : logical,dimension(ncol) :: box_cloudy2
506 :
507 : ! ####################################################################################
508 : ! Brightness Temperature
509 : ! ####################################################################################
510 9288 : if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then
511 1613088 : meantb(1:npoints)=sum(boxttop,2)/ncol
512 : else
513 0 : meantb(1:npoints) = output_missing_value
514 : endif
515 :
516 : ! ####################################################################################
517 : ! Determines ISCCP cloud type frequencies
518 : !
519 : ! Now that boxptop and boxtau have been determined, determine amount of each of the
520 : ! 49 ISCCP cloud types. Also compute grid box mean cloud top pressure and
521 : ! optical thickness. The mean cloud top pressure and optical thickness are
522 : ! averages over the cloudy area only. The mean cloud top pressure is a linear
523 : ! average of the cloud top pressures. The mean cloud optical thickness is
524 : ! computed by converting optical thickness to an albedo, averaging in albedo
525 : ! units, then converting the average albedo back to a mean optical thickness.
526 : ! ####################################################################################
527 :
528 : ! Initialize
529 1560168 : albedocld(1:npoints,1:ncol) = 0._wp
530 1560168 : box_cloudy(1:npoints,1:ncol) = .false.
531 :
532 : ! Reset frequencies
533 : !fq_isccp = spread(spread(merge(0._wp,output_missing_value,sunlit .eq. 1 .or. isccp_top_height .eq. 3),2,7),2,7)
534 74304 : do ilev=1,7
535 529416 : do ilev2=1,7
536 7664328 : do j=1,npoints !
537 7599312 : if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then
538 3572100 : fq_isccp(j,ilev,ilev2)= 0.
539 : else
540 3572100 : fq_isccp(j,ilev,ilev2)= output_missing_value
541 : end if
542 : enddo
543 : enddo
544 : enddo
545 :
546 :
547 : ! Reset variables need for averaging cloud properties
548 1321488 : where(sunlit .eq. 1 .or. isccp_top_height .eq. 3)
549 : totalcldarea(1:npoints) = 0._wp
550 : meanalbedocld(1:npoints) = 0._wp
551 : meanptop(1:npoints) = 0._wp
552 : meantaucld(1:npoints) = 0._wp
553 : elsewhere
554 : totalcldarea(1:npoints) = output_missing_value
555 : meanalbedocld(1:npoints) = output_missing_value
556 : meanptop(1:npoints) = output_missing_value
557 : meantaucld(1:npoints) = output_missing_value
558 : endwhere
559 :
560 : ! Compute column quantities and joint-histogram
561 155088 : do j=1,npoints
562 : ! Subcolumns that are cloudy(true) and not(false)
563 1603800 : box_cloudy2(1:ncol) = merge(.true.,.false.,boxtau(j,1:ncol) .gt. tauchk .and. boxptop(j,1:ncol) .gt. 0.)
564 :
565 : ! Compute joint histogram and column quantities for points that are sunlit and cloudy
566 155088 : if (sunlit(j) .eq.1 .or. isccp_top_height .eq. 3) then
567 : ! Joint-histogram
568 : call hist2D(boxtau(j,1:ncol),boxptop(j,1:ncol),ncol,isccp_histTau,numISCCPTauBins, &
569 5613300 : isccp_histPres,numISCCPPresBins,fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins))
570 : fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins) = &
571 4155300 : fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins)/ncol
572 :
573 : ! Column cloud area
574 801900 : totalcldarea(j) = real(count(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin))/ncol
575 :
576 : ! Subcolumn cloud albedo
577 : !albedocld(j,1:ncol) = merge((boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp),&
578 : ! 0._wp,box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)
579 801900 : where(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)
580 : albedocld(j,1:ncol) = (boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp)
581 : elsewhere
582 : albedocld(j,1:ncol) = 0._wp
583 : endwhere
584 :
585 : ! Column cloud albedo
586 801900 : meanalbedocld(j) = sum(albedocld(j,1:ncol))/ncol
587 :
588 : ! Column cloud top pressure
589 801900 : meanptop(j) = sum(boxptop(j,1:ncol),box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)/ncol
590 : endif
591 : enddo
592 :
593 : ! Compute mean cloud properties. Set to mssing value in the event that totalcldarea=0
594 1321488 : where(totalcldarea(1:npoints) .gt. 0)
595 : meanptop(1:npoints) = 100._wp*meanptop(1:npoints)/totalcldarea(1:npoints)
596 : meanalbedocld(1:npoints) = meanalbedocld(1:npoints)/totalcldarea(1:npoints)
597 : meantaucld(1:npoints) = (6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp)
598 : elsewhere
599 : meanptop(1:nPoints) = output_missing_value
600 : meanalbedocld(1:nPoints) = output_missing_value
601 : meantaucld(1:nPoints) = output_missing_value
602 : endwhere
603 : !meanptop(1:npoints) = merge(100._wp*meanptop(1:npoints)/totalcldarea(1:npoints),&
604 : ! output_missing_value,totalcldarea(1:npoints) .gt. 0)
605 : !meanalbedocld(1:npoints) = merge(meanalbedocld(1:npoints)/totalcldarea(1:npoints), &
606 : ! output_missing_value,totalcldarea(1:npoints) .gt. 0)
607 : !meantaucld(1:npoints) = merge((6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp), &
608 : ! output_missing_value,totalcldarea(1:npoints) .gt. 0)
609 :
610 : ! Represent in percent
611 155088 : where(totalcldarea .ne. output_missing_value) totalcldarea = totalcldarea*100._wp
612 7673616 : where(fq_isccp .ne. output_missing_value) fq_isccp = fq_isccp*100._wp
613 :
614 :
615 9288 : end SUBROUTINE ICARUS_column
616 :
617 0 : subroutine cosp_simulator_optics(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT)
618 : ! INPUTS
619 : integer,intent(in) :: &
620 : dim1, & ! Dimension 1 extent (Horizontal)
621 : dim2, & ! Dimension 2 extent (Subcolumn)
622 : dim3 ! Dimension 3 extent (Vertical)
623 : real(wp),intent(in),dimension(dim1,dim2,dim3) :: &
624 : flag ! Logical to determine the of merge var1IN and var2IN
625 : real(wp),intent(in),dimension(dim1, dim3) :: &
626 : varIN1, & ! Input field 1
627 : varIN2 ! Input field 2
628 : ! OUTPUTS
629 : real(wp),intent(out),dimension(dim1,dim2,dim3) :: &
630 : varOUT ! Merged output field
631 : ! LOCAL VARIABLES
632 : integer :: j
633 :
634 0 : varOUT(1:dim1,1:dim2,1:dim3) = 0._wp
635 0 : do j=1,dim2
636 0 : where(flag(:,j,:) .eq. 1)
637 0 : varOUT(:,j,:) = varIN2
638 : endwhere
639 0 : where(flag(:,j,:) .eq. 2)
640 : varOUT(:,j,:) = varIN1
641 : endwhere
642 : enddo
643 0 : end subroutine cosp_simulator_optics
644 : end module MOD_ICARUS
645 :
|