/[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.4 by molod, Wed Jun 9 18:35:31 2004 UTC revision 1.18 by molod, Mon Jul 26 20:23:16 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
8  c        the fields related to the earth's surface that are needed  c        the fields related to the earth's surface that are needed
9  c        by fizhi.  c        by fizhi.
10  c  c
11  c Call:  getalb    (Set the 4 albedos based on veg type and time)  c Call:  getlgr    (Set the leaf area index and surface greenness,
12    c                              based on veg type and month)
13    c        getalb    (Set the 4 albedos based on veg type, snow and time)
14  c        getemiss  (Set the surface emissivity based on the veg type  c        getemiss  (Set the surface emissivity based on the veg type
15  c                              and the snow depth)  c                              and the snow depth)
 c        getlgr    (Set the leaf area index and surface greenness,  
 c                              based on veg type and month)  
16  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
17         implicit none         implicit none
 #include "CPP_OPTIONS.h"  
18  #include "SIZE.h"  #include "SIZE.h"
19  #include "GRID.h"  #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"
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        integer i, j, L, bi, bj        logical alarm
33          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
43          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
46          ndayf(n) = mod(n,100)
47    
48        idim1 = 1-OLx        idim1 = 1-OLx
49        idim2 = sNx+OLx        idim2 = sNx+OLx
# Line 37  c--------------------------------------- Line 53  c---------------------------------------
53        im2 = sNx        im2 = sNx
54        jm1 = 1        jm1 = 1
55        jm2 = sNy        jm2 = sNy
56          month = nmonf(nymd)
57          day = ndayf(nymd)
58          sec = nsecf(nhms)
59    
60        do bj = myByLo(myThid), myByHi(myThid)        do bj = myByLo(myThid), myByHi(myThid)
61        do bi = myBxLo(myThid), myBxHi(myThid)        do bi = myBxLo(myThid), myBxHi(myThid)
62           do j = jm1,jm2
63           do i = im1,im2
64            lons(i,j) = xC(i,j,bi,bj)
65            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
80           enddo
81    
82  C***********************************************************************  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,         call getlgr (sec,month,day,chlt,ityp,nchpland,nchp,nSx,nSy,bi,bj,
88       .              land%grid%chlt,coupling%earth%ityp,coupling%earth%nchpland,       .                                                       alai,agrn )
89       .              coupling%earth%alai,coupling%earth%agrn )         endif
       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, alat,alon, im*jm, cosz,ra )          call astro(nymd,nhms,lats,lons,im2*jm2,cosz,radius)
97        call getalb ( sec,month,day,cosz,land%vars%snodep,fraci,fracl,          call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,
98       .              im,jm,land%grid%nchp,       .    nchptot,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,alai,agrn,
99       .              coupling%earth%nchpland,       .    albvisdr,albvisdf,albnirdr,albnirdf )
100       .              land%grid%igrd,coupling%earth%ityp,         endif
      .              coupling%earth%chfr,land%grid%chlt,  
      .              coupling%earth%alai,coupling%earth%agrn,  
      .              coupling%earth%albvisdr,coupling%earth%albvisdf,  
      .              coupling%earth%albnirdr,coupling%earth%albnirdf )  
       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           allocate ( ficetile(im*jm*maxtyp) )          call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchp)
109           call grd2msc  ( fraci,im,jm,land%grid%igrd,ficetile,land%grid%nchp,land%grid%nchp )          call getemiss(fracl,im2,jm2,nchp,nchptot,nSx,nSy,bi,bj,
110           call getemiss ( fracl,im,jm,land%grid%nchp,land%grid%igrd,       .   igrd,ityp,chfr,snodep,ficetile,emiss)
111       .                   coupling%earth%ityp,coupling%earth%chfr,land%vars%snodep,         endif
      .                   ficetile,coupling%earth%emiss )  
          deallocate ( ficetile )  
       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. ocean%vars%sea_ice(i,j).eq.0.0 ) then          tmpij(i,j) = 0.
122           coupling%land%tgz(i,j) = ocean%vars%sst(i,j)         enddo
123        endif         enddo
124        enddo         do i = 1,nchp
125        enddo          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 125  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 174  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 585  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 598  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 645  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 655  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 752  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 765  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 786  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 810  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 850  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,nchptot,nSx,nSy,bi,bj,
952         .   igrd,ityp,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 874  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 885  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,nchptot,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,nchptot
996           emisstile(n,i) = 1.           emisstile(n,i) = 1.
997        enddo        enddo
998        enddo        enddo
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,nchptot,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,
1014         .  nchptot,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
1023        end        end
1024    
1025        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)        subroutine emissivity (snowdepth,fraci,nchp,numpts,ityp,newemis)
1026        implicit none        implicit none
1027        integer numpts        integer nchp,numpts
1028        integer   ityp(numpts)        integer   ityp(nchp)
1029        real snowdepth(numpts),fraci(numpts)        _RL snowdepth(nchp)
1030        real   newemis(numpts,10)        _RL fraci(nchp)
1031          _RL newemis(nchp,10)
1032        real emis(12,11)  
1033        real snwmid(10)        _RL emis(12,11)
1034        real fac        _RL fac
1035        integer i,j        integer i,j
1036    
1037  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
# Line 984  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 1031  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 1076  c-------------------------------- Line 1200  c--------------------------------
1200        enddo        enddo
1201    
1202        return        return
1203          end
1204          subroutine get_landfrac(im,jm,nSx,nSy,bi,bj,maxtyp,surftype,
1205         .                                                    tilefrac,frac)
1206    C***********************************************************************
1207    C  Purpose
1208    C     To compute the total fraction of land within a model grid-box
1209    C
1210    C***********************************************************************
1211          implicit none
1212    
1213          integer im,jm,nSx,nSy,bi,bj,maxtyp
1214          integer surftype(im,jm,maxtyp,nSx,nSy)
1215          _RL tilefrac(im,jm,maxtyp,nSx,nSy)
1216          _RL frac(im,jm)
1217    
1218          integer  i,j,k
1219    
1220          do j=1,jm
1221          do i=1,im
1222          frac(i,j) = 0.0
1223          enddo
1224          enddo
1225    
1226          do k=1,maxtyp
1227          do j=1,jm
1228          do i=1,im
1229          if( (surftype(i,j,k,bi,bj).lt.100.).and.
1230         .                               (tilefrac(i,j,k,bi,bj).gt.0.0))then
1231           frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)
1232          endif
1233          enddo
1234          enddo
1235          enddo
1236    
1237          return
1238        end        end
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.18
  ViewVC Help
Powered by ViewVC 1.1.22