/[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.6 by molod, Wed Jun 9 20:33:37 2004 UTC revision 1.17 by molod, Mon Jul 26 20:15:05 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"
# Line 27  c--------------------------------------- Line 29  c---------------------------------------
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        real fraci(sNx,sNy), fracl(sNx,sNy)        external alarm
34        real ficetile(nchp)        _RL lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
35        real ra        _RL fraci(sNx,sNy), fracl(sNx,sNy)
36        integer i, j, L, bi, bj        _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 54  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         enddo
67         enddo         enddo
68    
69         call get_landfrac(im2,jm2,nSx,nSy,bi,bj,maxtyp,surftype,tilefrac,         call get_landfrac(im2,jm2,nSx,nSy,bi,bj,maxtyp,surftype,tilefrac,
70       .                                                            fracl)       .                                                            fracl)
71    
72         do j = jm1,jm2         do j = jm1,jm2
73         do i = im1,im2         do i = im1,im2
74          if(sea_ice(i,j,bi,bj).gt.0.) then          if(sice(i,j,bi,bj).gt.0.) then
75             fraci(i,j) = 1.             fraci(i,j) = 1.
76          else          else
77             fraci(i,j) = 0.             fraci(i,j) = 0.
# Line 75  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,bi,bj,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,im2,jm2,nchp,          call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,
98       .             nchpland,nSx,nSy,bi,bj,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    
103  C **********************************************************************  C **********************************************************************
104  C                      Compute Surface Emissivity  C                      Compute Surface Emissivity
105  C **********************************************************************  C **********************************************************************
106    
107        if( alarm('radlw') ) then         if( alarm('radlw') ) then
108         call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchp)          call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchp)
109         call getemiss(fracl,im2,jm2,nchp,nSx,nSy,bi,bj,igrd,ityp,chfr,          call getemiss(fracl,im2,jm2,nchp,nSx,nSy,bi,bj,igrd,ityp,chfr,
110       .      snodep,ficetile,emiss)       .      snodep,ficetile,emiss)
111        endif         endif
112    
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,nchp
125            tmpchp(i) = tcanopy(i,bi,bj)
126           enddo
127           call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,
128         .                           nchp,nchptot,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 142  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 191  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 602  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 615  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 662  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 672  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 769  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 782  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 803  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 827  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 867  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)        print *,' In getalb, chfr: '
896        call msc2grd(igrd,chfr,avisdf,nchp,nchpland,fracg,albvf,im,jm)        print *,(chfr(i,1,1),i=1,nchptot)
897        call msc2grd(igrd,chfr,anirdr,nchp,nchpland,fracg,albnr,im,jm)  
898        call msc2grd(igrd,chfr,anirdf,nchp,nchpland,fracg,albnf,im,jm)        DO I=1,IM
899          DO J=1,JM
900           tmpij(i,j) = albvr(i,j,bi,bj)
901          ENDDO
902          ENDDO
903          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdr,nchp,nchpland,
904         .                                     fracg,tmpij,im,jm)
905    
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) = albvf(i,j,bi,bj)
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) = albnr(i,j,bi,bj)
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) = albnf(i,j,bi,bj)
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 891  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 902  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        integer im,jm,nchp,nSx,nSy,bi,bj
983        real fracg(im,jm)        _RL fracg(im,jm)
984        real chfr(nchp)        _RL chfr(nchp,nSx,nSy)
985        integer igrd(nchp), ityp(nchp)        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)
986        real snowdep(nchp),fraci(nchp)        _RL snowdep(nchp,nSx,nSy)
987        real emiss(im,jm,10)        _RL fraci(nchp)
988          _RL emiss(im,jm,10,nSx,nSy)
989        real emisstile(nchp,10)  
990        integer i,n        _RL emisstile(nchp,10)
991          _RL tmpij(im,jm)
992          integer i,j,k,n
993    
994        do i = 1,10        do i = 1,10
995        do n = 1,nchp        do n = 1,nchp
# Line 924  C*************************************** Line 999  C***************************************
999    
1000  c call emissivity to get values in tile space  c call emissivity to get values in tile space
1001  c -------------------------------------------  c -------------------------------------------
1002        call emissivity (snowdep,fraci,nchp,ityp,emisstile)        call emissivity(snowdep(1,bi,bj),fraci,nchp,ityp(1,bi,bj),
1003         .                                                    emisstile)
1004    
1005  c transform back to grid space for emissivities  c transform back to grid space for emissivities
1006  c ---------------------------------------------  c ---------------------------------------------
1007        do i = 1,10        do k = 1,10
1008        emiss(:,:,i) = 0.0        do j = 1,jm
1009        call msc2grd (igrd,chfr,emisstile(1,i),nchp,nchp,fracg,emiss(1,1,i),im,jm)        do i = 1,im
1010           tmpij(i,j) = 0.0
1011          enddo
1012          enddo
1013          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),emisstile(1,k),nchp,nchp,
1014         .      fracg,tmpij,im,jm)
1015          do j = 1,jm
1016          do i = 1,im
1017           emiss(i,j,k,bi,bj) = tmpij(i,j)
1018          enddo
1019          enddo
1020        enddo        enddo
1021    
1022        return        return
# Line 940  c -------------------------------------- Line 1026  c --------------------------------------
1026        implicit none        implicit none
1027        integer numpts        integer numpts
1028        integer   ityp(numpts)        integer   ityp(numpts)
1029        real snowdepth(numpts),fraci(numpts)        _RL snowdepth(numpts)
1030        real   newemis(numpts,10)        _RL fraci(numpts)
1031          _RL newemis(numpts,10)
1032    
1033        real emis(12,11)        _RL emis(12,11)
1034        real snwmid(10)        _RL fac
       real fac  
1035        integer i,j        integer i,j
1036    
1037  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
# Line 1001  c      band 12: 35.7 -  oo  um Line 1087  c      band 12: 35.7 -  oo  um
1087  c  c
1088  c-------------------------------------------------------------------------  c-------------------------------------------------------------------------
1089        data ((emis(i,j),i=1,12),j=1,11) /        data ((emis(i,j),i=1,12),j=1,11) /
1090       &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903, ! evergreen needleleaf  C evergreen needleleaf
1091         &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903,
1092       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
1093       &   0.9849, 0.9856, 0.9841, 0.9831, 0.9789, 0.9805, ! deciduous needleleaf  C deciduous needleleaf
1094         &   0.9849, 0.9856, 0.9841, 0.9831, 0.9789, 0.9805,
1095       &   0.9733, 0.9869, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9733, 0.9869, 1.0000, 1.0000, 1.0000, 1.0000,
1096       &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903, ! evergreen needleleaf  C evergreen needleleaf
1097         &   0.9891, 0.9892, 0.9900, 0.9914, 0.9908, 0.9903,
1098       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9898, 0.9948, 1.0000, 1.0000, 1.0000, 1.0000,
1099       &   0.9867, 0.9897, 0.9920, 0.9933, 0.9830, 0.9752, ! grasslands  C grasslands
1100         &   0.9867, 0.9897, 0.9920, 0.9933, 0.9830, 0.9752,
1101       &   0.9853, 0.9928, 1.0000, 1.0000, 1.0000, 1.0000,       &   0.9853, 0.9928, 1.0000, 1.0000, 1.0000, 1.0000,
1102       &   0.9490, 0.9697, 0.9738, 0.9712, 0.9474, 0.9582, ! closed shrublands  C closed shrublands
1103         &   0.9490, 0.9697, 0.9738, 0.9712, 0.9474, 0.9582,
1104       &   0.9663, 0.9747, 0.9836, 0.9836, 0.9836, 0.9836,       &   0.9663, 0.9747, 0.9836, 0.9836, 0.9836, 0.9836,
1105       &   0.9469, 0.9670, 0.9883, 0.9795, 0.9751, 0.9767, ! tundra  C tundra
1106         &   0.9469, 0.9670, 0.9883, 0.9795, 0.9751, 0.9767,
1107       &   0.9920, 0.9888, 0.9888, 0.9888, 0.9888, 0.9888,       &   0.9920, 0.9888, 0.9888, 0.9888, 0.9888, 0.9888,
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.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren  C barren
1112         &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1113       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1114       &   0.9998, 0.9998, 0.9998, 0.9998, 0.9998, 0.9999, ! snow/ice  C snow/ice
1115         &   0.9998, 0.9998, 0.9998, 0.9998, 0.9998, 0.9999,
1116       &   0.9997, 0.9994, 0.9995, 0.9995, 0.9995, 0.9995,       &   0.9997, 0.9994, 0.9995, 0.9995, 0.9995, 0.9995,
1117       &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766, ! barren  C barren
1118         &   0.8353, 0.9163, 0.9342, 0.9229, 0.8354, 0.8766,
1119       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,       &   0.9210, 0.9262, 0.9345, 0.9345, 0.9345, 0.9345,
1120       &   0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865, ! water  C water
1121         &   0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865,
1122       &   0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/       &   0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/
1123    
1124        include 'snwmid.h'  #include "snwmid.h"
1125    
1126  c Convert to the 10 bands needed by Chou Radiation  c Convert to the 10 bands needed by Chou Radiation
1127  c ------------------------------------------------  c ------------------------------------------------
# Line 1048  c modify emissivity for snow based on sn Line 1145  c modify emissivity for snow based on sn
1145  c-------------------------------------------------------------  c-------------------------------------------------------------
1146          if(snowdepth (i).gt.0.) then          if(snowdepth (i).gt.0.) then
1147           fac = snowdepth(i) / (snowdepth(i) + snwmid(ityp(i)))           fac = snowdepth(i) / (snowdepth(i) + snwmid(ityp(i)))
1148           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.)
1149           newemis(i, 2) = newemis(i, 2) + (((emis( 2,9)+emis( 3,9))/2.) - newemis(i, 2)) * fac       .                                           - newemis(i, 1)) * fac
1150           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.)
1151           newemis(i, 4) = newemis(i, 4) +              (emis( 6,9)      - newemis(i, 4)) * fac       .                                           - newemis(i, 2)) * fac
1152           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.)
1153           newemis(i, 6) = newemis(i, 6) +              (emis( 8,9)      - newemis(i, 6)) * fac       .                                           - newemis(i, 3)) * fac
1154           newemis(i, 7) = newemis(i, 7) +              (emis( 9,9)      - newemis(i, 7)) * fac           newemis(i, 4) = newemis(i, 4) +              (emis( 6,9)      
1155           newemis(i, 8) = newemis(i, 8) + (((emis(10,9)+emis(11,9))/2.) - newemis(i, 8)) * fac       .                                           - newemis(i, 4)) * fac
1156           newemis(i, 9) = newemis(i, 9) +              (emis(12,9)      - newemis(i, 9)) * fac           newemis(i, 5) = newemis(i, 5) +              (emis( 7,9)      
1157           newemis(i,10) = newemis(i,10) +              (emis( 4,9)      - newemis(i,10)) * fac       .                                           - newemis(i, 5)) * fac
1158             newemis(i, 6) = newemis(i, 6) +              (emis( 8,9)      
1159         .                                           - newemis(i, 6)) * fac
1160             newemis(i, 7) = newemis(i, 7) +              (emis( 9,9)      
1161         .                                           - newemis(i, 7)) * fac
1162             newemis(i, 8) = newemis(i, 8) + (((emis(10,9)+emis(11,9))/2.)
1163         .                                           - newemis(i, 8)) * fac
1164             newemis(i, 9) = newemis(i, 9) +              (emis(12,9)      
1165         .                                           - newemis(i, 9)) * fac
1166             newemis(i,10) = newemis(i,10) +              (emis( 4,9)      
1167         .                                           - newemis(i,10)) * fac
1168          endif          endif
1169    
1170  c open water  c open water
# Line 1102  C     To compute the total fraction of l Line 1209  C     To compute the total fraction of l
1209  C  C
1210  C***********************************************************************  C***********************************************************************
1211        implicit none        implicit none
 #include "CPP_OPTIONS.h"  
1212    
1213        integer i,j,nSx,nSy,bi,bj,maxtyp        integer im,jm,nSx,nSy,bi,bj,maxtyp
1214        integer surftype(im,jm,nSx,nSy)        integer surftype(im,jm,maxtyp,nSx,nSy)
1215        _RL surftype(im,jm,nSx,nSy)        _RL tilefrac(im,jm,maxtyp,nSx,nSy)
1216        real frac(im,jm)        _RL frac(im,jm)
1217    
1218        integer  i,j,k        integer  i,j,k
1219    
# Line 1120  C*************************************** Line 1226  C***************************************
1226        do k=1,maxtyp        do k=1,maxtyp
1227        do j=1,jm        do j=1,jm
1228        do i=1,im        do i=1,im
1229        if(surftype(i,j,k,bi,bj).lt.100.and.        if( (surftype(i,j,k,bi,bj).lt.100.).and.
1230                                         tilefrac(i,j,k,bi,bj).gt.0.0)then       .                               (tilefrac(i,j,k,bi,bj).gt.0.0))then
1231         frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)         frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)
1232        endif        endif
1233        enddo        enddo
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.17
  ViewVC Help
Powered by ViewVC 1.1.22