/[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.7 by molod, Thu Jun 10 20:17:17 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          logical alarm
33          external alarm
34        _RL lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)        _RL lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
35        _RL fraci(sNx,sNy), fracl(sNx,sNy)        _RL fraci(sNx,sNy), fracl(sNx,sNy)
36        _RL ficetile(nchp)        _RL ficetile(nchp)
37        _RL ra        _RL radius
38        integer i, j, L, bi, bj        _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,nSx,nSy,bi,bj,         call getlgr (sec,month,day,chlt,ityp,nchpland,nchp,nSx,nSy,bi,bj,
88       .                                                       alai,agrn )       .                                                       alai,agrn )
89        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,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 141  C     ANIRDF:   near infra-red, diffuse Line 161  C     ANIRDF:   near infra-red, diffuse
161  C*******************************************************************  C*******************************************************************
162    
163        IMPLICIT NONE        IMPLICIT NONE
 #include "CPP_OPTIONS.h"  
164    
165        INTEGER IRUN        INTEGER IRUN
166        _RL 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        _RL ALVDRS,  ALIDRS        _RL ALVDRS,  ALIDRS
# Line 155  C*************************************** Line 175  C***************************************
175        _RL 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    
# Line 193  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
         INTEGER I, LAI  
   
         _RL FAC,               GAMMA,          BETA,          ALPHA,  
      `       DX,                DY,             ALA,           GRN (2),  
      `       SNWALB (4, NTYPS), SNWMID (NTYPS)  
   
 * [ Definition of Functions: ]  
 *  
         _RL COEFF  
   
 C   Constants used in albedo calculations:  
227    
228        _RL ALVDR (NLAI, 2, NTYPS)        _RL ALVDR (NLAI, 2, NTYPS)
229        _RL BTVDR (NLAI, 2, NTYPS)        _RL BTVDR (NLAI, 2, NTYPS)
# Line 604  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 617  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 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)
 #include "CPP_OPTIONS.h"  
679                    
680        INTEGER NTABL, LAI        INTEGER NTABL, LAI
681          _RL coeff
682        _RL TABLE (NTABL, 2), DX, DY        _RL TABLE (NTABL, 2), DX, DY
683    
684        COEFF = (TABLE(LAI,  1)        COEFF = (TABLE(LAI,  1)
# Line 676  cfpp$ expand (coeff) Line 689  cfpp$ expand (coeff)
689        RETURN        RETURN
690        END        END
691    
692        SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nSx,nSy,bi,bj,        SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nchpdim,
693       .                                                      ALAI,AGRN)       .    nSx,nSy,bi,bj,ALAI,AGRN)
694  C*********************************************************************  C*********************************************************************
695        implicit none        implicit none
 #include "CPP_OPTIONS"  
696    
697        integer ntyps        integer ntyps
698        _RL one,daylen        _RL one,daylen
# Line 688  C*************************************** Line 700  C***************************************
700        parameter (one = 1.)        parameter (one = 1.)
701        parameter (daylen = 86400.)        parameter (daylen = 86400.)
702    
703        integer sec, imon, iday, nchps, nSx, nSy, bi, bj        integer sec, imon, iday, nchps, nchpdim, nSx, nSy, bi, bj
704        _RL ALAI(NCHPS,nSx,nSy), AGRN(NCHPS,nSx,nSy)        _RL ALAI(nchpdim,nSx,nSy), AGRN(nchpdim,nSx,nSy)
705        _RL ALAT(NCHPS)        _RL ALAT(nchpdim)
706        integer ITYP(NCHPS,nSx,nSy)        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        _RL fac        _RL fac
# Line 770  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 794  C*************************************** Line 806  C***************************************
806        END        END
807    
808        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,im,jm,        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,im,jm,
809       .                  nchp,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,       .        nchp,nchptot,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,
810       .                  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 834  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
 #include "CPP_OPTIONS.h"  
849    
850        integer sec,month,day,im,jm,nchp,nchpland,nSx,nSy,bi,bj        integer sec,month,day,im,jm,nchp,nchptot,nchpland,nSx,nSy,bi,bj
851        _RL cosz(im,jm),fraci(im,jm),fracg(im,jm)        _RL cosz(im,jm),fraci(im,jm),fracg(im,jm)
852        _RL snodep(nchp,nSx,nSy),chfr(nchp,nSx,nSy),chlt(nchp,nSx,nSy)        _RL snodep(nchp,nSx,nSy),chfr(nchp,nSx,nSy),chlt(nchp,nSx,nSy)
853        integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)        integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)
# Line 855  C*************************************** Line 866  C***************************************
866    
867        _RL alboc(im,jm)        _RL alboc(im,jm)
868        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
869        _RL ANIRDF(nchp),zenith(nchp)        _RL ANIRDF(nchp)
870          _RL zenith(nchp)
871          _RL tmpij(im,jm)
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 877  C and now call sibalb Line 889  C and now call sibalb
889    
890        call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),        call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),
891       .  agrn(1,bi,bj),zenith,snodep(1,bi,bj),ityp(1,bi,bj),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          print *,' In getalb, chfr: '
896          print *,(chfr(i,1,1),i=1,nchptot)
897    
898          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,        call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdr,nchp,nchpland,
904       .                                      fracg,albvr(1,bi,bj),im,jm)       .                                     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,        call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdf,nchp,nchpland,
917       .                                      fracg,albvf(1,bi,bj),im,jm)       .                                     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,        call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdr,nchp,nchpland,
929       .                                      fracg,albnr(1,bi,bj),im,jm)       .                                     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,        call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdf,nchp,nchpland,
941       .                                      fracg,albnf(1,bi,bj),im,jm)       .                                     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,        subroutine getemiss(fracg,im,jm,nchp,nSx,nSy,bi,bj,igrd,ityp,
952       .                                                            emiss)       .                                         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 904  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 915  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  #include "CPP_OPTIONS.h"        integer im,jm,nchp,nSx,nSy,bi,bj
       integer im,jm,nchp  
983        _RL fracg(im,jm)        _RL fracg(im,jm)
984        _RL chfr(nchp)        _RL chfr(nchp,nSx,nSy)
985        integer igrd(nchp), ityp(nchp)        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)
986        _RL snowdep(nchp),fraci(nchp)        _RL snowdep(nchp,nSx,nSy)
987        _RL emiss(im,jm,10)        _RL fraci(nchp)
988          _RL emiss(im,jm,10,nSx,nSy)
989    
990        _RL emisstile(nchp,10)        _RL emisstile(nchp,10)
991        integer i,n        _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 938  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 952  c -------------------------------------- Line 1024  c --------------------------------------
1024    
1025        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)
1026        implicit none        implicit none
 #include "CPP_OPTIONS.h"  
1027        integer numpts        integer numpts
1028        integer   ityp(numpts)        integer   ityp(numpts)
1029        _RL snowdepth(numpts),fraci(numpts)        _RL snowdepth(numpts)
1030        _RL   newemis(numpts,10)        _RL fraci(numpts)
1031          _RL newemis(numpts,10)
1032    
1033        _RL emis(12,11)        _RL emis(12,11)
       _RL snwmid(10)  
1034        _RL fac        _RL fac
1035        integer i,j        integer i,j
1036    
# Line 1016  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 1063  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 1117  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        _RL frac(im,jm)        _RL frac(im,jm)
1217    
1218        integer  i,j,k        integer  i,j,k
# Line 1135  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.7  
changed lines
  Added in v.1.17
  ViewVC Help
Powered by ViewVC 1.1.22