/[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.9 by molod, Thu Jun 10 21:50:33 2004 UTC revision 1.21 by molod, Wed Jul 28 22:08:40 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  C **********************************************************************  C **********************************************************************
103  C                      Compute Surface Emissivity  C                      Compute Surface Emissivity
104  C **********************************************************************  C **********************************************************************
105    
106        if( alarm('radlw') ) then         if( alarm('radlw') ) then
107         call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchp)          call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchptot)
108         call getemiss(fracl,im2,jm2,nchp,nSx,nSy,bi,bj,igrd,ityp,chfr,          call getemiss(fracl,im2,jm2,nchp,nchptot,nSx,nSy,bi,bj,
109       .      snodep,ficetile,emiss)       .   igrd,ityp,chfr,snodep,ficetile,emiss)
110        endif         endif
   
111    
112  C*********************************************************************  C*********************************************************************
113  C            Ground Temperature Over Ocean is from SST array,  C            Ground Temperature Over Ocean is from SST array,
114    C               Over land is from tcanopy
115  C*********************************************************************  C*********************************************************************
116    
117        do j = 1,jm         do j = jm1,jm2
118        do i = 1,im         do i = im1,im2
119        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.
120        endif         enddo
121        enddo         enddo
122        enddo         do i = 1,nchpland
123            tmpchp(i) = tcanopy(i,bi,bj)
124           enddo
125           call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,
126         .                           nchp,nchpland,fracl,tmpij,im2,jm2)
127           do j = jm1,jm2
128           do i = im1,im2
129            tgz(i,j,bi,bj) = tmpij(i,j)
130            if(fracl(i,j).lt.0.3.and.sice(i,j,bi,bj).eq.0.0)
131         .                                 tgz(i,j,bi,bj) = sst(i,j,bi,bj)
132           enddo
133           enddo
134    
135        enddo        enddo
136        enddo        enddo
# Line 141  C     ANIRDF:   near infra-red, diffuse Line 159  C     ANIRDF:   near infra-red, diffuse
159  C*******************************************************************  C*******************************************************************
160    
161        IMPLICIT NONE        IMPLICIT NONE
 #include "CPP_EEOPTIONS.h"  
162    
163        INTEGER IRUN        INTEGER IRUN
164        _RL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN),        _RL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)
165       `       VLAI   (IRUN),   VGRN (IRUN),   ZTH  (IRUN),    SNW (IRUN)        _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)
166          _RL ZTH(IRUN)
167        INTEGER ITYP (IRUN)        INTEGER ITYP (IRUN)
168    
169        _RL ALVDRS,  ALIDRS        _RL ALVDRS,  ALIDRS
# Line 201  C                  9:  GLACIER Line 219  C                  9:  GLACIER
219  C                 10:  DARK DESERT  C                 10:  DARK DESERT
220  C  C
221    
222          INTEGER I, LAI
223  * [ Definition of Variables: ]        _RL FAC,GAMMA,BETA,ALPHA,DX,DY,ALA,GRN (2),SNWALB(4,NTYPS)
224  *        _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:  
225    
226        _RL ALVDR (NLAI, 2, NTYPS)        _RL ALVDR (NLAI, 2, NTYPS)
227        _RL BTVDR (NLAI, 2, NTYPS)        _RL BTVDR (NLAI, 2, NTYPS)
# Line 612  C**** ---------------------------------- Line 619  C**** ----------------------------------
619    
620        DATA GRN /0.33, 0.67/        DATA GRN /0.33, 0.67/
621    
622        include 'snwmid.h'  #include "snwmid.h"
623        DATA SNWALB /.65, .38, .65, .38,        DATA SNWALB /.65, .38, .65, .38,
624       *             .65, .38, .65, .38,       *             .65, .38, .65, .38,
625       *             .65, .38, .65, .38,       *             .65, .38, .65, .38,
# Line 625  C**** ---------------------------------- Line 632  C**** ----------------------------------
632       &             .65, .38, .65, .38       &             .65, .38, .65, .38
633       `            /       `            /
634    
635  #if CRAY  #ifdef CRAY
636  #if f77  #ifdef f77
637  cfpp$ expand (coeff)  cfpp$ expand (coeff)
638  #endif  #endif
639  #endif  #endif
# Line 667  cfpp$ expand (coeff) Line 674  cfpp$ expand (coeff)
674        RETURN        RETURN
675        END        END
676        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)
 #include "CPP_EEOPTIONS.h"  
677                    
678        INTEGER NTABL, LAI        INTEGER NTABL, LAI
679          _RL coeff
680        _RL TABLE (NTABL, 2), DX, DY        _RL TABLE (NTABL, 2), DX, DY
681    
682        COEFF = (TABLE(LAI,  1)        COEFF = (TABLE(LAI,  1)
# Line 681  cfpp$ expand (coeff) Line 687  cfpp$ expand (coeff)
687        RETURN        RETURN
688        END        END
689    
690        SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nSx,nSy,bi,bj,        SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nchpdim,
691       .                                                      ALAI,AGRN)       .    nSx,nSy,bi,bj,ALAI,AGRN)
692  C*********************************************************************  C*********************************************************************
693        implicit none        implicit none
 #include "CPP_EEOPTIONS.h"  
694    
695        integer ntyps        integer ntyps
696        _RL one,daylen        _RL one,daylen
# Line 693  C*************************************** Line 698  C***************************************
698        parameter (one = 1.)        parameter (one = 1.)
699        parameter (daylen = 86400.)        parameter (daylen = 86400.)
700    
701        integer sec, imon, iday, nchps, nSx, nSy, bi, bj        integer sec, imon, iday, nchps, nchpdim, nSx, nSy, bi, bj
702        _RL ALAI(NCHPS,nSx,nSy), AGRN(NCHPS,nSx,nSy)        _RL ALAI(nchpdim,nSx,nSy), AGRN(nchpdim,nSx,nSy)
703        _RL ALAT(NCHPS)        _RL ALAT(nchpdim)
704        integer ITYP(NCHPS,nSx,nSy)        integer ITYP(nchpdim,nSx,nSy)
705    
706        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2
707        _RL fac        _RL fac
# Line 799  C*************************************** Line 804  C***************************************
804        END        END
805    
806        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,im,jm,        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,im,jm,
807       .                  nchp,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,       .        nchp,nchptot,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,
808       .                  alai,agrn,albvr,albvf,albnr,albnf)       .        alai,agrn,albvr,albvf,albnr,albnf)
809  C***********************************************************************  C***********************************************************************
810  C  PURPOSE  C  PURPOSE
811  C     To act as an interface to routine sibalb, which calculates  C     To act as an interface to routine sibalb, which calculates
# Line 839  C albnf    - real array [im,jm] of near- Line 844  C albnf    - real array [im,jm] of near-
844  C  C
845  C***********************************************************************  C***********************************************************************
846        implicit none        implicit none
 #include "CPP_EEOPTIONS.h"  
847    
848        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
849        _RL cosz(im,jm),fraci(im,jm),fracg(im,jm)        _RL cosz(im,jm),fraci(im,jm),fracg(im,jm)
850        _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)
851        integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)        integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)
# Line 860  C*************************************** Line 864  C***************************************
864    
865        _RL alboc(im,jm)        _RL alboc(im,jm)
866        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
867        _RL ANIRDF(nchp),zenith(nchp)        _RL ANIRDF(nchp)
868          _RL zenith(nchp)
869          _RL tmpij(im,jm)
870        integer i,j        integer i,j
871    
872        DO I=1,IM        DO I=1,IM
873        DO J=1,JM        DO J=1,JM
874         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)
875         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))
876         ALBNR(I,J) = ALBVR(I,J)         ALBNR(I,J,bi,bj) = ALBVR(I,J,bi,bj)
877         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))
878         ALBNF(I,J) = ALBVF(I,J)         ALBNF(I,J,bi,bj) = ALBVF(I,J,bi,bj)
879        ENDDO        ENDDO
880        ENDDO        ENDDO
   
881    
882  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
883    
# Line 882  C and now call sibalb Line 887  C and now call sibalb
887    
888        call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),        call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),
889       .  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)
890    
891  C finally some transformations back to grid space for albedos  C finally some transformations back to grid space for albedos
892    
893          DO I=1,IM
894          DO J=1,JM
895           tmpij(i,j) = albvr(i,j,bi,bj)
896          ENDDO
897          ENDDO
898        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,
899       .                                      fracg,albvr(1,bi,bj),im,jm)       .                                     fracg,tmpij,im,jm)
900    
901          DO I=1,IM
902          DO J=1,JM
903           albvr(i,j,bi,bj) = tmpij(i,j)
904          ENDDO
905          ENDDO
906          DO I=1,IM
907          DO J=1,JM
908           tmpij(i,j) = albvf(i,j,bi,bj)
909          ENDDO
910          ENDDO
911        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,
912       .                                      fracg,albvf(1,bi,bj),im,jm)       .                                     fracg,tmpij,im,jm)
913          DO I=1,IM
914          DO J=1,JM
915           albvf(i,j,bi,bj) = tmpij(i,j)
916          ENDDO
917          ENDDO
918          DO I=1,IM
919          DO J=1,JM
920           tmpij(i,j) = albnr(i,j,bi,bj)
921          ENDDO
922          ENDDO
923        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,
924       .                                      fracg,albnr(1,bi,bj),im,jm)       .                                     fracg,tmpij,im,jm)
925          DO I=1,IM
926          DO J=1,JM
927           albnr(i,j,bi,bj) = tmpij(i,j)
928          ENDDO
929          ENDDO
930          DO I=1,IM
931          DO J=1,JM
932           tmpij(i,j) = albnf(i,j,bi,bj)
933          ENDDO
934          ENDDO
935        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,
936       .                                      fracg,albnf(1,bi,bj),im,jm)       .                                     fracg,tmpij,im,jm)
937          DO I=1,IM
938          DO J=1,JM
939           albnf(i,j,bi,bj) = tmpij(i,j)
940          ENDDO
941          ENDDO
942    
943        return        return
944        end        end
945    
946        subroutine getemiss(fracg,im,jm,nchp,nSx,nSy,bi,bj,igrd,ityp,        subroutine getemiss(fracg,im,jm,nchp,nchptot,nSx,nSy,bi,bj,
947       .                                         chfr,snowdep,fraci,emiss)       .   igrd,ityp,chfr,snowdep,fraci,emiss)
948  C***********************************************************************  C***********************************************************************
949  C  PURPOSE  C  PURPOSE
950  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 928  C emiss    - real array [im,jm,10,nSx,nS Line 974  C emiss    - real array [im,jm,10,nSx,nS
974  C  C
975  C***********************************************************************  C***********************************************************************
976        implicit none        implicit none
977  #include "CPP_EEOPTIONS.h"        integer im,jm,nchp,nchptot,nSx,nSy,bi,bj
       integer im,jm,nchp,nSx,nSy,bi,bj  
978        _RL fracg(im,jm)        _RL fracg(im,jm)
979        _RL chfr(nchp,nSx,nSy)        _RL chfr(nchp,nSx,nSy)
980        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)
981        _RL snowdep(nchp,nSx,nSy),fraci(nchp)        _RL snowdep(nchp,nSx,nSy)
982          _RL fraci(nchp)
983        _RL emiss(im,jm,10,nSx,nSy)        _RL emiss(im,jm,10,nSx,nSy)
984    
985        _RL emisstile(nchp,10)        _RL emisstile(nchp,10)
986          _RL tmpij(im,jm)
987        integer i,j,k,n        integer i,j,k,n
988    
989        do i = 1,10        do i = 1,10
990        do n = 1,nchp        do n = 1,nchptot
991           emisstile(n,i) = 1.           emisstile(n,i) = 1.
992        enddo        enddo
993        enddo        enddo
994    
995  c call emissivity to get values in tile space  c call emissivity to get values in tile space
996  c -------------------------------------------  c -------------------------------------------
997        call emissivity(snowdep(1,bi,bj),fraci,nchp,ityp(1,bi,bj),        call emissivity(snowdep(1,bi,bj),fraci,nchp,nchptot,ityp(1,bi,bj),
998       .                                                    emisstile)       .                                                    emisstile)
999    
1000  c transform back to grid space for emissivities  c transform back to grid space for emissivities
# Line 955  c -------------------------------------- Line 1002  c --------------------------------------
1002        do k = 1,10        do k = 1,10
1003        do j = 1,jm        do j = 1,jm
1004        do i = 1,im        do i = 1,im
1005        emiss(i,j,k) = 0.0         tmpij(i,j) = 0.0
1006          enddo
1007          enddo
1008          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),emisstile(1,k),nchp,
1009         .  nchptot,fracg,tmpij,im,jm)
1010          do j = 1,jm
1011          do i = 1,im
1012           emiss(i,j,k,bi,bj) = tmpij(i,j)
1013        enddo        enddo
1014        enddo        enddo
       call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),emisstile(1,k),nchp,nchp,  
      .      fracg,emiss(1,1,k,bi,bj),im,jm)  
1015        enddo        enddo
1016    
1017        return        return
1018        end        end
1019    
1020        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)        subroutine emissivity (snowdepth,fraci,nchp,numpts,ityp,newemis)
1021        implicit none        implicit none
1022  #include "CPP_EEOPTIONS.h"        integer nchp,numpts
1023        integer numpts        integer   ityp(nchp)
1024        integer   ityp(numpts)        _RL snowdepth(nchp)
1025        _RL snowdepth(numpts),fraci(numpts)        _RL fraci(nchp)
1026        _RL   newemis(numpts,10)        _RL newemis(nchp,10)
1027    
1028        _RL emis(12,11)        _RL emis(12,11)
       _RL snwmid(10)  
1029        _RL fac        _RL fac
1030        integer i,j        integer i,j
1031    
# Line 1065  C water Line 1116  C water
1116       &   0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865,       &   0.9788, 0.9833, 0.9819, 0.9820, 0.9835, 0.9865,
1117       &   0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/       &   0.9886, 0.9719, 0.9719, 0.9719, 0.9719, 0.9719/
1118    
1119        include 'snwmid.h'  #include "snwmid.h"
1120    
1121  c Convert to the 10 bands needed by Chou Radiation  c Convert to the 10 bands needed by Chou Radiation
1122  c ------------------------------------------------  c ------------------------------------------------
# Line 1153  C     To compute the total fraction of l Line 1204  C     To compute the total fraction of l
1204  C  C
1205  C***********************************************************************  C***********************************************************************
1206        implicit none        implicit none
 #include "CPP_EEOPTIONS.h"  
1207    
1208        integer i,j,nSx,nSy,bi,bj,maxtyp        integer im,jm,nSx,nSy,bi,bj,maxtyp
1209        integer surftype(im,jm,nSx,nSy)        integer surftype(im,jm,maxtyp,nSx,nSy)
1210        _RL surftype(im,jm,nSx,nSy)        _RL tilefrac(im,jm,maxtyp,nSx,nSy)
1211        _RL frac(im,jm)        _RL frac(im,jm)
1212    
1213        integer  i,j,k        integer  i,j,k
# Line 1171  C*************************************** Line 1221  C***************************************
1221        do k=1,maxtyp        do k=1,maxtyp
1222        do j=1,jm        do j=1,jm
1223        do i=1,im        do i=1,im
1224        if(surftype(i,j,k,bi,bj).lt.100.and.        if( (surftype(i,j,k,bi,bj).lt.100.).and.
1225                                         tilefrac(i,j,k,bi,bj).gt.0.0)then       .                               (tilefrac(i,j,k,bi,bj).gt.0.0))then
1226         frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)         frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)
1227        endif        endif
1228        enddo        enddo
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.21
  ViewVC Help
Powered by ViewVC 1.1.22