/[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.1 by molod, Tue Jun 15 14:47:23 2004 UTC revision 1.2 by molod, Tue Jun 15 16:06:03 2004 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3                                                                                        
4    #include "CPP_OPTIONS.h"
5        subroutine swrio (nymd,nhms,ndswr,myid,istrip,npcs,        subroutine swrio (nymd,nhms,ndswr,myid,istrip,npcs,
6       .                  pz,tz,qz,pkht,oz,co2,       .        pz,tz,qz,pkht,oz,co2,
7       .                  albvisdr,albvisdf,albnirdr,albnirdf,       .        albvisdr,albvisdf,albnirdr,albnirdf,
8       .                  dtradsw,dtswclr,radswg,swgclr,albedo,       .        dtradsw,dtswclr,radswg,swgclr,albedo,
9       .                  fdifpar,fdirpar,osr,osrclr,       .        fdifpar,fdirpar,osr,osrclr,
10       .                  im,jm,lm,sige,sig,dsig,ptop,       .        im,jm,lm,sige,sig,dsig,ptop,
11       .                  nswcld,cldsw,cswmo,nswlz,swlz,       .        nswcld,cldsw,cswmo,nswlz,swlz,
12       .                  lpnt,qdiag,nd,       .        lpnt,imstturb,qliqave,fccave,landtype,xlats,xlons)
      .                  imstturb,qliqave,fccave,landtype,xlats,xlons)  
13    
14        implicit none        implicit none
15        include 'diag.com'  #ifdef ALLOW_DIAGNOSTICS
16    #include "diagnostics.h"
17    #endif
18    
19  c Input Variables  c Input Variables
20  c ---------------  c ---------------
21        integer nymd,nhms,ndswr,istrip,npcs,nd        integer nymd,nhms,ndswr,istrip,npcs
22    
23        integer im,jm,lm        ! Physics Grid        integer im,jm,lm        
24        real  ptop              ! Physics Grid        real  ptop              
25        real  sige(lm+1)        ! Physics Grid        real  sige(lm+1)        
26        real   sig(lm)          ! Physics Grid        real   sig(lm)          
27        real  dsig(lm)          ! Physics Grid        real  dsig(lm)          
28    
29        real    pz(im,jm)       ! Dynamics State        real    pz(im,jm)      
30        real    tz(im,jm,lm)    ! Dynamics State        real    tz(im,jm,lm)    
31        real  pkht(im,jm,lm)    ! Dynamics State        real  pkht(im,jm,lm)    
32    
33        real    co2             ! Chemistry State        real    co2            
34        real    oz(im,jm,lm)    ! Chemistry Coupling        real    oz(im,jm,lm)    
35        real    qz(im,jm,lm)    ! Chemistry Coupling + Dynamics State        real    qz(im,jm,lm)    
36    
37        real albvisdr(im,jm)    ! Land Coupling        real albvisdr(im,jm)    
38        real albvisdf(im,jm)    ! Land Coupling        real albvisdf(im,jm)    
39        real albnirdr(im,jm)    ! Land Coupling        real albnirdr(im,jm)    
40        real albnirdf(im,jm)    ! Land Coupling        real albnirdf(im,jm)    
41    
42        real   radswg(im,jm)    ! Shortwave Coupling        real   radswg(im,jm)    
43        real   swgclr(im,jm)    ! Shortwave Coupling        real   swgclr(im,jm)    
44        real   albedo(im,jm)    ! Shortwave Coupling        real   albedo(im,jm)    
45        real  fdifpar(im,jm)    ! Shortwave Coupling        real  fdifpar(im,jm)    
46        real  fdirpar(im,jm)    ! Shortwave Coupling        real  fdirpar(im,jm)    
47        real      osr(im,jm)    ! Shortwave Coupling        real      osr(im,jm)    
48        real   osrclr(im,jm)    ! Shortwave Coupling        real   osrclr(im,jm)    
49        real  dtradsw(im,jm,lm) ! Shortwave Tendency        real  dtradsw(im,jm,lm)
50        real  dtswclr(im,jm,lm) ! Shortwave Tendency        real  dtswclr(im,jm,lm)
51    
52        integer nswcld,nswlz    ! Moist Coupling        integer nswcld,nswlz    
53        real  cldsw(im,jm,lm)   ! Moist Coupling        real  cldsw(im,jm,lm)  
54        real  cswmo(im,jm,lm)   ! Moist Coupling        real  cswmo(im,jm,lm)  
55        real   swlz(im,jm,lm)   ! Moist Coupling        real   swlz(im,jm,lm)  
56    
57        real  qdiag(im,jm,nd)   ! Diagnostics        logical lpnt            
58        logical lpnt            ! Point by Point Flag        integer imstturb        
59        integer imstturb        ! Turb Coupling        real qliqave(im,jm,lm)  
60        real qliqave(im,jm,lm)  ! Turb Coupling        real  fccave(im,jm,lm)  
       real  fccave(im,jm,lm)  ! Turb Coupling  
61    
62        integer landtype(im,jm) ! Surface Land Type        integer landtype(im,jm)
63    
64  c Local Variables  c Local Variables
65  c ---------------  c ---------------
# Line 67  c --------------- Line 68  c ---------------
68        real      getcon,grav,cp,undef,pcheck        real      getcon,grav,cp,undef,pcheck
69        real      ra,alf,reffw,reffi,tminv        real      ra,alf,reffw,reffi,tminv
70    
71        parameter ( reffw = 10.0 )   ! Effective radius for water droplets        parameter ( reffw = 10.0 )  
72        parameter ( reffi = 65.0 )   ! Effective radius for ice   particles        parameter ( reffi = 65.0 )  
73    
74        real      alat(im,jm)        real      alat(im,jm)
75        real      alon(im,jm)        real      alon(im,jm)
# Line 223  c -------------------------------------- Line 224  c --------------------------------------
224          do L =1,lm          do L =1,lm
225          do j =1,jm          do j =1,jm
226          do i =1,im          do i =1,im
227           cldtot(i,j,L) =  min( 1.0,max(cldsw(i,j,L),fccave(i,j,L)/imstturb) )           cldtot(i,j,L)=min(1.0,max(cldsw(i,j,L),fccave(i,j,L)/imstturb))
228           cldmxo(i,j,L) =  min( 1.0,    cswmo(i,j,L) )           cldmxo(i,j,L)=min(1.0,cswmo(i,j,L))
229             swlz(i,j,L) =                swlz(i,j,L)+qliqave(i,j,L)/imstturb             swlz(i,j,L)=swlz(i,j,L)+qliqave(i,j,L)/imstturb
230          enddo          enddo
231          enddo          enddo
232          enddo          enddo
# Line 383  c ------------------ Line 384  c ------------------
384    
385  C Compute Optical Thicknesses and Diagnostics  C Compute Optical Thicknesses and Diagnostics
386  C -------------------------------------------  C -------------------------------------------
387        call opthk ( tdry,plz,plze,swlz,cldtot,cldmxo,landtype,im,jm,lm,tautype )        call opthk(tdry,plz,plze,swlz,cldtot,cldmxo,landtype,im,jm,lm,
388         .                                                          tautype)
389    
390        do L = 1,lm        do L = 1,lm
391        do j = 1,jm        do j = 1,jm
392        do i = 1,im        do i = 1,im
393        tau(i,j,L) = tautype(i,j,L,1) + tautype(i,j,L,2) + tautype(i,j,L,3)        tau(i,j,L) = tautype(i,j,L,1)+tautype(i,j,L,2)+tautype(i,j,L,3)
394        enddo        enddo
395        enddo        enddo
396        enddo        enddo
# Line 397  C -------------------------------------- Line 399  C --------------------------------------
399        do L=1,lm        do L=1,lm
400        do j=1,jm        do j=1,jm
401        do i=1,im        do i=1,im
402        qdiag(i,j,itauave+L-1) = qdiag(i,j,itauave+L-1) + tau(i,j,L)*100/(plze(i,j,L+1)-plze(i,j,L))        qdiag(i,j,itauave+L-1) = qdiag(i,j,itauave+L-1) +
403         .                        tau(i,j,L)*100/(plze(i,j,L+1)-plze(i,j,L))
404        enddo        enddo
405        enddo        enddo
406        enddo        enddo
# Line 408  C -------------------------------------- Line 411  C --------------------------------------
411        do L=1,lm        do L=1,lm
412        do j=1,jm        do j=1,jm
413        do i=1,im        do i=1,im
414           if( cldtot(i,j,L).ne.0.0 ) then         if( cldtot(i,j,L).ne.0.0 ) then
415                qdiag(i,j,itaucld +L-1) = qdiag(i,j,itaucld +L-1) + tau(i,j,L)*100/(plze(i,j,L+1)-plze(i,j,L))          qdiag(i,j,itaucld +L-1) = qdiag(i,j,itaucld +L-1) +
416                qdiag(i,j,itaucldc+L-1) = qdiag(i,j,itaucldc+L-1) + 1.0       .                        tau(i,j,L)*100/(plze(i,j,L+1)-plze(i,j,L))
417           endif          qdiag(i,j,itaucldc+L-1) = qdiag(i,j,itaucldc+L-1) + 1.0
418           endif
419        enddo        enddo
420        enddo        enddo
421        enddo        enddo
# Line 550  C ************************************** Line 554  C **************************************
554  c Calculate Mean Albedo  c Calculate Mean Albedo
555  c ---------------------  c ---------------------
556        do i=1,istrip        do i=1,istrip
557        if( cosz(i).gt.0.0 ) then         if( cosz(i).gt.0.0 ) then
558              tstrip(i) = 1.0 - flux(i,lm+1)/( fdirir(i)+fdifir(i)+dirpar(i)+difpar(i)          tstrip(i) = 1.0 - flux(i,lm+1)/
559       .                                     + fdiruv(i)+fdifuv(i) )       . ( fdirir(i)+fdifir(i)+dirpar(i)+difpar(i) + fdiruv(i)+fdifuv(i) )
560          if( tstrip(i).lt.0.0 ) tstrip(i) = undef          if( tstrip(i).lt.0.0 ) tstrip(i) = undef
561        else         else
562              tstrip(i) = undef          tstrip(i) = undef
563        endif         endif
564        enddo        enddo
565        call paste ( tstrip,albedo,istrip,im*jm,1,nn )        call paste ( tstrip,albedo,istrip,im*jm,1,nn )
566    
# Line 672  c --------------- Line 676  c ---------------
676    
677  c Large-Scale Water  c Large-Scale Water
678  c -----------------  c -----------------
679    C Over Land
680           if( lwi(i,j).le.10 ) then           if( lwi(i,j).le.10 ) then
681                  tauh2o = max( 0.0020, 0.200*min(200*lz(i,j,L)*1000,1.0) )  ! Over Land            tauh2o = max( 0.0020, 0.200*min(200*lz(i,j,L)*1000,1.0) )  
682                  tau(i,j,L,3) = fracls*alf*tauh2o*dp            tau(i,j,L,3) = fracls*alf*tauh2o*dp
683           else           else
684              if( lz(i,j,L).eq.0.0 ) then  C Non-Precipitation Clouds Over Ocean
685                  tauh2o = .12                      ! Non-Precipitation Clouds Over Ocean            if( lz(i,j,L).eq.0.0 ) then
686                  tau(i,j,L,2) = fracls*alf*tauh2o*dp             tauh2o = .12                      
687              else             tau(i,j,L,2) = fracls*alf*tauh2o*dp
688                  tauh2o = max( 0.0020, 0.120*min( 20*lz(i,j,L)*1000,1.0) )  ! Over Ocean            else
689                  tau(i,j,L,3) = fracls*alf*tauh2o*dp  C Over Ocean
690              endif             tauh2o = max( 0.0020, 0.120*min( 20*lz(i,j,L)*1000,1.0) )  
691               tau(i,j,L,3) = fracls*alf*tauh2o*dp
692              endif
693           endif           endif
694    
695  c Sub-Grid Convective  c Sub-Grid Convective
# Line 809  c-----Explicit Inline Directives Line 816  c-----Explicit Inline Directives
816  #if f77  #if f77
817  cfpp$ expand (expmn)  cfpp$ expand (expmn)
818  #endif  #endif
 #if f90  
 !DIR$ inline always expmn  
 #endif  
819  #endif  #endif
820        real expmn        real expmn
821    
# Line 1274  cfpp$ expand (deledd) Line 1278  cfpp$ expand (deledd)
1278  cfpp$ expand (sagpol)  cfpp$ expand (sagpol)
1279  cfpp$ expand (expmn)  cfpp$ expand (expmn)
1280  #endif  #endif
 #if f90  
 !DIR$ inline always deledd  
 !DIR$ inline always sagpol  
 !DIR$ inline always expmn  
 #endif  
1281  #endif  #endif
1282        real expmn        real expmn
1283    
# Line 1688  c-----Explicit Inline Directives Line 1687  c-----Explicit Inline Directives
1687  cfpp$ expand (deledd)  cfpp$ expand (deledd)
1688  cfpp$ expand (sagpol)  cfpp$ expand (sagpol)
1689  #endif    #endif  
 #if f90    
 !DIR$ inline always deledd  
 !DIR$ inline always sagpol  
 #endif  
1690  #endif  #endif
1691    
1692  c-----input parameters  c-----input parameters
# Line 2008  c-----Explicit Inline Directives Line 2003  c-----Explicit Inline Directives
2003  #if f77    #if f77  
2004  cfpp$ expand (expmn)  cfpp$ expand (expmn)
2005  #endif    #endif  
 #if f90    
 !DIR$ inline always expmn  
 #endif  
2006  #endif  #endif
2007        real expmn        real expmn
2008    
# Line 2135  c-----Explicit Inline Directives Line 2127  c-----Explicit Inline Directives
2127  #if f77    #if f77  
2128  cfpp$ expand (expmn)  cfpp$ expand (expmn)
2129  #endif    #endif  
 #if f90    
 !DIR$ inline always expmn  
 #endif  
2130  #endif  #endif
2131        real expmn        real expmn
2132    
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
  ViewVC Help
Powered by ViewVC 1.1.22