/[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.13 by molod, Fri Jul 16 19:37:04 2004 UTC
# Line 16  c--------------------------------------- Line 16  c---------------------------------------
16         implicit none         implicit none
17  #include "CPP_OPTIONS.h"  #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          logical alarm
33          external alarm
34        real lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)        real lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
35        integer i, j, L, bi, bj        real fraci(sNx,sNy), fracl(sNx,sNy)
36          real ficetile(nchp)
37          real radius
38          real tmpij(sNx,sNy)
39          real 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           do j = jm1,jm2
72           do i = im1,im2
73            if(sice(i,j,bi,bj).gt.0.) then
74               fraci(i,j) = 1.
75            else
76               fraci(i,j) = 0.
77            endif
78         enddo         enddo
79         enddo         enddo
80    
# Line 59  C*************************************** Line 82  C***************************************
82  C*              Get Leaf-Area-Index and Greenness Index                *  C*              Get Leaf-Area-Index and Greenness Index                *
83  C***********************************************************************  C***********************************************************************
84    
85        if( alarm('turb') .or. alarm('radsw') ) then         if( alarm('turb') .or. alarm('radsw') ) then
86        call getlgr (sec,month,day,chlt,ityp,nchpland,alai,agrn )         call getlgr (sec,month,day,chlt,ityp,nchpland,nSx,nSy,bi,bj,
87        endif       .                                                       alai,agrn )
88           endif
89    
90  C **********************************************************************  C **********************************************************************
91  C                      Compute Surface Albedo  C                      Compute Surface Albedo
92  C **********************************************************************  C **********************************************************************
93    
94        if( alarm('radsw') ) then         if( alarm('radsw') ) then
95         call astro  ( nymd,nhms, lats,lons, im2*jm2, cosz,ra )          call astro(nymd,nhms,lats,lons,im2*jm2,cosz,radius)
96         call getalb ( sec,month,day,cosz,snodep,fraci,fracl,          call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,
97       .              im,jm,nchp,nchpland,igrd,ityp,chfr,chlt,alai,agrn,       .             nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,alai,agrn,
98       .              albvisdr,albvisdf,albnirdr,albnirdf )       .             albvisdr,albvisdf,albnirdr,albnirdf )
99        endif         endif
100    
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,nchp)
108         call getemiss ( fracl,im,jm,nchp,igrd,ityp,chfr,snodep,ficetile,          call getemiss(fracl,im2,jm2,nchp,nSx,nSy,bi,bj,igrd,ityp,chfr,
109       .                                             emiss )       .      snodep,ficetile,emiss)
110        endif         endif
111    
112    
113  C*********************************************************************  C*********************************************************************
114  C            Ground Temperature Over Ocean is from SST array,  C            Ground Temperature Over Ocean is from SST array,
115    C               Over land is from tcanopy
116  C*********************************************************************  C*********************************************************************
117    
118        do j = 1,jm         do j = jm1,jm2
119        do i = 1,im         do i = im1,im2
120        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.
121        endif         enddo
122        enddo         enddo
123        enddo         do i = 1,nchp
124            tmpchp(i) = tcanopy(i,bi,bj)
125           enddo
126           call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,
127         .                           nchp,nchp,fracl,tmpij,im2,jm2)
128           do j = jm1,jm2
129           do i = im1,im2
130            tgz(i,j,bi,bj) = tmpij(i,j)
131            if(fracl(i,j).lt.0.3.and.sice(i,j,bi,bj).eq.0.0)
132         .                                 tgz(i,j,bi,bj) = sst(i,j,bi,bj)
133           enddo
134           enddo
135    
136        enddo        enddo
137        enddo        enddo
# Line 124  C     ANIRDF:   near infra-red, diffuse Line 160  C     ANIRDF:   near infra-red, diffuse
160  C*******************************************************************  C*******************************************************************
161    
162        IMPLICIT NONE        IMPLICIT NONE
163    #include "CPP_EEOPTIONS.h"
164    
165        INTEGER IRUN        INTEGER IRUN
166        REAL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN),        real 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          REAL 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: ]        real FAC,GAMMA,BETA,ALPHA,DX,DY,ALA,GRN (2),SNWALB(4,NTYPS)
226  *        real COEFF
227          INTEGER I, LAI  
228          real ALVDR (NLAI, 2, NTYPS)
229          REAL FAC,               GAMMA,          BETA,          ALPHA,        real BTVDR (NLAI, 2, NTYPS)
230       `       DX,                DY,             ALA,           GRN (2),        real GMVDR (NLAI, 2, NTYPS)
231       `       SNWALB (4, NTYPS), SNWMID (NTYPS)        real ALIDR (NLAI, 2, NTYPS)
232          real BTIDR (NLAI, 2, NTYPS)
233  * [ Definition of Functions: ]        real 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 603  C**** ---------------------------------- Line 638  C**** ----------------------------------
638  #if f77  #if 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 644  cfpp$ expand (coeff) Line 676  cfpp$ expand (coeff)
676        RETURN        RETURN
677        END        END
678        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)
679    #include "CPP_EEOPTIONS.h"
680                    
681        INTEGER NTABL, LAI        INTEGER NTABL, LAI
682          real coeff
683        REAL TABLE (NTABL, 2), DX, DY        real TABLE (NTABL, 2), DX, DY
684    
685        COEFF = (TABLE(LAI,  1)        COEFF = (TABLE(LAI,  1)
686       *      + (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 689  cfpp$ expand (coeff)
689    
690        RETURN        RETURN
691        END        END
       SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,ALAI,AGRN)  
692    
693  C*********************************************************************        SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nSx,nSy,bi,bj,
694  C*********************** ARIES   MODEL *******************************       .                                                      ALAI,AGRN)
 C********************* SUBROUTINE GETLGR  ****************************  
 C**********************  14 JUNE 1991   ******************************  
695  C*********************************************************************  C*********************************************************************
696        implicit none        implicit none
697    #include "CPP_EEOPTIONS.h"
698    
699        integer ntyps        integer ntyps
700        real one,daylen        _RL one,daylen
701        PARAMETER (NTYPS=10)        PARAMETER (NTYPS=10)
702        parameter (one = 1.)        parameter (one = 1.)
703        parameter (daylen = 86400.)        parameter (daylen = 86400.)
704    
705        integer sec, imon, iday, nchps        integer sec, imon, iday, nchps, nSx, nSy, bi, bj
706        real ALAI(NCHPS), AGRN(NCHPS), ALAT(NCHPS)        _RL ALAI(NCHPS,nSx,nSy), AGRN(NCHPS,nSx,nSy)
707        integer ITYP(NCHPS)        _RL ALAT(NCHPS)
708          integer ITYP(NCHPS,nSx,nSy)
709    
710        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2
711        real fac        _RL fac
712    
713        INTEGER     DAYS(12)        INTEGER     DAYS(12)
714        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/
715    
716          _RL VGLA(12,NTYPS), VGGR(12,NTYPS)
       REAL VGLA(12,NTYPS), VGGR(12,NTYPS)  
717    
718        DATA VGLA  /        DATA VGLA  /
719       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 784  C***************************************
784          ID = IDAY          ID = IDAY
785        ENDIF        ENDIF
786    
787        FAC = (REAL(ID  -MIDM)*DAYLEN + SEC) /        FAC = (float(ID  -MIDM)*DAYLEN + SEC) /
788       *      (REAL(MIDP-MIDM)*DAYLEN            )       *      (float(MIDP-MIDM)*DAYLEN            )
789    
790        DO 220 I=1,NCHPS        DO 220 I=1,NCHPS
791    
# Line 766  C*************************************** Line 797  C***************************************
797         KK2 = MOD(K2+5,12) + 1         KK2 = MOD(K2+5,12) + 1
798        ENDIF        ENDIF
799    
800        ALAI(I) = VGLA(KK2,ITYP(I))*FAC + VGLA(KK1,ITYP(I))*(ONE-FAC)        ALAI(I,bi,bj) = VGLA(KK2,ITYP(I,bi,bj))*FAC+
801        AGRN(I) = VGGR(KK2,ITYP(I))*FAC + VGGR(KK1,ITYP(I))*(ONE-FAC)       .                                 VGLA(KK1,ITYP(I,bi,bj))*(ONE-FAC)
802          AGRN(I,bi,bj) = VGGR(KK2,ITYP(I,bi,bj))*FAC+
803         .                                 VGGR(KK1,ITYP(I,bi,bj))*(ONE-FAC)
804    
805    220 CONTINUE    220 CONTINUE
806    
807        RETURN        RETURN
808        END        END
809    
810        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,im,jm,
811       1              im,jm,nchp,nchpland,igrd,ityp,chfr,chlt,       .                  nchp,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,
812       2              alai,agrn,albvr,albvf,albnr,albnf)       .                  alai,agrn,albvr,albvf,albnr,albnf)
813  C***********************************************************************  C***********************************************************************
814  C  PURPOSE  C  PURPOSE
815  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 820  C sec      - number of seconds into the
820  C month    - month of the year of current time  C month    - month of the year of current time
821  C day      - day of the month of current time  C day      - day of the month of current time
822  C cosz     - local cosine of the zenith angle [im,jm]  C cosz     - local cosine of the zenith angle [im,jm]
823  C snodep   - snow cover in meters [nchp]  C snodep   - snow cover in meters [nchp,nSx,nSy]
824  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]
825  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]
826  C im       - model grid longitude dimension  C im       - model grid longitude dimension
827  C jm       - model grid latitude dimension (number of lat. points)  C jm       - model grid latitude dimension (number of lat. points)
828  C nchp     - integer actual number of tiles in tile space  C nchp     - integer actual number of tiles in tile space
829  C nchpland - integer number of land tiles  C nchpland - integer number of land tiles
830    C nSx      - number of processors in x-direction
831    C nSy      - number of processors in y-direction
832    C bi       - processors index in x-direction
833    C bj       - processors index in y-direction
834  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
835  C            tile [nchp]  C            tile [nchp,nSx,nSy]
836  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
837  C            tile [nchp]  C            tile [nchp,nSx,nSy]
838  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
839  C            each tile [nchp]  C            each tile [nchp,nSx,nSy]
840  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
841  C            [nchp]  C            [nchp,nSx,nSy]
842  C  C
843  C OUTPUT:  C OUTPUT:
844  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 848  C albnf    - real array [im,jm] of near-
848  C  C
849  C***********************************************************************  C***********************************************************************
850        implicit none        implicit none
851        real one,a0,a1,a2,a3,ocnalb,albsi  #include "CPP_EEOPTIONS.h"
852    
853          integer sec,month,day,im,jm,nchp,nchpland,nSx,nSy,bi,bj
854          real cosz(im,jm),fraci(im,jm),fracg(im,jm)
855          _RL snodep(nchp,nSx,nSy),chfr(nchp,nSx,nSy),chlt(nchp,nSx,nSy)
856          integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)
857          _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)
858          _RL albvr(im,jm,nSx,nSy),albvf(im,jm,nSx,nSy)
859          _RL albnr(im,jm,nSx,nSy),albnf(im,jm,nSx,nSy)
860    
861          _RL one,a0,a1,a2,a3,ocnalb,albsi
862        PARAMETER (one = 1.)        PARAMETER (one = 1.)
863        PARAMETER (A0= 0.40670980)        PARAMETER (A0= 0.40670980)
864        PARAMETER (A1=-1.2523634 )        PARAMETER (A1=-1.2523634 )
865        PARAMETER (A2= 1.4224051 )        PARAMETER (A2= 1.4224051 )
866        PARAMETER (A3=-0.55573341)        PARAMETER (A3=-0.55573341)
867        PARAMETER (OCNALB=0.08)        PARAMETER (OCNALB=0.08)
868  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  
869    
       integer sec,month,day,im,jm,nchp,nchpland  
       real cosz(im,jm),fraci(im,jm),fracg(im,jm)  
       real snodep(nchp),chfr(nchp),chlt(nchp)  
       integer igrd(nchp),ityp(nchp)  
       real albvr(im,jm),albvf(im,jm),albnr(im,jm)  
       real albnf(im,jm)  
   
870        real alboc(im,jm)        real alboc(im,jm)
871        real AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)        real AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
872        real ANIRDF(nchp),zenith(nchp)        real ANIRDF(nchp)
873        real alai(nchp),agrn(nchp)        real zenith(nchp)
874          real tmpij(im,jm)
875        integer i,j        integer i,j
876    
877        DO I=1,IM        DO I=1,IM
878        DO J=1,JM        DO J=1,JM
879         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)
880         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))
881         ALBNR(I,J) = ALBVR(I,J)         ALBNR(I,J,bi,bj) = ALBVR(I,J,bi,bj)
882         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))
883         ALBNF(I,J) = ALBVF(I,J)         ALBNF(I,J,bi,bj) = ALBVF(I,J,bi,bj)
884        ENDDO        ENDDO
885        ENDDO        ENDDO
886    
# Line 851  C and now some conversions from grid spa Line 891  C and now some conversions from grid spa
891    
892  C and now call sibalb  C and now call sibalb
893    
894        call sibalb(avisdr,anirdr,avisdf,anirdf,alai,agrn,zenith,        call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),
895       1     snodep,ityp,nchpland)       .  agrn(1,bi,bj),zenith,snodep(1,bi,bj),ityp(1,bi,bj),nchpland)
896    
897  C finally some transformations back to grid space for albedos  C finally some transformations back to grid space for albedos
898    
899        call msc2grd(igrd,chfr,avisdr,nchp,nchpland,fracg,albvr,im,jm)        DO I=1,IM
900        call msc2grd(igrd,chfr,avisdf,nchp,nchpland,fracg,albvf,im,jm)        DO J=1,JM
901        call msc2grd(igrd,chfr,anirdr,nchp,nchpland,fracg,albnr,im,jm)         tmpij(i,j) = 0.
902        call msc2grd(igrd,chfr,anirdf,nchp,nchpland,fracg,albnf,im,jm)        ENDDO
903          ENDDO
904          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdr,nchp,nchpland,
905         .                                     fracg,tmpij,im,jm)
906          DO I=1,IM
907          DO J=1,JM
908           albvr(i,j,bi,bj) = tmpij(i,j)
909          ENDDO
910          ENDDO
911          DO I=1,IM
912          DO J=1,JM
913           tmpij(i,j) = 0.
914          ENDDO
915          ENDDO
916          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdf,nchp,nchpland,
917         .                                     fracg,tmpij,im,jm)
918          DO I=1,IM
919          DO J=1,JM
920           albvf(i,j,bi,bj) = tmpij(i,j)
921          ENDDO
922          ENDDO
923          DO I=1,IM
924          DO J=1,JM
925           tmpij(i,j) = 0.
926          ENDDO
927          ENDDO
928          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdr,nchp,nchpland,
929         .                                     fracg,tmpij,im,jm)
930          DO I=1,IM
931          DO J=1,JM
932           albnr(i,j,bi,bj) = tmpij(i,j)
933          ENDDO
934          ENDDO
935          DO I=1,IM
936          DO J=1,JM
937           tmpij(i,j) = 0.
938          ENDDO
939          ENDDO
940          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdf,nchp,nchpland,
941         .                                     fracg,tmpij,im,jm)
942          DO I=1,IM
943          DO J=1,JM
944           albnf(i,j,bi,bj) = tmpij(i,j)
945          ENDDO
946          ENDDO
947    
948        return        return
949        end        end
950    
951        subroutine getemiss (fracg,im,jm,nchp,igrd,ityp,chfr,snowdep,fraci,emiss)        subroutine getemiss(fracg,im,jm,nchp,nSx,nSy,bi,bj,igrd,ityp,
952         .                                         chfr,snowdep,fraci,emiss)
953  C***********************************************************************  C***********************************************************************
954  C  PURPOSE  C  PURPOSE
955  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 960  C fracg    - real array in grid space of
960  C im       - model grid longitude dimension  C im       - model grid longitude dimension
961  C jm       - model grid latitude dimension (number of lat. points)  C jm       - model grid latitude dimension (number of lat. points)
962  C nchp     - integer actual number of tiles in tile space  C nchp     - integer actual number of tiles in tile space
963    C nSx      - number of processors in x-direction
964    C nSy      - number of processors in y-direction
965    C bi       - processors index in x-direction
966    C bj       - processors index in y-direction
967  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
968  C            tile [nchp]  C            tile [nchp]
969  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 975  C            in mm [nchp]
975  C fraci    - real array in tile space of sea ice fraction [nchp]  C fraci    - real array in tile space of sea ice fraction [nchp]
976  C  C
977  C OUTPUT:  C OUTPUT:
978  C emiss    - real array [im,jm,10] of surface emissivities (fraction)  C emiss    - real array [im,jm,10,nSx,nSy] - surface emissivity (frac)
979  C  C
980  C***********************************************************************  C***********************************************************************
981        implicit none        implicit none
982        integer im,jm,nchp  #include "CPP_EEOPTIONS.h"
983          integer im,jm,nchp,nSx,nSy,bi,bj
984        real fracg(im,jm)        real fracg(im,jm)
985        real chfr(nchp)        _RL chfr(nchp,nSx,nSy)
986        integer igrd(nchp), ityp(nchp)        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)
987        real snowdep(nchp),fraci(nchp)        _RL snowdep(nchp,nSx,nSy)
988        real emiss(im,jm,10)        real fraci(nchp)
989          _RL emiss(im,jm,10,nSx,nSy)
990    
991        real emisstile(nchp,10)        real emisstile(nchp,10)
992        integer i,n        real tmpij(im,jm)
993          integer i,j,k,n
994    
995        do i = 1,10        do i = 1,10
996        do n = 1,nchp        do n = 1,nchp
# Line 908  C*************************************** Line 1000  C***************************************
1000    
1001  c call emissivity to get values in tile space  c call emissivity to get values in tile space
1002  c -------------------------------------------  c -------------------------------------------
1003        call emissivity (snowdep,fraci,nchp,ityp,emisstile)        call emissivity(snowdep(1,bi,bj),fraci,nchp,ityp(1,bi,bj),
1004         .                                                    emisstile)
1005    
1006  c transform back to grid space for emissivities  c transform back to grid space for emissivities
1007  c ---------------------------------------------  c ---------------------------------------------
1008        do i = 1,10        do k = 1,10
1009        emiss(:,:,i) = 0.0        do j = 1,jm
1010        call msc2grd (igrd,chfr,emisstile(1,i),nchp,nchp,fracg,emiss(1,1,i),im,jm)        do i = 1,im
1011           tmpij(i,j) = 0.0
1012          enddo
1013          enddo
1014          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),emisstile(1,k),nchp,nchp,
1015         .      fracg,tmpij,im,jm)
1016          do j = 1,jm
1017          do i = 1,im
1018           emiss(i,j,k,bi,bj) = tmpij(i,j)
1019          enddo
1020          enddo
1021        enddo        enddo
1022    
1023        return        return
# Line 922  c -------------------------------------- Line 1025  c --------------------------------------
1025    
1026        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)
1027        implicit none        implicit none
1028    #include "CPP_EEOPTIONS.h"
1029        integer numpts        integer numpts
1030        integer   ityp(numpts)        integer   ityp(numpts)
1031        real snowdepth(numpts),fraci(numpts)        _RL snowdepth(numpts)
1032        real   newemis(numpts,10)        real fraci(numpts)
1033          real newemis(numpts,10)
1034    
1035        real emis(12,11)        real emis(12,11)
       real snwmid(10)  
1036        real fac        real fac
1037        integer i,j        integer i,j
1038    
# Line 985  c      band 12: 35.7 -  oo  um Line 1089  c      band 12: 35.7 -  oo  um
1089  c  c
1090  c-------------------------------------------------------------------------  c-------------------------------------------------------------------------
1091        data ((emis(i,j),i=1,12),j=1,11) /        data ((emis(i,j),i=1,12),j=1,11) /
1092       &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903, ! evergreen needleleaf  C evergreen needleleaf
1093         &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903,
1094       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
1095       &   0.9849, 0.9856, 0.9841, 0.9831, 0.9789, 0.9805, ! deciduous needleleaf  C deciduous needleleaf
1096         &   0.9849, 0.9856, 0.9841, 0.9831, 0.9789, 0.9805,
1097       &   0.9733, 0.9869, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9733, 0.9869, 1.0000, 1.0000, 1.0000, 1.0000,
1098       &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903, ! evergreen needleleaf  C evergreen needleleaf
1099         &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903,
1100       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
1101       &   0.9867, 0.9897, 0.9920, 0.9933, 0.9830, 0.9752, ! grasslands  C grasslands
1102         &   0.9867, 0.9897, 0.9920, 0.9933, 0.9830, 0.9752,
1103       &   0.9853, 0.9928, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9853, 0.9928, 1.0000, 1.0000, 1.0000, 1.0000,
1104       &   0.9490, 0.9697, 0.9738, 0.9712, 0.9474, 0.9582, ! closed shrublands  C closed shrublands
1105         &   0.9490, 0.9697, 0.9738, 0.9712, 0.9474, 0.9582,
1106       &   0.9663, 0.9747, 0.9836, 0.9836, 0.9836, 0.9836,       &   0.9663, 0.9747, 0.9836, 0.9836, 0.9836, 0.9836,
1107       &   0.9469, 0.9670, 0.9883, 0.9795, 0.9751, 0.9767, ! tundra  C tundra
1108         &   0.9469, 0.9670, 0.9883, 0.9795, 0.9751, 0.9767,
1109       &   0.9920, 0.9888, 0.9888, 0.9888, 0.9888, 0.9888,       &   0.9920, 0.9888, 0.9888, 0.9888, 0.9888, 0.9888,
1110       &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren  C barren
1111         &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1112       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1113       &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren  C barren
1114         &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1115       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1116       &   0.9998, 0.9998, 0.9998, 0.9998, 0.9998, 0.9999, ! snow/ice  C snow/ice
1117         &   0.9998, 0.9998, 0.9998, 0.9998, 0.9998, 0.9999,
1118       &   0.9997, 0.9994, 0.9995, 0.9995, 0.9995, 0.9995,       &   0.9997, 0.9994, 0.9995, 0.9995, 0.9995, 0.9995,
1119       &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren  C barren
1120         &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1121       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1122       &   0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865, ! water  C water
1123         &   0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865,
1124       &   0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/       &   0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/
1125    
1126        include 'snwmid.h'  #include "snwmid.h"
1127    
1128  c Convert to the 10 bands needed by Chou Radiation  c Convert to the 10 bands needed by Chou Radiation
1129  c ------------------------------------------------  c ------------------------------------------------
# Line 1032  c modify emissivity for snow based on sn Line 1147  c modify emissivity for snow based on sn
1147  c-------------------------------------------------------------  c-------------------------------------------------------------
1148          if(snowdepth (i).gt.0.) then          if(snowdepth (i).gt.0.) then
1149           fac = snowdepth(i) / (snowdepth(i) + snwmid(ityp(i)))           fac = snowdepth(i) / (snowdepth(i) + snwmid(ityp(i)))
1150           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.)
1151           newemis(i, 2) = newemis(i, 2) + (((emis( 2,9)+emis( 3,9))/2.) - newemis(i, 2)) * fac       .                                           - newemis(i, 1)) * fac
1152           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.)
1153           newemis(i, 4) = newemis(i, 4) +              (emis( 6,9)      - newemis(i, 4)) * fac       .                                           - newemis(i, 2)) * fac
1154           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.)
1155           newemis(i, 6) = newemis(i, 6) +              (emis( 8,9)      - newemis(i, 6)) * fac       .                                           - newemis(i, 3)) * fac
1156           newemis(i, 7) = newemis(i, 7) +              (emis( 9,9)      - newemis(i, 7)) * fac           newemis(i, 4) = newemis(i, 4) +              (emis( 6,9)      
1157           newemis(i, 8) = newemis(i, 8) + (((emis(10,9)+emis(11,9))/2.) - newemis(i, 8)) * fac       .                                           - newemis(i, 4)) * fac
1158           newemis(i, 9) = newemis(i, 9) +              (emis(12,9)      - newemis(i, 9)) * fac           newemis(i, 5) = newemis(i, 5) +              (emis( 7,9)      
1159           newemis(i,10) = newemis(i,10) +              (emis( 4,9)      - newemis(i,10)) * fac       .                                           - newemis(i, 5)) * fac
1160             newemis(i, 6) = newemis(i, 6) +              (emis( 8,9)      
1161         .                                           - newemis(i, 6)) * fac
1162             newemis(i, 7) = newemis(i, 7) +              (emis( 9,9)      
1163         .                                           - newemis(i, 7)) * fac
1164             newemis(i, 8) = newemis(i, 8) + (((emis(10,9)+emis(11,9))/2.)
1165         .                                           - newemis(i, 8)) * fac
1166             newemis(i, 9) = newemis(i, 9) +              (emis(12,9)      
1167         .                                           - newemis(i, 9)) * fac
1168             newemis(i,10) = newemis(i,10) +              (emis( 4,9)      
1169         .                                           - newemis(i,10)) * fac
1170          endif          endif
1171    
1172  c open water  c open water
# Line 1077  c-------------------------------- Line 1202  c--------------------------------
1202        enddo        enddo
1203    
1204        return        return
1205          end
1206          subroutine get_landfrac(im,jm,nSx,nSy,bi,bj,maxtyp,surftype,
1207         .                                                    tilefrac,frac)
1208    C***********************************************************************
1209    C  Purpose
1210    C     To compute the total fraction of land within a model grid-box
1211    C
1212    C***********************************************************************
1213          implicit none
1214    #include "CPP_EEOPTIONS.h"
1215    
1216          integer im,jm,nSx,nSy,bi,bj,maxtyp
1217          integer surftype(im,jm,maxtyp,nSx,nSy)
1218          _RL tilefrac(im,jm,maxtyp,nSx,nSy)
1219          real frac(im,jm)
1220    
1221          integer  i,j,k
1222    
1223          do j=1,jm
1224          do i=1,im
1225          frac(i,j) = 0.0
1226          enddo
1227          enddo
1228    
1229          do k=1,maxtyp
1230          do j=1,jm
1231          do i=1,im
1232          if( (surftype(i,j,k,bi,bj).lt.100.).and.
1233         .                               (tilefrac(i,j,k,bi,bj).gt.0.0))then
1234           frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)
1235          endif
1236          enddo
1237          enddo
1238          enddo
1239    
1240          return
1241        end        end
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.13
  ViewVC Help
Powered by ViewVC 1.1.22