1 | ! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ |
---|
2 | ! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/icarus-scops-4.1-bsd/isccp_cloud_types.f $ |
---|
3 | SUBROUTINE ISCCP_CLOUD_TYPES( |
---|
4 | & debug, |
---|
5 | & debugcol, |
---|
6 | & npoints, |
---|
7 | & sunlit, |
---|
8 | & nlev, |
---|
9 | & ncol, |
---|
10 | & seed, |
---|
11 | & pfull, |
---|
12 | & phalf, |
---|
13 | & qv, |
---|
14 | & cc, |
---|
15 | & conv, |
---|
16 | & dtau_s, |
---|
17 | & dtau_c, |
---|
18 | & top_height, |
---|
19 | & top_height_direction, |
---|
20 | & overlap, |
---|
21 | & frac_out, |
---|
22 | & skt, |
---|
23 | & emsfc_lw, |
---|
24 | & at, |
---|
25 | & dem_s, |
---|
26 | & dem_c, |
---|
27 | & fq_isccp, |
---|
28 | & totalcldarea, |
---|
29 | & meanptop, |
---|
30 | & meantaucld, |
---|
31 | & meanalbedocld, |
---|
32 | & meantb, |
---|
33 | & meantbclr, |
---|
34 | & boxtau, |
---|
35 | & boxptop |
---|
36 | &) |
---|
37 | |
---|
38 | !$Id: isccp_cloud_types.f,v 4.0 2009/03/06 11:05:11 hadmw Exp $ |
---|
39 | |
---|
40 | ! *****************************COPYRIGHT**************************** |
---|
41 | ! (c) British Crown Copyright 2009, the Met Office. |
---|
42 | ! All rights reserved. |
---|
43 | ! |
---|
44 | ! Redistribution and use in source and binary forms, with or without |
---|
45 | ! modification, are permitted provided that the |
---|
46 | ! following conditions are met: |
---|
47 | ! |
---|
48 | ! * Redistributions of source code must retain the above |
---|
49 | ! copyright notice, this list of conditions and the following |
---|
50 | ! disclaimer. |
---|
51 | ! * Redistributions in binary form must reproduce the above |
---|
52 | ! copyright notice, this list of conditions and the following |
---|
53 | ! disclaimer in the documentation and/or other materials |
---|
54 | ! provided with the distribution. |
---|
55 | ! * Neither the name of the Met Office nor the names of its |
---|
56 | ! contributors may be used to endorse or promote products |
---|
57 | ! derived from this software without specific prior written |
---|
58 | ! permission. |
---|
59 | ! |
---|
60 | ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS |
---|
61 | ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT |
---|
62 | ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR |
---|
63 | ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT |
---|
64 | ! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, |
---|
65 | ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT |
---|
66 | ! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, |
---|
67 | ! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY |
---|
68 | ! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT |
---|
69 | ! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE |
---|
70 | ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
---|
71 | ! |
---|
72 | ! *****************************COPYRIGHT******************************* |
---|
73 | ! *****************************COPYRIGHT******************************* |
---|
74 | ! *****************************COPYRIGHT******************************* |
---|
75 | |
---|
76 | implicit none |
---|
77 | |
---|
78 | ! NOTE: the maximum number of levels and columns is set by |
---|
79 | ! the following parameter statement |
---|
80 | |
---|
81 | INTEGER ncolprint |
---|
82 | |
---|
83 | ! ----- |
---|
84 | ! Input |
---|
85 | ! ----- |
---|
86 | |
---|
87 | INTEGER npoints ! number of model points in the horizontal |
---|
88 | INTEGER nlev ! number of model levels in column |
---|
89 | INTEGER ncol ! number of subcolumns |
---|
90 | |
---|
91 | INTEGER sunlit(npoints) ! 1 for day points, 0 for night time |
---|
92 | |
---|
93 | INTEGER seed(npoints) |
---|
94 | ! seed values for marsaglia random number generator |
---|
95 | ! It is recommended that the seed is set |
---|
96 | ! to a different value for each model |
---|
97 | ! gridbox it is called on, as it is |
---|
98 | ! possible that the choice of the same |
---|
99 | ! seed value every time may introduce some |
---|
100 | ! statistical bias in the results, particularly |
---|
101 | ! for low values of NCOL. |
---|
102 | |
---|
103 | REAL pfull(npoints,nlev) |
---|
104 | ! pressure of full model levels (Pascals) |
---|
105 | ! pfull(npoints,1) is top level of model |
---|
106 | ! pfull(npoints,nlev) is bot of model |
---|
107 | |
---|
108 | REAL phalf(npoints,nlev+1) |
---|
109 | ! pressure of half model levels (Pascals) |
---|
110 | ! phalf(npoints,1) is top of model |
---|
111 | ! phalf(npoints,nlev+1) is the surface pressure |
---|
112 | |
---|
113 | REAL qv(npoints,nlev) |
---|
114 | ! water vapor specific humidity (kg vapor/ kg air) |
---|
115 | ! on full model levels |
---|
116 | |
---|
117 | REAL cc(npoints,nlev) |
---|
118 | ! input cloud cover in each model level (fraction) |
---|
119 | ! NOTE: This is the HORIZONTAL area of each |
---|
120 | ! grid box covered by clouds |
---|
121 | |
---|
122 | REAL conv(npoints,nlev) |
---|
123 | ! input convective cloud cover in each model |
---|
124 | ! level (fraction) |
---|
125 | ! NOTE: This is the HORIZONTAL area of each |
---|
126 | ! grid box covered by convective clouds |
---|
127 | |
---|
128 | REAL dtau_s(npoints,nlev) |
---|
129 | ! mean 0.67 micron optical depth of stratiform |
---|
130 | ! clouds in each model level |
---|
131 | ! NOTE: this the cloud optical depth of only the |
---|
132 | ! cloudy part of the grid box, it is not weighted |
---|
133 | ! with the 0 cloud optical depth of the clear |
---|
134 | ! part of the grid box |
---|
135 | |
---|
136 | REAL dtau_c(npoints,nlev) |
---|
137 | ! mean 0.67 micron optical depth of convective |
---|
138 | ! clouds in each |
---|
139 | ! model level. Same note applies as in dtau_s. |
---|
140 | |
---|
141 | INTEGER overlap ! overlap type |
---|
142 | ! 1=max |
---|
143 | ! 2=rand |
---|
144 | ! 3=max/rand |
---|
145 | |
---|
146 | INTEGER top_height ! 1 = adjust top height using both a computed |
---|
147 | ! infrared brightness temperature and the visible |
---|
148 | ! optical depth to adjust cloud top pressure. Note |
---|
149 | ! that this calculation is most appropriate to compare |
---|
150 | ! to ISCCP data during sunlit hours. |
---|
151 | ! 2 = do not adjust top height, that is cloud top |
---|
152 | ! pressure is the actual cloud top pressure |
---|
153 | ! in the model |
---|
154 | ! 3 = adjust top height using only the computed |
---|
155 | ! infrared brightness temperature. Note that this |
---|
156 | ! calculation is most appropriate to compare to ISCCP |
---|
157 | ! IR only algortihm (i.e. you can compare to nighttime |
---|
158 | ! ISCCP data with this option) |
---|
159 | |
---|
160 | INTEGER top_height_direction ! direction for finding atmosphere pressure level |
---|
161 | ! with interpolated temperature equal to the radiance |
---|
162 | ! determined cloud-top temperature |
---|
163 | ! |
---|
164 | ! 1 = find the *lowest* altitude (highest pressure) level |
---|
165 | ! with interpolated temperature equal to the radiance |
---|
166 | ! determined cloud-top temperature |
---|
167 | ! |
---|
168 | ! 2 = find the *highest* altitude (lowest pressure) level |
---|
169 | ! with interpolated temperature equal to the radiance |
---|
170 | ! determined cloud-top temperature |
---|
171 | ! |
---|
172 | ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 |
---|
173 | ! |
---|
174 | ! 1 = old setting: matches all versions of |
---|
175 | ! ISCCP simulator with versions numbers 3.5.1 and lower |
---|
176 | ! |
---|
177 | ! 2 = default setting: for version numbers 4.0 and higher |
---|
178 | ! |
---|
179 | ! The following input variables are used only if top_height = 1 or top_height = 3 |
---|
180 | ! |
---|
181 | REAL skt(npoints) ! skin Temperature (K) |
---|
182 | REAL emsfc_lw ! 10.5 micron emissivity of surface (fraction) |
---|
183 | REAL at(npoints,nlev) ! temperature in each model level (K) |
---|
184 | REAL dem_s(npoints,nlev) ! 10.5 micron longwave emissivity of stratiform |
---|
185 | ! clouds in each |
---|
186 | ! model level. Same note applies as in dtau_s. |
---|
187 | REAL dem_c(npoints,nlev) ! 10.5 micron longwave emissivity of convective |
---|
188 | ! clouds in each |
---|
189 | ! model level. Same note applies as in dtau_s. |
---|
190 | |
---|
191 | REAL frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into |
---|
192 | ! Equivalent of BOX in original version, but |
---|
193 | ! indexed by column then row, rather than |
---|
194 | ! by row then column |
---|
195 | |
---|
196 | |
---|
197 | |
---|
198 | ! ------ |
---|
199 | ! Output |
---|
200 | ! ------ |
---|
201 | |
---|
202 | REAL fq_isccp(npoints,7,7) ! the fraction of the model grid box covered by |
---|
203 | ! each of the 49 ISCCP D level cloud types |
---|
204 | |
---|
205 | REAL totalcldarea(npoints) ! the fraction of model grid box columns |
---|
206 | ! with cloud somewhere in them. NOTE: This diagnostic |
---|
207 | ! does not count model clouds with tau < isccp_taumin |
---|
208 | ! Thus this diagnostic does not equal the sum over all entries of fq_isccp. |
---|
209 | ! However, this diagnostic does equal the sum over entries of fq_isccp with |
---|
210 | ! itau = 2:7 (omitting itau = 1) |
---|
211 | |
---|
212 | |
---|
213 | ! The following three means are averages only over the cloudy areas with tau > isccp_taumin. |
---|
214 | ! If no clouds with tau > isccp_taumin are in grid box all three quantities should equal zero. |
---|
215 | |
---|
216 | REAL meanptop(npoints) ! mean cloud top pressure (mb) - linear averaging |
---|
217 | ! in cloud top pressure. |
---|
218 | |
---|
219 | REAL meantaucld(npoints) ! mean optical thickness |
---|
220 | ! linear averaging in albedo performed. |
---|
221 | |
---|
222 | real meanalbedocld(npoints) ! mean cloud albedo |
---|
223 | ! linear averaging in albedo performed |
---|
224 | |
---|
225 | real meantb(npoints) ! mean all-sky 10.5 micron brightness temperature |
---|
226 | |
---|
227 | real meantbclr(npoints) ! mean clear-sky 10.5 micron brightness temperature |
---|
228 | |
---|
229 | REAL boxtau(npoints,ncol) ! optical thickness in each column |
---|
230 | |
---|
231 | REAL boxptop(npoints,ncol) ! cloud top pressure (mb) in each column |
---|
232 | |
---|
233 | |
---|
234 | ! |
---|
235 | ! ------ |
---|
236 | ! Working variables added when program updated to mimic Mark Webb's PV-Wave code |
---|
237 | ! ------ |
---|
238 | |
---|
239 | REAL dem(npoints,ncol),bb(npoints) ! working variables for 10.5 micron longwave |
---|
240 | ! emissivity in part of |
---|
241 | ! gridbox under consideration |
---|
242 | |
---|
243 | REAL ptrop(npoints) |
---|
244 | REAL attrop(npoints) |
---|
245 | REAL attropmin (npoints) |
---|
246 | REAL atmax(npoints) |
---|
247 | REAL atmin(npoints) |
---|
248 | REAL btcmin(npoints) |
---|
249 | REAL transmax(npoints) |
---|
250 | |
---|
251 | INTEGER i,j,ilev,ibox,itrop(npoints) |
---|
252 | INTEGER ipres(npoints) |
---|
253 | INTEGER itau(npoints),ilev2 |
---|
254 | INTEGER acc(nlev,ncol) |
---|
255 | INTEGER match(npoints,nlev-1) |
---|
256 | INTEGER nmatch(npoints) |
---|
257 | INTEGER levmatch(npoints,ncol) |
---|
258 | |
---|
259 | !variables needed for water vapor continuum absorption |
---|
260 | real fluxtop_clrsky(npoints),trans_layers_above_clrsky(npoints) |
---|
261 | real taumin(npoints) |
---|
262 | real dem_wv(npoints,nlev), wtmair, wtmh20, Navo, grav, pstd, t0 |
---|
263 | real press(npoints), dpress(npoints), atmden(npoints) |
---|
264 | real rvh20(npoints), wk(npoints), rhoave(npoints) |
---|
265 | real rh20s(npoints), rfrgn(npoints) |
---|
266 | real tmpexp(npoints),tauwv(npoints) |
---|
267 | |
---|
268 | character*1 cchar(6),cchar_realtops(6) |
---|
269 | integer icycle |
---|
270 | REAL tau(npoints,ncol) |
---|
271 | LOGICAL box_cloudy(npoints,ncol) |
---|
272 | REAL tb(npoints,ncol) |
---|
273 | REAL ptop(npoints,ncol) |
---|
274 | REAL emcld(npoints,ncol) |
---|
275 | REAL fluxtop(npoints,ncol) |
---|
276 | REAL trans_layers_above(npoints,ncol) |
---|
277 | real isccp_taumin,fluxtopinit(npoints),tauir(npoints) |
---|
278 | REAL albedocld(npoints,ncol) |
---|
279 | real boxarea |
---|
280 | integer debug ! set to non-zero value to print out inputs |
---|
281 | ! with step debug |
---|
282 | integer debugcol ! set to non-zero value to print out column |
---|
283 | ! decomposition with step debugcol |
---|
284 | integer rangevec(npoints),rangeerror |
---|
285 | |
---|
286 | integer index1(npoints),num1,jj,k1,k2 |
---|
287 | real rec2p13,tauchk,logp,logp1,logp2,atd |
---|
288 | |
---|
289 | character*10 ftn09 |
---|
290 | |
---|
291 | DATA isccp_taumin / 0.3 / |
---|
292 | DATA cchar / ' ','-','1','+','I','+'/ |
---|
293 | DATA cchar_realtops / ' ',' ','1','1','I','I'/ |
---|
294 | |
---|
295 | ! ------ End duplicate definitions common to wrapper routine |
---|
296 | |
---|
297 | ncolprint=0 |
---|
298 | |
---|
299 | CALL SCOPS( |
---|
300 | & npoints, |
---|
301 | & nlev, |
---|
302 | & ncol, |
---|
303 | & seed, |
---|
304 | & cc, |
---|
305 | & conv, |
---|
306 | & overlap, |
---|
307 | & frac_out, |
---|
308 | & ncolprint |
---|
309 | &) |
---|
310 | |
---|
311 | CALL ICARUS( |
---|
312 | & debug, |
---|
313 | & debugcol, |
---|
314 | & npoints, |
---|
315 | & sunlit, |
---|
316 | & nlev, |
---|
317 | & ncol, |
---|
318 | & pfull, |
---|
319 | & phalf, |
---|
320 | & qv, |
---|
321 | & cc, |
---|
322 | & conv, |
---|
323 | & dtau_s, |
---|
324 | & dtau_c, |
---|
325 | & top_height, |
---|
326 | & top_height_direction, |
---|
327 | & overlap, |
---|
328 | & frac_out, |
---|
329 | & skt, |
---|
330 | & emsfc_lw, |
---|
331 | & at, |
---|
332 | & dem_s, |
---|
333 | & dem_c, |
---|
334 | & fq_isccp, |
---|
335 | & totalcldarea, |
---|
336 | & meanptop, |
---|
337 | & meantaucld, |
---|
338 | & meanalbedocld, |
---|
339 | & meantb, |
---|
340 | & meantbclr, |
---|
341 | & boxtau, |
---|
342 | & boxptop |
---|
343 | &) |
---|
344 | |
---|
345 | return |
---|
346 | end |
---|
347 | |
---|