/[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.23 by molod, Fri Oct 22 14:52:14 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 27  c--------------------------------------- Line 27  c---------------------------------------
27  #include "fizhi_ocean_coms.h"  #include "fizhi_ocean_coms.h"
28  #include "EEPARAMS.h"  #include "EEPARAMS.h"
29    
30        integer myTime, myIter, myThid        integer myIter, myThid
31          _RL myTime
32    
33        logical alarm        logical alarm
34        external alarm        external alarm
35        real lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)        _RL lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
36        real fraci(sNx,sNy), fracl(sNx,sNy)        _RL fraci(sNx,sNy), fracl(sNx,sNy)
37        real ficetile(nchp)        _RL ficetile(nchp)
38        real radius        _RL radius
39        real tmpij(sNx,sNy)        _RL tmpij(sNx,sNy)
40        real tmpchp(nchp)        _RL tmpchp(nchp)
41        integer i, j, n, bi, bj        integer i, j, n, bi, bj
42        integer im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2        integer im1, im2, jm1, jm2, idim1, idim2, jdim1, jdim2
43        integer sec, day, month        integer sec, day, month
# Line 68  c--------------------------------------- Line 69  c---------------------------------------
69    
70         call get_landfrac(im2,jm2,nSx,nSy,bi,bj,maxtyp,surftype,tilefrac,         call get_landfrac(im2,jm2,nSx,nSy,bi,bj,maxtyp,surftype,tilefrac,
71       .                                                            fracl)       .                                                            fracl)
72    
73         do j = jm1,jm2         do j = jm1,jm2
74         do i = im1,im2         do i = im1,im2
75          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 85  C*              Get Leaf-Area-Index and
85  C***********************************************************************  C***********************************************************************
86    
87         if( alarm('turb') .or. alarm('radsw') ) then         if( alarm('turb') .or. alarm('radsw') ) then
88         call getlgr (sec,month,day,chlt,ityp,nchpland,nSx,nSy,bi,bj,         call getlgr (sec,month,day,chlt,ityp,nchpland(bi,bj),
89       .                                                       alai,agrn )       .       nchp,nSx,nSy,bi,bj,alai,agrn )
90         endif         endif
91    
92  C **********************************************************************  C **********************************************************************
# Line 94  C ************************************** Line 96  C **************************************
96         if( alarm('radsw') ) then         if( alarm('radsw') ) then
97          call astro(nymd,nhms,lats,lons,im2*jm2,cosz,radius)          call astro(nymd,nhms,lats,lons,im2*jm2,cosz,radius)
98          call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,          call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,
99       .             nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,alai,agrn,       .    nchptot(bi,bj),nchpland(bi,bj),nSx,nSy,bi,bj,igrd,ityp,
100       .             albvisdr,albvisdf,albnirdr,albnirdf )       .    chfr,chlt,alai,agrn,
101         .    albvisdr,albvisdf,albnirdr,albnirdf )
102         endif         endif
103    
   
104  C **********************************************************************  C **********************************************************************
105  C                      Compute Surface Emissivity  C                      Compute Surface Emissivity
106  C **********************************************************************  C **********************************************************************
107    
108         if( alarm('radlw') ) then         if( alarm('radlw') ) then
109          call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchp)          call grd2msc(fraci,im2,jm2,igrd,ficetile,nchp,nchptot(bi,bj))
110          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,
111       .      snodep,ficetile,emiss)       .   igrd,ityp,chfr,snodep,ficetile,emiss)
112         endif         endif
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  C               Over land is from tcanopy
# Line 120  C*************************************** Line 121  C***************************************
121          tmpij(i,j) = 0.          tmpij(i,j) = 0.
122         enddo         enddo
123         enddo         enddo
124         do i = 1,nchp         do i = 1,nchpland(bi,bj)
125          tmpchp(i) = tcanopy(i,bi,bj)          tmpchp(i) = tcanopy(i,bi,bj)
126         enddo         enddo
127         call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,         call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,
128       .                           nchp,nchp,fracl,tmpij,im2,jm2)       .                    nchp,nchpland(bi,bj),fracl,tmpij,im2,jm2)
129         do j = jm1,jm2         do j = jm1,jm2
130         do i = im1,im2         do i = im1,im2
131          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 161  C     ANIRDF:   near infra-red, diffuse
161  C*******************************************************************  C*******************************************************************
162    
163        IMPLICIT NONE        IMPLICIT NONE
 #include "CPP_EEOPTIONS.h"  
164    
165        INTEGER IRUN        INTEGER IRUN
166        real AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)        _RL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)
167        _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)        _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)
168        REAL ZTH(IRUN)        _RL ZTH(IRUN)
169        INTEGER ITYP (IRUN)        INTEGER ITYP (IRUN)
170    
171        _RL ALVDRS,  ALIDRS        _RL ALVDRS,  ALIDRS
# Line 222  C                 10:  DARK DESERT Line 222  C                 10:  DARK DESERT
222  C  C
223    
224        INTEGER I, LAI        INTEGER I, LAI
225        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)
226        real COEFF        _RL COEFF
227    
228        real ALVDR (NLAI, 2, NTYPS)        _RL ALVDR (NLAI, 2, NTYPS)
229        real BTVDR (NLAI, 2, NTYPS)        _RL BTVDR (NLAI, 2, NTYPS)
230        real GMVDR (NLAI, 2, NTYPS)        _RL GMVDR (NLAI, 2, NTYPS)
231        real ALIDR (NLAI, 2, NTYPS)        _RL ALIDR (NLAI, 2, NTYPS)
232        real BTIDR (NLAI, 2, NTYPS)        _RL BTIDR (NLAI, 2, NTYPS)
233        real GMIDR (NLAI, 2, NTYPS)        _RL GMIDR (NLAI, 2, NTYPS)
234    
235  C  (Data statements for ALVDR described in full; data statements for  C  (Data statements for ALVDR described in full; data statements for
236  C   other constants follow same framework.)  C   other constants follow same framework.)
# Line 676  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_EEOPTIONS.h"  
679                    
680        INTEGER NTABL, LAI        INTEGER NTABL, LAI
681        real coeff        _RL coeff
682        real TABLE (NTABL, 2), DX, DY        _RL TABLE (NTABL, 2), DX, DY
683    
684        COEFF = (TABLE(LAI,  1)        COEFF = (TABLE(LAI,  1)
685       *      + (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 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_EEOPTIONS.h"  
696    
697        integer ntyps        integer ntyps
698        _RL one,daylen        _RL one,daylen
# Line 702  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 808  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 848  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_EEOPTIONS.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        real 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)
854        _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)        _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)
# Line 867  C*************************************** Line 864  C***************************************
864        PARAMETER (OCNALB=0.08)        PARAMETER (OCNALB=0.08)
865        PARAMETER (ALBSI=0.7)        PARAMETER (ALBSI=0.7)
866    
867        real alboc(im,jm)        _RL alboc(im,jm)
868        real AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
869        real ANIRDF(nchp)        _RL ANIRDF(nchp)
870        real zenith(nchp)        _RL zenith(nchp)
871        real tmpij(im,jm)        _RL tmpij(im,jm)
872        integer i,j        integer i,j
873    
874        DO I=1,IM        DO I=1,IM
# Line 883  C*************************************** Line 880  C***************************************
880         ALBNF(I,J,bi,bj) = ALBVF(I,J,bi,bj)         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 893  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        DO I=1,IM        DO I=1,IM
896        DO J=1,JM        DO J=1,JM
897         tmpij(i,j) = 0.         tmpij(i,j) = albvr(i,j,bi,bj)
898        ENDDO        ENDDO
899        ENDDO        ENDDO
900        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,
901       .                                     fracg,tmpij,im,jm)       .                                     fracg,tmpij,im,jm)
902    
903        DO I=1,IM        DO I=1,IM
904        DO J=1,JM        DO J=1,JM
905         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 907  C finally some transformations back to g
907        ENDDO        ENDDO
908        DO I=1,IM        DO I=1,IM
909        DO J=1,JM        DO J=1,JM
910         tmpij(i,j) = 0.         tmpij(i,j) = albvf(i,j,bi,bj)
911        ENDDO        ENDDO
912        ENDDO        ENDDO
913        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 919  C finally some transformations back to g
919        ENDDO        ENDDO
920        DO I=1,IM        DO I=1,IM
921        DO J=1,JM        DO J=1,JM
922         tmpij(i,j) = 0.         tmpij(i,j) = albnr(i,j,bi,bj)
923        ENDDO        ENDDO
924        ENDDO        ENDDO
925        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 931  C finally some transformations back to g
931        ENDDO        ENDDO
932        DO I=1,IM        DO I=1,IM
933        DO J=1,JM        DO J=1,JM
934         tmpij(i,j) = 0.         tmpij(i,j) = albnf(i,j,bi,bj)
935        ENDDO        ENDDO
936        ENDDO        ENDDO
937        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 945  C finally some transformations back to g
945        return        return
946        end        end
947    
948        subroutine getemiss(fracg,im,jm,nchp,nSx,nSy,bi,bj,igrd,ityp,        subroutine getemiss(fracg,im,jm,nchp,nchptot,nSx,nSy,bi,bj,
949       .                                         chfr,snowdep,fraci,emiss)       .   igrd,ityp,chfr,snowdep,fraci,emiss)
950  C***********************************************************************  C***********************************************************************
951  C  PURPOSE  C  PURPOSE
952  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 976  C emiss    - real array [im,jm,10,nSx,nS
976  C  C
977  C***********************************************************************  C***********************************************************************
978        implicit none        implicit none
979  #include "CPP_EEOPTIONS.h"        integer im,jm,nchp,nchptot,nSx,nSy,bi,bj
980        integer im,jm,nchp,nSx,nSy,bi,bj        _RL fracg(im,jm)
       real fracg(im,jm)  
981        _RL chfr(nchp,nSx,nSy)        _RL chfr(nchp,nSx,nSy)
982        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)
983        _RL snowdep(nchp,nSx,nSy)        _RL snowdep(nchp,nSx,nSy)
984        real fraci(nchp)        _RL fraci(nchp)
985        _RL emiss(im,jm,10,nSx,nSy)        _RL emiss(im,jm,10,nSx,nSy)
986    
987        real emisstile(nchp,10)        _RL emisstile(nchp,10)
988        real tmpij(im,jm)        _RL tmpij(im,jm)
989        integer i,j,k,n        integer i,j,k,n
990    
991        do i = 1,10        do i = 1,10
992        do n = 1,nchp        do n = 1,nchptot
993           emisstile(n,i) = 1.           emisstile(n,i) = 1.
994        enddo        enddo
995        enddo        enddo
996    
997  c call emissivity to get values in tile space  c call emissivity to get values in tile space
998  c -------------------------------------------  c -------------------------------------------
999        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),
1000       .                                                    emisstile)       .                                                    emisstile)
1001    
1002  c transform back to grid space for emissivities  c transform back to grid space for emissivities
# Line 1011  c -------------------------------------- Line 1007  c --------------------------------------
1007         tmpij(i,j) = 0.0         tmpij(i,j) = 0.0
1008        enddo        enddo
1009        enddo        enddo
1010        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,
1011       .      fracg,tmpij,im,jm)       .  nchptot,fracg,tmpij,im,jm)
1012        do j = 1,jm        do j = 1,jm
1013        do i = 1,im        do i = 1,im
1014         emiss(i,j,k,bi,bj) = tmpij(i,j)         emiss(i,j,k,bi,bj) = tmpij(i,j)
# Line 1023  c -------------------------------------- Line 1019  c --------------------------------------
1019        return        return
1020        end        end
1021    
1022        subroutine emissivity (snowdepth,fraci,numpts,ityp,newemis)        subroutine emissivity (snowdepth,fraci,nchp,numpts,ityp,newemis)
1023        implicit none        implicit none
1024  #include "CPP_EEOPTIONS.h"        integer nchp,numpts
1025        integer numpts        integer   ityp(nchp)
1026        integer   ityp(numpts)        _RL snowdepth(nchp)
1027        _RL snowdepth(numpts)        _RL fraci(nchp)
1028        real fraci(numpts)        _RL newemis(nchp,10)
       real newemis(numpts,10)  
1029    
1030        real emis(12,11)        _RL emis(12,11)
1031        real fac        _RL fac
1032        integer i,j        integer i,j
1033    
1034  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
# Line 1211  C     To compute the total fraction of l Line 1206  C     To compute the total fraction of l
1206  C  C
1207  C***********************************************************************  C***********************************************************************
1208        implicit none        implicit none
 #include "CPP_EEOPTIONS.h"  
1209    
1210        integer im,jm,nSx,nSy,bi,bj,maxtyp        integer im,jm,nSx,nSy,bi,bj,maxtyp
1211        integer surftype(im,jm,maxtyp,nSx,nSy)        integer surftype(im,jm,maxtyp,nSx,nSy)
1212        _RL tilefrac(im,jm,maxtyp,nSx,nSy)        _RL tilefrac(im,jm,maxtyp,nSx,nSy)
1213        real frac(im,jm)        _RL frac(im,jm)
1214    
1215        integer  i,j,k        integer  i,j,k
1216    
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.23
  ViewVC Help
Powered by ViewVC 1.1.22