/[MITgcm]/MITgcm/pkg/fizhi/update_earth_exports.F
ViewVC logotype

Diff of /MITgcm/pkg/fizhi/update_earth_exports.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.6 by molod, Wed Jun 9 20:33:37 2004 UTC revision 1.7 by molod, Thu Jun 10 20:17:17 2004 UTC
# Line 27  c--------------------------------------- Line 27  c---------------------------------------
27    
28        integer myTime, myIter, myThid        integer myTime, myIter, myThid
29    
30        real lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)        _RL lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
31        real fraci(sNx,sNy), fracl(sNx,sNy)        _RL fraci(sNx,sNy), fracl(sNx,sNy)
32        real ficetile(nchp)        _RL ficetile(nchp)
33        real ra        _RL 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        integer sec, day, month
# Line 76  C*              Get Leaf-Area-Index and Line 76  C*              Get Leaf-Area-Index and
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,chlt,ityp,nchpland,bi,bj,alai,agrn )        call getlgr (sec,month,day,chlt,ityp,nchpland,nSx,nSy,bi,bj,
80         .                                                       alai,agrn )
81        endif        endif
82    
83  C **********************************************************************  C **********************************************************************
# Line 140  C     ANIRDF:   near infra-red, diffuse Line 141  C     ANIRDF:   near infra-red, diffuse
141  C*******************************************************************  C*******************************************************************
142    
143        IMPLICIT NONE        IMPLICIT NONE
144    #include "CPP_OPTIONS.h"
145    
146        INTEGER IRUN        INTEGER IRUN
147        REAL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN),        _RL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN),
148       `       VLAI   (IRUN),   VGRN (IRUN),   ZTH  (IRUN),    SNW (IRUN)       `       VLAI   (IRUN),   VGRN (IRUN),   ZTH  (IRUN),    SNW (IRUN)
149        INTEGER ITYP (IRUN)        INTEGER ITYP (IRUN)
150    
151        REAL ALVDRS,  ALIDRS        _RL ALVDRS,  ALIDRS
152        REAL ALVDRDL, ALIDRDL        _RL ALVDRDL, ALIDRDL
153        REAL ALVDRDD, ALIDRDD        _RL ALVDRDD, ALIDRDD
154        REAL ALVDRI,  ALIDRI        _RL ALVDRI,  ALIDRI
155        REAL minval        _RL minval
156        external     minval        external     minval
157    
158        PARAMETER (  ALVDRS  = 0.100 )  ! Albedo of soil         for visible   direct solar radiation.        PARAMETER (  ALVDRS  = 0.100 )  ! Albedo of soil         for visible   direct solar radiation.
# Line 166  C*************************************** Line 168  C***************************************
168    
169        INTEGER NTYPS        INTEGER NTYPS
170        INTEGER NLAI        INTEGER NLAI
171        REAL ZERO, ONE        _RL ZERO, ONE
172        REAL EPSLN, BLAI, DLAI        _RL EPSLN, BLAI, DLAI
173        REAL ALATRM        _RL ALATRM
174        PARAMETER (NLAI = 14 )        PARAMETER (NLAI = 14 )
175        PARAMETER (EPSLN = 1.E-6)        PARAMETER (EPSLN = 1.E-6)
176        PARAMETER (BLAI = 0.5)        PARAMETER (BLAI = 0.5)
# Line 196  C Line 198  C
198  *  *
199          INTEGER I, LAI          INTEGER I, LAI
200    
201          REAL FAC,               GAMMA,          BETA,          ALPHA,          _RL FAC,               GAMMA,          BETA,          ALPHA,
202       `       DX,                DY,             ALA,           GRN (2),       `       DX,                DY,             ALA,           GRN (2),
203       `       SNWALB (4, NTYPS), SNWMID (NTYPS)       `       SNWALB (4, NTYPS), SNWMID (NTYPS)
204    
205  * [ Definition of Functions: ]  * [ Definition of Functions: ]
206  *  *
207          REAL COEFF          _RL COEFF
208    
209  C   Constants used in albedo calculations:  C   Constants used in albedo calculations:
210    
211        REAL ALVDR (NLAI, 2, NTYPS)        _RL ALVDR (NLAI, 2, NTYPS)
212        REAL BTVDR (NLAI, 2, NTYPS)        _RL BTVDR (NLAI, 2, NTYPS)
213        REAL GMVDR (NLAI, 2, NTYPS)        _RL GMVDR (NLAI, 2, NTYPS)
214        REAL ALIDR (NLAI, 2, NTYPS)        _RL ALIDR (NLAI, 2, NTYPS)
215        REAL BTIDR (NLAI, 2, NTYPS)        _RL BTIDR (NLAI, 2, NTYPS)
216        REAL GMIDR (NLAI, 2, NTYPS)        _RL GMIDR (NLAI, 2, NTYPS)
217    
218  C  (Data statements for ALVDR described in full; data statements for  C  (Data statements for ALVDR described in full; data statements for
219  C   other constants follow same framework.)  C   other constants follow same framework.)
# Line 660  cfpp$ expand (coeff) Line 662  cfpp$ expand (coeff)
662        RETURN        RETURN
663        END        END
664        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)
665    #include "CPP_OPTIONS.h"
666                    
667        INTEGER NTABL, LAI        INTEGER NTABL, LAI
668    
669        REAL TABLE (NTABL, 2), DX, DY        _RL TABLE (NTABL, 2), DX, DY
670    
671        COEFF = (TABLE(LAI,  1)        COEFF = (TABLE(LAI,  1)
672       *      + (TABLE(LAI  ,2) - TABLE(LAI  ,1)) * DY ) * (1.0-DX)       *      + (TABLE(LAI  ,2) - TABLE(LAI  ,1)) * DY ) * (1.0-DX)
# Line 672  cfpp$ expand (coeff) Line 675  cfpp$ expand (coeff)
675    
676        RETURN        RETURN
677        END        END
       SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,ALAI,AGRN)  
678    
679  C*********************************************************************        SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nSx,nSy,bi,bj,
680  C*********************** ARIES   MODEL *******************************       .                                                      ALAI,AGRN)
 C********************* SUBROUTINE GETLGR  ****************************  
 C**********************  14 JUNE 1991   ******************************  
681  C*********************************************************************  C*********************************************************************
682        implicit none        implicit none
683    #include "CPP_OPTIONS"
684    
685        integer ntyps        integer ntyps
686        real one,daylen        _RL one,daylen
687        PARAMETER (NTYPS=10)        PARAMETER (NTYPS=10)
688        parameter (one = 1.)        parameter (one = 1.)
689        parameter (daylen = 86400.)        parameter (daylen = 86400.)
690    
691        integer sec, imon, iday, nchps        integer sec, imon, iday, nchps, nSx, nSy, bi, bj
692        real ALAI(NCHPS), AGRN(NCHPS), ALAT(NCHPS)        _RL ALAI(NCHPS,nSx,nSy), AGRN(NCHPS,nSx,nSy)
693        integer ITYP(NCHPS)        _RL ALAT(NCHPS)
694          integer ITYP(NCHPS,nSx,nSy)
695    
696        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2
697        real fac        _RL fac
698    
699        INTEGER     DAYS(12)        INTEGER     DAYS(12)
700        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/
701    
702          _RL VGLA(12,NTYPS), VGGR(12,NTYPS)
       REAL VGLA(12,NTYPS), VGGR(12,NTYPS)  
703    
704        DATA VGLA  /        DATA VGLA  /
705       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 782  C*************************************** Line 783  C***************************************
783         KK2 = MOD(K2+5,12) + 1         KK2 = MOD(K2+5,12) + 1
784        ENDIF        ENDIF
785    
786        ALAI(I) = VGLA(KK2,ITYP(I))*FAC + VGLA(KK1,ITYP(I))*(ONE-FAC)        ALAI(I,bi,bj) = VGLA(KK2,ITYP(I,bi,bj))*FAC+
787        AGRN(I) = VGGR(KK2,ITYP(I))*FAC + VGGR(KK1,ITYP(I))*(ONE-FAC)       .                                 VGLA(KK1,ITYP(I,bi,bj))*(ONE-FAC)
788          AGRN(I,bi,bj) = VGGR(KK2,ITYP(I,bi,bj))*FAC+
789         .                                 VGGR(KK1,ITYP(I,bi,bj))*(ONE-FAC)
790    
791    220 CONTINUE    220 CONTINUE
792    
793        RETURN        RETURN
794        END        END
795    
796        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,im,jm,
797       1              im,jm,nchp,nchpland,igrd,ityp,chfr,chlt,       .                  nchp,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,
798       2              alai,agrn,albvr,albvf,albnr,albnf)       .                  alai,agrn,albvr,albvf,albnr,albnf)
799  C***********************************************************************  C***********************************************************************
800  C  PURPOSE  C  PURPOSE
801  C     To act as an interface to routine sibalb, which calculates  C     To act as an interface to routine sibalb, which calculates
# Line 803  C sec      - number of seconds into the Line 806  C sec      - number of seconds into the
806  C month    - month of the year of current time  C month    - month of the year of current time
807  C day      - day of the month of current time  C day      - day of the month of current time
808  C cosz     - local cosine of the zenith angle [im,jm]  C cosz     - local cosine of the zenith angle [im,jm]
809  C snodep   - snow cover in meters [nchp]  C snodep   - snow cover in meters [nchp,nSx,nSy]
810  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]
811  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]
812  C im       - model grid longitude dimension  C im       - model grid longitude dimension
813  C jm       - model grid latitude dimension (number of lat. points)  C jm       - model grid latitude dimension (number of lat. points)
814  C nchp     - integer actual number of tiles in tile space  C nchp     - integer actual number of tiles in tile space
815  C nchpland - integer number of land tiles  C nchpland - integer number of land tiles
816    C nSx      - number of processors in x-direction
817    C nSy      - number of processors in y-direction
818    C bi       - processors index in x-direction
819    C bj       - processors index in y-direction
820  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
821  C            tile [nchp]  C            tile [nchp,nSx,nSy]
822  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
823  C            tile [nchp]  C            tile [nchp,nSx,nSy]
824  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
825  C            each tile [nchp]  C            each tile [nchp,nSx,nSy]
826  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
827  C            [nchp]  C            [nchp,nSx,nSy]
828  C  C
829  C OUTPUT:  C OUTPUT:
830  C albvr    - real array [im,jm] of visible direct beam albedo  C albvr    - real array [im,jm] of visible direct beam albedo
# Line 827  C albnf    - real array [im,jm] of near- Line 834  C albnf    - real array [im,jm] of near-
834  C  C
835  C***********************************************************************  C***********************************************************************
836        implicit none        implicit none
837        real one,a0,a1,a2,a3,ocnalb,albsi  #include "CPP_OPTIONS.h"
838    
839          integer sec,month,day,im,jm,nchp,nchpland,nSx,nSy,bi,bj
840          _RL cosz(im,jm),fraci(im,jm),fracg(im,jm)
841          _RL snodep(nchp,nSx,nSy),chfr(nchp,nSx,nSy),chlt(nchp,nSx,nSy)
842          integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)
843          _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)
844          _RL albvr(im,jm,nSx,nSy),albvf(im,jm,nSx,nSy)
845          _RL albnr(im,jm,nSx,nSy),albnf(im,jm,nSx,nSy)
846    
847          _RL one,a0,a1,a2,a3,ocnalb,albsi
848        PARAMETER (one = 1.)        PARAMETER (one = 1.)
849        PARAMETER (A0= 0.40670980)        PARAMETER (A0= 0.40670980)
850        PARAMETER (A1=-1.2523634 )        PARAMETER (A1=-1.2523634 )
851        PARAMETER (A2= 1.4224051 )        PARAMETER (A2= 1.4224051 )
852        PARAMETER (A3=-0.55573341)        PARAMETER (A3=-0.55573341)
853        PARAMETER (OCNALB=0.08)        PARAMETER (OCNALB=0.08)
854  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  
855    
856        integer sec,month,day,im,jm,nchp,nchpland        _RL alboc(im,jm)
857        real cosz(im,jm),fraci(im,jm),fracg(im,jm)        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
858        real snodep(nchp),chfr(nchp),chlt(nchp)        _RL ANIRDF(nchp),zenith(nchp)
       integer igrd(nchp),ityp(nchp)  
       real albvr(im,jm),albvf(im,jm),albnr(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)  
859        integer i,j        integer i,j
860    
861        DO I=1,IM        DO I=1,IM
# Line 867  C and now some conversions from grid spa Line 875  C and now some conversions from grid spa
875    
876  C and now call sibalb  C and now call sibalb
877    
878        call sibalb(avisdr,anirdr,avisdf,anirdf,alai,agrn,zenith,        call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),
879       1     snodep,ityp,nchpland)       .  agrn(1,bi,bj),zenith,snodep(1,bi,bj),ityp(1,bi,bj),nchpland)
880    
881  C finally some transformations back to grid space for albedos  C finally some transformations back to grid space for albedos
882    
883        call msc2grd(igrd,chfr,avisdr,nchp,nchpland,fracg,albvr,im,jm)        call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdr,nchp,nchpland,
884        call msc2grd(igrd,chfr,avisdf,nchp,nchpland,fracg,albvf,im,jm)       .                                      fracg,albvr(1,bi,bj),im,jm)
885        call msc2grd(igrd,chfr,anirdr,nchp,nchpland,fracg,albnr,im,jm)        call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),avisdf,nchp,nchpland,
886        call msc2grd(igrd,chfr,anirdf,nchp,nchpland,fracg,albnf,im,jm)       .                                      fracg,albvf(1,bi,bj),im,jm)
887          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdr,nchp,nchpland,
888         .                                      fracg,albnr(1,bi,bj),im,jm)
889          call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),anirdf,nchp,nchpland,
890         .                                      fracg,albnf(1,bi,bj),im,jm)
891    
892        return        return
893        end        end
894    
895        subroutine getemiss (fracg,im,jm,nchp,igrd,ityp,chfr,snowdep,fraci,emiss)        subroutine getemiss(fracg,im,jm,nchp,igrd,ityp,chfr,snowdep,fraci,
896         .                                                            emiss)
897  C***********************************************************************  C***********************************************************************
898  C  PURPOSE  C  PURPOSE
899  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 906  C emiss    - real array [im,jm,10] of su Line 919  C emiss    - real array [im,jm,10] of su
919  C  C
920  C***********************************************************************  C***********************************************************************
921        implicit none        implicit none
922    #include "CPP_OPTIONS.h"
923        integer im,jm,nchp        integer im,jm,nchp
924        real fracg(im,jm)        _RL fracg(im,jm)
925        real chfr(nchp)        _RL chfr(nchp)
926        integer igrd(nchp), ityp(nchp)        integer igrd(nchp), ityp(nchp)
927        real snowdep(nchp),fraci(nchp)        _RL snowdep(nchp),fraci(nchp)
928        real emiss(im,jm,10)        _RL emiss(im,jm,10)
929    
930        real emisstile(nchp,10)        _RL emisstile(nchp,10)
931        integer i,n        integer i,n
932    
933        do i = 1,10        do i = 1,10
# Line 938  c -------------------------------------- Line 952  c --------------------------------------
952    
953        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)
954        implicit none        implicit none
955    #include "CPP_OPTIONS.h"
956        integer numpts        integer numpts
957        integer   ityp(numpts)        integer   ityp(numpts)
958        real snowdepth(numpts),fraci(numpts)        _RL snowdepth(numpts),fraci(numpts)
959        real   newemis(numpts,10)        _RL   newemis(numpts,10)
960    
961        real emis(12,11)        _RL emis(12,11)
962        real snwmid(10)        _RL snwmid(10)
963        real fac        _RL fac
964        integer i,j        integer i,j
965    
966  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
# Line 1107  C*************************************** Line 1122  C***************************************
1122        integer i,j,nSx,nSy,bi,bj,maxtyp        integer i,j,nSx,nSy,bi,bj,maxtyp
1123        integer surftype(im,jm,nSx,nSy)        integer surftype(im,jm,nSx,nSy)
1124        _RL surftype(im,jm,nSx,nSy)        _RL surftype(im,jm,nSx,nSy)
1125        real frac(im,jm)        _RL frac(im,jm)
1126    
1127        integer  i,j,k        integer  i,j,k
1128    
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7
  ViewVC Help
Powered by ViewVC 1.1.22