/[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.14 by molod, Fri Jul 16 20:08:08 2004 UTC revision 1.22 by molod, Thu Aug 12 15:21:22 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"  #include "GRID.h"
20  #include "fizhi_land_SIZE.h"  #include "fizhi_land_SIZE.h"
# Line 31  c--------------------------------------- Line 31  c---------------------------------------
31    
32        logical alarm        logical alarm
33        external alarm        external alarm
34        real lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)        _RL lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
35        real fraci(sNx,sNy), fracl(sNx,sNy)        _RL fraci(sNx,sNy), fracl(sNx,sNy)
36        real ficetile(nchp)        _RL ficetile(nchp)
37        real radius        _RL radius
38        real tmpij(sNx,sNy)        _RL tmpij(sNx,sNy)
39        real tmpchp(nchp)        _RL tmpchp(nchp)
40        integer i, j, n, bi, bj        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
# Line 68  c--------------------------------------- Line 68  c---------------------------------------
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(sice(i,j,bi,bj).gt.0.) then          if(sice(i,j,bi,bj).gt.0.) then
# Line 83  C*              Get Leaf-Area-Index and Line 84  C*              Get Leaf-Area-Index and
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(bi,bj),
88       .                                                       alai,agrn )       .       nchp,nSx,nSy,bi,bj,alai,agrn )
89         endif         endif
90    
91  C **********************************************************************  C **********************************************************************
# Line 94  C ************************************** Line 95  C **************************************
95         if( alarm('radsw') ) then         if( alarm('radsw') ) then
96          call astro(nymd,nhms,lats,lons,im2*jm2,cosz,radius)          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(bi,bj),nchpland(bi,bj),nSx,nSy,bi,bj,igrd,ityp,
99       .             albvisdr,albvisdf,albnirdr,albnirdf )       .    chfr,chlt,alai,agrn,
100         .    albvisdr,albvisdf,albnirdr,albnirdf )
101         endif         endif
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,nchptot(bi,bj))
109          call getemiss(fracl,im2,jm2,nchp,nSx,nSy,bi,bj,igrd,ityp,chfr,          call getemiss(fracl,im2,jm2,nchp,nchptot(bi,bj),nSx,nSy,bi,bj,
110       .      snodep,ficetile,emiss)       .   igrd,ityp,chfr,snodep,ficetile,emiss)
111         endif         endif
112    
   
113  C*********************************************************************  C*********************************************************************
114  C            Ground Temperature Over Ocean is from SST array,  C            Ground Temperature Over Ocean is from SST array,
115  C               Over land is from tcanopy  C               Over land is from tcanopy
# Line 120  C*************************************** Line 120  C***************************************
120          tmpij(i,j) = 0.          tmpij(i,j) = 0.
121         enddo         enddo
122         enddo         enddo
123         do i = 1,nchp         do i = 1,nchpland(bi,bj)
124          tmpchp(i) = tcanopy(i,bi,bj)          tmpchp(i) = tcanopy(i,bi,bj)
125         enddo         enddo
126         call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,         call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,
127       .                           nchp,nchp,fracl,tmpij,im2,jm2)       .                    nchp,nchpland(bi,bj),fracl,tmpij,im2,jm2)
128         do j = jm1,jm2         do j = jm1,jm2
129         do i = im1,im2         do i = im1,im2
130          tgz(i,j,bi,bj) = tmpij(i,j)          tgz(i,j,bi,bj) = tmpij(i,j)
# Line 160  C     ANIRDF:   near infra-red, diffuse Line 160  C     ANIRDF:   near infra-red, diffuse
160  C*******************************************************************  C*******************************************************************
161    
162        IMPLICIT NONE        IMPLICIT NONE
 #include "CPP_EEOPTIONS.h"  
163    
164        INTEGER IRUN        INTEGER IRUN
165        real AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)        _RL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)
166        _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)        _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)
167        REAL ZTH(IRUN)        _RL ZTH(IRUN)
168        INTEGER ITYP (IRUN)        INTEGER ITYP (IRUN)
169    
170        _RL ALVDRS,  ALIDRS        _RL ALVDRS,  ALIDRS
# Line 222  C                 10:  DARK DESERT Line 221  C                 10:  DARK DESERT
221  C  C
222    
223        INTEGER I, LAI        INTEGER I, LAI
224        real FAC,GAMMA,BETA,ALPHA,DX,DY,ALA,GRN (2),SNWALB(4,NTYPS)        _RL FAC,GAMMA,BETA,ALPHA,DX,DY,ALA,GRN (2),SNWALB(4,NTYPS)
225        real COEFF        _RL COEFF
226    
227        real ALVDR (NLAI, 2, NTYPS)        _RL ALVDR (NLAI, 2, NTYPS)
228        real BTVDR (NLAI, 2, NTYPS)        _RL BTVDR (NLAI, 2, NTYPS)
229        real GMVDR (NLAI, 2, NTYPS)        _RL GMVDR (NLAI, 2, NTYPS)
230        real ALIDR (NLAI, 2, NTYPS)        _RL ALIDR (NLAI, 2, NTYPS)
231        real BTIDR (NLAI, 2, NTYPS)        _RL BTIDR (NLAI, 2, NTYPS)
232        real GMIDR (NLAI, 2, NTYPS)        _RL GMIDR (NLAI, 2, NTYPS)
233    
234  C  (Data statements for ALVDR described in full; data statements for  C  (Data statements for ALVDR described in full; data statements for
235  C   other constants follow same framework.)  C   other constants follow same framework.)
# Line 676  cfpp$ expand (coeff) Line 675  cfpp$ expand (coeff)
675        RETURN        RETURN
676        END        END
677        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)        FUNCTION COEFF(TABLE, NTABL, LAI ,DX, DY)
 #include "CPP_EEOPTIONS.h"  
678                    
679        INTEGER NTABL, LAI        INTEGER NTABL, LAI
680        real coeff        _RL coeff
681        real TABLE (NTABL, 2), DX, DY        _RL TABLE (NTABL, 2), DX, DY
682    
683        COEFF = (TABLE(LAI,  1)        COEFF = (TABLE(LAI,  1)
684       *      + (TABLE(LAI  ,2) - TABLE(LAI  ,1)) * DY ) * (1.0-DX)       *      + (TABLE(LAI  ,2) - TABLE(LAI  ,1)) * DY ) * (1.0-DX)
# Line 690  cfpp$ expand (coeff) Line 688  cfpp$ expand (coeff)
688        RETURN        RETURN
689        END        END
690    
691        SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nSx,nSy,bi,bj,        SUBROUTINE GETLGR(sec,IMON,IDAY,ALAT,ITYP,NCHPS,nchpdim,
692       .                                                      ALAI,AGRN)       .    nSx,nSy,bi,bj,ALAI,AGRN)
693  C*********************************************************************  C*********************************************************************
694        implicit none        implicit none
 #include "CPP_EEOPTIONS.h"  
695    
696        integer ntyps        integer ntyps
697        _RL one,daylen        _RL one,daylen
# Line 702  C*************************************** Line 699  C***************************************
699        parameter (one = 1.)        parameter (one = 1.)
700        parameter (daylen = 86400.)        parameter (daylen = 86400.)
701    
702        integer sec, imon, iday, nchps, nSx, nSy, bi, bj        integer sec, imon, iday, nchps, nchpdim, nSx, nSy, bi, bj
703        _RL ALAI(NCHPS,nSx,nSy), AGRN(NCHPS,nSx,nSy)        _RL ALAI(nchpdim,nSx,nSy), AGRN(nchpdim,nSx,nSy)
704        _RL ALAT(NCHPS)        _RL ALAT(nchpdim)
705        integer ITYP(NCHPS,nSx,nSy)        integer ITYP(nchpdim,nSx,nSy)
706    
707        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2        integer i,midmon,midm,midp,id,k1,k2,kk1,kk2
708        _RL fac        _RL fac
# Line 808  C*************************************** Line 805  C***************************************
805        END        END
806    
807        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,im,jm,        subroutine getalb(sec,month,day,cosz,snodep,fraci,fracg,im,jm,
808       .                  nchp,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,       .        nchp,nchptot,nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,
809       .                  alai,agrn,albvr,albvf,albnr,albnf)       .        alai,agrn,albvr,albvf,albnr,albnf)
810  C***********************************************************************  C***********************************************************************
811  C  PURPOSE  C  PURPOSE
812  C     To act as an interface to routine sibalb, which calculates  C     To act as an interface to routine sibalb, which calculates
# Line 848  C albnf    - real array [im,jm] of near- Line 845  C albnf    - real array [im,jm] of near-
845  C  C
846  C***********************************************************************  C***********************************************************************
847        implicit none        implicit none
 #include "CPP_EEOPTIONS.h"  
848    
849        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
850        real cosz(im,jm),fraci(im,jm),fracg(im,jm)        _RL cosz(im,jm),fraci(im,jm),fracg(im,jm)
851        _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)
852        integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)        integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)
853        _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)        _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)
# Line 867  C*************************************** Line 863  C***************************************
863        PARAMETER (OCNALB=0.08)        PARAMETER (OCNALB=0.08)
864        PARAMETER (ALBSI=0.7)        PARAMETER (ALBSI=0.7)
865    
866        real alboc(im,jm)        _RL alboc(im,jm)
867        real AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
868        real ANIRDF(nchp)        _RL ANIRDF(nchp)
869        real zenith(nchp)        _RL zenith(nchp)
870        real tmpij(im,jm)        _RL tmpij(im,jm)
871        integer i,j        integer i,j
872    
873        DO I=1,IM        DO I=1,IM
# Line 883  C*************************************** Line 879  C***************************************
879         ALBNF(I,J,bi,bj) = ALBVF(I,J,bi,bj)         ALBNF(I,J,bi,bj) = ALBVF(I,J,bi,bj)
880        ENDDO        ENDDO
881        ENDDO        ENDDO
   
882    
883  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
884    
# Line 893  C and now call sibalb Line 888  C and now call sibalb
888    
889        call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),        call sibalb(avisdr,anirdr,avisdf,anirdf,alai(1,bi,bj),
890       .  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)
891    
892  C finally some transformations back to grid space for albedos  C finally some transformations back to grid space for albedos
893    
894        DO I=1,IM        DO I=1,IM
895        DO J=1,JM        DO J=1,JM
896         tmpij(i,j) = 0.         tmpij(i,j) = albvr(i,j,bi,bj)
897        ENDDO        ENDDO
898        ENDDO        ENDDO
899        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,
900       .                                     fracg,tmpij,im,jm)       .                                     fracg,tmpij,im,jm)
901    
902        DO I=1,IM        DO I=1,IM
903        DO J=1,JM        DO J=1,JM
904         albvr(i,j,bi,bj) = tmpij(i,j)         albvr(i,j,bi,bj) = tmpij(i,j)
# Line 910  C finally some transformations back to g Line 906  C finally some transformations back to g
906        ENDDO        ENDDO
907        DO I=1,IM        DO I=1,IM
908        DO J=1,JM        DO J=1,JM
909         tmpij(i,j) = 0.         tmpij(i,j) = albvf(i,j,bi,bj)
910        ENDDO        ENDDO
911        ENDDO        ENDDO
912        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,
# Line 922  C finally some transformations back to g Line 918  C finally some transformations back to g
918        ENDDO        ENDDO
919        DO I=1,IM        DO I=1,IM
920        DO J=1,JM        DO J=1,JM
921         tmpij(i,j) = 0.         tmpij(i,j) = albnr(i,j,bi,bj)
922        ENDDO        ENDDO
923        ENDDO        ENDDO
924        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,
# Line 934  C finally some transformations back to g Line 930  C finally some transformations back to g
930        ENDDO        ENDDO
931        DO I=1,IM        DO I=1,IM
932        DO J=1,JM        DO J=1,JM
933         tmpij(i,j) = 0.         tmpij(i,j) = albnf(i,j,bi,bj)
934        ENDDO        ENDDO
935        ENDDO        ENDDO
936        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,
# Line 948  C finally some transformations back to g Line 944  C finally some transformations back to g
944        return        return
945        end        end
946    
947        subroutine getemiss(fracg,im,jm,nchp,nSx,nSy,bi,bj,igrd,ityp,        subroutine getemiss(fracg,im,jm,nchp,nchptot,nSx,nSy,bi,bj,
948       .                                         chfr,snowdep,fraci,emiss)       .   igrd,ityp,chfr,snowdep,fraci,emiss)
949  C***********************************************************************  C***********************************************************************
950  C  PURPOSE  C  PURPOSE
951  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 979  C emiss    - real array [im,jm,10,nSx,nS Line 975  C emiss    - real array [im,jm,10,nSx,nS
975  C  C
976  C***********************************************************************  C***********************************************************************
977        implicit none        implicit none
978  #include "CPP_EEOPTIONS.h"        integer im,jm,nchp,nchptot,nSx,nSy,bi,bj
979        integer im,jm,nchp,nSx,nSy,bi,bj        _RL fracg(im,jm)
       real fracg(im,jm)  
980        _RL chfr(nchp,nSx,nSy)        _RL chfr(nchp,nSx,nSy)
981        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)
982        _RL snowdep(nchp,nSx,nSy)        _RL snowdep(nchp,nSx,nSy)
983        real fraci(nchp)        _RL fraci(nchp)
984        _RL emiss(im,jm,10,nSx,nSy)        _RL emiss(im,jm,10,nSx,nSy)
985    
986        real emisstile(nchp,10)        _RL emisstile(nchp,10)
987        real tmpij(im,jm)        _RL tmpij(im,jm)
988        integer i,j,k,n        integer i,j,k,n
989    
990        do i = 1,10        do i = 1,10
991        do n = 1,nchp        do n = 1,nchptot
992           emisstile(n,i) = 1.           emisstile(n,i) = 1.
993        enddo        enddo
994        enddo        enddo
995    
996  c call emissivity to get values in tile space  c call emissivity to get values in tile space
997  c -------------------------------------------  c -------------------------------------------
998        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),
999       .                                                    emisstile)       .                                                    emisstile)
1000    
1001  c transform back to grid space for emissivities  c transform back to grid space for emissivities
# Line 1011  c -------------------------------------- Line 1006  c --------------------------------------
1006         tmpij(i,j) = 0.0         tmpij(i,j) = 0.0
1007        enddo        enddo
1008        enddo        enddo
1009        call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),emisstile(1,k),nchp,nchp,        call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),emisstile(1,k),nchp,
1010       .      fracg,tmpij,im,jm)       .  nchptot,fracg,tmpij,im,jm)
1011        do j = 1,jm        do j = 1,jm
1012        do i = 1,im        do i = 1,im
1013         emiss(i,j,k,bi,bj) = tmpij(i,j)         emiss(i,j,k,bi,bj) = tmpij(i,j)
# Line 1023  c -------------------------------------- Line 1018  c --------------------------------------
1018        return        return
1019        end        end
1020    
1021        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)        subroutine emissivity (snowdepth,fraci,nchp,numpts,ityp,newemis)
1022        implicit none        implicit none
1023  #include "CPP_EEOPTIONS.h"        integer nchp,numpts
1024        integer numpts        integer   ityp(nchp)
1025        integer   ityp(numpts)        _RL snowdepth(nchp)
1026        _RL snowdepth(numpts)        _RL fraci(nchp)
1027        real fraci(numpts)        _RL newemis(nchp,10)
       real newemis(numpts,10)  
1028    
1029        real emis(12,11)        _RL emis(12,11)
1030        real fac        _RL fac
1031        integer i,j        integer i,j
1032    
1033  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
# Line 1211  C     To compute the total fraction of l Line 1205  C     To compute the total fraction of l
1205  C  C
1206  C***********************************************************************  C***********************************************************************
1207        implicit none        implicit none
 #include "CPP_EEOPTIONS.h"  
1208    
1209        integer im,jm,nSx,nSy,bi,bj,maxtyp        integer im,jm,nSx,nSy,bi,bj,maxtyp
1210        integer surftype(im,jm,maxtyp,nSx,nSy)        integer surftype(im,jm,maxtyp,nSx,nSy)
1211        _RL tilefrac(im,jm,maxtyp,nSx,nSy)        _RL tilefrac(im,jm,maxtyp,nSx,nSy)
1212        real frac(im,jm)        _RL frac(im,jm)
1213    
1214        integer  i,j,k        integer  i,j,k
1215    
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.22
  ViewVC Help
Powered by ViewVC 1.1.22