[2432] | 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 | |
---|