/[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.12 by molod, Wed Jul 14 17:31:58 2004 UTC revision 1.13 by molod, Fri Jul 16 19:37:04 2004 UTC
# Line 16  c--------------------------------------- Line 16  c---------------------------------------
16         implicit none         implicit none
17  #include "CPP_OPTIONS.h"  #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 29  c--------------------------------------- Line 31  c---------------------------------------
31    
32        logical alarm        logical alarm
33        external alarm        external alarm
34        _RL lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)        real lats(sNx,sNy), lons(sNx,sNy), cosz(sNx,sNy)
35        _RL fraci(sNx,sNy), fracl(sNx,sNy)        real fraci(sNx,sNy), fracl(sNx,sNy)
36        _RL ficetile(nchp)        real ficetile(nchp)
37        _RL ra        real radius
38        integer i, j, L, bi, bj        real tmpij(sNx,sNy)
39          real 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 56  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    
# Line 65  c--------------------------------------- Line 70  c---------------------------------------
70       .                                                            fracl)       .                                                            fracl)
71         do j = jm1,jm2         do j = jm1,jm2
72         do i = im1,im2         do i = im1,im2
73          if(sea_ice(i,j,bi,bj).gt.0.) then          if(sice(i,j,bi,bj).gt.0.) then
74             fraci(i,j) = 1.             fraci(i,j) = 1.
75          else          else
76             fraci(i,j) = 0.             fraci(i,j) = 0.
# Line 87  C                      Compute Surface A Line 92  C                      Compute Surface A
92  C **********************************************************************  C **********************************************************************
93    
94         if( alarm('radsw') ) then         if( alarm('radsw') ) then
95          call astro(nymd,nhms,lats,lons,im2*jm2,cosz,ra)          call astro(nymd,nhms,lats,lons,im2*jm2,cosz,radius)
96          call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,          call getalb(sec,month,day,cosz,snodep,fraci,fracl,im2,jm2,nchp,
97       .             nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,alai,agrn,       .             nchpland,nSx,nSy,bi,bj,igrd,ityp,chfr,chlt,alai,agrn,
98       .             albvisdr,albvisdf,albnirdr,albnirdf )       .             albvisdr,albvisdf,albnirdr,albnirdf )
# Line 112  C*************************************** Line 117  C***************************************
117    
118         do j = jm1,jm2         do j = jm1,jm2
119         do i = im1,im2         do i = im1,im2
120          tgz(i,j,bi,bj) = 0.          tmpij(i,j) = 0.
121         enddo         enddo
122         enddo         enddo
123         call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tcanopy(1,bi,bj),         do i = 1,nchp
124       .                           nchp,nchp,fracl,tgz(1,bi,bj),im2,jm2)          tmpchp(i) = tcanopy(i,bi,bj)
125           enddo
126           call msc2grd(igrd(1,bi,bj),chfr(1,bi,bj),tmpchp,
127         .                           nchp,nchp,fracl,tmpij,im2,jm2)
128         do j = jm1,jm2         do j = jm1,jm2
129         do i = im1,im2         do i = im1,im2
130          if(fracl(i,j).lt.0.3.and.sea_ice(i,j,bi,bj).eq.0.0)          tgz(i,j,bi,bj) = tmpij(i,j)
131            if(fracl(i,j).lt.0.3.and.sice(i,j,bi,bj).eq.0.0)
132       .                                 tgz(i,j,bi,bj) = sst(i,j,bi,bj)       .                                 tgz(i,j,bi,bj) = sst(i,j,bi,bj)
133         enddo         enddo
134         enddo         enddo
# Line 154  C*************************************** Line 163  C***************************************
163  #include "CPP_EEOPTIONS.h"  #include "CPP_EEOPTIONS.h"
164    
165        INTEGER IRUN        INTEGER IRUN
166        _RL AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN),        real AVISDR  (IRUN), ANIRDR (IRUN), AVISDF (IRUN), ANIRDF (IRUN)
167       `       VLAI   (IRUN),   VGRN (IRUN),   ZTH  (IRUN),    SNW (IRUN)        _RL VLAI(IRUN),VGRN (IRUN), SNW(IRUN)
168          REAL ZTH(IRUN)
169        INTEGER ITYP (IRUN)        INTEGER ITYP (IRUN)
170    
171        _RL ALVDRS,  ALIDRS        _RL ALVDRS,  ALIDRS
# Line 211  C                  9:  GLACIER Line 221  C                  9:  GLACIER
221  C                 10:  DARK DESERT  C                 10:  DARK DESERT
222  C  C
223    
224          INTEGER I, LAI
225  * [ Definition of Variables: ]        real FAC,GAMMA,BETA,ALPHA,DX,DY,ALA,GRN (2),SNWALB(4,NTYPS)
226  *        real COEFF
227          INTEGER I, LAI  
228          real ALVDR (NLAI, 2, NTYPS)
229          _RL FAC,               GAMMA,          BETA,          ALPHA,        real BTVDR (NLAI, 2, NTYPS)
230       `       DX,                DY,             ALA,           GRN (2),        real GMVDR (NLAI, 2, NTYPS)
231       `       SNWALB (4, NTYPS), SNWMID (NTYPS)        real ALIDR (NLAI, 2, NTYPS)
232          real BTIDR (NLAI, 2, NTYPS)
233  * [ Definition of Functions: ]        real GMIDR (NLAI, 2, NTYPS)
 *  
         _RL COEFF  
   
 C   Constants used in albedo calculations:  
   
       _RL ALVDR (NLAI, 2, NTYPS)  
       _RL BTVDR (NLAI, 2, NTYPS)  
       _RL GMVDR (NLAI, 2, NTYPS)  
       _RL ALIDR (NLAI, 2, NTYPS)  
       _RL BTIDR (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 680  cfpp$ expand (coeff) Line 679  cfpp$ expand (coeff)
679  #include "CPP_EEOPTIONS.h"  #include "CPP_EEOPTIONS.h"
680                    
681        INTEGER NTABL, LAI        INTEGER NTABL, LAI
682          real coeff
683        _RL TABLE (NTABL, 2), DX, DY        real TABLE (NTABL, 2), DX, DY
684    
685        COEFF = (TABLE(LAI,  1)        COEFF = (TABLE(LAI,  1)
686       *      + (TABLE(LAI  ,2) - TABLE(LAI  ,1)) * DY ) * (1.0-DX)       *      + (TABLE(LAI  ,2) - TABLE(LAI  ,1)) * DY ) * (1.0-DX)
# Line 852  C*************************************** Line 851  C***************************************
851  #include "CPP_EEOPTIONS.h"  #include "CPP_EEOPTIONS.h"
852    
853        integer sec,month,day,im,jm,nchp,nchpland,nSx,nSy,bi,bj        integer sec,month,day,im,jm,nchp,nchpland,nSx,nSy,bi,bj
854        _RL cosz(im,jm),fraci(im,jm),fracg(im,jm)        real cosz(im,jm),fraci(im,jm),fracg(im,jm)
855        _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)
856        integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)        integer igrd(nchp,nSx,nSy),ityp(nchp,nSx,nSy)
857        _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)        _RL alai(nchp,nSx,nSy),agrn(nchp,nSx,nSy)
# Line 868  C*************************************** Line 867  C***************************************
867        PARAMETER (OCNALB=0.08)        PARAMETER (OCNALB=0.08)
868        PARAMETER (ALBSI=0.7)        PARAMETER (ALBSI=0.7)
869    
870        _RL alboc(im,jm)        real alboc(im,jm)
871        _RL AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)        real AVISDR(nchp),ANIRDR(nchp),AVISDF(nchp)
872        _RL ANIRDF(nchp),zenith(nchp)        real ANIRDF(nchp)
873          real zenith(nchp)
874          real tmpij(im,jm)
875        integer i,j        integer i,j
876    
877        DO I=1,IM        DO I=1,IM
878        DO J=1,JM        DO J=1,JM
879         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)
880         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))
881         ALBNR(I,J) = ALBVR(I,J)         ALBNR(I,J,bi,bj) = ALBVR(I,J,bi,bj)
882         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))
883         ALBNF(I,J) = ALBVF(I,J)         ALBNF(I,J,bi,bj) = ALBVF(I,J,bi,bj)
884        ENDDO        ENDDO
885        ENDDO        ENDDO
886    
# Line 895  C and now call sibalb Line 896  C and now call sibalb
896    
897  C finally some transformations back to grid space for albedos  C finally some transformations back to grid space for albedos
898    
899          DO I=1,IM
900          DO J=1,JM
901           tmpij(i,j) = 0.
902          ENDDO
903          ENDDO
904        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,
905       .                                      fracg,albvr(1,bi,bj),im,jm)       .                                     fracg,tmpij,im,jm)
906          DO I=1,IM
907          DO J=1,JM
908           albvr(i,j,bi,bj) = tmpij(i,j)
909          ENDDO
910          ENDDO
911          DO I=1,IM
912          DO J=1,JM
913           tmpij(i,j) = 0.
914          ENDDO
915          ENDDO
916        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,
917       .                                      fracg,albvf(1,bi,bj),im,jm)       .                                     fracg,tmpij,im,jm)
918          DO I=1,IM
919          DO J=1,JM
920           albvf(i,j,bi,bj) = tmpij(i,j)
921          ENDDO
922          ENDDO
923          DO I=1,IM
924          DO J=1,JM
925           tmpij(i,j) = 0.
926          ENDDO
927          ENDDO
928        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,
929       .                                      fracg,albnr(1,bi,bj),im,jm)       .                                     fracg,tmpij,im,jm)
930          DO I=1,IM
931          DO J=1,JM
932           albnr(i,j,bi,bj) = tmpij(i,j)
933          ENDDO
934          ENDDO
935          DO I=1,IM
936          DO J=1,JM
937           tmpij(i,j) = 0.
938          ENDDO
939          ENDDO
940        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,
941       .                                      fracg,albnf(1,bi,bj),im,jm)       .                                     fracg,tmpij,im,jm)
942          DO I=1,IM
943          DO J=1,JM
944           albnf(i,j,bi,bj) = tmpij(i,j)
945          ENDDO
946          ENDDO
947    
948        return        return
949        end        end
# Line 940  C*************************************** Line 981  C***************************************
981        implicit none        implicit none
982  #include "CPP_EEOPTIONS.h"  #include "CPP_EEOPTIONS.h"
983        integer im,jm,nchp,nSx,nSy,bi,bj        integer im,jm,nchp,nSx,nSy,bi,bj
984        _RL fracg(im,jm)        real fracg(im,jm)
985        _RL chfr(nchp,nSx,nSy)        _RL chfr(nchp,nSx,nSy)
986        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)        integer igrd(nchp,nSx,nSy), ityp(nchp,nSx,nSy)
987        _RL snowdep(nchp,nSx,nSy),fraci(nchp)        _RL snowdep(nchp,nSx,nSy)
988          real fraci(nchp)
989        _RL emiss(im,jm,10,nSx,nSy)        _RL emiss(im,jm,10,nSx,nSy)
990    
991        _RL emisstile(nchp,10)        real emisstile(nchp,10)
992          real tmpij(im,jm)
993        integer i,j,k,n        integer i,j,k,n
994    
995        do i = 1,10        do i = 1,10
# Line 965  c -------------------------------------- Line 1008  c --------------------------------------
1008        do k = 1,10        do k = 1,10
1009        do j = 1,jm        do j = 1,jm
1010        do i = 1,im        do i = 1,im
1011        emiss(i,j,k) = 0.0         tmpij(i,j) = 0.0
1012        enddo        enddo
1013        enddo        enddo
1014        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,nchp,
1015       .      fracg,emiss(1,1,k,bi,bj),im,jm)       .      fracg,tmpij,im,jm)
1016          do j = 1,jm
1017          do i = 1,im
1018           emiss(i,j,k,bi,bj) = tmpij(i,j)
1019          enddo
1020          enddo
1021        enddo        enddo
1022    
1023        return        return
# Line 980  c -------------------------------------- Line 1028  c --------------------------------------
1028  #include "CPP_EEOPTIONS.h"  #include "CPP_EEOPTIONS.h"
1029        integer numpts        integer numpts
1030        integer   ityp(numpts)        integer   ityp(numpts)
1031        _RL snowdepth(numpts),fraci(numpts)        _RL snowdepth(numpts)
1032        _RL   newemis(numpts,10)        real fraci(numpts)
1033          real newemis(numpts,10)
1034    
1035        _RL emis(12,11)        real emis(12,11)
1036        _RL snwmid(10)        real fac
       _RL fac  
1037        integer i,j        integer i,j
1038    
1039  c-----------------------------------------------------------------------  c-----------------------------------------------------------------------
# Line 1165  C*************************************** Line 1213  C***************************************
1213        implicit none        implicit none
1214  #include "CPP_EEOPTIONS.h"  #include "CPP_EEOPTIONS.h"
1215    
1216        integer i,j,nSx,nSy,bi,bj,maxtyp        integer im,jm,nSx,nSy,bi,bj,maxtyp
1217        integer surftype(im,jm,nSx,nSy)        integer surftype(im,jm,maxtyp,nSx,nSy)
1218        _RL surftype(im,jm,nSx,nSy)        _RL tilefrac(im,jm,maxtyp,nSx,nSy)
1219        _RL frac(im,jm)        real frac(im,jm)
1220    
1221        integer  i,j,k        integer  i,j,k
1222    
# Line 1181  C*************************************** Line 1229  C***************************************
1229        do k=1,maxtyp        do k=1,maxtyp
1230        do j=1,jm        do j=1,jm
1231        do i=1,im        do i=1,im
1232        if(surftype(i,j,k,bi,bj).lt.100.and.        if( (surftype(i,j,k,bi,bj).lt.100.).and.
1233                                         tilefrac(i,j,k,bi,bj).gt.0.0)then       .                               (tilefrac(i,j,k,bi,bj).gt.0.0))then
1234         frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)         frac(i,j) = frac(i,j) + tilefrac(i,j,k,bi,bj)
1235        endif        endif
1236        enddo        enddo
Legend:
Removed from v.1.12  
changed lines
  Added in v.1.13
  ViewVC Help
Powered by ViewVC 1.1.22