File indexing completed on 2023-03-03 06:10:03 UTC
view on githubraw file Latest commit 06d4643e on 2023-01-18 18:18:37 UTC
a456aa407c Andr*0001 #include "FIZHI_OPTIONS.h"
ff4f33cd17 Jean*0002
0003
0004
0005
0006
0007
0008
0009
0010
0011
0012
0013
0014
0015 SUBROUTINE UPDATE_EARTH_EXPORTS (myTime, myIter, myThid)
0016
0017
0018
0019
0020
0021
0022
0023
0024
0025
0026
0027 IMPLICIT NONE
e337e4ca8c Andr*0028 #include "SIZE.h"
613fa3996d Andr*0029 #include "GRID.h"
f4a0368053 Andr*0030 #include "fizhi_land_SIZE.h"
e337e4ca8c Andr*0031 #include "fizhi_SIZE.h"
0032 #include "fizhi_coms.h"
613fa3996d Andr*0033 #include "chronos.h"
e337e4ca8c Andr*0034 #include "gridalt_mapping.h"
f4a0368053 Andr*0035 #include "fizhi_land_coms.h"
4a7a870959 Andr*0036 #include "fizhi_earth_coms.h"
9bc7f6e71e Andr*0037 #include "fizhi_ocean_coms.h"
e337e4ca8c Andr*0038 #include "EEPARAMS.h"
0039
ff4f33cd17 Jean*0040 INTEGER myIter, myThid
3768927683 Andr*0041 _RL myTime
e337e4ca8c Andr*0042
ff4f33cd17 Jean*0043 LOGICAL alarm
0044 EXTERNAL alarm
a456aa407c Andr*0045 _RL lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
0046 _RL fraci(sNx,sNy), fracl(sNx,sNy)
0047 _RL ficetile(nchp)
0048 _RL radius
0049 _RL tmpij(sNx,sNy)
0050 _RL tmpchp(nchp)
ff4f33cd17 Jean*0051 INTEGER i, j, n, bi, bj
0052 INTEGER im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2
0053 INTEGER sec, day, month
0054 INTEGER nmonf,ndayf,nsecf
613fa3996d Andr*0055 nsecf(n) = n/10000*3600 + mod(n,10000)/100* 60 + mod(n,100)
4a7a870959 Andr*0056 nmonf(n) = mod(n,10000)/100
0057 ndayf(n) = mod(n,100)
e337e4ca8c Andr*0058
1411aca51b Andr*0059 idim1 = 1-OLx
0060 idim2 = sNx+OLx
0061 jdim1 = 1-OLy
0062 jdim2 = sNy+OLy
0063 im1 = 1
0064 im2 = sNx
0065 jm1 = 1
0066 jm2 = sNy
4a7a870959 Andr*0067 month = nmonf(nymd)
0068 day = ndayf(nymd)
0069 sec = nsecf(nhms)
e337e4ca8c Andr*0070
1411aca51b Andr*0071 do bj = myByLo(myThid), myByHi(myThid)
0072 do bi = myBxLo(myThid), myBxHi(myThid)
4a7a870959 Andr*0073 do j = jm1,jm2
0074 do i = im1,im2
613fa3996d Andr*0075 lons(i,j) = xC(i,j,bi,bj)
0076 lats(i,j) = yC(i,j,bi,bj)
4a7a870959 Andr*0077 enddo
0078 enddo
e337e4ca8c Andr*0079
9bc7f6e71e Andr*0080 call get_landfrac(im2,jm2,nSx,nSy,bi,bj,maxtyp,surftype,tilefrac,
89889933df Jean*0081 & fracl)
c88fa11306 Andr*0082
9bc7f6e71e Andr*0083 do j = jm1,jm2
0084 do i = im1,im2
613fa3996d Andr*0085 if(sice(i,j,bi,bj).gt.0.) then
9bc7f6e71e Andr*0086 fraci(i,j) = 1.
0087 else
0088 fraci(i,j) = 0.
0089 endif
0090 enddo
0091 enddo
0092
1411aca51b Andr*0093
0094
0095
0096
4c46c31842 Andr*0097 if( alarm('turb') .or. alarm('radsw') ) then
032fb71841 Andr*0098 call getlgr (sec,month,day,chlt,ityp,nchpland(bi,bj),
89889933df Jean*0099 & nchp,nSx,nSy,bi,bj,alai,agrn )
4c46c31842 Andr*0100 endif
1411aca51b Andr*0101
0102
0103
0104
0105
4c46c31842 Andr*0106 if( alarm('radsw') ) then
89889933df Jean*0107 #ifdef FIZHI_USE_FIXED_DAY
0108 call astro(20040321,nhms,lats,lons,im2*jm2,cosz,radius)
0109 #else
613fa3996d Andr*0110 call astro(nymd,nhms,lats,lons,im2*jm2,cosz,radius)
89889933df Jean*0111 #endif
4c46c31842 Andr*0112 call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,
89889933df Jean*0113 & nchptot(bi,bj),nchpland(bi,bj),nSx,nSy,bi,bj,igrd,ityp,
0114 & chfr,chlt,alai,agrn,
0115 & albvisdr,albvisdf,albnirdr,albnirdf )
4c46c31842 Andr*0116 endif
1411aca51b Andr*0117
0118
0119
0120
0121
4c46c31842 Andr*0122 if( alarm('radlw') ) then
626071fec8 Jean*0123 call grd2msc(fraci,im2,jm2,igrd(1,bi,bj),ficetile,
0124 & nchp,nchptot(bi,bj))
032fb71841 Andr*0125 call getemiss(fracl,im2,jm2,nchp,nchptot(bi,bj),nSx,nSy,bi,bj,
89889933df Jean*0126 & igrd,ityp,chfr,snodep,ficetile,emiss)
4c46c31842 Andr*0127 endif
1411aca51b Andr*0128
0129
0130
4c46c31842 Andr*0131
1411aca51b Andr*0132
0133
4c46c31842 Andr*0134 do j = jm1,jm2
0135 do i = im1,im2
613fa3996d Andr*0136 tmpij(i,j) = 0.
4c46c31842 Andr*0137 enddo
0138 enddo
94b04dd079 Andr*0139 do i = 1,nchptot(bi,bj)
613fa3996d Andr*0140 tmpchp(i) = tcanopy(i,bi,bj)
0141 enddo
0142 call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,
89889933df Jean*0143 & nchp,nchptot(bi,bj),fracl,tmpij,im2,jm2)
4c46c31842 Andr*0144 do j = jm1,jm2
0145 do i = im1,im2
613fa3996d Andr*0146 tgz(i,j,bi,bj) = tmpij(i,j)
0147 if(fracl(i,j).lt.0.3.and.sice(i,j,bi,bj).eq.0.0)
89889933df Jean*0148 & tgz(i,j,bi,bj) = sst(i,j,bi,bj)
4c46c31842 Andr*0149 enddo
0150 enddo
1411aca51b Andr*0151
0152 enddo
0153 enddo
0154
0155 return
0156 end
0157
ff4f33cd17 Jean*0158
0159
1411aca51b Andr*0160 SUBROUTINE SIBALB ( AVISDR, ANIRDR, AVISDF, ANIRDF,
89889933df Jean*0161 & VLAI, VGRN, ZTH, SNW, ITYP, IRUN )
1411aca51b Andr*0162
0163
0164
0165
0166
0167
0168
0169
0170
0171
0172
0173
0174
0175
0176
0177
0178
0179
0180 IMPLICIT NONE
0181
0182 INTEGER IRUN
a456aa407c Andr*0183 _RL AVISDR (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)
613fa3996d Andr*0184 _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)
a456aa407c Andr*0185 _RL ZTH(IRUN)
1411aca51b Andr*0186 INTEGER ITYP (IRUN)
0187
a20b61c7ed Andr*0188 _RL ALVDRS, ALIDRS
0189 _RL ALVDRDL, ALIDRDL
0190 _RL ALVDRDD, ALIDRDD
0191 _RL ALVDRI, ALIDRI
0192 _RL minval
ff4f33cd17 Jean*0193 EXTERNAL minval
1411aca51b Andr*0194
63416ca6a5 Andr*0195
89889933df Jean*0196 PARAMETER ( ALVDRS = 0.100 )
63416ca6a5 Andr*0197
89889933df Jean*0198 PARAMETER ( ALIDRS = 0.200 )
63416ca6a5 Andr*0199
89889933df Jean*0200 PARAMETER ( ALVDRDL = 0.300 )
63416ca6a5 Andr*0201
89889933df Jean*0202 PARAMETER ( ALIDRDL = 0.350 )
63416ca6a5 Andr*0203
89889933df Jean*0204 PARAMETER ( ALVDRDD = 0.250 )
63416ca6a5 Andr*0205
89889933df Jean*0206 PARAMETER ( ALIDRDD = 0.300 )
63416ca6a5 Andr*0207
89889933df Jean*0208 PARAMETER ( ALVDRI = 0.800 )
63416ca6a5 Andr*0209
89889933df Jean*0210 PARAMETER ( ALIDRI = 0.800 )
1411aca51b Andr*0211
ff4f33cd17 Jean*0212
1411aca51b Andr*0213
0214 INTEGER NTYPS
0215 INTEGER NLAI
a20b61c7ed Andr*0216 _RL ZERO, ONE
0217 _RL EPSLN, BLAI, DLAI
0218 _RL ALATRM
1411aca51b Andr*0219 PARAMETER (NLAI = 14 )
0220 PARAMETER (EPSLN = 1.E-6)
0221 PARAMETER (BLAI = 0.5)
0222 PARAMETER (DLAI = 0.5)
0223 PARAMETER (ZERO=0., ONE=1.0)
0224 PARAMETER (ALATRM = BLAI + (NLAI - 1) * DLAI - EPSLN)
0225 PARAMETER (NTYPS=10)
0226
0227
0228
0229
0230
0231
0232
0233
0234
0235
0236
0237
0238
0239
613fa3996d Andr*0240 INTEGER I, LAI
a456aa407c Andr*0241 _RL FAC,GAMMA,BETA,ALPHA,DX,DY,ALA,GRN (2),SNWALB(4,NTYPS)
0242 _RL COEFF
1411aca51b Andr*0243
a456aa407c Andr*0244 _RL ALVDR (NLAI, 2, NTYPS)
0245 _RL BTVDR (NLAI, 2, NTYPS)
0246 _RL GMVDR (NLAI, 2, NTYPS)
0247 _RL ALIDR (NLAI, 2, NTYPS)
0248 _RL BTIDR (NLAI, 2, NTYPS)
0249 _RL GMIDR (NLAI, 2, NTYPS)
1411aca51b Andr*0250
0251
0252
0253
0254
89889933df Jean*0255 DATA (ALVDR (I, 1, 1), I = 1, 14)
0256 & /0.0808, 0.0796, 0.0792, 0.0790, 10*0.0789/
1411aca51b Andr*0257
0258
89889933df Jean*0259 DATA (ALVDR (I, 2, 1), I = 1, 14)
0260 & /0.0788, 0.0775, 0.0771, 0.0769, 10*0.0768/
1411aca51b Andr*0261
0262
89889933df Jean*0263 DATA (ALVDR (I, 1, 2), I = 1, 14)
0264 & /0.0803, 0.0790, 0.0785, 0.0784, 3*0.0783, 7*0.0782/
1411aca51b Andr*0265
0266
89889933df Jean*0267 DATA (ALVDR (I, 2, 2), I = 1, 14)
0268 & /0.0782, 0.0770, 0.0765, 0.0763, 10*0.0762/
1411aca51b Andr*0269
0270
89889933df Jean*0271 DATA (ALVDR (I, 1, 3), I = 1, 14)
0272 & /0.0758, 0.0746, 0.0742, 0.0740, 10*0.0739/
1411aca51b Andr*0273
0274
89889933df Jean*0275 DATA (ALVDR (I, 2, 3), I = 1, 14)
0276 & /0.0683, 0.0672, 0.0667, 2*0.0665, 9*0.0664/
1411aca51b Andr*0277
0278
89889933df Jean*0279 DATA (ALVDR (I, 1, 4), I = 1, 14)
0280 & /0.2436, 0.2470, 0.2486, 0.2494, 0.2498, 0.2500, 2*0.2501,
0281 & 6*0.2502
0282 & /
1411aca51b Andr*0283
89889933df Jean*0284 DATA (ALVDR (I, 2, 4), I = 1, 14) /14*0.1637/
1411aca51b Andr*0285
0286
0287 DATA (ALVDR (I, 1, 5), I = 1, 14)
0288 & /0.0807, 0.0798, 0.0794, 0.0792, 0.0792, 9*0.0791/
0289
0290
0291 DATA (ALVDR (I, 2, 5), I = 1, 14)
0292 & /0.0787, 0.0777, 0.0772, 0.0771, 10*0.0770/
0293
0294
0295 DATA (ALVDR (I, 1, 6), I = 1, 14)
0296 & /0.0802, 0.0791, 0.0787, 0.0786, 10*0.0785/
0297
0298
0299 DATA (ALVDR (I, 2, 6), I = 1, 14)
0300 & /0.0781, 0.0771, 0.0767, 0.0765, 0.0765, 9*0.0764/
0301
0302
89889933df Jean*0303 DATA (ALVDR (I, 1, 7), I = 1, 14) /14*ALVDRS/
0304 DATA (ALVDR (I, 2, 7), I = 1, 14) /14*ALVDRS/
1411aca51b Andr*0305
0306
89889933df Jean*0307 DATA (ALVDR (I, 1, 8), I = 1, 14) /14*ALVDRDL/
0308 DATA (ALVDR (I, 2, 8), I = 1, 14) /14*ALVDRDL/
1411aca51b Andr*0309
0310
89889933df Jean*0311 DATA (ALVDR (I, 1, 9), I = 1, 14) /14*ALVDRI/
0312 DATA (ALVDR (I, 2, 9), I = 1, 14) /14*ALVDRI/
1411aca51b Andr*0313
0314
89889933df Jean*0315 DATA (ALVDR (I, 1, 10), I = 1, 14) /14*ALVDRDD/
0316 DATA (ALVDR (I, 2, 10), I = 1, 14) /14*ALVDRDD/
1411aca51b Andr*0317
89889933df Jean*0318 DATA (BTVDR (I, 1, 1), I = 1, 14)
0319 & /0.0153, 0.0372, 0.0506, 0.0587, 0.0630, 0.0652, 0.0663,
0320 & 0.0668, 0.0671, 0.0672, 4*0.0673
0321 & /
0322 DATA (BTVDR (I, 2, 1), I = 1, 14)
0323 & /0.0135, 0.0354, 0.0487, 0.0568, 0.0611, 0.0633, 0.0644,
0324 & 0.0650, 0.0652, 0.0654, 0.0654, 3*0.0655
0325 & /
0326 DATA (BTVDR (I, 1, 2), I = 1, 14)
0327 & /0.0148, 0.0357, 0.0462, 0.0524, 0.0554, 0.0569, 0.0576,
0328 & 0.0579, 0.0580, 0.0581, 0.0581, 3*0.0582
0329 & /
0330 DATA (BTVDR (I, 2, 2), I = 1, 14)
0331 & /0.0131, 0.0342, 0.0446, 0.0508, 0.0539, 0.0554, 0.0560,
0332 & 0.0564, 0.0565, 5*0.0566
0333 & /
0334 DATA (BTVDR (I, 1, 3), I = 1, 14)
0335 & /0.0108, 0.0334, 0.0478, 0.0571, 0.0624, 0.0652, 0.0666,
0336 & 0.0673, 0.0677, 0.0679, 4*0.0680
0337 & /
0338 DATA (BTVDR (I, 2, 3), I = 1, 14)
0339 & /0.0034, 0.0272, 0.0408, 0.0501, 0.0554, 0.0582, 0.0597,
0340 & 0.0604, 0.0608, 0.0610, 4*0.0611
0341 & /
0342 DATA (BTVDR (I, 1, 4), I = 1, 14)
0343 & /0.2050, 0.2524, 0.2799, 0.2947, 0.3022, 0.3059, 0.3076,
0344 & 0.3085, 0.3088, 0.3090, 4*0.3091
0345 & /
0346 DATA (BTVDR (I, 2, 4), I = 1, 14)
0347 & /0.1084, 0.1404, 0.1617, 0.1754, 0.1837, 0.1887, 0.1915,
0348 & 0.1931, 0.1940, 0.1946, 0.1948, 0.1950, 2*0.1951
0349 & /
1411aca51b Andr*0350 DATA (BTVDR (I, 1, 5), I = 1, 14)
0351 & /0.0203, 0.0406, 0.0548, 0.0632, 0.0679, 0.0703, 0.0716,
0352 & 0.0722, 0.0726, 0.0727, 0.0728, 0.0728, 0.0728, 0.0729
89889933df Jean*0353 & /
1411aca51b Andr*0354
0355 DATA (BTVDR (I, 2, 5), I = 1, 14)
0356 & /0.0184, 0.0385, 0.0526, 0.0611, 0.0658, 0.0683, 0.0696,
0357 & 0.0702, 0.0705, 0.0707, 4*0.0708
89889933df Jean*0358 & /
1411aca51b Andr*0359
0360 DATA (BTVDR (I, 1, 6), I = 1, 14)
0361 & /0.0199, 0.0388, 0.0494, 0.0554, 0.0584, 0.0599, 0.0606,
0362 & 0.0609, 0.0611, 5*0.0612
89889933df Jean*0363 & /
1411aca51b Andr*0364
0365 DATA (BTVDR (I, 2, 6), I = 1, 14)
0366 & /0.0181, 0.0371, 0.0476, 0.0537, 0.0568, 0.0583, 0.0590,
0367 & 0.0593, 0.0595, 0.0595, 4*0.0596
89889933df Jean*0368 & /
1411aca51b Andr*0369
89889933df Jean*0370 DATA (BTVDR (I, 1, 7), I = 1, 14) /14*0./
0371 DATA (BTVDR (I, 2, 7), I = 1, 14) /14*0./
1411aca51b Andr*0372
89889933df Jean*0373 DATA (BTVDR (I, 1, 8), I = 1, 14) /14*0./
0374 DATA (BTVDR (I, 2, 8), I = 1, 14) /14*0./
1411aca51b Andr*0375
89889933df Jean*0376 DATA (BTVDR (I, 1, 9), I = 1, 14) /14*0./
0377 DATA (BTVDR (I, 2, 9), I = 1, 14) /14*0./
1411aca51b Andr*0378
89889933df Jean*0379 DATA (BTVDR (I, 1, 10), I = 1, 14) /14*0./
0380 DATA (BTVDR (I, 2, 10), I = 1, 14) /14*0./
1411aca51b Andr*0381
0382
89889933df Jean*0383 DATA (GMVDR (I, 1, 1), I = 1, 14)
0384 & /0.0814, 0.1361, 0.2078, 0.2650, 0.2986, 0.3169, 0.3265,
0385 & 0.3313, 0.3337, 0.3348, 0.3354, 0.3357, 2*0.3358
0386 & /
0387 DATA (GMVDR (I, 2, 1), I = 1, 14)
0388 & /0.0760, 0.1336, 0.2034, 0.2622, 0.2969, 0.3159, 0.3259,
0389 & 0.3309, 0.3333, 0.3346, 0.3352, 0.3354, 2*0.3356
0390 & /
0391 DATA (GMVDR (I, 1, 2), I = 1, 14)
0392 & /0.0834, 0.1252, 0.1558, 0.1927, 0.2131, 0.2237, 0.2290,
0393 & 0.2315, 0.2327, 0.2332, 0.2335, 2*0.2336, 0.2337
0394 & /
0395 DATA (GMVDR (I, 2, 2), I = 1, 14)
0396 & /0.0789, 0.1235, 0.1531, 0.1912, 0.2122, 0.2232, 0.2286,
0397 & 0.2312, 0.2324, 0.2330, 0.2333, 0.2334, 2*0.2335
0398 & /
0399 DATA (GMVDR (I, 1, 3), I = 1, 14)
0400 & /0.0647, 0.1342, 0.2215, 0.2968, 0.3432, 0.3696, 0.3838,
0401 & 0.3912, 0.3950, 0.3968, 0.3978, 0.3982, 0.3984, 0.3985
0402 & /
0403 DATA (GMVDR (I, 2, 3), I = 1, 14)
0404 & /0.0258, 0.1227, 0.1999, 0.2825, 0.3339, 0.3634, 0.3794,
0405 & 0.3877, 0.3919, 0.3940, 0.3950, 0.3956, 0.3958, 0.3959
0406 & /
0407 DATA (GMVDR (I, 1, 4), I = 1, 14)
0408 & /0.3371, 0.5762, 0.7159, 0.7927, 0.8324, 0.8526, 0.8624,
0409 & 0.8671, 0.8693, 0.8704, 0.8709, 0.8710, 2*0.8712
0410 & /
0411 DATA (GMVDR (I, 2, 4), I = 1, 14)
0412 & /0.2634, 0.4375, 0.5532, 0.6291, 0.6763, 0.7048, 0.7213,
0413 & 0.7310, 0.7363, 0.7395, 0.7411, 0.7420, 0.7426, 0.7428
0414 & /
1411aca51b Andr*0415 DATA (GMVDR (I, 1, 5), I = 1, 14)
0416 & /0.0971, 0.1544, 0.2511, 0.3157, 0.3548, 0.3768, 0.3886,
0417 & 0.3948, 0.3978, 0.3994, 0.4001, 0.4006, 0.4007, 0.4008
89889933df Jean*0418 & /
1411aca51b Andr*0419
0420 DATA (GMVDR (I, 2, 5), I = 1, 14)
0421 & /0.0924, 0.1470, 0.2458, 0.3123, 0.3527, 0.3756, 0.3877,
0422 & 0.3942, 0.3974, 0.3990, 0.3998, 0.4002, 0.4004, 0.4005
89889933df Jean*0423 & /
1411aca51b Andr*0424
0425 DATA (GMVDR (I, 1, 6), I = 1, 14)
0426 & /0.0970, 0.1355, 0.1841, 0.2230, 0.2447, 0.2561, 0.2617,
0427 & 0.2645, 0.2658, 0.2664, 0.2667, 3*0.2669
89889933df Jean*0428 & /
1411aca51b Andr*0429
0430 DATA (GMVDR (I, 2, 6), I = 1, 14)
0431 & /0.0934, 0.1337, 0.1812, 0.2213, 0.2437, 0.2554, 0.2613,
0432 & 0.2642, 0.2656, 0.2662, 0.2665, 0.2667, 0.2667, 0.2668
89889933df Jean*0433 & /
1411aca51b Andr*0434
89889933df Jean*0435 DATA (GMVDR (I, 1, 7), I = 1, 14) /14*1./
0436 DATA (GMVDR (I, 2, 7), I = 1, 14) /14*1./
1411aca51b Andr*0437
89889933df Jean*0438 DATA (GMVDR (I, 1, 8), I = 1, 14) /14*1./
0439 DATA (GMVDR (I, 2, 8), I = 1, 14) /14*1./
1411aca51b Andr*0440
89889933df Jean*0441 DATA (GMVDR (I, 1, 9), I = 1, 14) /14*1./
0442 DATA (GMVDR (I, 2, 9), I = 1, 14) /14*1./
1411aca51b Andr*0443
89889933df Jean*0444 DATA (GMVDR (I, 1, 10), I = 1, 14) /14*1./
0445 DATA (GMVDR (I, 2, 10), I = 1, 14) /14*1./
1411aca51b Andr*0446
0447
0448
89889933df Jean*0449 DATA (ALIDR (I, 1, 1), I = 1, 14)
0450 & /0.2867, 0.2840, 0.2828, 0.2822, 0.2819, 0.2818, 2*0.2817,
0451 & 6*0.2816
0452 & /
0453 DATA (ALIDR (I, 2, 1), I = 1, 14)
0454 & /0.3564, 0.3573, 0.3577, 0.3580, 2*0.3581, 8*0.3582/
0455 DATA (ALIDR (I, 1, 2), I = 1, 14)
0456 & /0.2848, 0.2819, 0.2804, 0.2798, 0.2795, 2*0.2793, 7*0.2792/
0457 DATA (ALIDR (I, 2, 2), I = 1, 14)
0458 & /0.3544, 0.3550, 0.3553, 2*0.3555, 9*0.3556/
0459 DATA (ALIDR (I, 1, 3), I = 1, 14)
0460 & /0.2350, 0.2311, 0.2293, 0.2285, 0.2281, 0.2280, 8*0.2279/
0461 DATA (ALIDR (I, 2, 3), I = 1, 14)
0462 & /0.2474, 0.2436, 0.2418, 0.2410, 0.2406, 0.2405, 3*0.2404,
0463 & 5*0.2403
0464 & /
0465 DATA (ALIDR (I, 1, 4), I = 1, 14)
0466 & /0.5816, 0.6157, 0.6391, 0.6556, 0.6673, 0.6758, 0.6820,
0467 & 0.6866, 0.6899, 0.6924, 0.6943, 0.6956, 0.6966, 0.6974
0468 & /
0469 DATA (ALIDR (I, 2, 4), I = 1, 14)
0470 & /0.5489, 0.5770, 0.5955, 0.6079, 0.6163, 0.6221, 0.6261,
0471 & 0.6288, 0.6308, 0.6321, 0.6330, 0.6337, 0.6341, 0.6344
0472 & /
1411aca51b Andr*0473 DATA (ALIDR (I, 1, 5), I = 1, 14)
0474 & /0.2845, 0.2837, 0.2832, 0.2831, 0.2830, 9*0.2829/
0475 DATA (ALIDR (I, 2, 5), I = 1, 14)
0476 & /0.3532, 0.3562, 0.3578, 0.3586, 0.3590, 0.3592, 0.3594,
0477 & 0.3594, 0.3594, 5*0.3595
89889933df Jean*0478 & /
1411aca51b Andr*0479 DATA (ALIDR (I, 1, 6), I = 1, 14)
0480 & /0.2825, 0.2812, 0.2806, 0.2803, 0.2802, 9*0.2801/
0481 DATA (ALIDR (I, 2, 6), I = 1, 14)
0482 & /0.3512, 0.3538, 0.3552, 0.3559, 0.3562, 0.3564, 0.3565,
0483 & 0.3565, 6*0.3566
89889933df Jean*0484 & /
1411aca51b Andr*0485
89889933df Jean*0486 DATA (ALIDR (I, 1, 7), I = 1, 14) /14*ALIDRS/
0487 DATA (ALIDR (I, 2, 7), I = 1, 14) /14*ALIDRS/
1411aca51b Andr*0488
89889933df Jean*0489 DATA (ALIDR (I, 1, 8), I = 1, 14) /14*ALIDRDL/
0490 DATA (ALIDR (I, 2, 8), I = 1, 14) /14*ALIDRDL/
1411aca51b Andr*0491
89889933df Jean*0492 DATA (ALIDR (I, 1, 9), I = 1, 14) /14*ALIDRI/
0493 DATA (ALIDR (I, 2, 9), I = 1, 14) /14*ALIDRI/
1411aca51b Andr*0494
89889933df Jean*0495 DATA (ALIDR (I, 1, 10), I = 1, 14) /14*ALIDRDD/
0496 DATA (ALIDR (I, 2, 10), I = 1, 14) /14*ALIDRDD/
1411aca51b Andr*0497
0498
89889933df Jean*0499 DATA (BTIDR (I, 1, 1), I = 1, 14)
0500 & /0.1291, 0.1707, 0.1969, 0.2125, 0.2216, 0.2267, 0.2295,
0501 & 0.2311, 0.2319, 0.2323, 0.2326, 2*0.2327, 0.2328
0502 & /
0503 DATA (BTIDR (I, 2, 1), I = 1, 14)
0504 & /0.1939, 0.2357, 0.2598, 0.2735, 0.2810, 0.2851, 0.2874,
0505 & 0.2885, 0.2892, 0.2895, 0.2897, 3*0.2898
0506 & /
0507 DATA (BTIDR (I, 1, 2), I = 1, 14)
0508 & /0.1217, 0.1522, 0.1713, 0.1820, 0.1879, 0.1910, 0.1926,
0509 & 0.1935, 0.1939, 0.1942, 2*0.1943, 2*0.1944
0510 & /
0511 DATA (BTIDR (I, 2, 2), I = 1, 14)
0512 & /0.1781, 0.2067, 0.2221, 0.2301, 0.2342, 0.2363, 0.2374,
0513 & 0.2379, 0.2382, 0.2383, 2*0.2384, 2*0.2385
0514 & /
0515 DATA (BTIDR (I, 1, 3), I = 1, 14)
0516 & /0.0846, 0.1299, 0.1614, 0.1814, 0.1935, 0.2004, 0.2043,
0517 & 0.2064, 0.2076, 0.2082, 0.2085, 2*0.2087, 0.2088
0518 & /
0519 DATA (BTIDR (I, 2, 3), I = 1, 14)
0520 & /0.0950, 0.1410, 0.1722, 0.1921, 0.2042, 0.2111, 0.2151,
0521 & 0.2172, 0.2184, 0.2191, 0.2194, 0.2196, 2*0.2197
0522 & /
0523 DATA (BTIDR (I, 1, 4), I = 1, 14)
0524 & /0.5256, 0.7444, 0.9908, 1.2700, 1.5680, 1.8505, 2.0767,
0525 & 2.2211, 2.2808, 2.2774, 2.2362, 2.1779, 2.1160, 2.0564
0526 & /
0527 DATA (BTIDR (I, 2, 4), I = 1, 14)
0528 & /0.4843, 0.6714, 0.8577, 1.0335, 1.1812, 1.2858, 1.3458,
0529 & 1.3688, 1.3685, 1.3546, 1.3360, 1.3168, 1.2989, 1.2838
0530 & /
0531 DATA (BTIDR (I, 1, 5), I = 1, 14)
1411aca51b Andr*0532 & /0.1498, 0.1930, 0.2201, 0.2364, 0.2460, 0.2514, 0.2544,
0533 & 0.2560, 0.2569, 0.2574, 0.2577, 0.2578, 0.2579, 0.2579
89889933df Jean*0534 & /
1411aca51b Andr*0535
0536 DATA (BTIDR (I, 2, 5), I = 1, 14)
0537 & /0.2184, 0.2656, 0.2927, 0.3078, 0.3159, 0.3202, 0.3224,
0538 & 0.3235, 0.3241, 0.3244, 0.3245, 3*0.3246
89889933df Jean*0539 & /
1411aca51b Andr*0540
0541 DATA (BTIDR (I, 1, 6), I = 1, 14)
0542 & /0.1369, 0.1681, 0.1860, 0.1958, 0.2010, 0.2038, 0.2053,
0543 & 0.2060, 0.2064, 0.2066, 0.2067, 3*0.2068
89889933df Jean*0544 & /
1411aca51b Andr*0545
0546 DATA (BTIDR (I, 2, 6), I = 1, 14)
0547 & /0.1969, 0.2268, 0.2416, 0.2488, 0.2521, 0.2537, 0.2544,
0548 & 0.2547, 0.2548, 5*0.2549
89889933df Jean*0549 & /
1411aca51b Andr*0550
89889933df Jean*0551 DATA (BTIDR (I, 1, 7), I = 1, 14) /14*0./
0552 DATA (BTIDR (I, 2, 7), I = 1, 14) /14*0./
1411aca51b Andr*0553
89889933df Jean*0554 DATA (BTIDR (I, 1, 8), I = 1, 14) /14*0./
0555 DATA (BTIDR (I, 2, 8), I = 1, 14) /14*0./
1411aca51b Andr*0556
89889933df Jean*0557 DATA (BTIDR (I, 1, 9), I = 1, 14) /14*0./
0558 DATA (BTIDR (I, 2, 9), I = 1, 14) /14*0./
1411aca51b Andr*0559
89889933df Jean*0560 DATA (BTIDR (I, 1, 10), I = 1, 14) /14*0./
0561 DATA (BTIDR (I, 2, 10), I = 1, 14) /14*0./
1411aca51b Andr*0562
0563
89889933df Jean*0564 DATA (GMIDR (I, 1, 1), I = 1, 14)
0565 & /0.1582, 0.2581, 0.3227, 0.3635, 0.3882, 0.4026, 0.4108,
0566 & 0.4154, 0.4179, 0.4193, 0.4200, 0.4204, 0.4206, 0.4207
0567 & /
0568 DATA (GMIDR (I, 2, 1), I = 1, 14)
0569 & /0.1934, 0.3141, 0.3818, 0.4200, 0.4415, 0.4533, 0.4598,
0570 & 0.4633, 0.4651, 0.4662, 0.4667, 0.4671, 2*0.4672
0571 & /
0572 DATA (GMIDR (I, 1, 2), I = 1, 14)
0573 & /0.1347, 0.1871, 0.2277, 0.2515, 0.2651, 0.2727, 0.2768,
0574 & 0.2790, 0.2801, 0.2808, 0.2811, 0.2812, 0.2813, 0.2814
0575 & /
0576 DATA (GMIDR (I, 2, 2), I = 1, 14)
0577 & /0.1440, 0.2217, 0.2629, 0.2839, 0.2947, 0.3003, 0.3031,
0578 & 0.3046, 0.3054, 0.3058, 0.3060, 2*0.3061, 0.3062
0579 & /
0580 DATA (GMIDR (I, 1, 3), I = 1, 14)
0581 & /0.1372, 0.2368, 0.3235, 0.3839, 0.4229, 0.4465, 0.4602,
0582 & 0.4679, 0.4722, 0.4745, 0.4758, 0.4764, 0.4768, 0.4770
0583 & /
0584 DATA (GMIDR (I, 2, 3), I = 1, 14)
0585 & /0.1435, 0.2524, 0.3370, 0.3955, 0.4332, 0.4563, 0.4697,
0586 & 0.4773, 0.4815, 0.4839, 0.4851, 0.4858, 0.4861, 0.4863
0587 & /
0588 DATA (GMIDR (I, 1, 4), I = 1, 14)
0589 & /0.4298, 0.9651, 1.6189, 2.4084, 3.2992, 4.1928, 4.9611,
0590 & 5.5095, 5.8085, 5.9069, 5.8726, 5.7674, 5.6346, 5.4944
0591 & /
0592 DATA (GMIDR (I, 2, 4), I = 1, 14)
0593 & /0.4167, 0.8974, 1.4160, 1.9414, 2.4147, 2.7803, 3.0202,
0594 & 3.1468, 3.1954, 3.1932, 3.1676, 3.1328, 3.0958, 3.0625
0595 & /
1411aca51b Andr*0596 DATA (GMIDR (I, 1, 5), I = 1, 14)
0597 & /0.1959, 0.3203, 0.3985, 0.4472, 0.4766, 0.4937, 0.5034,
0598 & 0.5088, 0.5117, 0.5134, 0.5143, 0.5147, 0.5150, 0.5152
89889933df Jean*0599 & /
1411aca51b Andr*0600
0601 DATA (GMIDR (I, 2, 5), I = 1, 14)
0602 & /0.2328, 0.3859, 0.4734, 0.5227, 0.5498, 0.5644, 0.5720,
0603 & 0.5761, 0.5781, 0.5792, 0.5797, 0.5800, 0.5802, 0.5802
89889933df Jean*0604 & /
1411aca51b Andr*0605
0606 DATA (GMIDR (I, 1, 6), I = 1, 14)
0607 & /0.1447, 0.2244, 0.2698, 0.2953, 0.3094, 0.3170, 0.3211,
0608 & 0.3233, 0.3244, 0.3250, 0.3253, 0.3255, 0.3256, 0.3256
89889933df Jean*0609 & /
1411aca51b Andr*0610
0611 DATA (GMIDR (I, 2, 6), I = 1, 14)
0612 & /0.1643, 0.2624, 0.3110, 0.3347, 0.3461, 0.3517, 0.3543,
0613 & 0.3556, 0.3562, 0.3564, 0.3565, 0.3566, 0.3566, 0.3566
89889933df Jean*0614 & /
1411aca51b Andr*0615
89889933df Jean*0616 DATA (GMIDR (I, 1, 7), I = 1, 14) /14*1./
0617 DATA (GMIDR (I, 2, 7), I = 1, 14) /14*1./
1411aca51b Andr*0618
89889933df Jean*0619 DATA (GMIDR (I, 1, 8), I = 1, 14) /14*1./
0620 DATA (GMIDR (I, 2, 8), I = 1, 14) /14*1./
1411aca51b Andr*0621
89889933df Jean*0622 DATA (GMIDR (I, 1, 9), I = 1, 14) /14*1./
0623 DATA (GMIDR (I, 2, 9), I = 1, 14) /14*1./
1411aca51b Andr*0624
89889933df Jean*0625 DATA (GMIDR (I, 1, 10), I = 1, 14) /14*1./
0626 DATA (GMIDR (I, 2, 10), I = 1, 14) /14*1./
1411aca51b Andr*0627
0628
0629
0630 DATA GRN /0.33, 0.67/
0631
175684e43e Andr*0632 #include "snwmid.h"
1411aca51b Andr*0633 DATA SNWALB /.65, .38, .65, .38,
89889933df Jean*0634 & .65, .38, .65, .38,
0635 & .65, .38, .65, .38,
0636 & .65, .38, .65, .38,
0637 & .65, .38, .65, .38,
1411aca51b Andr*0638 & .65, .38, .65, .38,
0639 & .65, .38, .65, .38,
0640 & .65, .38, .65, .38,
0641 & .80, .60, .80, .60,
0642 & .65, .38, .65, .38
89889933df Jean*0643 & /
1411aca51b Andr*0644
06d4643e1f Jean*0645 #ifdef FIZHI_CRAY
4e1c053948 Jean*0646 #ifdef FIZHI_F77_COMPIL
1411aca51b Andr*0647
0648 #endif
0649 #endif
0650
0651 DO 100 I=1,IRUN
89889933df Jean*0652 ALA = MIN (MAX (ZERO, VLAI(I)), ALATRM)
0653 LAI = 1 + MAX(0, INT((ALA-BLAI)/DLAI) )
0654 DX = (ALA - (BLAI+(LAI-1)*DLAI)) * (ONE/DLAI)
0655 DY = (VGRN(I)- GRN(1)) * (ONE/(GRN(2) - GRN(1)))
1411aca51b Andr*0656
89889933df Jean*0657 ALPHA = COEFF (ALVDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
0658 BETA = COEFF (BTVDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
0659 GAMMA = COEFF (GMVDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
1411aca51b Andr*0660
89889933df Jean*0661 AVISDR(I) = ALPHA - ZTH(I)*BETA / (GAMMA+ZTH(I))
0662 AVISDF(I) = ALPHA-BETA
0663 & + 2.*BETA*GAMMA*(1.-GAMMA*LOG((1.+GAMMA)/GAMMA))
1411aca51b Andr*0664
89889933df Jean*0665 ALPHA = COEFF (ALIDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
0666 BETA = COEFF (BTIDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
0667 GAMMA = COEFF (GMIDR (1, 1, ITYP (I)), NLAI, LAI ,DX, DY)
1411aca51b Andr*0668
89889933df Jean*0669 ANIRDR(I) = ALPHA - ZTH(I)*BETA / (GAMMA+ZTH(I))
0670 ANIRDF(I) = ALPHA-BETA
0671 & + 2.*BETA*GAMMA*(1.-GAMMA*LOG((1.+GAMMA)/GAMMA))
1411aca51b Andr*0672
89889933df Jean*0673 IF (SNW (I) .GT. ZERO) THEN
0674 FAC = SNW(I) / (SNW(I) + SNWMID(ITYP(I)))
1411aca51b Andr*0675
89889933df Jean*0676 AVISDR(I) = AVISDR(I) + (SNWALB(1,ITYP(I)) - AVISDR(I)) * FAC
0677 ANIRDR(I) = ANIRDR(I) + (SNWALB(2,ITYP(I)) - ANIRDR(I)) * FAC
0678 AVISDF(I) = AVISDF(I) + (SNWALB(3,ITYP(I)) - AVISDF(I)) * FAC
0679 ANIRDF(I) = ANIRDF(I) + (SNWALB(4,ITYP(I)) - ANIRDF(I)) * FAC
0680 ENDIF
1411aca51b Andr*0681
0682 100 CONTINUE
0683
0684 RETURN
0685 END
0686 FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)
89889933df Jean*0687
1411aca51b Andr*0688 INTEGER NTABL, LAI
89889933df Jean*0689 _RL coeff
a456aa407c Andr*0690 _RL TABLE (NTABL, 2), DX, DY
89889933df Jean*0691
1411aca51b Andr*0692 COEFF = (TABLE(LAI, 1)
89889933df Jean*0693 & + (TABLE(LAI ,2) - TABLE(LAI ,1)) * DY ) * (1.0-DX)
0694 & + (TABLE(LAI+1,1)
0695 & + (TABLE(LAI+1,2) - TABLE(LAI+1,1)) * DY ) * DX
0696
1411aca51b Andr*0697 RETURN
0698 END
0699
ff4f33cd17 Jean*0700
0701
c88fa11306 Andr*0702 SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nchpdim,
89889933df Jean*0703 & nSx,nSy,bi,bj,ALAI,AGRN)
1411aca51b Andr*0704
ff4f33cd17 Jean*0705 IMPLICIT NONE
1411aca51b Andr*0706
ff4f33cd17 Jean*0707 INTEGER ntyps
a20b61c7ed Andr*0708 _RL one,daylen
1411aca51b Andr*0709 PARAMETER (NTYPS=10)
ff4f33cd17 Jean*0710 PARAMETER (one = 1.)
0711 PARAMETER (daylen = 86400.)
1411aca51b Andr*0712
ff4f33cd17 Jean*0713 INTEGER sec, imon, iday, nchps, nchpdim, nSx, nSy, bi, bj
89889933df Jean*0714 _RL ALAI(nchpdim,nSx,nSy), AGRN(nchpdim,nSx,nSy)
9e4e91cf9e Andr*0715 _RL ALAT(nchpdim,nSx,nSy)
ff4f33cd17 Jean*0716 INTEGER ITYP(nchpdim,nSx,nSy)
1411aca51b Andr*0717
ff4f33cd17 Jean*0718 INTEGER i,midmon,midm,midp,id,k1,k2,kk1,kk2
a20b61c7ed Andr*0719 _RL fac
1411aca51b Andr*0720
0721 INTEGER DAYS(12)
0722 DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/
0723
a20b61c7ed Andr*0724 _RL VGLA(12,NTYPS), VGGR(12,NTYPS)
1411aca51b Andr*0725
0726 DATA VGLA /
0727 1 5.117, 5.117, 5.117, 5.117, 5.117, 5.117, 5.117, 5.117,
0728 1 5.117, 5.117, 5.117, 5.117,
0729 2 0.520, 0.520, 0.867, 2.107, 4.507, 6.773, 7.173, 6.507,
0730 2 5.040, 2.173, 0.867, 0.520,
0731 3 8.760, 9.160, 9.827,10.093,10.360,10.760,10.493,10.227,
0732 3 10.093, 9.827, 9.160, 8.760,
0733 4 0.782, 0.893, 1.004, 1.116, 1.782, 3.671, 4.782, 4.227,
0734 4 2.004, 1.227, 1.004, 0.893,
0735 5 3.760, 3.760, 2.760, 1.760, 1.760, 1.760, 1.760, 5.760,
0736 5 10.760, 7.760, 4.760, 3.760,
0737 6 0.739, 0.739, 0.739, 0.739, 0.739, 1.072, 5.072, 5.739,
0738 6 4.405, 0.739, 0.739, 0.739,
0739 7 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
0740 7 0.001, 0.001, 0.001, 0.001,
0741 8 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
0742 8 0.001, 0.001, 0.001, 0.001,
0743 9 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
0744 9 0.001, 0.001, 0.001, 0.001,
0745 1 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
0746 1 0.001, 0.001, 0.001, 0.001
0747 & /
0748
0749 DATA VGGR
0750 1 /0.905, 0.905, 0.905, 0.905, 0.905, 0.905, 0.905, 0.905,
0751 1 0.905, 0.905, 0.905, 0.905,
0752 2 0.026, 0.026, 0.415, 0.759, 0.888, 0.925, 0.836, 0.697,
0753 2 0.331, 0.166, 0.015, 0.026,
0754 3 0.913, 0.917, 0.923, 0.925, 0.927, 0.905, 0.902, 0.913,
0755 3 0.898, 0.855, 0.873, 0.913,
0756 4 0.568, 0.622, 0.664, 0.697, 0.810, 0.908, 0.813, 0.394,
0757 4 0.443, 0.543, 0.553, 0.498,
0758 5 0.798, 0.532, 0.362, 0.568, 0.568, 0.568, 0.568, 0.868,
0759 5 0.651, 0.515, 0.630, 0.798,
0760 6 0.451, 0.451, 0.451, 0.451, 0.451, 0.622, 0.920, 0.697,
0761 6 0.076, 0.451, 0.451, 0.451,
0762 7 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
0763 7 0.001, 0.001, 0.001, 0.001,
0764 8 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
0765 8 0.001, 0.001, 0.001, 0.001,
0766 9 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
0767 9 0.001, 0.001, 0.001, 0.001,
0768 1 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001,
0769 1 0.001, 0.001, 0.001, 0.001
0770 & /
0771
0772 MIDMON = DAYS(IMON)/2 + 1
0773
0774 IF (IDAY .LT. MIDMON) THEN
0775 K2 = IMON
0776 K1 = MOD(IMON+10,12) + 1
0777 ELSE
0778 K1 = IMON
0779 K2 = MOD(IMON,12) + 1
0780 ENDIF
0781
0782 IF (IDAY .LT. MIDMON) THEN
0783 MIDM = DAYS(K1)/2 + 1
0784 MIDP = DAYS(K1) + MIDMON
0785 ID = IDAY + DAYS(K1)
0786 ELSE
0787 MIDM = MIDMON
0788 MIDP = DAYS(K2)/2 + 1 + DAYS(K1)
0789 ID = IDAY
0790 ENDIF
0791
61c43d0040 Andr*0792 FAC = (float(ID -MIDM)*DAYLEN + SEC) /
89889933df Jean*0793 & (float(MIDP-MIDM)*DAYLEN )
1411aca51b Andr*0794
0795 DO 220 I=1,NCHPS
0796
9e4e91cf9e Andr*0797 IF(ALAT(I,bi,bj).GT.0.) THEN
1411aca51b Andr*0798 KK1 = K1
0799 KK2 = K2
0800 ELSE
0801 KK1 = MOD(K1+5,12) + 1
0802 KK2 = MOD(K2+5,12) + 1
0803 ENDIF
0804
a20b61c7ed Andr*0805 ALAI(I,bi,bj) = VGLA(KK2,ITYP(I,bi,bj))*FAC+
89889933df Jean*0806 & VGLA(KK1,ITYP(I,bi,bj))*(ONE-FAC)
a20b61c7ed Andr*0807 AGRN(I,bi,bj) = VGGR(KK2,ITYP(I,bi,bj))*FAC+
89889933df Jean*0808 & VGGR(KK1,ITYP(I,bi,bj))*(ONE-FAC)
1411aca51b Andr*0809
0810 220 CONTINUE
0811
0812 RETURN
0813 END
0814
ff4f33cd17 Jean*0815
0816
0817 SUBROUTINE GETALB(sec,month,day,cosz,snodep,fraci,fracg,im,jm,
89889933df Jean*0818 & nchp,nchptot,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,
0819 & alai,agrn,albvr,albvf,albnr,albnf)
1411aca51b Andr*0820
0821
0822
0823
0824
0825
0826
0827
0828
0829
a20b61c7ed Andr*0830
1411aca51b Andr*0831
0832
0833
0834
0835
0836
a20b61c7ed Andr*0837
0838
0839
0840
1411aca51b Andr*0841
a20b61c7ed Andr*0842
1411aca51b Andr*0843
a20b61c7ed Andr*0844
1411aca51b Andr*0845
a20b61c7ed Andr*0846
1411aca51b Andr*0847
a20b61c7ed Andr*0848
1411aca51b Andr*0849
0850
0851
0852
0853
0854
0855
0856
ff4f33cd17 Jean*0857 IMPLICIT NONE
a20b61c7ed Andr*0858
ff4f33cd17 Jean*0859 INTEGER sec,month,day,im,jm,nchp,nchptot,nchpland,nSx,nSy,bi,bj
a456aa407c Andr*0860 _RL cosz(im,jm),fraci(im,jm),fracg(im,jm)
a20b61c7ed Andr*0861 _RL snodep(nchp,nSx,nSy),chfr(nchp,nSx,nSy),chlt(nchp,nSx,nSy)
ff4f33cd17 Jean*0862 INTEGER igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)
a20b61c7ed Andr*0863 _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)
0864 _RL albvr(im,jm,nSx,nSy),albvf(im,jm,nSx,nSy)
0865 _RL albnr(im,jm,nSx,nSy),albnf(im,jm,nSx,nSy)
0866
ff4f33cd17 Jean*0867
a20b61c7ed Andr*0868 _RL one,a0,a1,a2,a3,ocnalb,albsi
1411aca51b Andr*0869 PARAMETER (one = 1.)
0870 PARAMETER (A0= 0.40670980)
0871 PARAMETER (A1=-1.2523634 )
0872 PARAMETER (A2= 1.4224051 )
0873 PARAMETER (A3=-0.55573341)
0874 PARAMETER (OCNALB=0.08)
a20b61c7ed Andr*0875 PARAMETER (ALBSI=0.7)
89889933df Jean*0876
a456aa407c Andr*0877 _RL alboc(im,jm)
ff4f33cd17 Jean*0878 _RL avisdr(nchp),anirdr(nchp),avisdf(nchp)
0879 _RL anirdf(nchp)
a456aa407c Andr*0880 _RL zenith(nchp)
0881 _RL tmpij(im,jm)
ff4f33cd17 Jean*0882 INTEGER i,j
1411aca51b Andr*0883
0884 DO I=1,IM
0885 DO J=1,JM
0886 ALBOC(I,J) = A0 + (A1 + (A2 + A3*cosz(I,J))*cosz(I,J))*cosz(I,J)
613fa3996d Andr*0887 ALBVR(I,J,bi,bj) = ALBSI*FRACI(I,J) + ALBOC(I,J)*(ONE-FRACI(I,J))
0888 ALBNR(I,J,bi,bj) = ALBVR(I,J,bi,bj)
0889 ALBVF(I,J,bi,bj) = ALBSI * FRACI(I,J) + OCNALB * (ONE-FRACI(I,J))
0890 ALBNF(I,J,bi,bj) = ALBVF(I,J,bi,bj)
1411aca51b Andr*0891 ENDDO
0892 ENDDO
0893
0894
89889933df Jean*0895
626071fec8 Jean*0896 call grd2msc(cosz,im,jm,igrd(1,bi,bj),zenith,nchp,nchpland)
89889933df Jean*0897
1411aca51b Andr*0898
89889933df Jean*0899
a20b61c7ed Andr*0900 call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),
89889933df Jean*0901 & agrn(1,bi,bj),zenith,snodep(1,bi,bj),ityp(1,bi,bj),nchpland)
c88fa11306 Andr*0902
1411aca51b Andr*0903
89889933df Jean*0904
613fa3996d Andr*0905 DO I=1,IM
0906 DO J=1,JM
c88fa11306 Andr*0907 tmpij(i,j) = albvr(i,j,bi,bj)
613fa3996d Andr*0908 ENDDO
0909 ENDDO
a20b61c7ed Andr*0910 call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdr,nchp,nchpland,
89889933df Jean*0911 & fracg,tmpij,im,jm)
c88fa11306 Andr*0912
613fa3996d Andr*0913 DO I=1,IM
0914 DO J=1,JM
0915 albvr(i,j,bi,bj) = tmpij(i,j)
0916 ENDDO
0917 ENDDO
0918 DO I=1,IM
0919 DO J=1,JM
c88fa11306 Andr*0920 tmpij(i,j) = albvf(i,j,bi,bj)
613fa3996d Andr*0921 ENDDO
0922 ENDDO
a20b61c7ed Andr*0923 call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdf,nchp,nchpland,
89889933df Jean*0924 & fracg,tmpij,im,jm)
613fa3996d Andr*0925 DO I=1,IM
0926 DO J=1,JM
0927 albvf(i,j,bi,bj) = tmpij(i,j)
0928 ENDDO
0929 ENDDO
0930 DO I=1,IM
0931 DO J=1,JM
c88fa11306 Andr*0932 tmpij(i,j) = albnr(i,j,bi,bj)
613fa3996d Andr*0933 ENDDO
0934 ENDDO
a20b61c7ed Andr*0935 call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdr,nchp,nchpland,
89889933df Jean*0936 & fracg,tmpij,im,jm)
613fa3996d Andr*0937 DO I=1,IM
0938 DO J=1,JM
0939 albnr(i,j,bi,bj) = tmpij(i,j)
0940 ENDDO
0941 ENDDO
0942 DO I=1,IM
0943 DO J=1,JM
c88fa11306 Andr*0944 tmpij(i,j) = albnf(i,j,bi,bj)
613fa3996d Andr*0945 ENDDO
0946 ENDDO
a20b61c7ed Andr*0947 call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdf,nchp,nchpland,
89889933df Jean*0948 & fracg,tmpij,im,jm)
613fa3996d Andr*0949 DO I=1,IM
0950 DO J=1,JM
0951 albnf(i,j,bi,bj) = tmpij(i,j)
0952 ENDDO
0953 ENDDO
89889933df Jean*0954
1411aca51b Andr*0955 return
0956 end
0957
ff4f33cd17 Jean*0958
0959
0960 SUBROUTINE GETEMISS(fracg,im,jm,nchp,nchptot,nSx,nSy,bi,bj,
89889933df Jean*0961 & igrd,ityp,chfr,snowdep,fraci,emiss)
1411aca51b Andr*0962
0963
0964
0965
0966
0967
0968
0969
0970
0971
61c43d0040 Andr*0972
0973
0974
0975
1411aca51b Andr*0976
0977
0978
0979
0980
0981
0982
0983
0984
0985
0986
61c43d0040 Andr*0987
1411aca51b Andr*0988
0989
ff4f33cd17 Jean*0990 IMPLICIT NONE
0991 INTEGER im,jm,nchp,nchptot,nSx,nSy,bi,bj
a456aa407c Andr*0992 _RL fracg(im,jm)
61c43d0040 Andr*0993 _RL chfr(nchp,nSx,nSy)
ff4f33cd17 Jean*0994 INTEGER igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)
613fa3996d Andr*0995 _RL snowdep(nchp,nSx,nSy)
a456aa407c Andr*0996 _RL fraci(nchp)
61c43d0040 Andr*0997 _RL emiss(im,jm,10,nSx,nSy)
1411aca51b Andr*0998
a456aa407c Andr*0999 _RL emisstile(nchp,10)
1000 _RL tmpij(im,jm)
ff4f33cd17 Jean*1001 INTEGER i,j,k,n
1411aca51b Andr*1002
1003 do i = 1,10
b30e700407 Andr*1004 do n = 1,nchptot
1411aca51b Andr*1005 emisstile(n,i) = 1.
1006 enddo
1007 enddo
1008
ff4f33cd17 Jean*1009
1010
b30e700407 Andr*1011 call emissivity(snowdep(1,bi,bj),fraci,nchp,nchptot,ityp(1,bi,bj),
89889933df Jean*1012 & emisstile)
1411aca51b Andr*1013
ff4f33cd17 Jean*1014
1015
61c43d0040 Andr*1016 do k = 1,10
1017 do j = 1,jm
1018 do i = 1,im
613fa3996d Andr*1019 tmpij(i,j) = 0.0
61c43d0040 Andr*1020 enddo
1021 enddo
b30e700407 Andr*1022 call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),emisstile(1,k),nchp,
89889933df Jean*1023 & nchptot,fracg,tmpij,im,jm)
613fa3996d Andr*1024 do j = 1,jm
1025 do i = 1,im
1026 emiss(i,j,k,bi,bj) = tmpij(i,j)
1027 enddo
1028 enddo
1411aca51b Andr*1029 enddo
1030
1031 return
1032 end
1033
ff4f33cd17 Jean*1034
1035
1036 SUBROUTINE EMISSIVITY (snowdepth,fraci,nchp,numpts,ityp,newemis)
1037 IMPLICIT NONE
1038 INTEGER nchp,numpts
1039 INTEGER ityp(nchp)
b30e700407 Andr*1040 _RL snowdepth(nchp)
1041 _RL fraci(nchp)
1042 _RL newemis(nchp,10)
1411aca51b Andr*1043
a456aa407c Andr*1044 _RL emis(12,11)
1045 _RL fac
ff4f33cd17 Jean*1046 INTEGER i,j
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100 DATA ((emis(i,j),i=1,12),j=1,11) /
63416ca6a5 Andr*1101
89889933df Jean*1102 & 0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903,
1411aca51b Andr*1103 & 0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
63416ca6a5 Andr*1104
89889933df Jean*1105 & 0.9849, 0.9856, 0.9841, 0.9831, 0.9789, 0.9805,
1411aca51b Andr*1106 & 0.9733, 0.9869, 1.0000, 1.0000, 1.0000, 1.0000,
63416ca6a5 Andr*1107
89889933df Jean*1108 & 0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903,
1411aca51b Andr*1109 & 0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
63416ca6a5 Andr*1110
89889933df Jean*1111 & 0.9867, 0.9897, 0.9920, 0.9933, 0.9830, 0.9752,
1411aca51b Andr*1112 & 0.9853, 0.9928, 1.0000, 1.0000, 1.0000, 1.0000,
63416ca6a5 Andr*1113
89889933df Jean*1114 & 0.9490, 0.9697, 0.9738, 0.9712, 0.9474, 0.9582,
1411aca51b Andr*1115 & 0.9663, 0.9747, 0.9836, 0.9836, 0.9836, 0.9836,
63416ca6a5 Andr*1116
89889933df Jean*1117 & 0.9469, 0.9670, 0.9883, 0.9795, 0.9751, 0.9767,
1411aca51b Andr*1118 & 0.9920, 0.9888, 0.9888, 0.9888, 0.9888, 0.9888,
63416ca6a5 Andr*1119
89889933df Jean*1120 & 0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1411aca51b Andr*1121 & 0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
63416ca6a5 Andr*1122
89889933df Jean*1123 & 0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1411aca51b Andr*1124 & 0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
63416ca6a5 Andr*1125
89889933df Jean*1126 & 0.9998, 0.9998, 0.9998, 0.9998, 0.9998, 0.9999,
1411aca51b Andr*1127 & 0.9997, 0.9994, 0.9995, 0.9995, 0.9995, 0.9995,
63416ca6a5 Andr*1128
89889933df Jean*1129 & 0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1411aca51b Andr*1130 & 0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
63416ca6a5 Andr*1131
89889933df Jean*1132 & 0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865,
1411aca51b Andr*1133 & 0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/
1134
175684e43e Andr*1135 #include "snwmid.h"
1411aca51b Andr*1136
ff4f33cd17 Jean*1137
1138
1411aca51b Andr*1139 do i=1,numpts
1140
ff4f33cd17 Jean*1141
1142
1411aca51b Andr*1143 if(ityp(i).le.10)then
1144 newemis(i, 1) = (emis( 1,ityp(i))+emis(2,ityp(i)))/2.
1145 newemis(i, 2) = (emis( 2,ityp(i))+emis(3,ityp(i)))/2.
1146 newemis(i, 3) = (emis( 4,ityp(i))+emis(5,ityp(i)))/2.
1147 newemis(i, 4) = emis( 6,ityp(i))
1148 newemis(i, 5) = emis( 7,ityp(i))
1149 newemis(i, 6) = emis( 8,ityp(i))
1150 newemis(i, 7) = emis( 9,ityp(i))
1151 newemis(i, 8) = (emis(10,ityp(i))+emis(11,ityp(i)))/2.
1152 newemis(i, 9) = emis(12,ityp(i))
1153 newemis(i,10) = emis( 4,ityp(i))
1154
ff4f33cd17 Jean*1155
1156
1411aca51b Andr*1157 if(snowdepth (i).gt.0.) then
1158 fac = snowdepth(i) / (snowdepth(i) + snwmid(ityp(i)))
89889933df Jean*1159 newemis(i, 1) = newemis(i, 1) + (((emis( 1,9)+emis( 2,9))/2.)
1160 & - newemis(i, 1)) * fac
1161 newemis(i, 2) = newemis(i, 2) + (((emis( 2,9)+emis( 3,9))/2.)
1162 & - newemis(i, 2)) * fac
1163 newemis(i, 3) = newemis(i, 3) + (((emis( 4,9)+emis( 5,9))/2.)
1164 & - newemis(i, 3)) * fac
1165 newemis(i, 4) = newemis(i, 4) + (emis( 6,9)
1166 & - newemis(i, 4)) * fac
1167 newemis(i, 5) = newemis(i, 5) + (emis( 7,9)
1168 & - newemis(i, 5)) * fac
1169 newemis(i, 6) = newemis(i, 6) + (emis( 8,9)
1170 & - newemis(i, 6)) * fac
1171 newemis(i, 7) = newemis(i, 7) + (emis( 9,9)
1172 & - newemis(i, 7)) * fac
1173 newemis(i, 8) = newemis(i, 8) + (((emis(10,9)+emis(11,9))/2.)
1174 & - newemis(i, 8)) * fac
1175 newemis(i, 9) = newemis(i, 9) + (emis(12,9)
1176 & - newemis(i, 9)) * fac
1177 newemis(i,10) = newemis(i,10) + (emis( 4,9)
1178 & - newemis(i,10)) * fac
1411aca51b Andr*1179 endif
1180
ff4f33cd17 Jean*1181
1182
1411aca51b Andr*1183 else
1184 if(fraci(i).eq.0.)then
1185 newemis(i, 1) = (emis( 1,11)+emis(2,11))/2.
1186 newemis(i, 2) = (emis( 2,11)+emis(3,11))/2.
1187 newemis(i, 3) = (emis( 4,11)+emis(5,11))/2.
1188 newemis(i, 4) = emis( 6,11)
1189 newemis(i, 5) = emis( 7,11)
1190 newemis(i, 6) = emis( 8,11)
1191 newemis(i, 7) = emis( 9,11)
1192 newemis(i, 8) = (emis(10,11)+emis(11,11))/2.
1193 newemis(i, 9) = emis(12,11)
1194 newemis(i,10) = emis( 4,11)
1195
ff4f33cd17 Jean*1196
1197
1411aca51b Andr*1198 else
1199 newemis(i, 1) = (emis( 1,9)+emis(2,9))/2.
1200 newemis(i, 2) = (emis( 2,9)+emis(3,9))/2.
1201 newemis(i, 3) = (emis( 4,9)+emis(5,9))/2.
1202 newemis(i, 4) = emis( 6,9)
1203 newemis(i, 5) = emis( 7,9)
1204 newemis(i, 6) = emis( 8,9)
1205 newemis(i, 7) = emis( 9,9)
1206 newemis(i, 8) = (emis(10,9)+emis(11,9))/2.
1207 newemis(i, 9) = emis(12,9)
1208 newemis(i,10) = emis( 4,9)
1209 endif
1210 endif
1211 enddo
1212
1213 return
1214 end
ff4f33cd17 Jean*1215
1216
1217
1218 SUBROUTINE GET_LANDFRAC(im,jm,nSx,nSy,bi,bj,maxtyp,surftype,
89889933df Jean*1219 & tilefrac,frac)
9bc7f6e71e Andr*1220
1221
1222
1223
1224
ff4f33cd17 Jean*1225 IMPLICIT NONE
9bc7f6e71e Andr*1226
ff4f33cd17 Jean*1227 INTEGER im,jm,nSx,nSy,bi,bj,maxtyp
1228 INTEGER surftype(im,jm,maxtyp,nSx,nSy)
613fa3996d Andr*1229 _RL tilefrac(im,jm,maxtyp,nSx,nSy)
a456aa407c Andr*1230 _RL frac(im,jm)
9bc7f6e71e Andr*1231
ff4f33cd17 Jean*1232 INTEGER i,j,k
9bc7f6e71e Andr*1233
1234 do j=1,jm
1235 do i=1,im
1236 frac(i,j) = 0.0
1237 enddo
1238 enddo
1239
1240 do k=1,maxtyp
1241 do j=1,jm
1242 do i=1,im
613fa3996d Andr*1243 if( (surftype(i,j,k,bi,bj).lt.100.).and.
89889933df Jean*1244 & (tilefrac(i,j,k,bi,bj).gt.0.0))then
9bc7f6e71e Andr*1245 frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)
1246 endif
1247 enddo
1248 enddo
1249 enddo
1250
1251 return
1252 end