/[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.6 by molod, Wed Jun 9 20:33:37 2004 UTC
# Line 7  c  Subroutine update_earth_exports - 'Wr Line 7  c  Subroutine update_earth_exports - 'Wr
7  c        the fields related to the earth's surface that are needed  c        the fields related to the earth's surface that are needed
8  c        by fizhi.  c        by fizhi.
9  c  c
10  c Call:  getalb    (Set the 4 albedos based on veg type and time)  c Call:  getlgr    (Set the leaf area index and surface greenness,
11    c                              based on veg type and month)
12    c        getalb    (Set the 4 albedos based on veg type, snow and time)
13  c        getemiss  (Set the surface emissivity based on the veg type  c        getemiss  (Set the surface emissivity based on the veg type
14  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)  
15  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
16         implicit none         implicit none
17  #include "CPP_OPTIONS.h"  #include "CPP_OPTIONS.h"
18  #include "SIZE.h"  #include "SIZE.h"
 #include "GRID.h"  
19  #include "fizhi_land_SIZE.h"  #include "fizhi_land_SIZE.h"
20  #include "fizhi_SIZE.h"  #include "fizhi_SIZE.h"
21  #include "fizhi_coms.h"  #include "fizhi_coms.h"
22  #include "gridalt_mapping.h"  #include "gridalt_mapping.h"
23  #include "fizhi_land_coms.h"  #include "fizhi_land_coms.h"
24    #include "fizhi_earth_coms.h"
25    #include "fizhi_ocean_coms.h"
26  #include "EEPARAMS.h"  #include "EEPARAMS.h"
27    
28        integer myTime, myIter, myThid        integer myTime, myIter, myThid
29    
30          real lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
31          real fraci(sNx,sNy), fracl(sNx,sNy)
32          real ficetile(nchp)
33          real ra
34        integer i, j, L, bi, bj        integer i, j, L, bi, bj
35        integer im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2        integer im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2
36          integer sec, day, month
37          integer nmonf,ndayf
38          nmonf(n) = mod(n,10000)/100
39          ndayf(n) = mod(n,100)
40    
41        idim1 = 1-OLx        idim1 = 1-OLx
42        idim2 = sNx+OLx        idim2 = sNx+OLx
# Line 37  c--------------------------------------- Line 46  c---------------------------------------
46        im2 = sNx        im2 = sNx
47        jm1 = 1        jm1 = 1
48        jm2 = sNy        jm2 = sNy
49          month = nmonf(nymd)
50          day = ndayf(nymd)
51          sec = nsecf(nhms)
52    
53        do bj = myByLo(myThid), myByHi(myThid)        do bj = myByLo(myThid), myByHi(myThid)
54        do bi = myBxLo(myThid), myBxHi(myThid)        do bi = myBxLo(myThid), myBxHi(myThid)
55           do j = jm1,jm2
56           do i = im1,im2
57            lons(i,j,bi,bj) = xC(i,j,bi,bj)
58            lats(i,j,bi,bj) = yC(i,j,bi,bj)
59           enddo
60           enddo
61    
62           call get_landfrac(im2,jm2,nSx,nSy,bi,bj,maxtyp,surftype,tilefrac,
63         .                                                            fracl)
64           do j = jm1,jm2
65           do i = im1,im2
66            if(sea_ice(i,j,bi,bj).gt.0.) then
67               fraci(i,j) = 1.
68            else
69               fraci(i,j) = 0.
70            endif
71           enddo
72           enddo
73    
74  C***********************************************************************  C***********************************************************************
75  C*              Get Leaf-Area-Index and Greenness Index                *  C*              Get Leaf-Area-Index and Greenness Index                *
76  C***********************************************************************  C***********************************************************************
77    
78        if( alarm('turb') .or. alarm('radsw') ) then        if( alarm('turb') .or. alarm('radsw') ) then
79        call getlgr ( sec,month,day,        call getlgr (sec,month,day,chlt,ityp,nchpland,bi,bj,alai,agrn )
      .              land%grid%chlt,coupling%earth%ityp,coupling%earth%nchpland,  
      .              coupling%earth%alai,coupling%earth%agrn )  
80        endif        endif
81    
   
82  C **********************************************************************  C **********************************************************************
83  C                      Compute Surface Albedo  C                      Compute Surface Albedo
84  C **********************************************************************  C **********************************************************************
85    
86        if( alarm('radsw') ) then        if( alarm('radsw') ) then
87        call astro  ( nymd,nhms, alat,alon, im*jm, cosz,ra )         call astro(nymd,nhms,lats,lons,im2*jm2,cosz,ra)
88        call getalb ( sec,month,day,cosz,land%vars%snodep,fraci,fracl,         call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,
89       .              im,jm,land%grid%nchp,       .             nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,alai,agrn,
90       .              coupling%earth%nchpland,       .             albvisdr,albvisdf,albnirdr,albnirdf )
      .              land%grid%igrd,coupling%earth%ityp,  
      .              coupling%earth%chfr,land%grid%chlt,  
      .              coupling%earth%alai,coupling%earth%agrn,  
      .              coupling%earth%albvisdr,coupling%earth%albvisdf,  
      .              coupling%earth%albnirdr,coupling%earth%albnirdf )  
91        endif        endif
92    
93    
# Line 75  C                      Compute Surface E Line 96  C                      Compute Surface E
96  C **********************************************************************  C **********************************************************************
97    
98        if( alarm('radlw') ) then        if( alarm('radlw') ) then
99           allocate ( ficetile(im*jm*maxtyp) )         call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchp)
100           call grd2msc  ( fraci,im,jm,land%grid%igrd,ficetile,land%grid%nchp,land%grid%nchp )         call getemiss(fracl,im2,jm2,nchp,nSx,nSy,bi,bj,igrd,ityp,chfr,
101           call getemiss ( fracl,im,jm,land%grid%nchp,land%grid%igrd,       .      snodep,ficetile,emiss)
      .                   coupling%earth%ityp,coupling%earth%chfr,land%vars%snodep,  
      .                   ficetile,coupling%earth%emiss )  
          deallocate ( ficetile )  
102        endif        endif
103    
104    
# Line 90  C*************************************** Line 108  C***************************************
108    
109        do j = 1,jm        do j = 1,jm
110        do i = 1,im        do i = 1,im
111        if( fracl(i,j).lt.0.3 .and. ocean%vars%sea_ice(i,j).eq.0.0 ) then        if(fracl(i,j).lt.0.3.and.sea_ice(i,j).eq.0.0)tgz(i,j) = sst(i,j)
          coupling%land%tgz(i,j) = ocean%vars%sst(i,j)  
112        endif        endif
113        enddo        enddo
114        enddo        enddo
# Line 1076  c-------------------------------- Line 1093  c--------------------------------
1093        enddo        enddo
1094    
1095        return        return
1096          end
1097          subroutine get_landfrac(im,jm,nSx,nSy,bi,bj,maxtyp,surftype,
1098         .                                                    tilefrac,frac)
1099    C***********************************************************************
1100    C  Purpose
1101    C     To compute the total fraction of land within a model grid-box
1102    C
1103    C***********************************************************************
1104          implicit none
1105    #include "CPP_OPTIONS.h"
1106    
1107          integer i,j,nSx,nSy,bi,bj,maxtyp
1108          integer surftype(im,jm,nSx,nSy)
1109          _RL surftype(im,jm,nSx,nSy)
1110          real frac(im,jm)
1111    
1112          integer  i,j,k
1113    
1114          do j=1,jm
1115          do i=1,im
1116          frac(i,j) = 0.0
1117          enddo
1118          enddo
1119    
1120          do k=1,maxtyp
1121          do j=1,jm
1122          do i=1,im
1123          if(surftype(i,j,k,bi,bj).lt.100.and.
1124                                           tilefrac(i,j,k,bi,bj).gt.0.0)then
1125           frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)
1126          endif
1127          enddo
1128          enddo
1129          enddo
1130    
1131          return
1132        end        end
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.6
  ViewVC Help
Powered by ViewVC 1.1.22