/[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.5 by molod, Wed Jun 9 18:54:20 2004 UTC revision 1.23 by molod, Fri Oct 22 14:52:14 2004 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3    
4    #include "FIZHI_OPTIONS.h"
5         subroutine update_earth_exports (myTime, myIter, myThid)         subroutine update_earth_exports (myTime, myIter, myThid)
6  c----------------------------------------------------------------------  c----------------------------------------------------------------------
7  c  Subroutine update_earth_exports - 'Wrapper' routine to update  c  Subroutine update_earth_exports - 'Wrapper' routine to update
# Line 14  c        getemiss  (Set the surface emis Line 15  c        getemiss  (Set the surface emis
15  c                              and the snow depth)  c                              and the snow depth)
16  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
17         implicit none         implicit none
 #include "CPP_OPTIONS.h"  
18  #include "SIZE.h"  #include "SIZE.h"
19    #include "GRID.h"
20  #include "fizhi_land_SIZE.h"  #include "fizhi_land_SIZE.h"
21  #include "fizhi_SIZE.h"  #include "fizhi_SIZE.h"
22  #include "fizhi_coms.h"  #include "fizhi_coms.h"
23    #include "chronos.h"
24  #include "gridalt_mapping.h"  #include "gridalt_mapping.h"
25  #include "fizhi_land_coms.h"  #include "fizhi_land_coms.h"
26  #include "fizhi_earth_coms.h"  #include "fizhi_earth_coms.h"
27    #include "fizhi_ocean_coms.h"
28  #include "EEPARAMS.h"  #include "EEPARAMS.h"
29    
30        integer myTime, myIter, myThid        integer myIter, myThid
31          _RL myTime
32    
33        real lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)        logical alarm
34        integer i, j, L, bi, bj        external alarm
35          _RL lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
36          _RL fraci(sNx,sNy), fracl(sNx,sNy)
37          _RL ficetile(nchp)
38          _RL radius
39          _RL tmpij(sNx,sNy)
40          _RL tmpchp(nchp)
41          integer i, j, n, bi, bj
42        integer im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2        integer im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2
43        integer sec, day, month        integer sec, day, month
44        integer nmonf,ndayf        integer nmonf,ndayf,nsecf
45          nsecf(n) = n/10000*3600 + mod(n,10000)/100* 60 + mod(n,100)
46        nmonf(n) = mod(n,10000)/100        nmonf(n) = mod(n,10000)/100
47        ndayf(n) = mod(n,100)        ndayf(n) = mod(n,100)
48    
# Line 50  c--------------------------------------- Line 62  c---------------------------------------
62        do bi = myBxLo(myThid), myBxHi(myThid)        do bi = myBxLo(myThid), myBxHi(myThid)
63         do j = jm1,jm2         do j = jm1,jm2
64         do i = im1,im2         do i = im1,im2
65          lons(i,j,bi,bj) = xC(i,j,bi,bj)          lons(i,j) = xC(i,j,bi,bj)
66          lats(i,j,bi,bj) = yC(i,j,bi,bj)          lats(i,j) = yC(i,j,bi,bj)
67           enddo
68           enddo
69    
70           call get_landfrac(im2,jm2,nSx,nSy,bi,bj,maxtyp,surftype,tilefrac,
71         .                                                            fracl)
72    
73           do j = jm1,jm2
74           do i = im1,im2
75            if(sice(i,j,bi,bj).gt.0.) then
76               fraci(i,j) = 1.
77            else
78               fraci(i,j) = 0.
79            endif
80         enddo         enddo
81         enddo         enddo
82    
# Line 59  C*************************************** Line 84  C***************************************
84  C*              Get Leaf-Area-Index and Greenness Index                *  C*              Get Leaf-Area-Index and Greenness Index                *
85  C***********************************************************************  C***********************************************************************
86    
87        if( alarm('turb') .or. alarm('radsw') ) then         if( alarm('turb') .or. alarm('radsw') ) then
88        call getlgr (sec,month,day,chlt,ityp,nchpland,alai,agrn )         call getlgr (sec,month,day,chlt,ityp,nchpland(bi,bj),
89        endif       .       nchp,nSx,nSy,bi,bj,alai,agrn )
90           endif
91    
92  C **********************************************************************  C **********************************************************************
93  C                      Compute Surface Albedo  C                      Compute Surface Albedo
94  C **********************************************************************  C **********************************************************************
95    
96        if( alarm('radsw') ) then         if( alarm('radsw') ) then
97         call astro  ( nymd,nhms, lats,lons, im2*jm2, cosz,ra )          call astro(nymd,nhms,lats,lons,im2*jm2,cosz,radius)
98         call getalb ( sec,month,day,cosz,snodep,fraci,fracl,          call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,
99       .              im,jm,nchp,nchpland,igrd,ityp,chfr,chlt,alai,agrn,       .    nchptot(bi,bj),nchpland(bi,bj),nSx,nSy,bi,bj,igrd,ityp,
100       .              albvisdr,albvisdf,albnirdr,albnirdf )       .    chfr,chlt,alai,agrn,
101        endif       .    albvisdr,albvisdf,albnirdr,albnirdf )
102           endif
103    
104  C **********************************************************************  C **********************************************************************
105  C                      Compute Surface Emissivity  C                      Compute Surface Emissivity
106  C **********************************************************************  C **********************************************************************
107    
108        if( alarm('radlw') ) then         if( alarm('radlw') ) then
109         call grd2msc  ( fraci,im,jm,igrd,ficetile,nchp,nchp )          call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchptot(bi,bj))
110         call getemiss ( fracl,im,jm,nchp,igrd,ityp,chfr,snodep,ficetile,          call getemiss(fracl,im2,jm2,nchp,nchptot(bi,bj),nSx,nSy,bi,bj,
111       .                                             emiss )       .   igrd,ityp,chfr,snodep,ficetile,emiss)
112        endif         endif
   
113    
114  C*********************************************************************  C*********************************************************************
115  C            Ground Temperature Over Ocean is from SST array,  C            Ground Temperature Over Ocean is from SST array,
116    C               Over land is from tcanopy
117  C*********************************************************************  C*********************************************************************
118    
119        do j = 1,jm         do j = jm1,jm2
120        do i = 1,im         do i = im1,im2
121        if(fracl(i,j).lt.0.3.and.sea_ice(i,j).eq.0.0)tgz(i,j) = sst(i,j)          tmpij(i,j) = 0.
122        endif         enddo
123        enddo         enddo
124        enddo         do i = 1,nchpland(bi,bj)
125            tmpchp(i) = tcanopy(i,bi,bj)
126           enddo
127           call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,
128         .                    nchp,nchpland(bi,bj),fracl,tmpij,im2,jm2)
129           do j = jm1,jm2
130           do i = im1,im2
131            tgz(i,j,bi,bj) = tmpij(i,j)
132            if(fracl(i,j).lt.0.3.and.sice(i,j,bi,bj).eq.0.0)
133         .                                 tgz(i,j,bi,bj) = sst(i,j,bi,bj)
134           enddo
135           enddo
136    
137        enddo        enddo
138        enddo        enddo
# Line 126  C*************************************** Line 163  C***************************************
163        IMPLICIT NONE        IMPLICIT NONE
164    
165        INTEGER IRUN        INTEGER IRUN
166        REAL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN),        _RL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)
167       `       VLAI   (IRUN),   VGRN (IRUN),   ZTH  (IRUN),    SNW (IRUN)        _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)
168          _RL ZTH(IRUN)
169        INTEGER ITYP (IRUN)        INTEGER ITYP (IRUN)
170    
171        REAL ALVDRS,  ALIDRS        _RL ALVDRS,  ALIDRS
172        REAL ALVDRDL, ALIDRDL        _RL ALVDRDL, ALIDRDL
173        REAL ALVDRDD, ALIDRDD        _RL ALVDRDD, ALIDRDD
174        REAL ALVDRI,  ALIDRI        _RL ALVDRI,  ALIDRI
175        REAL minval        _RL minval
176        external     minval        external     minval
177    
178        PARAMETER (  ALVDRS  = 0.100 )  ! Albedo of soil         for visible   direct solar radiation.  C Albedo of soil         for visible   direct solar radiation.
179        PARAMETER (  ALIDRS  = 0.200 )  ! Albedo of soil         for infra-red direct solar radiation.        PARAMETER (  ALVDRS  = 0.100 )  
180        PARAMETER (  ALVDRDL = 0.300 )  ! Albedo of light desert for visible   direct solar radiation.  C Albedo of soil         for infra-red direct solar radiation.
181        PARAMETER (  ALIDRDL = 0.350 )  ! Albedo of light desert for infra-red direct solar radiation.        PARAMETER (  ALIDRS  = 0.200 )  
182        PARAMETER (  ALVDRDD = 0.250 )  ! Albedo of dark  desert for visible   direct solar radiation.  C Albedo of light desert for visible   direct solar radiation.
183        PARAMETER (  ALIDRDD = 0.300 )  ! Albedo of dark  desert for infra-red direct solar radiation.        PARAMETER (  ALVDRDL = 0.300 )  
184        PARAMETER (  ALVDRI  = 0.800 )  ! Albedo of ice          for visible   direct solar radiation.  C Albedo of light desert for infra-red direct solar radiation.
185        PARAMETER (  ALIDRI  = 0.800 )  ! Albedo of ice          for infra-red direct solar radiation.        PARAMETER (  ALIDRDL = 0.350 )  
186    C Albedo of dark  desert for visible   direct solar radiation.
187          PARAMETER (  ALVDRDD = 0.250 )  
188    C Albedo of dark  desert for infra-red direct solar radiation.
189          PARAMETER (  ALIDRDD = 0.300 )  
190    C Albedo of ice          for visible   direct solar radiation.
191          PARAMETER (  ALVDRI  = 0.800 )  
192    C Albedo of ice          for infra-red direct solar radiation.
193          PARAMETER (  ALIDRI  = 0.800 )  
194    
195  * --------------------------------------------------------------------------------------------  * --------------------------------------------------------------------------------------------
196    
197        INTEGER NTYPS        INTEGER NTYPS
198        INTEGER NLAI        INTEGER NLAI
199        REAL ZERO, ONE        _RL ZERO, ONE
200        REAL EPSLN, BLAI, DLAI        _RL EPSLN, BLAI, DLAI
201        REAL ALATRM        _RL ALATRM
202        PARAMETER (NLAI = 14 )        PARAMETER (NLAI = 14 )
203        PARAMETER (EPSLN = 1.E-6)        PARAMETER (EPSLN = 1.E-6)
204        PARAMETER (BLAI = 0.5)        PARAMETER (BLAI = 0.5)
# Line 175  C                  9:  GLACIER Line 221  C                  9:  GLACIER
221  C                 10:  DARK DESERT  C                 10:  DARK DESERT
222  C  C
223    
224          INTEGER I, LAI
225  * [ Definition of Variables: ]        _RL FAC,GAMMA,BETA,ALPHA,DX,DY,ALA,GRN (2),SNWALB(4,NTYPS)
226  *        _RL COEFF
227          INTEGER I, LAI  
228          _RL ALVDR (NLAI, 2, NTYPS)
229          REAL FAC,               GAMMA,          BETA,          ALPHA,        _RL BTVDR (NLAI, 2, NTYPS)
230       `       DX,                DY,             ALA,           GRN (2),        _RL GMVDR (NLAI, 2, NTYPS)
231       `       SNWALB (4, NTYPS), SNWMID (NTYPS)        _RL ALIDR (NLAI, 2, NTYPS)
232          _RL BTIDR (NLAI, 2, NTYPS)
233  * [ Definition of Functions: ]        _RL GMIDR (NLAI, 2, NTYPS)
 *  
         REAL COEFF  
   
 C   Constants used in albedo calculations:  
   
       REAL ALVDR (NLAI, 2, NTYPS)  
       REAL BTVDR (NLAI, 2, NTYPS)  
       REAL GMVDR (NLAI, 2, NTYPS)  
       REAL ALIDR (NLAI, 2, NTYPS)  
       REAL BTIDR (NLAI, 2, NTYPS)  
       REAL GMIDR (NLAI, 2, NTYPS)  
234    
235  C  (Data statements for ALVDR described in full; data statements for  C  (Data statements for ALVDR described in full; data statements for
236  C   other constants follow same framework.)  C   other constants follow same framework.)
# Line 586  C**** ---------------------------------- Line 621  C**** ----------------------------------
621    
622        DATA GRN /0.33, 0.67/        DATA GRN /0.33, 0.67/
623    
624        include 'snwmid.h'  #include "snwmid.h"
625        DATA SNWALB /.65, .38, .65, .38,        DATA SNWALB /.65, .38, .65, .38,
626       *             .65, .38, .65, .38,       *             .65, .38, .65, .38,
627       *             .65, .38, .65, .38,       *             .65, .38, .65, .38,
# Line 599  C**** ---------------------------------- Line 634  C**** ----------------------------------
634       &             .65, .38, .65, .38       &             .65, .38, .65, .38
635       `            /       `            /
636    
637  #if CRAY  #ifdef CRAY
638  #if f77  #ifdef f77
639  cfpp$ expand (coeff)  cfpp$ expand (coeff)
640  #endif  #endif
 #if f90  
 !DIR$ inline always coeff  
 #endif  
641  #endif  #endif
642    
643        DO 100 I=1,IRUN        DO 100 I=1,IRUN
# Line 646  cfpp$ expand (coeff) Line 678  cfpp$ expand (coeff)
678        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)
679                    
680        INTEGER NTABL, LAI        INTEGER NTABL, LAI
681          _RL coeff
682        REAL TABLE (NTABL, 2), DX, DY        _RL TABLE (NTABL, 2), DX, DY
683    
684        COEFF = (TABLE(LAI,  1)        COEFF = (TABLE(LAI,  1)
685       *      + (TABLE(LAI  ,2) - TABLE(LAI  ,1)) * DY ) * (1.0-DX)       *      + (TABLE(LAI  ,2) - TABLE(LAI  ,1)) * DY ) * (1.0-DX)
# Line 656  cfpp$ expand (coeff) Line 688  cfpp$ expand (coeff)
688    
689        RETURN        RETURN
690        END        END
       SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,ALAI,AGRN)  
691    
692  C*********************************************************************        SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nchpdim,
693  C*********************** ARIES   MODEL *******************************       .    nSx,nSy,bi,bj,ALAI,AGRN)
 C********************* SUBROUTINE GETLGR  ****************************  
 C**********************  14 JUNE 1991   ******************************  
694  C*********************************************************************  C*********************************************************************
695        implicit none        implicit none
696    
697        integer ntyps        integer ntyps
698        real one,daylen        _RL one,daylen
699        PARAMETER (NTYPS=10)        PARAMETER (NTYPS=10)
700        parameter (one = 1.)        parameter (one = 1.)
701        parameter (daylen = 86400.)        parameter (daylen = 86400.)
702    
703        integer sec, imon, iday, nchps        integer sec, imon, iday, nchps, nchpdim, nSx, nSy, bi, bj
704        real ALAI(NCHPS), AGRN(NCHPS), ALAT(NCHPS)        _RL ALAI(nchpdim,nSx,nSy), AGRN(nchpdim,nSx,nSy)
705        integer ITYP(NCHPS)        _RL ALAT(nchpdim)
706          integer ITYP(nchpdim,nSx,nSy)
707    
708        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2
709        real fac        _RL fac
710    
711        INTEGER     DAYS(12)        INTEGER     DAYS(12)
712        DATA        DAYS/31,28,31,30,31,30,31,31,30,31,30,31/        DATA        DAYS/31,28,31,30,31,30,31,31,30,31,30,31/
713    
714          _RL VGLA(12,NTYPS), VGGR(12,NTYPS)
       REAL VGLA(12,NTYPS), VGGR(12,NTYPS)  
715    
716        DATA VGLA  /        DATA VGLA  /
717       1    5.117, 5.117, 5.117, 5.117, 5.117, 5.117, 5.117, 5.117,       1    5.117, 5.117, 5.117, 5.117, 5.117, 5.117, 5.117, 5.117,
# Line 753  C*************************************** Line 782  C***************************************
782          ID = IDAY          ID = IDAY
783        ENDIF        ENDIF
784    
785        FAC = (REAL(ID  -MIDM)*DAYLEN + SEC) /        FAC = (float(ID  -MIDM)*DAYLEN + SEC) /
786       *      (REAL(MIDP-MIDM)*DAYLEN            )       *      (float(MIDP-MIDM)*DAYLEN            )
787    
788        DO 220 I=1,NCHPS        DO 220 I=1,NCHPS
789    
# Line 766  C*************************************** Line 795  C***************************************
795         KK2 = MOD(K2+5,12) + 1         KK2 = MOD(K2+5,12) + 1
796        ENDIF        ENDIF
797    
798        ALAI(I) = VGLA(KK2,ITYP(I))*FAC + VGLA(KK1,ITYP(I))*(ONE-FAC)        ALAI(I,bi,bj) = VGLA(KK2,ITYP(I,bi,bj))*FAC+
799        AGRN(I) = VGGR(KK2,ITYP(I))*FAC + VGGR(KK1,ITYP(I))*(ONE-FAC)       .                                 VGLA(KK1,ITYP(I,bi,bj))*(ONE-FAC)
800          AGRN(I,bi,bj) = VGGR(KK2,ITYP(I,bi,bj))*FAC+
801         .                                 VGGR(KK1,ITYP(I,bi,bj))*(ONE-FAC)
802    
803    220 CONTINUE    220 CONTINUE
804    
805        RETURN        RETURN
806        END        END
807    
808        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,im,jm,
809       1              im,jm,nchp,nchpland,igrd,ityp,chfr,chlt,       .        nchp,nchptot,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,
810       2              alai,agrn,albvr,albvf,albnr,albnf)       .        alai,agrn,albvr,albvf,albnr,albnf)
811  C***********************************************************************  C***********************************************************************
812  C  PURPOSE  C  PURPOSE
813  C     To act as an interface to routine sibalb, which calculates  C     To act as an interface to routine sibalb, which calculates
# Line 787  C sec      - number of seconds into the Line 818  C sec      - number of seconds into the
818  C month    - month of the year of current time  C month    - month of the year of current time
819  C day      - day of the month of current time  C day      - day of the month of current time
820  C cosz     - local cosine of the zenith angle [im,jm]  C cosz     - local cosine of the zenith angle [im,jm]
821  C snodep   - snow cover in meters [nchp]  C snodep   - snow cover in meters [nchp,nSx,nSy]
822  C fraci    - real array in grid space of total sea ice fraction [im,jm]  C fraci    - real array in grid space of total sea ice fraction [im,jm]
823  C fracg    - real array in grid space of total land fraction [im,jm]  C fracg    - real array in grid space of total land fraction [im,jm]
824  C im       - model grid longitude dimension  C im       - model grid longitude dimension
825  C jm       - model grid latitude dimension (number of lat. points)  C jm       - model grid latitude dimension (number of lat. points)
826  C nchp     - integer actual number of tiles in tile space  C nchp     - integer actual number of tiles in tile space
827  C nchpland - integer number of land tiles  C nchpland - integer number of land tiles
828    C nSx      - number of processors in x-direction
829    C nSy      - number of processors in y-direction
830    C bi       - processors index in x-direction
831    C bj       - processors index in y-direction
832  C igrd     - integer array in tile space of grid point number for each  C igrd     - integer array in tile space of grid point number for each
833  C            tile [nchp]  C            tile [nchp,nSx,nSy]
834  C ityp     - integer array in tile space of land surface type for each  C ityp     - integer array in tile space of land surface type for each
835  C            tile [nchp]  C            tile [nchp,nSx,nSy]
836  C chfr     - real array in tile space of land surface type fraction for  C chfr     - real array in tile space of land surface type fraction for
837  C            each tile [nchp]  C            each tile [nchp,nSx,nSy]
838  C chlt     - real array in tile space of latitude value for each tile  C chlt     - real array in tile space of latitude value for each tile
839  C            [nchp]  C            [nchp,nSx,nSy]
840  C  C
841  C OUTPUT:  C OUTPUT:
842  C albvr    - real array [im,jm] of visible direct beam albedo  C albvr    - real array [im,jm] of visible direct beam albedo
# Line 811  C albnf    - real array [im,jm] of near- Line 846  C albnf    - real array [im,jm] of near-
846  C  C
847  C***********************************************************************  C***********************************************************************
848        implicit none        implicit none
849        real one,a0,a1,a2,a3,ocnalb,albsi  
850          integer sec,month,day,im,jm,nchp,nchptot,nchpland,nSx,nSy,bi,bj
851          _RL cosz(im,jm),fraci(im,jm),fracg(im,jm)
852          _RL snodep(nchp,nSx,nSy),chfr(nchp,nSx,nSy),chlt(nchp,nSx,nSy)
853          integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)
854          _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)
855          _RL albvr(im,jm,nSx,nSy),albvf(im,jm,nSx,nSy)
856          _RL albnr(im,jm,nSx,nSy),albnf(im,jm,nSx,nSy)
857    
858          _RL one,a0,a1,a2,a3,ocnalb,albsi
859        PARAMETER (one = 1.)        PARAMETER (one = 1.)
860        PARAMETER (A0= 0.40670980)        PARAMETER (A0= 0.40670980)
861        PARAMETER (A1=-1.2523634 )        PARAMETER (A1=-1.2523634 )
862        PARAMETER (A2= 1.4224051 )        PARAMETER (A2= 1.4224051 )
863        PARAMETER (A3=-0.55573341)        PARAMETER (A3=-0.55573341)
864        PARAMETER (OCNALB=0.08)        PARAMETER (OCNALB=0.08)
865  ccc   PARAMETER (ALBSI=0.6)        PARAMETER (ALBSI=0.7)
       PARAMETER (ALBSI=0.7)  ! Increased to GEOS-1 Value (0.7) L.Takacs 4/2/96  
866    
867        integer sec,month,day,im,jm,nchp,nchpland        _RL alboc(im,jm)
868        real cosz(im,jm),fraci(im,jm),fracg(im,jm)        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
869        real snodep(nchp),chfr(nchp),chlt(nchp)        _RL ANIRDF(nchp)
870        integer igrd(nchp),ityp(nchp)        _RL zenith(nchp)
871        real albvr(im,jm),albvf(im,jm),albnr(im,jm)        _RL tmpij(im,jm)
       real albnf(im,jm)  
   
       real alboc(im,jm)  
       real AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)  
       real ANIRDF(nchp),zenith(nchp)  
       real alai(nchp),agrn(nchp)  
872        integer i,j        integer i,j
873    
874        DO I=1,IM        DO I=1,IM
875        DO J=1,JM        DO J=1,JM
876         ALBOC(I,J) = A0 + (A1 + (A2 +  A3*cosz(I,J))*cosz(I,J))*cosz(I,J)         ALBOC(I,J) = A0 + (A1 + (A2 +  A3*cosz(I,J))*cosz(I,J))*cosz(I,J)
877         ALBVR(I,J) = ALBSI * FRACI(I,J) + ALBOC(I,J) * (ONE-FRACI(I,J))         ALBVR(I,J,bi,bj) = ALBSI*FRACI(I,J) + ALBOC(I,J)*(ONE-FRACI(I,J))
878         ALBNR(I,J) = ALBVR(I,J)         ALBNR(I,J,bi,bj) = ALBVR(I,J,bi,bj)
879         ALBVF(I,J) = ALBSI * FRACI(I,J) + OCNALB * (ONE-FRACI(I,J))         ALBVF(I,J,bi,bj) = ALBSI * FRACI(I,J) + OCNALB * (ONE-FRACI(I,J))
880         ALBNF(I,J) = ALBVF(I,J)         ALBNF(I,J,bi,bj) = ALBVF(I,J,bi,bj)
881        ENDDO        ENDDO
882        ENDDO        ENDDO
   
883    
884  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
885    
# Line 851  C and now some conversions from grid spa Line 887  C and now some conversions from grid spa
887    
888  C and now call sibalb  C and now call sibalb
889    
890        call sibalb(avisdr,anirdr,avisdf,anirdf,alai,agrn,zenith,        call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),
891       1     snodep,ityp,nchpland)       .  agrn(1,bi,bj),zenith,snodep(1,bi,bj),ityp(1,bi,bj),nchpland)
892    
893  C finally some transformations back to grid space for albedos  C finally some transformations back to grid space for albedos
894    
895        call msc2grd(igrd,chfr,avisdr,nchp,nchpland,fracg,albvr,im,jm)        DO I=1,IM
896        call msc2grd(igrd,chfr,avisdf,nchp,nchpland,fracg,albvf,im,jm)        DO J=1,JM
897        call msc2grd(igrd,chfr,anirdr,nchp,nchpland,fracg,albnr,im,jm)         tmpij(i,j) = albvr(i,j,bi,bj)
898        call msc2grd(igrd,chfr,anirdf,nchp,nchpland,fracg,albnf,im,jm)        ENDDO
899          ENDDO
900          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdr,nchp,nchpland,
901         .                                     fracg,tmpij,im,jm)
902    
903          DO I=1,IM
904          DO J=1,JM
905           albvr(i,j,bi,bj) = tmpij(i,j)
906          ENDDO
907          ENDDO
908          DO I=1,IM
909          DO J=1,JM
910           tmpij(i,j) = albvf(i,j,bi,bj)
911          ENDDO
912          ENDDO
913          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdf,nchp,nchpland,
914         .                                     fracg,tmpij,im,jm)
915          DO I=1,IM
916          DO J=1,JM
917           albvf(i,j,bi,bj) = tmpij(i,j)
918          ENDDO
919          ENDDO
920          DO I=1,IM
921          DO J=1,JM
922           tmpij(i,j) = albnr(i,j,bi,bj)
923          ENDDO
924          ENDDO
925          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdr,nchp,nchpland,
926         .                                     fracg,tmpij,im,jm)
927          DO I=1,IM
928          DO J=1,JM
929           albnr(i,j,bi,bj) = tmpij(i,j)
930          ENDDO
931          ENDDO
932          DO I=1,IM
933          DO J=1,JM
934           tmpij(i,j) = albnf(i,j,bi,bj)
935          ENDDO
936          ENDDO
937          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdf,nchp,nchpland,
938         .                                     fracg,tmpij,im,jm)
939          DO I=1,IM
940          DO J=1,JM
941           albnf(i,j,bi,bj) = tmpij(i,j)
942          ENDDO
943          ENDDO
944    
945        return        return
946        end        end
947    
948        subroutine getemiss (fracg,im,jm,nchp,igrd,ityp,chfr,snowdep,fraci,emiss)        subroutine getemiss(fracg,im,jm,nchp,nchptot,nSx,nSy,bi,bj,
949         .   igrd,ityp,chfr,snowdep,fraci,emiss)
950  C***********************************************************************  C***********************************************************************
951  C  PURPOSE  C  PURPOSE
952  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 875  C fracg    - real array in grid space of Line 957  C fracg    - real array in grid space of
957  C im       - model grid longitude dimension  C im       - model grid longitude dimension
958  C jm       - model grid latitude dimension (number of lat. points)  C jm       - model grid latitude dimension (number of lat. points)
959  C nchp     - integer actual number of tiles in tile space  C nchp     - integer actual number of tiles in tile space
960    C nSx      - number of processors in x-direction
961    C nSy      - number of processors in y-direction
962    C bi       - processors index in x-direction
963    C bj       - processors index in y-direction
964  C igrd     - integer array in tile space of grid point number for each  C igrd     - integer array in tile space of grid point number for each
965  C            tile [nchp]  C            tile [nchp]
966  C ityp     - integer array in tile space of land surface type for each  C ityp     - integer array in tile space of land surface type for each
# Line 886  C            in mm [nchp] Line 972  C            in mm [nchp]
972  C fraci    - real array in tile space of sea ice fraction [nchp]  C fraci    - real array in tile space of sea ice fraction [nchp]
973  C  C
974  C OUTPUT:  C OUTPUT:
975  C emiss    - real array [im,jm,10] of surface emissivities (fraction)  C emiss    - real array [im,jm,10,nSx,nSy] - surface emissivity (frac)
976  C  C
977  C***********************************************************************  C***********************************************************************
978        implicit none        implicit none
979        integer im,jm,nchp        integer im,jm,nchp,nchptot,nSx,nSy,bi,bj
980        real fracg(im,jm)        _RL fracg(im,jm)
981        real chfr(nchp)        _RL chfr(nchp,nSx,nSy)
982        integer igrd(nchp), ityp(nchp)        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)
983        real snowdep(nchp),fraci(nchp)        _RL snowdep(nchp,nSx,nSy)
984        real emiss(im,jm,10)        _RL fraci(nchp)
985          _RL emiss(im,jm,10,nSx,nSy)
986        real emisstile(nchp,10)  
987        integer i,n        _RL emisstile(nchp,10)
988          _RL tmpij(im,jm)
989          integer i,j,k,n
990    
991        do i = 1,10        do i = 1,10
992        do n = 1,nchp        do n = 1,nchptot
993           emisstile(n,i) = 1.           emisstile(n,i) = 1.
994        enddo        enddo
995        enddo        enddo
996    
997  c call emissivity to get values in tile space  c call emissivity to get values in tile space
998  c -------------------------------------------  c -------------------------------------------
999        call emissivity (snowdep,fraci,nchp,ityp,emisstile)        call emissivity(snowdep(1,bi,bj),fraci,nchp,nchptot,ityp(1,bi,bj),
1000         .                                                    emisstile)
1001    
1002  c transform back to grid space for emissivities  c transform back to grid space for emissivities
1003  c ---------------------------------------------  c ---------------------------------------------
1004        do i = 1,10        do k = 1,10
1005        emiss(:,:,i) = 0.0        do j = 1,jm
1006        call msc2grd (igrd,chfr,emisstile(1,i),nchp,nchp,fracg,emiss(1,1,i),im,jm)        do i = 1,im
1007           tmpij(i,j) = 0.0
1008          enddo
1009          enddo
1010          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),emisstile(1,k),nchp,
1011         .  nchptot,fracg,tmpij,im,jm)
1012          do j = 1,jm
1013          do i = 1,im
1014           emiss(i,j,k,bi,bj) = tmpij(i,j)
1015          enddo
1016          enddo
1017        enddo        enddo
1018    
1019        return        return
1020        end        end
1021    
1022        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)        subroutine emissivity (snowdepth,fraci,nchp,numpts,ityp,newemis)
1023        implicit none        implicit none
1024        integer numpts        integer nchp,numpts
1025        integer   ityp(numpts)        integer   ityp(nchp)
1026        real snowdepth(numpts),fraci(numpts)        _RL snowdepth(nchp)
1027        real   newemis(numpts,10)        _RL fraci(nchp)
1028          _RL newemis(nchp,10)
1029        real emis(12,11)  
1030        real snwmid(10)        _RL emis(12,11)
1031        real fac        _RL fac
1032        integer i,j        integer i,j
1033    
1034  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
# Line 985  c      band 12: 35.7 -  oo  um Line 1084  c      band 12: 35.7 -  oo  um
1084  c  c
1085  c-------------------------------------------------------------------------  c-------------------------------------------------------------------------
1086        data ((emis(i,j),i=1,12),j=1,11) /        data ((emis(i,j),i=1,12),j=1,11) /
1087       &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903, ! evergreen needleleaf  C evergreen needleleaf
1088         &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903,
1089       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
1090       &   0.9849, 0.9856, 0.9841, 0.9831, 0.9789, 0.9805, ! deciduous needleleaf  C deciduous needleleaf
1091         &   0.9849, 0.9856, 0.9841, 0.9831, 0.9789, 0.9805,
1092       &   0.9733, 0.9869, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9733, 0.9869, 1.0000, 1.0000, 1.0000, 1.0000,
1093       &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903, ! evergreen needleleaf  C evergreen needleleaf
1094         &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903,
1095       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
1096       &   0.9867, 0.9897, 0.9920, 0.9933, 0.9830, 0.9752, ! grasslands  C grasslands
1097         &   0.9867, 0.9897, 0.9920, 0.9933, 0.9830, 0.9752,
1098       &   0.9853, 0.9928, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9853, 0.9928, 1.0000, 1.0000, 1.0000, 1.0000,
1099       &   0.9490, 0.9697, 0.9738, 0.9712, 0.9474, 0.9582, ! closed shrublands  C closed shrublands
1100         &   0.9490, 0.9697, 0.9738, 0.9712, 0.9474, 0.9582,
1101       &   0.9663, 0.9747, 0.9836, 0.9836, 0.9836, 0.9836,       &   0.9663, 0.9747, 0.9836, 0.9836, 0.9836, 0.9836,
1102       &   0.9469, 0.9670, 0.9883, 0.9795, 0.9751, 0.9767, ! tundra  C tundra
1103         &   0.9469, 0.9670, 0.9883, 0.9795, 0.9751, 0.9767,
1104       &   0.9920, 0.9888, 0.9888, 0.9888, 0.9888, 0.9888,       &   0.9920, 0.9888, 0.9888, 0.9888, 0.9888, 0.9888,
1105       &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren  C barren
1106         &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1107       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1108       &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren  C barren
1109         &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1110       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1111       &   0.9998, 0.9998, 0.9998, 0.9998, 0.9998, 0.9999, ! snow/ice  C snow/ice
1112         &   0.9998, 0.9998, 0.9998, 0.9998, 0.9998, 0.9999,
1113       &   0.9997, 0.9994, 0.9995, 0.9995, 0.9995, 0.9995,       &   0.9997, 0.9994, 0.9995, 0.9995, 0.9995, 0.9995,
1114       &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren  C barren
1115         &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1116       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1117       &   0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865, ! water  C water
1118         &   0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865,
1119       &   0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/       &   0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/
1120    
1121        include 'snwmid.h'  #include "snwmid.h"
1122    
1123  c Convert to the 10 bands needed by Chou Radiation  c Convert to the 10 bands needed by Chou Radiation
1124  c ------------------------------------------------  c ------------------------------------------------
# Line 1032  c modify emissivity for snow based on sn Line 1142  c modify emissivity for snow based on sn
1142  c-------------------------------------------------------------  c-------------------------------------------------------------
1143          if(snowdepth (i).gt.0.) then          if(snowdepth (i).gt.0.) then
1144           fac = snowdepth(i) / (snowdepth(i) + snwmid(ityp(i)))           fac = snowdepth(i) / (snowdepth(i) + snwmid(ityp(i)))
1145           newemis(i, 1) = newemis(i, 1) + (((emis( 1,9)+emis( 2,9))/2.) - newemis(i, 1)) * fac           newemis(i, 1) = newemis(i, 1) + (((emis( 1,9)+emis( 2,9))/2.)
1146           newemis(i, 2) = newemis(i, 2) + (((emis( 2,9)+emis( 3,9))/2.) - newemis(i, 2)) * fac       .                                           - newemis(i, 1)) * fac
1147           newemis(i, 3) = newemis(i, 3) + (((emis( 4,9)+emis( 5,9))/2.) - newemis(i, 3)) * fac           newemis(i, 2) = newemis(i, 2) + (((emis( 2,9)+emis( 3,9))/2.)
1148           newemis(i, 4) = newemis(i, 4) +              (emis( 6,9)      - newemis(i, 4)) * fac       .                                           - newemis(i, 2)) * fac
1149           newemis(i, 5) = newemis(i, 5) +              (emis( 7,9)      - newemis(i, 5)) * fac           newemis(i, 3) = newemis(i, 3) + (((emis( 4,9)+emis( 5,9))/2.)
1150           newemis(i, 6) = newemis(i, 6) +              (emis( 8,9)      - newemis(i, 6)) * fac       .                                           - newemis(i, 3)) * fac
1151           newemis(i, 7) = newemis(i, 7) +              (emis( 9,9)      - newemis(i, 7)) * fac           newemis(i, 4) = newemis(i, 4) +              (emis( 6,9)      
1152           newemis(i, 8) = newemis(i, 8) + (((emis(10,9)+emis(11,9))/2.) - newemis(i, 8)) * fac       .                                           - newemis(i, 4)) * fac
1153           newemis(i, 9) = newemis(i, 9) +              (emis(12,9)      - newemis(i, 9)) * fac           newemis(i, 5) = newemis(i, 5) +              (emis( 7,9)      
1154           newemis(i,10) = newemis(i,10) +              (emis( 4,9)      - newemis(i,10)) * fac       .                                           - newemis(i, 5)) * fac
1155             newemis(i, 6) = newemis(i, 6) +              (emis( 8,9)      
1156         .                                           - newemis(i, 6)) * fac
1157             newemis(i, 7) = newemis(i, 7) +              (emis( 9,9)      
1158         .                                           - newemis(i, 7)) * fac
1159             newemis(i, 8) = newemis(i, 8) + (((emis(10,9)+emis(11,9))/2.)
1160         .                                           - newemis(i, 8)) * fac
1161             newemis(i, 9) = newemis(i, 9) +              (emis(12,9)      
1162         .                                           - newemis(i, 9)) * fac
1163             newemis(i,10) = newemis(i,10) +              (emis( 4,9)      
1164         .                                           - newemis(i,10)) * fac
1165          endif          endif
1166    
1167  c open water  c open water
# Line 1077  c-------------------------------- Line 1197  c--------------------------------
1197        enddo        enddo
1198    
1199        return        return
1200          end
1201          subroutine get_landfrac(im,jm,nSx,nSy,bi,bj,maxtyp,surftype,
1202         .                                                    tilefrac,frac)
1203    C***********************************************************************
1204    C  Purpose
1205    C     To compute the total fraction of land within a model grid-box
1206    C
1207    C***********************************************************************
1208          implicit none
1209    
1210          integer im,jm,nSx,nSy,bi,bj,maxtyp
1211          integer surftype(im,jm,maxtyp,nSx,nSy)
1212          _RL tilefrac(im,jm,maxtyp,nSx,nSy)
1213          _RL frac(im,jm)
1214    
1215          integer  i,j,k
1216    
1217          do j=1,jm
1218          do i=1,im
1219          frac(i,j) = 0.0
1220          enddo
1221          enddo
1222    
1223          do k=1,maxtyp
1224          do j=1,jm
1225          do i=1,im
1226          if( (surftype(i,j,k,bi,bj).lt.100.).and.
1227         .                               (tilefrac(i,j,k,bi,bj).gt.0.0))then
1228           frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)
1229          endif
1230          enddo
1231          enddo
1232          enddo
1233    
1234          return
1235        end        end
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.23
  ViewVC Help
Powered by ViewVC 1.1.22