/[MITgcm]/MITgcm/pkg/fizhi/update_earth_exports.F
ViewVC logotype

Contents of /MITgcm/pkg/fizhi/update_earth_exports.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.6 - (show annotations) (download)
Wed Jun 9 20:33:37 2004 UTC (20 years ago) by molod
Branch: MAIN
Changes since 1.5: +60 -8 lines
More input stuff for fizhi

1 C $Header: /u/gcmpack/MITgcm/pkg/fizhi/update_earth_exports.F,v 1.2 2004/06/07 18:11:38 molod Exp $
2 C $Name: $
3
4 subroutine update_earth_exports (myTime, myIter, myThid)
5 c----------------------------------------------------------------------
6 c Subroutine update_earth_exports - 'Wrapper' routine to update
7 c the fields related to the earth's surface that are needed
8 c by fizhi.
9 c
10 c Call: getlgr (Set the leaf area index and surface greenness,
11 c based on veg type and month)
12 c getalb (Set the 4 albedos based on veg type, snow and time)
13 c getemiss (Set the surface emissivity based on the veg type
14 c and the snow depth)
15 c-----------------------------------------------------------------------
16 implicit none
17 #include "CPP_OPTIONS.h"
18 #include "SIZE.h"
19 #include "fizhi_land_SIZE.h"
20 #include "fizhi_SIZE.h"
21 #include "fizhi_coms.h"
22 #include "gridalt_mapping.h"
23 #include "fizhi_land_coms.h"
24 #include "fizhi_earth_coms.h"
25 #include "fizhi_ocean_coms.h"
26 #include "EEPARAMS.h"
27
28 integer myTime, myIter, myThid
29
30 real lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
31 real fraci(sNx,sNy), fracl(sNx,sNy)
32 real ficetile(nchp)
33 real ra
34 integer i, j, L, bi, bj
35 integer im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2
36 integer sec, day, month
37 integer nmonf,ndayf
38 nmonf(n) = mod(n,10000)/100
39 ndayf(n) = mod(n,100)
40
41 idim1 = 1-OLx
42 idim2 = sNx+OLx
43 jdim1 = 1-OLy
44 jdim2 = sNy+OLy
45 im1 = 1
46 im2 = sNx
47 jm1 = 1
48 jm2 = sNy
49 month = nmonf(nymd)
50 day = ndayf(nymd)
51 sec = nsecf(nhms)
52
53 do bj = myByLo(myThid), myByHi(myThid)
54 do bi = myBxLo(myThid), myBxHi(myThid)
55 do j = jm1,jm2
56 do i = im1,im2
57 lons(i,j,bi,bj) = xC(i,j,bi,bj)
58 lats(i,j,bi,bj) = yC(i,j,bi,bj)
59 enddo
60 enddo
61
62 call get_landfrac(im2,jm2,nSx,nSy,bi,bj,maxtyp,surftype,tilefrac,
63 . fracl)
64 do j = jm1,jm2
65 do i = im1,im2
66 if(sea_ice(i,j,bi,bj).gt.0.) then
67 fraci(i,j) = 1.
68 else
69 fraci(i,j) = 0.
70 endif
71 enddo
72 enddo
73
74 C***********************************************************************
75 C* Get Leaf-Area-Index and Greenness Index *
76 C***********************************************************************
77
78 if( alarm('turb') .or. alarm('radsw') ) then
79 call getlgr (sec,month,day,chlt,ityp,nchpland,bi,bj,alai,agrn )
80 endif
81
82 C **********************************************************************
83 C Compute Surface Albedo
84 C **********************************************************************
85
86 if( alarm('radsw') ) then
87 call astro(nymd,nhms,lats,lons,im2*jm2,cosz,ra)
88 call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,
89 . nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,alai,agrn,
90 . albvisdr,albvisdf,albnirdr,albnirdf )
91 endif
92
93
94 C **********************************************************************
95 C Compute Surface Emissivity
96 C **********************************************************************
97
98 if( alarm('radlw') ) then
99 call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchp)
100 call getemiss(fracl,im2,jm2,nchp,nSx,nSy,bi,bj,igrd,ityp,chfr,
101 . snodep,ficetile,emiss)
102 endif
103
104
105 C*********************************************************************
106 C Ground Temperature Over Ocean is from SST array,
107 C*********************************************************************
108
109 do j = 1,jm
110 do i = 1,im
111 if(fracl(i,j).lt.0.3.and.sea_ice(i,j).eq.0.0)tgz(i,j) = sst(i,j)
112 endif
113 enddo
114 enddo
115
116 enddo
117 enddo
118
119 return
120 end
121
122 SUBROUTINE SIBALB ( AVISDR, ANIRDR, AVISDF, ANIRDF,
123 . VLAI, VGRN, ZTH, SNW, ITYP, IRUN )
124
125 C*********************************************************************
126 C The input list is as follows:
127 C VLAI: the leaf area index.
128 C VGRN: the greenness index.
129 C ZTH: The cosine of the solar zenith angle.
130 C SNW: Snow cover in meters water equivalent.
131 C ITYP: The surface type (grass, bare soil, etc.)
132 C IRUN: Number of tiles (same as used for SUBROUTINE TILE).
133 C
134 C The output list is as follows:
135 C
136 C AVISDR: visible, direct albedo.
137 C ANIRDR: near infra-red, direct albedo.
138 C AVISDF: visible, diffuse albedo.
139 C ANIRDF: near infra-red, diffuse albedo.
140 C*******************************************************************
141
142 IMPLICIT NONE
143
144 INTEGER IRUN
145 REAL AVISDR (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN),
146 ` VLAI (IRUN), VGRN (IRUN), ZTH (IRUN), SNW (IRUN)
147 INTEGER ITYP (IRUN)
148
149 REAL ALVDRS, ALIDRS
150 REAL ALVDRDL, ALIDRDL
151 REAL ALVDRDD, ALIDRDD
152 REAL ALVDRI, ALIDRI
153 REAL minval
154 external minval
155
156 PARAMETER ( ALVDRS = 0.100 ) ! Albedo of soil for visible direct solar radiation.
157 PARAMETER ( ALIDRS = 0.200 ) ! Albedo of soil for infra-red direct solar radiation.
158 PARAMETER ( ALVDRDL = 0.300 ) ! Albedo of light desert for visible direct solar radiation.
159 PARAMETER ( ALIDRDL = 0.350 ) ! Albedo of light desert for infra-red direct solar radiation.
160 PARAMETER ( ALVDRDD = 0.250 ) ! Albedo of dark desert for visible direct solar radiation.
161 PARAMETER ( ALIDRDD = 0.300 ) ! Albedo of dark desert for infra-red direct solar radiation.
162 PARAMETER ( ALVDRI = 0.800 ) ! Albedo of ice for visible direct solar radiation.
163 PARAMETER ( ALIDRI = 0.800 ) ! Albedo of ice for infra-red direct solar radiation.
164
165 * --------------------------------------------------------------------------------------------
166
167 INTEGER NTYPS
168 INTEGER NLAI
169 REAL ZERO, ONE
170 REAL EPSLN, BLAI, DLAI
171 REAL ALATRM
172 PARAMETER (NLAI = 14 )
173 PARAMETER (EPSLN = 1.E-6)
174 PARAMETER (BLAI = 0.5)
175 PARAMETER (DLAI = 0.5)
176 PARAMETER (ZERO=0., ONE=1.0)
177 PARAMETER (ALATRM = BLAI + (NLAI - 1) * DLAI - EPSLN)
178 PARAMETER (NTYPS=10)
179
180
181 C ITYP: Vegetation type as follows:
182 C 1: BROADLEAF EVERGREEN TREES
183 C 2: BROADLEAF DECIDUOUS TREES
184 C 3: NEEDLELEAF TREES
185 C 4: GROUND COVER
186 C 5: BROADLEAF SHRUBS
187 C 6: DWARF TREES (TUNDRA)
188 C 7: BARE SOIL
189 C 8: LIGHT DESERT
190 C 9: GLACIER
191 C 10: DARK DESERT
192 C
193
194
195 * [ Definition of Variables: ]
196 *
197 INTEGER I, LAI
198
199 REAL FAC, GAMMA, BETA, ALPHA,
200 ` DX, DY, ALA, GRN (2),
201 ` SNWALB (4, NTYPS), SNWMID (NTYPS)
202
203 * [ Definition of Functions: ]
204 *
205 REAL COEFF
206
207 C Constants used in albedo calculations:
208
209 REAL ALVDR (NLAI, 2, NTYPS)
210 REAL BTVDR (NLAI, 2, NTYPS)
211 REAL GMVDR (NLAI, 2, NTYPS)
212 REAL ALIDR (NLAI, 2, NTYPS)
213 REAL BTIDR (NLAI, 2, NTYPS)
214 REAL GMIDR (NLAI, 2, NTYPS)
215
216 C (Data statements for ALVDR described in full; data statements for
217 C other constants follow same framework.)
218
219 C BROADLEAF EVERGREEN (ITYP=4); GREEN=0.33; LAI: .5-7
220 DATA (ALVDR (I, 1, 1), I = 1, 14)
221 ` /0.0808, 0.0796, 0.0792, 0.0790, 10*0.0789/
222
223 C BROADLEAF EVERGREEN (ITYP=4); GREEN=0.67; LAI: .5-7
224 DATA (ALVDR (I, 2, 1), I = 1, 14)
225 ` /0.0788, 0.0775, 0.0771, 0.0769, 10*0.0768/
226
227 C BROADLEAF DECIDUOUS (ITYP=1); GREEN=0.33; LAI: .5-7
228 DATA (ALVDR (I, 1, 2), I = 1, 14)
229 ` /0.0803, 0.0790, 0.0785, 0.0784, 3*0.0783, 7*0.0782/
230
231 C BROADLEAF DECIDUOUS (ITYP=1); GREEN=0.67; LAI: .5-7
232 DATA (ALVDR (I, 2, 2), I = 1, 14)
233 ` /0.0782, 0.0770, 0.0765, 0.0763, 10*0.0762/
234
235 C NEEDLELEAF (ITYP=3); GREEN=0.33; LAI=.5-7
236 DATA (ALVDR (I, 1, 3), I = 1, 14)
237 ` /0.0758, 0.0746, 0.0742, 0.0740, 10*0.0739/
238
239 C NEEDLELEAF (ITYP=3); GREEN=0.67; LAI=.5-7
240 DATA (ALVDR (I, 2, 3), I = 1, 14)
241 ` /0.0683, 0.0672, 0.0667, 2*0.0665, 9*0.0664/
242
243 C GROUNDCOVER (ITYP=2); GREEN=0.33; LAI=.5-7
244 DATA (ALVDR (I, 1, 4), I = 1, 14)
245 ` /0.2436, 0.2470, 0.2486, 0.2494, 0.2498, 0.2500, 2*0.2501,
246 ` 6*0.2502
247 ` /
248 C GROUNDCOVER (ITYP=2); GREEN=0.67; LAI=.5-7
249 DATA (ALVDR (I, 2, 4), I = 1, 14) /14*0.1637/
250
251 C BROADLEAF SHRUBS (ITYP=5); GREEN=0.33,LAI=.5-7
252 DATA (ALVDR (I, 1, 5), I = 1, 14)
253 & /0.0807, 0.0798, 0.0794, 0.0792, 0.0792, 9*0.0791/
254
255 C BROADLEAF SHRUBS (ITYP=5); GREEN=0.67,LAI=.5-7
256 DATA (ALVDR (I, 2, 5), I = 1, 14)
257 & /0.0787, 0.0777, 0.0772, 0.0771, 10*0.0770/
258
259 C DWARF TREES, OR TUNDRA (ITYP=6); GREEN=0.33,LAI=.5-7
260 DATA (ALVDR (I, 1, 6), I = 1, 14)
261 & /0.0802, 0.0791, 0.0787, 0.0786, 10*0.0785/
262
263 C DWARF TREES, OR TUNDRA (ITYP=6); GREEN=0.67,LAI=.5-7
264 DATA (ALVDR (I, 2, 6), I = 1, 14)
265 & /0.0781, 0.0771, 0.0767, 0.0765, 0.0765, 9*0.0764/
266
267
268 C BARE SOIL
269 DATA (ALVDR (I, 1, 7), I = 1, 14) /14*ALVDRS/
270 DATA (ALVDR (I, 2, 7), I = 1, 14) /14*ALVDRS/
271
272 C LIGHT DESERT (SAHARA, EG)
273 DATA (ALVDR (I, 1, 8), I = 1, 14) /14*ALVDRDL/
274 DATA (ALVDR (I, 2, 8), I = 1, 14) /14*ALVDRDL/
275
276 C ICE
277 DATA (ALVDR (I, 1, 9), I = 1, 14) /14*ALVDRI/
278 DATA (ALVDR (I, 2, 9), I = 1, 14) /14*ALVDRI/
279
280 C DARK DESERT (AUSTRALIA, EG)
281 DATA (ALVDR (I, 1, 10), I = 1, 14) /14*ALVDRDD/
282 DATA (ALVDR (I, 2, 10), I = 1, 14) /14*ALVDRDD/
283 C****
284 C**** -------------------------------------------------
285 DATA (BTVDR (I, 1, 1), I = 1, 14)
286 ` /0.0153, 0.0372, 0.0506, 0.0587, 0.0630, 0.0652, 0.0663,
287 ` 0.0668, 0.0671, 0.0672, 4*0.0673
288 ` /
289 DATA (BTVDR (I, 2, 1), I = 1, 14)
290 * /0.0135, 0.0354, 0.0487, 0.0568, 0.0611, 0.0633, 0.0644,
291 ` 0.0650, 0.0652, 0.0654, 0.0654, 3*0.0655
292 ` /
293 DATA (BTVDR (I, 1, 2), I = 1, 14)
294 * /0.0148, 0.0357, 0.0462, 0.0524, 0.0554, 0.0569, 0.0576,
295 ` 0.0579, 0.0580, 0.0581, 0.0581, 3*0.0582
296 ` /
297 DATA (BTVDR (I, 2, 2), I = 1, 14)
298 * /0.0131, 0.0342, 0.0446, 0.0508, 0.0539, 0.0554, 0.0560,
299 ` 0.0564, 0.0565, 5*0.0566
300 ` /
301 DATA (BTVDR (I, 1, 3), I = 1, 14)
302 * /0.0108, 0.0334, 0.0478, 0.0571, 0.0624, 0.0652, 0.0666,
303 ` 0.0673, 0.0677, 0.0679, 4*0.0680
304 ` /
305 DATA (BTVDR (I, 2, 3), I = 1, 14)
306 * /0.0034, 0.0272, 0.0408, 0.0501, 0.0554, 0.0582, 0.0597,
307 * 0.0604, 0.0608, 0.0610, 4*0.0611
308 ` /
309 DATA (BTVDR (I, 1, 4), I = 1, 14)
310 * /0.2050, 0.2524, 0.2799, 0.2947, 0.3022, 0.3059, 0.3076,
311 * 0.3085, 0.3088, 0.3090, 4*0.3091
312 ` /
313 DATA (BTVDR (I, 2, 4), I = 1, 14)
314 * /0.1084, 0.1404, 0.1617, 0.1754, 0.1837, 0.1887, 0.1915,
315 * 0.1931, 0.1940, 0.1946, 0.1948, 0.1950, 2*0.1951
316 ` /
317 DATA (BTVDR (I, 1, 5), I = 1, 14)
318 & /0.0203, 0.0406, 0.0548, 0.0632, 0.0679, 0.0703, 0.0716,
319 & 0.0722, 0.0726, 0.0727, 0.0728, 0.0728, 0.0728, 0.0729
320 ` /
321
322 DATA (BTVDR (I, 2, 5), I = 1, 14)
323 & /0.0184, 0.0385, 0.0526, 0.0611, 0.0658, 0.0683, 0.0696,
324 & 0.0702, 0.0705, 0.0707, 4*0.0708
325 ` /
326
327 DATA (BTVDR (I, 1, 6), I = 1, 14)
328 & /0.0199, 0.0388, 0.0494, 0.0554, 0.0584, 0.0599, 0.0606,
329 & 0.0609, 0.0611, 5*0.0612
330 ` /
331
332 DATA (BTVDR (I, 2, 6), I = 1, 14)
333 & /0.0181, 0.0371, 0.0476, 0.0537, 0.0568, 0.0583, 0.0590,
334 & 0.0593, 0.0595, 0.0595, 4*0.0596
335 ` /
336
337 DATA (BTVDR (I, 1, 7), I = 1, 14) /14*0./
338 DATA (BTVDR (I, 2, 7), I = 1, 14) /14*0./
339
340 DATA (BTVDR (I, 1, 8), I = 1, 14) /14*0./
341 DATA (BTVDR (I, 2, 8), I = 1, 14) /14*0./
342
343 DATA (BTVDR (I, 1, 9), I = 1, 14) /14*0./
344 DATA (BTVDR (I, 2, 9), I = 1, 14) /14*0./
345
346 DATA (BTVDR (I, 1, 10), I = 1, 14) /14*0./
347 DATA (BTVDR (I, 2, 10), I = 1, 14) /14*0./
348
349 C****
350 C**** -----------------------------------------------------------
351 DATA (GMVDR (I, 1, 1), I = 1, 14)
352 ` /0.0814, 0.1361, 0.2078, 0.2650, 0.2986, 0.3169, 0.3265,
353 * 0.3313, 0.3337, 0.3348, 0.3354, 0.3357, 2*0.3358
354 ` /
355 DATA (GMVDR (I, 2, 1), I = 1, 14)
356 * /0.0760, 0.1336, 0.2034, 0.2622, 0.2969, 0.3159, 0.3259,
357 * 0.3309, 0.3333, 0.3346, 0.3352, 0.3354, 2*0.3356
358 ` /
359 DATA (GMVDR (I, 1, 2), I = 1, 14)
360 * /0.0834, 0.1252, 0.1558, 0.1927, 0.2131, 0.2237, 0.2290,
361 * 0.2315, 0.2327, 0.2332, 0.2335, 2*0.2336, 0.2337
362 ` /
363 DATA (GMVDR (I, 2, 2), I = 1, 14)
364 * /0.0789, 0.1235, 0.1531, 0.1912, 0.2122, 0.2232, 0.2286,
365 * 0.2312, 0.2324, 0.2330, 0.2333, 0.2334, 2*0.2335
366 ` /
367 DATA (GMVDR (I, 1, 3), I = 1, 14)
368 * /0.0647, 0.1342, 0.2215, 0.2968, 0.3432, 0.3696, 0.3838,
369 * 0.3912, 0.3950, 0.3968, 0.3978, 0.3982, 0.3984, 0.3985
370 ` /
371 DATA (GMVDR (I, 2, 3), I = 1, 14)
372 * /0.0258, 0.1227, 0.1999, 0.2825, 0.3339, 0.3634, 0.3794,
373 * 0.3877, 0.3919, 0.3940, 0.3950, 0.3956, 0.3958, 0.3959
374 ` /
375 DATA (GMVDR (I, 1, 4), I = 1, 14)
376 * /0.3371, 0.5762, 0.7159, 0.7927, 0.8324, 0.8526, 0.8624,
377 * 0.8671, 0.8693, 0.8704, 0.8709, 0.8710, 2*0.8712
378 ` /
379 DATA (GMVDR (I, 2, 4), I = 1, 14)
380 * /0.2634, 0.4375, 0.5532, 0.6291, 0.6763, 0.7048, 0.7213,
381 * 0.7310, 0.7363, 0.7395, 0.7411, 0.7420, 0.7426, 0.7428
382 ` /
383 DATA (GMVDR (I, 1, 5), I = 1, 14)
384 & /0.0971, 0.1544, 0.2511, 0.3157, 0.3548, 0.3768, 0.3886,
385 & 0.3948, 0.3978, 0.3994, 0.4001, 0.4006, 0.4007, 0.4008
386 ` /
387
388 DATA (GMVDR (I, 2, 5), I = 1, 14)
389 & /0.0924, 0.1470, 0.2458, 0.3123, 0.3527, 0.3756, 0.3877,
390 & 0.3942, 0.3974, 0.3990, 0.3998, 0.4002, 0.4004, 0.4005
391 ` /
392
393 DATA (GMVDR (I, 1, 6), I = 1, 14)
394 & /0.0970, 0.1355, 0.1841, 0.2230, 0.2447, 0.2561, 0.2617,
395 & 0.2645, 0.2658, 0.2664, 0.2667, 3*0.2669
396 ` /
397
398 DATA (GMVDR (I, 2, 6), I = 1, 14)
399 & /0.0934, 0.1337, 0.1812, 0.2213, 0.2437, 0.2554, 0.2613,
400 & 0.2642, 0.2656, 0.2662, 0.2665, 0.2667, 0.2667, 0.2668
401 ` /
402
403 DATA (GMVDR (I, 1, 7), I = 1, 14) /14*1./
404 DATA (GMVDR (I, 2, 7), I = 1, 14) /14*1./
405
406 DATA (GMVDR (I, 1, 8), I = 1, 14) /14*1./
407 DATA (GMVDR (I, 2, 8), I = 1, 14) /14*1./
408
409 DATA (GMVDR (I, 1, 9), I = 1, 14) /14*1./
410 DATA (GMVDR (I, 2, 9), I = 1, 14) /14*1./
411
412 DATA (GMVDR (I, 1, 10), I = 1, 14) /14*1./
413 DATA (GMVDR (I, 2, 10), I = 1, 14) /14*1./
414
415 C****
416 C**** -----------------------------------------------------------
417
418 DATA (ALIDR (I, 1, 1), I = 1, 14)
419 * /0.2867, 0.2840, 0.2828, 0.2822, 0.2819, 0.2818, 2*0.2817,
420 * 6*0.2816
421 ` /
422 DATA (ALIDR (I, 2, 1), I = 1, 14)
423 * /0.3564, 0.3573, 0.3577, 0.3580, 2*0.3581, 8*0.3582/
424 DATA (ALIDR (I, 1, 2), I = 1, 14)
425 * /0.2848, 0.2819, 0.2804, 0.2798, 0.2795, 2*0.2793, 7*0.2792/
426 DATA (ALIDR (I, 2, 2), I = 1, 14)
427 * /0.3544, 0.3550, 0.3553, 2*0.3555, 9*0.3556/
428 DATA (ALIDR (I, 1, 3), I = 1, 14)
429 * /0.2350, 0.2311, 0.2293, 0.2285, 0.2281, 0.2280, 8*0.2279/
430 DATA (ALIDR (I, 2, 3), I = 1, 14)
431 * /0.2474, 0.2436, 0.2418, 0.2410, 0.2406, 0.2405, 3*0.2404,
432 * 5*0.2403
433 ` /
434 DATA (ALIDR (I, 1, 4), I = 1, 14)
435 * /0.5816, 0.6157, 0.6391, 0.6556, 0.6673, 0.6758, 0.6820,
436 * 0.6866, 0.6899, 0.6924, 0.6943, 0.6956, 0.6966, 0.6974
437 ` /
438 DATA (ALIDR (I, 2, 4), I = 1, 14)
439 * /0.5489, 0.5770, 0.5955, 0.6079, 0.6163, 0.6221, 0.6261,
440 * 0.6288, 0.6308, 0.6321, 0.6330, 0.6337, 0.6341, 0.6344
441 ` /
442 DATA (ALIDR (I, 1, 5), I = 1, 14)
443 & /0.2845, 0.2837, 0.2832, 0.2831, 0.2830, 9*0.2829/
444 DATA (ALIDR (I, 2, 5), I = 1, 14)
445 & /0.3532, 0.3562, 0.3578, 0.3586, 0.3590, 0.3592, 0.3594,
446 & 0.3594, 0.3594, 5*0.3595
447 ` /
448 DATA (ALIDR (I, 1, 6), I = 1, 14)
449 & /0.2825, 0.2812, 0.2806, 0.2803, 0.2802, 9*0.2801/
450 DATA (ALIDR (I, 2, 6), I = 1, 14)
451 & /0.3512, 0.3538, 0.3552, 0.3559, 0.3562, 0.3564, 0.3565,
452 & 0.3565, 6*0.3566
453 ` /
454
455 DATA (ALIDR (I, 1, 7), I = 1, 14) /14*ALIDRS/
456 DATA (ALIDR (I, 2, 7), I = 1, 14) /14*ALIDRS/
457
458 DATA (ALIDR (I, 1, 8), I = 1, 14) /14*ALIDRDL/
459 DATA (ALIDR (I, 2, 8), I = 1, 14) /14*ALIDRDL/
460
461 DATA (ALIDR (I, 1, 9), I = 1, 14) /14*ALIDRI/
462 DATA (ALIDR (I, 2, 9), I = 1, 14) /14*ALIDRI/
463
464 DATA (ALIDR (I, 1, 10), I = 1, 14) /14*ALIDRDD/
465 DATA (ALIDR (I, 2, 10), I = 1, 14) /14*ALIDRDD/
466
467 C****
468 C**** -----------------------------------------------------------
469 DATA (BTIDR (I, 1, 1), I = 1, 14)
470 * /0.1291, 0.1707, 0.1969, 0.2125, 0.2216, 0.2267, 0.2295,
471 * 0.2311, 0.2319, 0.2323, 0.2326, 2*0.2327, 0.2328
472 ` /
473 DATA (BTIDR (I, 2, 1), I = 1, 14)
474 * /0.1939, 0.2357, 0.2598, 0.2735, 0.2810, 0.2851, 0.2874,
475 * 0.2885, 0.2892, 0.2895, 0.2897, 3*0.2898
476 ` /
477 DATA (BTIDR (I, 1, 2), I = 1, 14)
478 * /0.1217, 0.1522, 0.1713, 0.1820, 0.1879, 0.1910, 0.1926,
479 * 0.1935, 0.1939, 0.1942, 2*0.1943, 2*0.1944
480 ` /
481 DATA (BTIDR (I, 2, 2), I = 1, 14)
482 * /0.1781, 0.2067, 0.2221, 0.2301, 0.2342, 0.2363, 0.2374,
483 * 0.2379, 0.2382, 0.2383, 2*0.2384, 2*0.2385
484 ` /
485 DATA (BTIDR (I, 1, 3), I = 1, 14)
486 * /0.0846, 0.1299, 0.1614, 0.1814, 0.1935, 0.2004, 0.2043,
487 * 0.2064, 0.2076, 0.2082, 0.2085, 2*0.2087, 0.2088
488 ` /
489 DATA (BTIDR (I, 2, 3), I = 1, 14)
490 * /0.0950, 0.1410, 0.1722, 0.1921, 0.2042, 0.2111, 0.2151,
491 * 0.2172, 0.2184, 0.2191, 0.2194, 0.2196, 2*0.2197
492 ` /
493 DATA (BTIDR (I, 1, 4), I = 1, 14)
494 * /0.5256, 0.7444, 0.9908, 1.2700, 1.5680, 1.8505, 2.0767,
495 * 2.2211, 2.2808, 2.2774, 2.2362, 2.1779, 2.1160, 2.0564
496 ` /
497 DATA (BTIDR (I, 2, 4), I = 1, 14)
498 * /0.4843, 0.6714, 0.8577, 1.0335, 1.1812, 1.2858, 1.3458,
499 * 1.3688, 1.3685, 1.3546, 1.3360, 1.3168, 1.2989, 1.2838
500 ` /
501 DATA (BTIDR (I, 1, 5), I = 1, 14)
502 & /0.1498, 0.1930, 0.2201, 0.2364, 0.2460, 0.2514, 0.2544,
503 & 0.2560, 0.2569, 0.2574, 0.2577, 0.2578, 0.2579, 0.2579
504 ` /
505
506 DATA (BTIDR (I, 2, 5), I = 1, 14)
507 & /0.2184, 0.2656, 0.2927, 0.3078, 0.3159, 0.3202, 0.3224,
508 & 0.3235, 0.3241, 0.3244, 0.3245, 3*0.3246
509 ` /
510
511 DATA (BTIDR (I, 1, 6), I = 1, 14)
512 & /0.1369, 0.1681, 0.1860, 0.1958, 0.2010, 0.2038, 0.2053,
513 & 0.2060, 0.2064, 0.2066, 0.2067, 3*0.2068
514 ` /
515
516 DATA (BTIDR (I, 2, 6), I = 1, 14)
517 & /0.1969, 0.2268, 0.2416, 0.2488, 0.2521, 0.2537, 0.2544,
518 & 0.2547, 0.2548, 5*0.2549
519 ` /
520
521
522 DATA (BTIDR (I, 1, 7), I = 1, 14) /14*0./
523 DATA (BTIDR (I, 2, 7), I = 1, 14) /14*0./
524
525 DATA (BTIDR (I, 1, 8), I = 1, 14) /14*0./
526 DATA (BTIDR (I, 2, 8), I = 1, 14) /14*0./
527
528 DATA (BTIDR (I, 1, 9), I = 1, 14) /14*0./
529 DATA (BTIDR (I, 2, 9), I = 1, 14) /14*0./
530
531 DATA (BTIDR (I, 1, 10), I = 1, 14) /14*0./
532 DATA (BTIDR (I, 2, 10), I = 1, 14) /14*0./
533
534 C****
535 C**** --------------------------------------------------------------
536 DATA (GMIDR (I, 1, 1), I = 1, 14)
537 * /0.1582, 0.2581, 0.3227, 0.3635, 0.3882, 0.4026, 0.4108,
538 * 0.4154, 0.4179, 0.4193, 0.4200, 0.4204, 0.4206, 0.4207
539 ` /
540 DATA (GMIDR (I, 2, 1), I = 1, 14)
541 * /0.1934, 0.3141, 0.3818, 0.4200, 0.4415, 0.4533, 0.4598,
542 * 0.4633, 0.4651, 0.4662, 0.4667, 0.4671, 2*0.4672
543 ` /
544 DATA (GMIDR (I, 1, 2), I = 1, 14)
545 * /0.1347, 0.1871, 0.2277, 0.2515, 0.2651, 0.2727, 0.2768,
546 * 0.2790, 0.2801, 0.2808, 0.2811, 0.2812, 0.2813, 0.2814
547 ` /
548 DATA (GMIDR (I, 2, 2), I = 1, 14)
549 * /0.1440, 0.2217, 0.2629, 0.2839, 0.2947, 0.3003, 0.3031,
550 * 0.3046, 0.3054, 0.3058, 0.3060, 2*0.3061, 0.3062
551 ` /
552 DATA (GMIDR (I, 1, 3), I = 1, 14)
553 * /0.1372, 0.2368, 0.3235, 0.3839, 0.4229, 0.4465, 0.4602,
554 * 0.4679, 0.4722, 0.4745, 0.4758, 0.4764, 0.4768, 0.4770
555 ` /
556 DATA (GMIDR (I, 2, 3), I = 1, 14)
557 * /0.1435, 0.2524, 0.3370, 0.3955, 0.4332, 0.4563, 0.4697,
558 * 0.4773, 0.4815, 0.4839, 0.4851, 0.4858, 0.4861, 0.4863
559 ` /
560 DATA (GMIDR (I, 1, 4), I = 1, 14)
561 * /0.4298, 0.9651, 1.6189, 2.4084, 3.2992, 4.1928, 4.9611,
562 * 5.5095, 5.8085, 5.9069, 5.8726, 5.7674, 5.6346, 5.4944
563 ` /
564 DATA (GMIDR (I, 2, 4), I = 1, 14)
565 * /0.4167, 0.8974, 1.4160, 1.9414, 2.4147, 2.7803, 3.0202,
566 * 3.1468, 3.1954, 3.1932, 3.1676, 3.1328, 3.0958, 3.0625
567 ` /
568 DATA (GMIDR (I, 1, 5), I = 1, 14)
569 & /0.1959, 0.3203, 0.3985, 0.4472, 0.4766, 0.4937, 0.5034,
570 & 0.5088, 0.5117, 0.5134, 0.5143, 0.5147, 0.5150, 0.5152
571 ` /
572
573 DATA (GMIDR (I, 2, 5), I = 1, 14)
574 & /0.2328, 0.3859, 0.4734, 0.5227, 0.5498, 0.5644, 0.5720,
575 & 0.5761, 0.5781, 0.5792, 0.5797, 0.5800, 0.5802, 0.5802
576 ` /
577
578 DATA (GMIDR (I, 1, 6), I = 1, 14)
579 & /0.1447, 0.2244, 0.2698, 0.2953, 0.3094, 0.3170, 0.3211,
580 & 0.3233, 0.3244, 0.3250, 0.3253, 0.3255, 0.3256, 0.3256
581 ` /
582
583 DATA (GMIDR (I, 2, 6), I = 1, 14)
584 & /0.1643, 0.2624, 0.3110, 0.3347, 0.3461, 0.3517, 0.3543,
585 & 0.3556, 0.3562, 0.3564, 0.3565, 0.3566, 0.3566, 0.3566
586 ` /
587
588 DATA (GMIDR (I, 1, 7), I = 1, 14) /14*1./
589 DATA (GMIDR (I, 2, 7), I = 1, 14) /14*1./
590
591 DATA (GMIDR (I, 1, 8), I = 1, 14) /14*1./
592 DATA (GMIDR (I, 2, 8), I = 1, 14) /14*1./
593
594 DATA (GMIDR (I, 1, 9), I = 1, 14) /14*1./
595 DATA (GMIDR (I, 2, 9), I = 1, 14) /14*1./
596
597 DATA (GMIDR (I, 1, 10), I = 1, 14) /14*1./
598 DATA (GMIDR (I, 2, 10), I = 1, 14) /14*1./
599
600
601 C**** -----------------------------------------------------------
602
603 DATA GRN /0.33, 0.67/
604
605 include 'snwmid.h'
606 DATA SNWALB /.65, .38, .65, .38,
607 * .65, .38, .65, .38,
608 * .65, .38, .65, .38,
609 * .65, .38, .65, .38,
610 * .65, .38, .65, .38,
611 & .65, .38, .65, .38,
612 & .65, .38, .65, .38,
613 & .65, .38, .65, .38,
614 & .80, .60, .80, .60,
615 & .65, .38, .65, .38
616 ` /
617
618 #if CRAY
619 #if f77
620 cfpp$ expand (coeff)
621 #endif
622 #if f90
623 !DIR$ inline always coeff
624 #endif
625 #endif
626
627 DO 100 I=1,IRUN
628 ALA = MIN (MAX (ZERO, VLAI(I)), ALATRM)
629 LAI = 1 + MAX(0, INT((ALA-BLAI)/DLAI) )
630 DX = (ALA - (BLAI+(LAI-1)*DLAI)) * (ONE/DLAI)
631 DY = (VGRN(I)- GRN(1)) * (ONE/(GRN(2) - GRN(1)))
632
633 ALPHA = COEFF (ALVDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
634 BETA = COEFF (BTVDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
635 GAMMA = COEFF (GMVDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
636
637 AVISDR(I) = ALPHA - ZTH(I)*BETA / (GAMMA+ZTH(I))
638 AVISDF(I) = ALPHA-BETA
639 * + 2.*BETA*GAMMA*(1.-GAMMA*LOG((1.+GAMMA)/GAMMA))
640
641 ALPHA = COEFF (ALIDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
642 BETA = COEFF (BTIDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
643 GAMMA = COEFF (GMIDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
644
645 ANIRDR(I) = ALPHA - ZTH(I)*BETA / (GAMMA+ZTH(I))
646 ANIRDF(I) = ALPHA-BETA
647 * + 2.*BETA*GAMMA*(1.-GAMMA*LOG((1.+GAMMA)/GAMMA))
648
649 IF (SNW (I) .GT. ZERO) THEN
650 FAC = SNW(I) / (SNW(I) + SNWMID(ITYP(I)))
651
652 AVISDR(I) = AVISDR(I) + (SNWALB(1,ITYP(I)) - AVISDR(I)) * FAC
653 ANIRDR(I) = ANIRDR(I) + (SNWALB(2,ITYP(I)) - ANIRDR(I)) * FAC
654 AVISDF(I) = AVISDF(I) + (SNWALB(3,ITYP(I)) - AVISDF(I)) * FAC
655 ANIRDF(I) = ANIRDF(I) + (SNWALB(4,ITYP(I)) - ANIRDF(I)) * FAC
656 ENDIF
657
658 100 CONTINUE
659
660 RETURN
661 END
662 FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)
663
664 INTEGER NTABL, LAI
665
666 REAL TABLE (NTABL, 2), DX, DY
667
668 COEFF = (TABLE(LAI, 1)
669 * + (TABLE(LAI ,2) - TABLE(LAI ,1)) * DY ) * (1.0-DX)
670 * + (TABLE(LAI+1,1)
671 * + (TABLE(LAI+1,2) - TABLE(LAI+1,1)) * DY ) * DX
672
673 RETURN
674 END
675 SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,ALAI,AGRN)
676
677 C*********************************************************************
678 C*********************** ARIES MODEL *******************************
679 C********************* SUBROUTINE GETLGR ****************************
680 C********************** 14 JUNE 1991 ******************************
681 C*********************************************************************
682 implicit none
683
684 integer ntyps
685 real one,daylen
686 PARAMETER (NTYPS=10)
687 parameter (one = 1.)
688 parameter (daylen = 86400.)
689
690 integer sec, imon, iday, nchps
691 real ALAI(NCHPS), AGRN(NCHPS), ALAT(NCHPS)
692 integer ITYP(NCHPS)
693
694 integer i,midmon,midm,midp,id,k1,k2,kk1,kk2
695 real fac
696
697 INTEGER DAYS(12)
698 DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/
699
700
701 REAL VGLA(12,NTYPS), VGGR(12,NTYPS)
702
703 DATA VGLA /
704 1 5.117, 5.117, 5.117, 5.117, 5.117, 5.117, 5.117, 5.117,
705 1 5.117, 5.117, 5.117, 5.117,
706 2 0.520, 0.520, 0.867, 2.107, 4.507, 6.773, 7.173, 6.507,
707 2 5.040, 2.173, 0.867, 0.520,
708 3 8.760, 9.160, 9.827,10.093,10.360,10.760,10.493,10.227,
709 3 10.093, 9.827, 9.160, 8.760,
710 4 0.782, 0.893, 1.004, 1.116, 1.782, 3.671, 4.782, 4.227,
711 4 2.004, 1.227, 1.004, 0.893,
712 5 3.760, 3.760, 2.760, 1.760, 1.760, 1.760, 1.760, 5.760,
713 5 10.760, 7.760, 4.760, 3.760,
714 6 0.739, 0.739, 0.739, 0.739, 0.739, 1.072, 5.072, 5.739,
715 6 4.405, 0.739, 0.739, 0.739,
716 7 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
717 7 0.001, 0.001, 0.001, 0.001,
718 8 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
719 8 0.001, 0.001, 0.001, 0.001,
720 9 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
721 9 0.001, 0.001, 0.001, 0.001,
722 1 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
723 1 0.001, 0.001, 0.001, 0.001
724 & /
725
726
727 DATA VGGR
728 1 /0.905, 0.905, 0.905, 0.905, 0.905, 0.905, 0.905, 0.905,
729 1 0.905, 0.905, 0.905, 0.905,
730 2 0.026, 0.026, 0.415, 0.759, 0.888, 0.925, 0.836, 0.697,
731 2 0.331, 0.166, 0.015, 0.026,
732 3 0.913, 0.917, 0.923, 0.925, 0.927, 0.905, 0.902, 0.913,
733 3 0.898, 0.855, 0.873, 0.913,
734 4 0.568, 0.622, 0.664, 0.697, 0.810, 0.908, 0.813, 0.394,
735 4 0.443, 0.543, 0.553, 0.498,
736 5 0.798, 0.532, 0.362, 0.568, 0.568, 0.568, 0.568, 0.868,
737 5 0.651, 0.515, 0.630, 0.798,
738 6 0.451, 0.451, 0.451, 0.451, 0.451, 0.622, 0.920, 0.697,
739 6 0.076, 0.451, 0.451, 0.451,
740 7 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
741 7 0.001, 0.001, 0.001, 0.001,
742 8 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
743 8 0.001, 0.001, 0.001, 0.001,
744 9 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
745 9 0.001, 0.001, 0.001, 0.001,
746 1 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
747 1 0.001, 0.001, 0.001, 0.001
748 & /
749
750
751 MIDMON = DAYS(IMON)/2 + 1
752
753
754 IF (IDAY .LT. MIDMON) THEN
755 K2 = IMON
756 K1 = MOD(IMON+10,12) + 1
757 ELSE
758 K1 = IMON
759 K2 = MOD(IMON,12) + 1
760 ENDIF
761
762 IF (IDAY .LT. MIDMON) THEN
763 MIDM = DAYS(K1)/2 + 1
764 MIDP = DAYS(K1) + MIDMON
765 ID = IDAY + DAYS(K1)
766 ELSE
767 MIDM = MIDMON
768 MIDP = DAYS(K2)/2 + 1 + DAYS(K1)
769 ID = IDAY
770 ENDIF
771
772 FAC = (REAL(ID -MIDM)*DAYLEN + SEC) /
773 * (REAL(MIDP-MIDM)*DAYLEN )
774
775 DO 220 I=1,NCHPS
776
777 IF(ALAT(I).GT.0.) THEN
778 KK1 = K1
779 KK2 = K2
780 ELSE
781 KK1 = MOD(K1+5,12) + 1
782 KK2 = MOD(K2+5,12) + 1
783 ENDIF
784
785 ALAI(I) = VGLA(KK2,ITYP(I))*FAC + VGLA(KK1,ITYP(I))*(ONE-FAC)
786 AGRN(I) = VGGR(KK2,ITYP(I))*FAC + VGGR(KK1,ITYP(I))*(ONE-FAC)
787
788 220 CONTINUE
789
790 RETURN
791 END
792
793 subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,
794 1 im,jm,nchp,nchpland,igrd,ityp,chfr,chlt,
795 2 alai,agrn,albvr,albvf,albnr,albnf)
796 C***********************************************************************
797 C PURPOSE
798 C To act as an interface to routine sibalb, which calculates
799 C the four albedos for use by the shortwave radiation routine
800 C
801 C INPUT:
802 C sec - number of seconds into the day of current time
803 C month - month of the year of current time
804 C day - day of the month of current time
805 C cosz - local cosine of the zenith angle [im,jm]
806 C snodep - snow cover in meters [nchp]
807 C fraci - real array in grid space of total sea ice fraction [im,jm]
808 C fracg - real array in grid space of total land fraction [im,jm]
809 C im - model grid longitude dimension
810 C jm - model grid latitude dimension (number of lat. points)
811 C nchp - integer actual number of tiles in tile space
812 C nchpland - integer number of land tiles
813 C igrd - integer array in tile space of grid point number for each
814 C tile [nchp]
815 C ityp - integer array in tile space of land surface type for each
816 C tile [nchp]
817 C chfr - real array in tile space of land surface type fraction for
818 C each tile [nchp]
819 C chlt - real array in tile space of latitude value for each tile
820 C [nchp]
821 C
822 C OUTPUT:
823 C albvr - real array [im,jm] of visible direct beam albedo
824 C albvf - real array [im,jm] of visible diffuse beam albedo
825 C albnr - real array [im,jm] of near-ir direct beam albedo
826 C albnf - real array [im,jm] of near-ir diffuse beam albedo
827 C
828 C***********************************************************************
829 implicit none
830 real one,a0,a1,a2,a3,ocnalb,albsi
831 PARAMETER (one = 1.)
832 PARAMETER (A0= 0.40670980)
833 PARAMETER (A1=-1.2523634 )
834 PARAMETER (A2= 1.4224051 )
835 PARAMETER (A3=-0.55573341)
836 PARAMETER (OCNALB=0.08)
837 ccc PARAMETER (ALBSI=0.6)
838 PARAMETER (ALBSI=0.7) ! Increased to GEOS-1 Value (0.7) L.Takacs 4/2/96
839
840 integer sec,month,day,im,jm,nchp,nchpland
841 real cosz(im,jm),fraci(im,jm),fracg(im,jm)
842 real snodep(nchp),chfr(nchp),chlt(nchp)
843 integer igrd(nchp),ityp(nchp)
844 real albvr(im,jm),albvf(im,jm),albnr(im,jm)
845 real albnf(im,jm)
846
847 real alboc(im,jm)
848 real AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
849 real ANIRDF(nchp),zenith(nchp)
850 real alai(nchp),agrn(nchp)
851 integer i,j
852
853 DO I=1,IM
854 DO J=1,JM
855 ALBOC(I,J) = A0 + (A1 + (A2 + A3*cosz(I,J))*cosz(I,J))*cosz(I,J)
856 ALBVR(I,J) = ALBSI * FRACI(I,J) + ALBOC(I,J) * (ONE-FRACI(I,J))
857 ALBNR(I,J) = ALBVR(I,J)
858 ALBVF(I,J) = ALBSI * FRACI(I,J) + OCNALB * (ONE-FRACI(I,J))
859 ALBNF(I,J) = ALBVF(I,J)
860 ENDDO
861 ENDDO
862
863
864 C and now some conversions from grid space to tile space before sibalb
865
866 call grd2msc(cosz,im,jm,igrd,zenith,nchp,nchpland)
867
868 C and now call sibalb
869
870 call sibalb(avisdr,anirdr,avisdf,anirdf,alai,agrn,zenith,
871 1 snodep,ityp,nchpland)
872
873 C finally some transformations back to grid space for albedos
874
875 call msc2grd(igrd,chfr,avisdr,nchp,nchpland,fracg,albvr,im,jm)
876 call msc2grd(igrd,chfr,avisdf,nchp,nchpland,fracg,albvf,im,jm)
877 call msc2grd(igrd,chfr,anirdr,nchp,nchpland,fracg,albnr,im,jm)
878 call msc2grd(igrd,chfr,anirdf,nchp,nchpland,fracg,albnf,im,jm)
879
880 return
881 end
882
883 subroutine getemiss (fracg,im,jm,nchp,igrd,ityp,chfr,snowdep,fraci,emiss)
884 C***********************************************************************
885 C PURPOSE
886 C To act as an interface to routine to emissivity, which calculates
887 C ten bands of surface emissivities for use by the longwave radiation
888 C
889 C INPUT:
890 C fracg - real array in grid space of total land fraction [im,jm]
891 C im - model grid longitude dimension
892 C jm - model grid latitude dimension (number of lat. points)
893 C nchp - integer actual number of tiles in tile space
894 C igrd - integer array in tile space of grid point number for each
895 C tile [nchp]
896 C ityp - integer array in tile space of land surface type for each
897 C tile [nchp]
898 C chfr - real array in tile space of land surface type fraction for
899 C each tile [nchp]
900 C snowdep - real array in tile space of snow depth (liquid water equiv)
901 C in mm [nchp]
902 C fraci - real array in tile space of sea ice fraction [nchp]
903 C
904 C OUTPUT:
905 C emiss - real array [im,jm,10] of surface emissivities (fraction)
906 C
907 C***********************************************************************
908 implicit none
909 integer im,jm,nchp
910 real fracg(im,jm)
911 real chfr(nchp)
912 integer igrd(nchp), ityp(nchp)
913 real snowdep(nchp),fraci(nchp)
914 real emiss(im,jm,10)
915
916 real emisstile(nchp,10)
917 integer i,n
918
919 do i = 1,10
920 do n = 1,nchp
921 emisstile(n,i) = 1.
922 enddo
923 enddo
924
925 c call emissivity to get values in tile space
926 c -------------------------------------------
927 call emissivity (snowdep,fraci,nchp,ityp,emisstile)
928
929 c transform back to grid space for emissivities
930 c ---------------------------------------------
931 do i = 1,10
932 emiss(:,:,i) = 0.0
933 call msc2grd (igrd,chfr,emisstile(1,i),nchp,nchp,fracg,emiss(1,1,i),im,jm)
934 enddo
935
936 return
937 end
938
939 subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)
940 implicit none
941 integer numpts
942 integer ityp(numpts)
943 real snowdepth(numpts),fraci(numpts)
944 real newemis(numpts,10)
945
946 real emis(12,11)
947 real snwmid(10)
948 real fac
949 integer i,j
950
951 c-----------------------------------------------------------------------
952 c NOTE: Emissivities were obtained for the following surface types:
953 c ( 1) evergreen needleleaf = conifer
954 c ( 2) evergreen broadleaf = conifer
955 c ( 3) deciduous needleleaf = deciduous
956 c ( 4) deciduous broadleaf = deciduous
957 c ( 5) mixed forests = 1/2 conifer + 1/2 deciduous = tree
958 c ( 6) closed shrublands = 3/4 tree + 1/4 quartz
959 c ( 7) open shrubland = 1/4 tree + 3/4 quartz
960 c ( 8) woody savannas = grass
961 c ( 9) savannas = grass
962 c (10) grasslands = grass
963 c (11) permanent wetlands = 1/2 grass + 1/2 water
964 c (12) croplands = grass
965 c (13) urban = black body
966 c (14) mosaic = 1/2 grass + 1/2 mixed forest
967 c (15) snow/ice
968 c (16) barren/sparsely vegetated = desert(quartz)
969 c (17) water
970 c (18) tundra = frost
971 c
972 c NOTE: Translation to Koster-Suarez surface types was as follows:
973 c ( 1) broadleaf evergreen FROM above type 1 (conifer)
974 c ( 2) broadleaf deciduous FROM above type 2 (deciduous)
975 c ( 3) needleleaf evergreen FROM above type 1 (conifer)
976 c ( 4) groundcover FROM above type 10 (grass)
977 c ( 5) broadleaf shrubs FROM above type 6 (closed shrublands)
978 c ( 6) dwarf trees (tundra) FROM above type 18 (tundra)
979 c ( 7) bare soil FROM above type 16 (desert)
980 c ( 8) light desert FROM above type 16 (desert)
981 c ( 9) glacier FROM above type 15 (snow/ice)
982 c ( 10) dark desert FROM above type 16 (desert)
983 c (100) ocean FROM above type 17 (water)
984 c
985 c NOTE: snow-covered ground uses interpolated emissivities based on snow depth
986 c =============================================================================
987 c -----------------------------------------------------------------------------
988 c Emmissivities for 12 bands in Fu/Liou
989 c band 1: 4.5 - 5.3 um
990 c band 2: 5.3 - 5.9 um
991 c band 3: 5.9 - 7.1 um
992 c band 4: 7.1 - 8.0 um
993 c band 5: 8.0 - 9.1 um
994 c band 6: 9.1 - 10.2 um
995 c band 7: 10.2 - 12.5 um
996 c band 8: 12.5 - 14.9 um
997 c band 9: 14.9 - 18.5 um
998 c band 10: 18.5 - 25.0 um
999 c band 11: 25.0 - 35.7 um
1000 c band 12: 35.7 - oo um
1001 c
1002 c-------------------------------------------------------------------------
1003 data ((emis(i,j),i=1,12),j=1,11) /
1004 & 0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903, ! evergreen needleleaf
1005 & 0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
1006 & 0.9849, 0.9856, 0.9841, 0.9831, 0.9789, 0.9805, ! deciduous needleleaf
1007 & 0.9733, 0.9869, 1.0000, 1.0000, 1.0000, 1.0000,
1008 & 0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903, ! evergreen needleleaf
1009 & 0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
1010 & 0.9867, 0.9897, 0.9920, 0.9933, 0.9830, 0.9752, ! grasslands
1011 & 0.9853, 0.9928, 1.0000, 1.0000, 1.0000, 1.0000,
1012 & 0.9490, 0.9697, 0.9738, 0.9712, 0.9474, 0.9582, ! closed shrublands
1013 & 0.9663, 0.9747, 0.9836, 0.9836, 0.9836, 0.9836,
1014 & 0.9469, 0.9670, 0.9883, 0.9795, 0.9751, 0.9767, ! tundra
1015 & 0.9920, 0.9888, 0.9888, 0.9888, 0.9888, 0.9888,
1016 & 0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren
1017 & 0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1018 & 0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren
1019 & 0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1020 & 0.9998, 0.9998, 0.9998, 0.9998, 0.9998, 0.9999, ! snow/ice
1021 & 0.9997, 0.9994, 0.9995, 0.9995, 0.9995, 0.9995,
1022 & 0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren
1023 & 0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1024 & 0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865, ! water
1025 & 0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/
1026
1027 include 'snwmid.h'
1028
1029 c Convert to the 10 bands needed by Chou Radiation
1030 c ------------------------------------------------
1031 do i=1,numpts
1032
1033 c land points
1034 c------------
1035 if(ityp(i).le.10)then
1036 newemis(i, 1) = (emis( 1,ityp(i))+emis(2,ityp(i)))/2.
1037 newemis(i, 2) = (emis( 2,ityp(i))+emis(3,ityp(i)))/2.
1038 newemis(i, 3) = (emis( 4,ityp(i))+emis(5,ityp(i)))/2.
1039 newemis(i, 4) = emis( 6,ityp(i))
1040 newemis(i, 5) = emis( 7,ityp(i))
1041 newemis(i, 6) = emis( 8,ityp(i))
1042 newemis(i, 7) = emis( 9,ityp(i))
1043 newemis(i, 8) = (emis(10,ityp(i))+emis(11,ityp(i)))/2.
1044 newemis(i, 9) = emis(12,ityp(i))
1045 newemis(i,10) = emis( 4,ityp(i))
1046
1047 c modify emissivity for snow based on snow depth (like albedo)
1048 c-------------------------------------------------------------
1049 if(snowdepth (i).gt.0.) then
1050 fac = snowdepth(i) / (snowdepth(i) + snwmid(ityp(i)))
1051 newemis(i, 1) = newemis(i, 1) + (((emis( 1,9)+emis( 2,9))/2.) - newemis(i, 1)) * fac
1052 newemis(i, 2) = newemis(i, 2) + (((emis( 2,9)+emis( 3,9))/2.) - newemis(i, 2)) * fac
1053 newemis(i, 3) = newemis(i, 3) + (((emis( 4,9)+emis( 5,9))/2.) - newemis(i, 3)) * fac
1054 newemis(i, 4) = newemis(i, 4) + (emis( 6,9) - newemis(i, 4)) * fac
1055 newemis(i, 5) = newemis(i, 5) + (emis( 7,9) - newemis(i, 5)) * fac
1056 newemis(i, 6) = newemis(i, 6) + (emis( 8,9) - newemis(i, 6)) * fac
1057 newemis(i, 7) = newemis(i, 7) + (emis( 9,9) - newemis(i, 7)) * fac
1058 newemis(i, 8) = newemis(i, 8) + (((emis(10,9)+emis(11,9))/2.) - newemis(i, 8)) * fac
1059 newemis(i, 9) = newemis(i, 9) + (emis(12,9) - newemis(i, 9)) * fac
1060 newemis(i,10) = newemis(i,10) + (emis( 4,9) - newemis(i,10)) * fac
1061 endif
1062
1063 c open water
1064 c-----------
1065 else
1066 if(fraci(i).eq.0.)then
1067 newemis(i, 1) = (emis( 1,11)+emis(2,11))/2.
1068 newemis(i, 2) = (emis( 2,11)+emis(3,11))/2.
1069 newemis(i, 3) = (emis( 4,11)+emis(5,11))/2.
1070 newemis(i, 4) = emis( 6,11)
1071 newemis(i, 5) = emis( 7,11)
1072 newemis(i, 6) = emis( 8,11)
1073 newemis(i, 7) = emis( 9,11)
1074 newemis(i, 8) = (emis(10,11)+emis(11,11))/2.
1075 newemis(i, 9) = emis(12,11)
1076 newemis(i,10) = emis( 4,11)
1077
1078 c sea ice (like glacier and snow)
1079 c--------------------------------
1080 else
1081 newemis(i, 1) = (emis( 1,9)+emis(2,9))/2.
1082 newemis(i, 2) = (emis( 2,9)+emis(3,9))/2.
1083 newemis(i, 3) = (emis( 4,9)+emis(5,9))/2.
1084 newemis(i, 4) = emis( 6,9)
1085 newemis(i, 5) = emis( 7,9)
1086 newemis(i, 6) = emis( 8,9)
1087 newemis(i, 7) = emis( 9,9)
1088 newemis(i, 8) = (emis(10,9)+emis(11,9))/2.
1089 newemis(i, 9) = emis(12,9)
1090 newemis(i,10) = emis( 4,9)
1091 endif
1092 endif
1093 enddo
1094
1095 return
1096 end
1097 subroutine get_landfrac(im,jm,nSx,nSy,bi,bj,maxtyp,surftype,
1098 . tilefrac,frac)
1099 C***********************************************************************
1100 C Purpose
1101 C To compute the total fraction of land within a model grid-box
1102 C
1103 C***********************************************************************
1104 implicit none
1105 #include "CPP_OPTIONS.h"
1106
1107 integer i,j,nSx,nSy,bi,bj,maxtyp
1108 integer surftype(im,jm,nSx,nSy)
1109 _RL surftype(im,jm,nSx,nSy)
1110 real frac(im,jm)
1111
1112 integer i,j,k
1113
1114 do j=1,jm
1115 do i=1,im
1116 frac(i,j) = 0.0
1117 enddo
1118 enddo
1119
1120 do k=1,maxtyp
1121 do j=1,jm
1122 do i=1,im
1123 if(surftype(i,j,k,bi,bj).lt.100.and.
1124 tilefrac(i,j,k,bi,bj).gt.0.0)then
1125 frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)
1126 endif
1127 enddo
1128 enddo
1129 enddo
1130
1131 return
1132 end

  ViewVC Help
Powered by ViewVC 1.1.22