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