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

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

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

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