/[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.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"  #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,nchp,nSx,nSy,bi,bj,
88       .                                                       alai,agrn )       .                                                       alai,agrn )
89         endif         endif
90    
# 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,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  C               Over land is from tcanopy
# Line 120  C*************************************** Line 119  C***************************************
119          tmpij(i,j) = 0.          tmpij(i,j) = 0.
120         enddo         enddo
121         enddo         enddo
122         do i = 1,nchp         do i = 1,nchpland
123          tmpchp(i) = tcanopy(i,bi,bj)          tmpchp(i) = tcanopy(i,bi,bj)
124         enddo         enddo
125         call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,         call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,
126       .                           nchp,nchp,fracl,tmpij,im2,jm2)       .                           nchp,nchpland,fracl,tmpij,im2,jm2)
127         do j = jm1,jm2         do j = jm1,jm2
128         do i = im1,im2         do i = im1,im2
129          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 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        real AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)        _RL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)
165        _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)        _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)
166        REAL ZTH(IRUN)        _RL ZTH(IRUN)
167        INTEGER ITYP (IRUN)        INTEGER ITYP (IRUN)
168    
169        _RL ALVDRS,  ALIDRS        _RL ALVDRS,  ALIDRS
# Line 222  C                 10:  DARK DESERT Line 220  C                 10:  DARK DESERT
220  C  C
221    
222        INTEGER I, LAI        INTEGER I, LAI
223        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)
224        real COEFF        _RL COEFF
225    
226        real ALVDR (NLAI, 2, NTYPS)        _RL ALVDR (NLAI, 2, NTYPS)
227        real BTVDR (NLAI, 2, NTYPS)        _RL BTVDR (NLAI, 2, NTYPS)
228        real GMVDR (NLAI, 2, NTYPS)        _RL GMVDR (NLAI, 2, NTYPS)
229        real ALIDR (NLAI, 2, NTYPS)        _RL ALIDR (NLAI, 2, NTYPS)
230        real BTIDR (NLAI, 2, NTYPS)        _RL BTIDR (NLAI, 2, NTYPS)
231        real GMIDR (NLAI, 2, NTYPS)        _RL GMIDR (NLAI, 2, NTYPS)
232    
233  C  (Data statements for ALVDR described in full; data statements for  C  (Data statements for ALVDR described in full; data statements for
234  C   other constants follow same framework.)  C   other constants follow same framework.)
# Line 676  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        real coeff        _RL coeff
680        real TABLE (NTABL, 2), DX, DY        _RL TABLE (NTABL, 2), DX, DY
681    
682        COEFF = (TABLE(LAI,  1)        COEFF = (TABLE(LAI,  1)
683       *      + (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 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 702  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 808  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 848  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        real 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)
852        _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)        _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)
# Line 867  C*************************************** Line 862  C***************************************
862        PARAMETER (OCNALB=0.08)        PARAMETER (OCNALB=0.08)
863        PARAMETER (ALBSI=0.7)        PARAMETER (ALBSI=0.7)
864    
865        real alboc(im,jm)        _RL alboc(im,jm)
866        real AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
867        real ANIRDF(nchp)        _RL ANIRDF(nchp)
868        real zenith(nchp)        _RL zenith(nchp)
869        real tmpij(im,jm)        _RL tmpij(im,jm)
870        integer i,j        integer i,j
871    
872        DO I=1,IM        DO I=1,IM
# Line 883  C*************************************** Line 878  C***************************************
878         ALBNF(I,J,bi,bj) = ALBVF(I,J,bi,bj)         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 893  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        DO I=1,IM
894        DO J=1,JM        DO J=1,JM
895         tmpij(i,j) = 0.         tmpij(i,j) = albvr(i,j,bi,bj)
896        ENDDO        ENDDO
897        ENDDO        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,tmpij,im,jm)       .                                     fracg,tmpij,im,jm)
900    
901        DO I=1,IM        DO I=1,IM
902        DO J=1,JM        DO J=1,JM
903         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 905  C finally some transformations back to g
905        ENDDO        ENDDO
906        DO I=1,IM        DO I=1,IM
907        DO J=1,JM        DO J=1,JM
908         tmpij(i,j) = 0.         tmpij(i,j) = albvf(i,j,bi,bj)
909        ENDDO        ENDDO
910        ENDDO        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,
# Line 922  C finally some transformations back to g Line 917  C finally some transformations back to g
917        ENDDO        ENDDO
918        DO I=1,IM        DO I=1,IM
919        DO J=1,JM        DO J=1,JM
920         tmpij(i,j) = 0.         tmpij(i,j) = albnr(i,j,bi,bj)
921        ENDDO        ENDDO
922        ENDDO        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,
# Line 934  C finally some transformations back to g Line 929  C finally some transformations back to g
929        ENDDO        ENDDO
930        DO I=1,IM        DO I=1,IM
931        DO J=1,JM        DO J=1,JM
932         tmpij(i,j) = 0.         tmpij(i,j) = albnf(i,j,bi,bj)
933        ENDDO        ENDDO
934        ENDDO        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,
# Line 948  C finally some transformations back to g Line 943  C finally some transformations back to g
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 979  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
978        integer im,jm,nchp,nSx,nSy,bi,bj        _RL fracg(im,jm)
       real 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)        _RL snowdep(nchp,nSx,nSy)
982        real fraci(nchp)        _RL fraci(nchp)
983        _RL emiss(im,jm,10,nSx,nSy)        _RL emiss(im,jm,10,nSx,nSy)
984    
985        real emisstile(nchp,10)        _RL emisstile(nchp,10)
986        real tmpij(im,jm)        _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 1011  c -------------------------------------- Line 1005  c --------------------------------------
1005         tmpij(i,j) = 0.0         tmpij(i,j) = 0.0
1006        enddo        enddo
1007        enddo        enddo
1008        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,
1009       .      fracg,tmpij,im,jm)       .  nchptot,fracg,tmpij,im,jm)
1010        do j = 1,jm        do j = 1,jm
1011        do i = 1,im        do i = 1,im
1012         emiss(i,j,k,bi,bj) = tmpij(i,j)         emiss(i,j,k,bi,bj) = tmpij(i,j)
# Line 1023  c -------------------------------------- Line 1017  c --------------------------------------
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)        _RL fraci(nchp)
1026        real fraci(numpts)        _RL newemis(nchp,10)
       real newemis(numpts,10)  
1027    
1028        real emis(12,11)        _RL emis(12,11)
1029        real fac        _RL fac
1030        integer i,j        integer i,j
1031    
1032  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
# Line 1211  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 im,jm,nSx,nSy,bi,bj,maxtyp        integer im,jm,nSx,nSy,bi,bj,maxtyp
1209        integer surftype(im,jm,maxtyp,nSx,nSy)        integer surftype(im,jm,maxtyp,nSx,nSy)
1210        _RL tilefrac(im,jm,maxtyp,nSx,nSy)        _RL tilefrac(im,jm,maxtyp,nSx,nSy)
1211        real frac(im,jm)        _RL frac(im,jm)
1212    
1213        integer  i,j,k        integer  i,j,k
1214    
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.21
  ViewVC Help
Powered by ViewVC 1.1.22