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

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

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

revision 1.4 by molod, Thu Jun 24 19:57:02 2004 UTC revision 1.5 by molod, Wed Jul 7 19:33:48 2004 UTC
# Line 3  C $Name$ Line 3  C $Name$
3    
4  #include "CPP_OPTIONS.h"  #include "CPP_OPTIONS.h"
5        subroutine swrio (nymd,nhms,bi,bj,ndswr,myid,istrip,npcs,        subroutine swrio (nymd,nhms,bi,bj,ndswr,myid,istrip,npcs,
6       .        pz,tz,qz,pkht,oz,co2,       .        low_level,mid_level,
7         .        pz,plz,plze,dpres,pkht,pkz,tz,qz,oz,co2,
8       .        albvisdr,albvisdf,albnirdr,albnirdf,       .        albvisdr,albvisdf,albnirdr,albnirdf,
9       .        dtradsw,dtswclr,radswg,swgclr,       .        dtradsw,dtswclr,radswg,swgclr,
10       .        fdifpar,fdirpar,osr,osrclr,       .        fdifpar,fdirpar,osr,osrclr,
11       .        im,jm,lm,sige,sig,dsig,ptop,       .        im,jm,lm,ptop,
12       .        nswcld,cldsw,cswmo,nswlz,swlz,       .        nswcld,cldsw,cswmo,nswlz,swlz,
13       .        lpnt,imstturb,qliqave,fccave,landtype,xlats,xlons)       .        lpnt,imstturb,qliqave,fccave,landtype,xlats,xlons)
14    
# Line 18  C $Name$ Line 19  C $Name$
19    
20  c Input Variables  c Input Variables
21  c ---------------  c ---------------
22        integer nymd,nhms,ndswr,istrip,npcs,bi,bj        integer nymd,nhms,bi,bj,ndswr,myid,istrip,npcs
23          integer mid_level,low_level
24        integer im,jm,lm                integer im,jm,lm        
25        real  ptop                      real  ptop
26        real  sige(lm+1)                real pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)
27        real   sig(lm)                  real pkht(im,jm,lm+1),pkz(im,jm,lm)
28        real  dsig(lm)                  real tz(im,jm,lm),qz(im,jm,lm)
29          real oz(im,jm,lm)
30        real    pz(im,jm)              real co2
31        real    tz(im,jm,lm)            real albvisdr(im,jm),albvisdf(im,jm),albnirdr(im,jm)
32        real  pkht(im,jm,lm)            real albnirdf(im,jm)
33          real radswg(im,jm),swgclr(im,jm),fdifpar(im,jm),fdirpar(im,jm)
34        real    co2                    real osr(im,jm),osrclr(im,jm),dtradsw(im,jm,lm),dtswclr(im,jm,lm)
       real    oz(im,jm,lm)      
       real    qz(im,jm,lm)      
   
       real albvisdr(im,jm)      
       real albvisdf(im,jm)      
       real albnirdr(im,jm)      
       real albnirdf(im,jm)      
   
       real   radswg(im,jm)      
       real   swgclr(im,jm)      
       real  fdifpar(im,jm)      
       real  fdirpar(im,jm)      
       real      osr(im,jm)      
       real   osrclr(im,jm)      
       real  dtradsw(im,jm,lm)  
       real  dtswclr(im,jm,lm)  
   
35        integer nswcld,nswlz            integer nswcld,nswlz    
36        real  cldsw(im,jm,lm)          real cldsw(im,jm,lm),cswmo(im,jm,lm),swlz(im,jm,lm)  
       real  cswmo(im,jm,lm)    
       real   swlz(im,jm,lm)    
   
37        logical lpnt                    logical lpnt            
38        integer imstturb                integer imstturb        
39        real qliqave(im,jm,lm)          real qliqave(im,jm,lm),fccave(im,jm,lm)  
       real  fccave(im,jm,lm)    
   
40        integer landtype(im,jm)        integer landtype(im,jm)
41          real xlats(im,jm),xlons(im,jm)
42    
43  c Local Variables  c Local Variables
44  c ---------------  c ---------------
45        integer   i,j,L,nn,nsecf,mid_level, low_level        integer   i,j,L,nn,nsecf
46        integer   nb2,ntmstp,nymd2,nhms2        integer   nb2,ntmstp,nymd2,nhms2
47        real      getcon,grav,cp,undef,pcheck        real      getcon,grav,cp,undef,pcheck
48        real      ra,alf,reffw,reffi,tminv        real      ra,alf,reffw,reffi,tminv
# Line 70  c --------------- Line 50  c ---------------
50        parameter ( reffw = 10.0 )          parameter ( reffw = 10.0 )  
51        parameter ( reffi = 65.0 )          parameter ( reffi = 65.0 )  
52    
53        real      alat(im,jm)        real tdry(im,jm,lm)
54        real      alon(im,jm)        real TEMP1(im,jm)
55          real TEMP2(im,jm)
56          real zenith (im,jm)
57          real cldtot (im,jm,lm)
58          real cldmxo (im,jm,lm)
59          real totcld (im,jm)
60          real cldlow (im,jm)
61          real cldmid (im,jm)
62          real cldhi  (im,jm)
63          real taulow (im,jm)
64          real taumid (im,jm)
65          real tauhi  (im,jm)
66          real tautype(im,jm,lm,3)
67          real tau(im,jm,lm)
68          real albedo(im,jm)    
69    
70          real PK(ISTRIP,lm)
71          real qzl(ISTRIP,lm),CLRO(ISTRIP,lm)
72          real TZL(ISTRIP,lm)
73          real OZL(ISTRIP,lm)
74          real PLE(ISTRIP,lm+1)
75          real OSZ(ISTRIP)
76          real dpstrip(ISTRIP,lm)
77    
78          real albuvdr(ISTRIP),albuvdf(ISTRIP)
79          real albirdr(ISTRIP),albirdf(ISTRIP)
80          real difpar (ISTRIP),dirpar (ISTRIP)
81    
82          real fdirir(istrip),fdifir(istrip)
83          real fdiruv(istrip),fdifuv(istrip)
84    
85          real flux(istrip,lm+1)
86          real fluxclr(istrip,lm+1)
87          real dtsw(istrip,lm)
88          real dtswc(istrip,lm)
89    
90          real taul   (istrip,lm)
91          real reff   (istrip,lm,2)
92          real tauc   (istrip,lm,2)
93          real taua   (istrip,lm)
94          real tstrip (istrip)
95    
96        real          PKZ(im,jm,lm)        logical first
97        real          PLZ(im,jm,lm)        data first /.true./
       real         tdry(im,jm,lm)  
       real         PLZE(im,jm,lm+1)  
       real        TEMP1(im,jm)  
       real        TEMP2(im,jm)  
       real      zenith (im,jm)  
       real      cldtot (im,jm,lm)  
       real      cldmxo (im,jm,lm)  
       real      totcld (im,jm)  
       real      cldlow (im,jm)  
       real      cldmid (im,jm)  
       real      cldhi  (im,jm)  
       real      taulow (im,jm)  
       real      taumid (im,jm)  
       real      tauhi  (im,jm)  
       real      tautype(im,jm,lm,3)  
       real      tau    (im,jm,lm)  
       real      albedo(im,jm)      
   
       real          PK(ISTRIP,lm)  
       real         qzl(ISTRIP,lm),  CLRO(ISTRIP,lm)  
       real         TZL(ISTRIP,lm)  
       real         OZL(ISTRIP,lm)  
       real         PLE(ISTRIP,lm+1)  
       real        COSZ(ISTRIP)  
   
       real      albuvdr(ISTRIP),albuvdf(ISTRIP)  
       real      albirdr(ISTRIP),albirdf(ISTRIP)  
       real      difpar (ISTRIP),dirpar (ISTRIP)  
   
       real      fdirir(istrip),fdifir(istrip)  
       real      fdiruv(istrip),fdifuv(istrip)  
   
       real      flux   (istrip,lm+1)  
       real      fluxclr(istrip,lm+1)  
       real      dtsw   (istrip,lm)  
       real      dtswc  (istrip,lm)  
   
       real      taul   (istrip,lm)  
       real      reff   (istrip,lm,2)  
       real      tauc   (istrip,lm,2)  
       real      taua   (istrip,lm)  
       real      tstrip (istrip)  
   
       logical   first  
       data      first /.true./  
   
       integer   koz, kh2o  
       data      KOZ  /20/  
       data      kh2o /18/  
98    
99  C **********************************************************************  C **********************************************************************
100  C ****                       INITIALIZATION                         ****  C ****                       INITIALIZATION                         ****
# Line 136  C ************************************** Line 107  C **************************************
107        NTMSTP = nsecf(NDSWR)        NTMSTP = nsecf(NDSWR)
108        TMINV  = 1./float(ntmstp)        TMINV  = 1./float(ntmstp)
109    
       do j = 1,jm  
       do i = 1,im  
       PLZE(I,j,1) = SIGE(1)*PZ(I,j) + PTOP  
       enddo  
       enddo  
         
       DO L = 1,lm  
       do j = 1,jm  
       DO I = 1,im  
       PLZ (I,j,L  ) = SIG (L)  *PZ(I,j) + PTOP  
       PLZE(I,j,L+1) = SIGE(L+1)*PZ(I,j) + PTOP  
       ENDDO  
       ENDDO  
       ENDDO  
   
       call pkappa ( pz,pkht,pkz,ptop,sige,dsig,im,jm,lm )  
   
110  C Compute Temperature from Theta  C Compute Temperature from Theta
111  C ------------------------------  C ------------------------------
112        do L=1,lm        do L=1,lm
# Line 163  C ------------------------------ Line 117  C ------------------------------
117        enddo        enddo
118        enddo        enddo
119    
 c Determine Level Indices for Low-Mid-High Cloud Regions  
 c ------------------------------------------------------  
       low_level = lm  
       mid_level = lm  
       do L = lm-1,1,-1  
       pcheck = (1000.-ptop)*sig(l) + ptop  
       if (pcheck.gt.700.0) low_level = L  
       if (pcheck.gt.400.0) mid_level = L  
       enddo  
   
120        if (first .and. myid.eq.0 ) then        if (first .and. myid.eq.0 ) then
121        print *        print *
122        print *,'Low-Level Clouds are Grouped between levels: ',        print *,'Low-Level Clouds are Grouped between levels: ',
# Line 187  C ************************************** Line 131  C **************************************
131  C ****             CALCULATE COSINE OF THE ZENITH ANGLE             ****  C ****             CALCULATE COSINE OF THE ZENITH ANGLE             ****
132  C **********************************************************************  C **********************************************************************
133    
134        CALL ASTRO ( NYMD,   NHMS,  ALAT,ALON, im*jm, TEMP1,RA )        CALL ASTRO ( NYMD,   NHMS,  XLATS,XLONS, im*jm, TEMP1,RA )
135                     NYMD2 = NYMD                     NYMD2 = NYMD
136                     NHMS2 = NHMS                     NHMS2 = NHMS
137        CALL TICK  ( NYMD2,  NHMS2, NTMSTP )        CALL TICK  ( NYMD2,  NHMS2, NTMSTP )
138        CALL ASTRO ( NYMD2,  NHMS2, ALAT,ALON, im*jm, TEMP2,RA )        CALL ASTRO ( NYMD2,  NHMS2, XLATS,XLONS, im*jm, TEMP2,RA )
139    
140        do j = 1,jm        do j = 1,jm
141        do i = 1,im        do i = 1,im
# Line 491  C ************************************** Line 435  C **************************************
435    
436        CALL STRIP ( zenith,COSZ,im*jm,ISTRIP,1,NN )        CALL STRIP ( zenith,COSZ,im*jm,ISTRIP,1,NN )
437    
438        CALL STRIP ( plze, ple   ,im*jm,ISTRIP,lm+1,NN)        CALL STRIP ( plze,  ple   ,im*jm,ISTRIP,lm+1,NN)
439        CALL STRIP ( pkz , pk    ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( pkz ,  pk    ,im*jm,ISTRIP,lm  ,NN)
440        CALL STRIP ( tdry, tzl   ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( dpres,dpstrip,im*jm,ISTRIP,lm  ,NN)
441        CALL STRIP ( qz  , qzl   ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( tdry,  tzl   ,im*jm,ISTRIP,lm  ,NN)
442        CALL STRIP ( oz  , ozl   ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( qz  ,  qzl   ,im*jm,ISTRIP,lm  ,NN)
443        CALL STRIP ( tau , taul  ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( oz  ,  ozl   ,im*jm,ISTRIP,lm  ,NN)
444          CALL STRIP ( tau ,  taul  ,im*jm,ISTRIP,lm  ,NN)
445    
446        CALL STRIP ( albvisdr,albuvdr,im*jm,ISTRIP,1,NN )        CALL STRIP ( albvisdr,albuvdr,im*jm,ISTRIP,1,NN )
447        CALL STRIP ( albvisdf,albuvdf,im*jm,ISTRIP,1,NN )        CALL STRIP ( albvisdf,albuvdf,im*jm,ISTRIP,1,NN )
# Line 543  C ****     Compute Mass-Weighted Theta T Line 488  C ****     Compute Mass-Weighted Theta T
488  C **********************************************************************  C **********************************************************************
489    
490        do l=1,lm        do l=1,lm
       alf = grav/(cp*dsig(L)*100)  
491        do i=1,istrip        do i=1,istrip
492          alf = grav*(ple(i,L+1)-ptop)/(cp*dpstrip(i,L)*100)
493        dtsw (i,L) = alf*( flux   (i,L)-flux   (i,L+1) )/pk(i,L)        dtsw (i,L) = alf*( flux   (i,L)-flux   (i,L+1) )/pk(i,L)
494        dtswc(i,L) = alf*( fluxclr(i,L)-fluxclr(i,L+1) )/pk(i,L)        dtswc(i,L) = alf*( fluxclr(i,L)-fluxclr(i,L+1) )/pk(i,L)
495        enddo        enddo
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5
  ViewVC Help
Powered by ViewVC 1.1.22