/[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.9 by molod, Wed Jul 14 15:52:04 2004 UTC revision 1.14 by molod, Wed Jul 28 01:25:07 2004 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3    
4  #include "CPP_OPTIONS.h"  #include "FIZHI_OPTIONS.h"
 #include "PACKAGES_CONFIG.h"  
5        subroutine swrio (nymd,nhms,bi,bj,ndswr,myid,istrip,npcs,        subroutine swrio (nymd,nhms,bi,bj,ndswr,myid,istrip,npcs,
6       .        low_level,mid_level,       .        low_level,mid_level,
7       .        pz,plz,plze,dpres,pkht,pkz,tz,qz,oz,co2,       .        pz,plz,plze,dpres,pkht,pkz,tz,qz,oz,co2,
# Line 25  c --------------- Line 24  c ---------------
24        integer nymd,nhms,bi,bj,ndswr,myid,istrip,npcs        integer nymd,nhms,bi,bj,ndswr,myid,istrip,npcs
25        integer mid_level,low_level        integer mid_level,low_level
26        integer im,jm,lm                integer im,jm,lm        
27        real  ptop        _RL  ptop
28        real pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)        _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)
29        real pkht(im,jm,lm+1),pkz(im,jm,lm)        _RL pkht(im,jm,lm+1),pkz(im,jm,lm)
30        real tz(im,jm,lm),qz(im,jm,lm)        _RL tz(im,jm,lm),qz(im,jm,lm)
31        real oz(im,jm,lm)        _RL oz(im,jm,lm)
32        real co2        _RL co2
33        real albvisdr(im,jm),albvisdf(im,jm),albnirdr(im,jm)        _RL albvisdr(im,jm),albvisdf(im,jm),albnirdr(im,jm)
34        real albnirdf(im,jm)        _RL albnirdf(im,jm)
35        real radswg(im,jm),swgclr(im,jm),fdifpar(im,jm),fdirpar(im,jm)        _RL radswg(im,jm),swgclr(im,jm),fdifpar(im,jm),fdirpar(im,jm)
36        real osr(im,jm),osrclr(im,jm),dtradsw(im,jm,lm),dtswclr(im,jm,lm)        _RL osr(im,jm),osrclr(im,jm),dtradsw(im,jm,lm)
37          _RL dtswclr(im,jm,lm)
38        integer nswcld,nswlz            integer nswcld,nswlz    
39        real cldsw(im,jm,lm),cswmo(im,jm,lm),swlz(im,jm,lm)          _RL cldsw(im,jm,lm),cswmo(im,jm,lm),swlz(im,jm,lm)  
40        logical lpnt                    logical lpnt            
41        integer imstturb                integer imstturb        
42        real qliqave(im,jm,lm),fccave(im,jm,lm)          _RL qliqave(im,jm,lm),fccave(im,jm,lm)  
43        integer landtype(im,jm)        integer landtype(im,jm)
44        real xlats(im,jm),xlons(im,jm)        _RL xlats(im,jm),xlons(im,jm)
45    
46  c Local Variables  c Local Variables
47  c ---------------  c ---------------
48        integer   i,j,L,nn,nsecf        integer   i,j,L,nn,nsecf
49        integer   ntmstp,nymd2,nhms2        integer   ntmstp,nymd2,nhms2
50        real      getcon,grav,cp,undef        _RL      getcon,grav,cp,undef
51        real      ra,alf,reffw,reffi,tminv        _RL      ra,alf,reffw,reffi,tminv
52    
53        parameter ( reffw = 10.0 )          parameter ( reffw = 10.0 )  
54        parameter ( reffi = 65.0 )          parameter ( reffi = 65.0 )  
55    
56        real tdry(im,jm,lm)        _RL tdry(im,jm,lm)
57        real TEMP1(im,jm)        _RL TEMP1(im,jm)
58        real TEMP2(im,jm)        _RL TEMP2(im,jm)
59        real zenith (im,jm)        _RL zenith (im,jm)
60        real cldtot (im,jm,lm)        _RL cldtot (im,jm,lm)
61        real cldmxo (im,jm,lm)        _RL cldmxo (im,jm,lm)
62        real totcld (im,jm)        _RL totcld (im,jm)
63        real cldlow (im,jm)        _RL cldlow (im,jm)
64        real cldmid (im,jm)        _RL cldmid (im,jm)
65        real cldhi  (im,jm)        _RL cldhi  (im,jm)
66        real taulow (im,jm)        _RL taulow (im,jm)
67        real taumid (im,jm)        _RL taumid (im,jm)
68        real tauhi  (im,jm)        _RL tauhi  (im,jm)
69        real tautype(im,jm,lm,3)        _RL tautype(im,jm,lm,3)
70        real tau(im,jm,lm)        _RL tau(im,jm,lm)
71        real albedo(im,jm)            _RL albedo(im,jm)    
72    
73        real PK(ISTRIP,lm)        _RL PK(ISTRIP,lm)
74        real qzl(ISTRIP,lm),CLRO(ISTRIP,lm)        _RL qzl(ISTRIP,lm),CLRO(ISTRIP,lm)
75        real TZL(ISTRIP,lm)        _RL TZL(ISTRIP,lm)
76        real OZL(ISTRIP,lm)        _RL OZL(ISTRIP,lm)
77        real PLE(ISTRIP,lm+1)        _RL PLE(ISTRIP,lm+1)
78        real COSZ(ISTRIP)        _RL COSZ(ISTRIP)
79        real dpstrip(ISTRIP,lm)        _RL dpstrip(ISTRIP,lm)
80    
81        real albuvdr(ISTRIP),albuvdf(ISTRIP)        _RL albuvdr(ISTRIP),albuvdf(ISTRIP)
82        real albirdr(ISTRIP),albirdf(ISTRIP)        _RL albirdr(ISTRIP),albirdf(ISTRIP)
83        real difpar (ISTRIP),dirpar (ISTRIP)        _RL difpar (ISTRIP),dirpar (ISTRIP)
84    
85        real fdirir(istrip),fdifir(istrip)        _RL fdirir(istrip),fdifir(istrip)
86        real fdiruv(istrip),fdifuv(istrip)        _RL fdiruv(istrip),fdifuv(istrip)
87    
88        real flux(istrip,lm+1)        _RL flux(istrip,lm+1)
89        real fluxclr(istrip,lm+1)        _RL fluxclr(istrip,lm+1)
90        real dtsw(istrip,lm)        _RL dtsw(istrip,lm)
91        real dtswc(istrip,lm)        _RL dtswc(istrip,lm)
92    
93        real taul   (istrip,lm)        _RL taul   (istrip,lm)
94        real reff   (istrip,lm,2)        _RL reff   (istrip,lm,2)
95        real tauc   (istrip,lm,2)        _RL tauc   (istrip,lm,2)
96        real taua   (istrip,lm)        _RL taua   (istrip,lm)
97        real tstrip (istrip)        _RL tstrip (istrip)
98    
99        logical first        logical first
100        data first /.true./        data first /.true./
# Line 120  C ------------------------------ Line 120  C ------------------------------
120        enddo        enddo
121        enddo        enddo
122    
123        if (first .and. myid.eq.0 ) then        if (first .and. myid.eq.1 ) then
124        print *        print *
125        print *,'Low-Level Clouds are Grouped between levels: ',        print *,'Low-Level Clouds are Grouped between levels: ',
126       .         lm,' and ',low_level       .         lm,' and ',low_level
# Line 150  C ************************************** Line 150  C **************************************
150        ENDDO        ENDDO
151        ENDDO        ENDDO
152    
   
153  C **********************************************************************  C **********************************************************************
154  c ****        Compute Two-Dimension Total Cloud Fraction (0-1)      ****  c ****        Compute Two-Dimension Total Cloud Fraction (0-1)      ****
155  C **********************************************************************  C **********************************************************************
# Line 586  C                  tau(im,jm,lm,2):  Sus Line 585  C                  tau(im,jm,lm,2):  Sus
585  C                  tau(im,jm,lm,3):  Raindrops  C                  tau(im,jm,lm,3):  Raindrops
586  C  C
587  C***********************************************************************  C***********************************************************************
 C*                  GODDARD LABORATORY FOR ATMOSPHERES                 *  
 C***********************************************************************  
588    
589        implicit none        implicit none
590    
591        integer  im,jm,lm,i,j,L        integer  im,jm,lm,i,j,L
592    
593        real  tl(im,jm,lm)        _RL  tl(im,jm,lm)
594        real  pl(im,jm,lm)        _RL  pl(im,jm,lm)
595        real ple(im,jm,lm+1)        _RL ple(im,jm,lm+1)
596        real  lz(im,jm,lm)        _RL  lz(im,jm,lm)
597        real  cf(im,jm,lm)        _RL  cf(im,jm,lm)
598        real cfm(im,jm,lm)        _RL cfm(im,jm,lm)
599        real tau(im,jm,lm,3)        _RL tau(im,jm,lm,3)
600        integer lwi(im,jm)        integer lwi(im,jm)
601    
602        real dp, alf, fracls, fraccu        _RL dp, alf, fracls, fraccu
603        real tauice, tauh2o, tauras        _RL tauice, tauh2o, tauras
604    
605  c Compute Cloud Optical Depths  c Compute Cloud Optical Depths
606  c ----------------------------  c ----------------------------
# Line 771  c*************************************** Line 768  c***************************************
768    
769  c-----Explicit Inline Directives  c-----Explicit Inline Directives
770    
771  #if CRAY  #ifdef CRAY
772  #if f77  #ifdef f77
773  cfpp$ expand (expmn)  cfpp$ expand (expmn)
774  #endif  #endif
775  #endif  #endif
776        real expmn        _RL expmn
777    
778  c-----input parameters  c-----input parameters
779    
780        integer m,n,ndim,np,ict,icb        integer m,n,ndim,np,ict,icb
781        real pl(m,ndim,np+1),ta(m,ndim,np),wa(m,ndim,np),oa(m,ndim,np)        _RL pl(m,ndim,np+1),ta(m,ndim,np),wa(m,ndim,np),oa(m,ndim,np)
782        real  taucld(m,ndim,np,2),reff(m,ndim,np,2)        _RL  taucld(m,ndim,np,2),reff(m,ndim,np,2)
783        real  fcld(m,ndim,np),taual(m,ndim,np)        _RL  fcld(m,ndim,np),taual(m,ndim,np)
784        real  rsirbm(m,ndim),rsirdf(m,ndim),        _RL  rsirbm(m,ndim),rsirdf(m,ndim),
785       *     rsuvbm(m,ndim),rsuvdf(m,ndim),cosz(m,ndim),co2       *     rsuvbm(m,ndim),rsuvdf(m,ndim),cosz(m,ndim),co2
786    
787  c-----output parameters  c-----output parameters
788    
789        real  flx(m,ndim,np+1),flc(m,ndim,np+1)        _RL  flx(m,ndim,np+1),flc(m,ndim,np+1)
790        real  fdirir(m,ndim),fdifir(m,ndim)        _RL  fdirir(m,ndim),fdifir(m,ndim)
791        real  fdirpar(m,ndim),fdifpar(m,ndim)        _RL  fdirpar(m,ndim),fdifpar(m,ndim)
792        real  fdiruv(m,ndim),fdifuv(m,ndim)        _RL  fdiruv(m,ndim),fdifuv(m,ndim)
793    
794  c-----temporary array  c-----temporary array
795    
796        integer i,j,k,ik        integer i,j,k
797        real  cc(m,n,3),tauclb(m,n,np),tauclf(m,n,np)        _RL  cc(m,n,3),tauclb(m,n,np),tauclf(m,n,np)
798        real  dp(m,n,np),wh(m,n,np),oh(m,n,np),scal(m,n,np)        _RL  dp(m,n,np),wh(m,n,np),oh(m,n,np),scal(m,n,np)
799        real  swh(m,n,np+1),so2(m,n,np+1),df(m,n,np+1)        _RL  swh(m,n,np+1),so2(m,n,np+1),df(m,n,np+1)
800        real  sdf(m,n),sclr(m,n),csm(m,n),taux,x        _RL  sdf(m,n),sclr(m,n),csm(m,n),x
801    
802  c-----------------------------------------------------------------  c-----------------------------------------------------------------
803    
# Line 1013  c*************************************** Line 1010  c***************************************
1010  c-----input parameters  c-----input parameters
1011    
1012        integer m,n,ndim,np,ict,icb        integer m,n,ndim,np,ict,icb
1013        real  cosz(m,ndim),fcld(m,ndim,np),taucld(m,ndim,np,2)        _RL  cosz(m,ndim),fcld(m,ndim,np),taucld(m,ndim,np,2)
1014    
1015  c-----output parameters  c-----output parameters
1016    
1017        real  cc(m,n,3),tauclb(m,n,np),tauclf(m,n,np)        _RL  cc(m,n,3),tauclb(m,n,np),tauclf(m,n,np)
1018    
1019  c-----temporary variables  c-----temporary variables
1020    
1021        integer i,j,k,im,it,ia,kk        integer i,j,k,im,it,ia,kk
1022        real   fm,ft,fa,xai,taucl,taux        _RL   fm,ft,fa,xai,taux
1023    
1024  c-----pre-computed table  c-----pre-computed table
1025    
1026        integer   nm,nt,na        integer   nm,nt,na
1027        parameter (nm=11,nt=9,na=11)        parameter (nm=11,nt=9,na=11)
1028        real   dm,dt,da,t1,caib(nm,nt,na),caif(nt,na)        _RL   dm,dt,da,t1,caib(nm,nt,na),caif(nt,na)
1029        parameter (dm=0.1,dt=0.30103,da=0.1,t1=-0.9031)        parameter (dm=0.1,dt=0.30103,da=0.1,t1=-0.9031)
1030    
1031  c-----include the pre-computed table for cai  c-----include the pre-computed table for cai
# Line 1231  c*************************************** Line 1228  c***************************************
1228    
1229  c-----Explicit Inline Directives  c-----Explicit Inline Directives
1230    
1231  #if CRAY  #ifdef CRAY
1232  #if f77  #ifdef f77
1233  cfpp$ expand (deledd)  cfpp$ expand (deledd)
1234  cfpp$ expand (sagpol)  cfpp$ expand (sagpol)
1235  cfpp$ expand (expmn)  cfpp$ expand (expmn)
1236  #endif  #endif
1237  #endif  #endif
1238        real expmn        _RL expmn
1239    
1240  c-----input parameters  c-----input parameters
1241    
1242        integer m,n,ndim,np,ict,icb        integer m,n,ndim,np,ict,icb
1243        real  taucld(m,ndim,np,2),reff(m,ndim,np,2),fcld(m,ndim,np)        _RL  taucld(m,ndim,np,2),reff(m,ndim,np,2),fcld(m,ndim,np)
1244        real  tauclb(m,n,np),tauclf(m,n,np),cc(m,n,3)        _RL  tauclb(m,n,np),tauclf(m,n,np),cc(m,n,3)
1245        real  rsirbm(m,ndim),rsirdf(m,ndim)        _RL  rsirbm(m,ndim),rsirdf(m,ndim)
1246        real  wh(m,n,np),taual(m,ndim,np),csm(m,n)        _RL  wh(m,n,np),taual(m,ndim,np),csm(m,n)
1247    
1248  c-----output (updated) parameters  c-----output (updated) parameters
1249    
1250        real  flx(m,ndim,np+1),flc(m,ndim,np+1)        _RL  flx(m,ndim,np+1),flc(m,ndim,np+1)
1251        real  fdirir(m,ndim),fdifir(m,ndim)        _RL  fdirir(m,ndim),fdifir(m,ndim)
1252    
1253  c-----static parameters  c-----static parameters
1254    
1255        integer nk,nband        integer nk,nband
1256        parameter (nk=10,nband=3)        parameter (nk=10,nband=3)
1257        real  xk(nk),hk(nband,nk),ssaal(nband),asyal(nband)        _RL  xk(nk),hk(nband,nk),ssaal(nband),asyal(nband)
1258        real  aia(nband,3),awa(nband,3),aig(nband,3),awg(nband,3)        _RL  aia(nband,3),awa(nband,3),aig(nband,3),awg(nband,3)
1259    
1260  c-----temporary array  c-----temporary array
1261    
1262        integer ib,ik,i,j,k        integer ib,ik,i,j,k
1263        real  ssacl(m,n,np),asycl(m,n,np)        _RL  ssacl(m,n,np),asycl(m,n,np)
1264        real  rr(m,n,np+1,2),tt(m,n,np+1,2),td(m,n,np+1,2),        _RL  rr(m,n,np+1,2),tt(m,n,np+1,2),td(m,n,np+1,2),
1265       *       rs(m,n,np+1,2),ts(m,n,np+1,2)       *       rs(m,n,np+1,2),ts(m,n,np+1,2)
1266        real  rssab(m,n,np+1),rabx(m,n,np+1),rsabx(m,n,np+1)        _RL  fall(m,n,np+1),fclr(m,n,np+1)
1267        real  fall(m,n,np+1),fclr(m,n,np+1)        _RL  fsdir(m,n),fsdif(m,n)
1268        real  fsdir(m,n),fsdif(m,n)  
1269          _RL  tauwv,tausto,ssatau,asysto,tauto,ssato,asyto
1270        real  tauwv,tausto,ssatau,asysto,tauto,ssato,asyto        _RL  taux,reff1,reff2,w1,w2,g1,g2
1271        real  taux,reff1,reff2,w1,w2,g1,g2        _RL  ssaclt(m,n),asyclt(m,n)
1272        real  ssaclt(m,n),asyclt(m,n)        _RL  rr1t(m,n),tt1t(m,n),td1t(m,n),rs1t(m,n),ts1t(m,n)
1273        real  rr1t(m,n),tt1t(m,n),td1t(m,n),rs1t(m,n),ts1t(m,n)        _RL  rr2t(m,n),tt2t(m,n),td2t(m,n),rs2t(m,n),ts2t(m,n)
       real  rr2t(m,n),tt2t(m,n),td2t(m,n),rs2t(m,n),ts2t(m,n)  
1274    
1275  c-----water vapor absorption coefficient for 10 k-intervals.  c-----water vapor absorption coefficient for 10 k-intervals.
1276  c     unit: cm^2/gm  c     unit: cm^2/gm
# Line 1407  c-----integration over the k-distributio Line 1403  c-----integration over the k-distributio
1403              do i= 1, m              do i= 1, m
1404    
1405               tauwv=xk(ik)*wh(i,j,k)               tauwv=xk(ik)*wh(i,j,k)
1406    
1407  c-----compute total optical thickness, single scattering albedo,  c-----compute total optical thickness, single scattering albedo,
1408  c     and asymmetry factor.  c     and asymmetry factor.
1409    
# Line 1533  c     in certain parallel processors. Line 1529  c     in certain parallel processors.
1529    
1530  c-----flux calculations  c-----flux calculations
1531    
1532          call cldflx (m,n,np,ict,icb,cc,rr,tt,td,rs,ts,         do k= 1, np+1
1533       *               fclr,fall,fsdir,fsdif)          do j= 1, n
1534             do i= 1, m
1535              fclr(i,j,k) = 0.
1536              fall(i,j,k) = 0.
1537             enddo
1538            enddo
1539           enddo
1540           do j= 1, n
1541            do i= 1, m
1542             fsdir(i,j) = 0.
1543             fsdif(i,j) = 0.
1544            enddo
1545           enddo
1546    
1547    c       call cldflx (m,n,np,ict,icb,cc,rr,tt,td,rs,ts,
1548    c    *               fclr,fall,fsdir,fsdif)
1549    
1550         do k= 1, np+1         do k= 1, np+1
1551          do j= 1, n          do j= 1, n
# Line 1641  c*************************************** Line 1652  c***************************************
1652    
1653  c-----Explicit Inline Directives    c-----Explicit Inline Directives  
1654        
1655  #if CRAY  #ifdef CRAY
1656  #if f77    #ifdef f77  
1657  cfpp$ expand (deledd)  cfpp$ expand (deledd)
1658  cfpp$ expand (sagpol)  cfpp$ expand (sagpol)
1659  #endif    #endif  
# Line 1651  cfpp$ expand (sagpol) Line 1662  cfpp$ expand (sagpol)
1662  c-----input parameters  c-----input parameters
1663    
1664        integer m,n,ndim,np,ict,icb        integer m,n,ndim,np,ict,icb
1665        real  taucld(m,ndim,np,2),reff(m,ndim,np,2),fcld(m,ndim,np)        _RL  taucld(m,ndim,np,2),reff(m,ndim,np,2),fcld(m,ndim,np)
1666        real  tauclb(m,n,np),tauclf(m,n,np),cc(m,n,3)        _RL  tauclb(m,n,np),tauclf(m,n,np),cc(m,n,3)
1667        real  oh(m,n,np),dp(m,n,np),taual(m,ndim,np)        _RL  oh(m,n,np),dp(m,n,np),taual(m,ndim,np)
1668        real  rsuvbm(m,ndim),rsuvdf(m,ndim),csm(m,n)        _RL  rsuvbm(m,ndim),rsuvdf(m,ndim),csm(m,n)
1669    
1670  c-----output (updated) parameter  c-----output (updated) parameter
1671    
1672        real  flx(m,ndim,np+1),flc(m,ndim,np+1)        _RL  flx(m,ndim,np+1),flc(m,ndim,np+1)
1673        real  fdirpar(m,ndim),fdifpar(m,ndim)        _RL  fdirpar(m,ndim),fdifpar(m,ndim)
1674        real  fdiruv(m,ndim),fdifuv(m,ndim)        _RL  fdiruv(m,ndim),fdifuv(m,ndim)
1675    
1676  c-----static parameters  c-----static parameters
1677    
1678        integer nband        integer nband
1679        parameter (nband=8)        parameter (nband=8)
1680        real  hk(nband),xk(nband),ry(nband)        _RL  hk(nband),xk(nband),ry(nband)
1681        real  asyal(nband),ssaal(nband),aig(3),awg(3)        _RL  asyal(nband),ssaal(nband),aig(3),awg(3)
1682    
1683  c-----temporary array  c-----temporary array
1684    
1685        integer i,j,k,ib        integer i,j,k,ib
1686        real  taurs,tauoz,tausto,ssatau,asysto,tauto,ssato,asyto        _RL  taurs,tauoz,tausto,ssatau,asysto,tauto,ssato,asyto
1687        real  taux,reff1,reff2,g1,g2,asycl(m,n,np)        _RL  taux,reff1,reff2,g1,g2,asycl(m,n,np)
1688        real  td(m,n,np+1,2),rr(m,n,np+1,2),tt(m,n,np+1,2),        _RL  td(m,n,np+1,2),rr(m,n,np+1,2),tt(m,n,np+1,2),
1689       *       rs(m,n,np+1,2),ts(m,n,np+1,2)       *       rs(m,n,np+1,2),ts(m,n,np+1,2)
1690        real  upflux(m,n,np+1),dwflux(m,n,np+1),        _RL  fall(m,n,np+1),fclr(m,n,np+1),fsdir(m,n),fsdif(m,n)
1691       *     rssab(m,n,np+1),rabx(m,n,np+1),rsabx(m,n,np+1)        _RL  asyclt(m,n)
1692        real  fall(m,n,np+1),fclr(m,n,np+1),fsdir(m,n),fsdif(m,n)        _RL  rr1t(m,n),tt1t(m,n),td1t(m,n),rs1t(m,n),ts1t(m,n)
1693        real  asyclt(m,n)        _RL  rr2t(m,n),tt2t(m,n),td2t(m,n),rs2t(m,n),ts2t(m,n)
       real  rr1t(m,n),tt1t(m,n),td1t(m,n),rs1t(m,n),ts1t(m,n)  
       real  rr2t(m,n),tt2t(m,n),td2t(m,n),rs2t(m,n),ts2t(m,n)  
1694    
1695  c-----hk is the fractional extra-terrestrial solar flux.  c-----hk is the fractional extra-terrestrial solar flux.
1696  c     the sum of hk is 0.47074.  c     the sum of hk is 0.47074.
# Line 1892  c-----compute reflectance and transmitta Line 1901  c-----compute reflectance and transmitta
1901    
1902  c-----flux calculations  c-----flux calculations
1903    
1904          call cldflx (m,n,np,ict,icb,cc,rr,tt,td,rs,ts,         do k= 1, np+1
1905       *               fclr,fall,fsdir,fsdif)          do j= 1, n
1906             do i= 1, m
1907              fclr(i,j,k) = 0.
1908              fall(i,j,k) = 0.
1909             enddo
1910            enddo
1911           enddo
1912           do j= 1, n
1913            do i= 1, m
1914             fsdir(i,j) = 0.
1915             fsdif(i,j) = 0.
1916            enddo
1917           enddo
1918    c       call cldflx (m,n,np,ict,icb,cc,rr,tt,td,rs,ts,
1919    c    *               fclr,fall,fsdir,fsdif)
1920    
1921         do k= 1, np+1         do k= 1, np+1
1922          do j= 1, n          do j= 1, n
# Line 1958  c*************************************** Line 1981  c***************************************
1981    
1982  c-----Explicit Inline Directives    c-----Explicit Inline Directives  
1983        
1984  #if CRAY  #ifdef CRAY
1985  #if f77    #ifdef f77  
1986  cfpp$ expand (expmn)  cfpp$ expand (expmn)
1987  #endif    #endif  
1988  #endif  #endif
1989        real expmn        _RL expmn
1990    
1991        real  zero,one,two,three,four,fourth,seven,tumin        _RL  zero,one,two,three,four,fourth,seven,tumin
1992        parameter (one=1., three=3.)        parameter (one=1., three=3.)
1993        parameter (seven=7., two=2.)        parameter (seven=7., two=2.)
1994        parameter (four=4., fourth=.25)        parameter (four=4., fourth=.25)
1995        parameter (zero=0., tumin=1.e-20)        parameter (zero=0., tumin=1.e-20)
1996    
1997  c-----input parameters  c-----input parameters
1998        real  tau,ssc,g0,csm        _RL  tau,ssc,g0,csm
1999    
2000  c-----output parameters  c-----output parameters
2001        real  rr,tt,td        _RL  rr,tt,td
2002    
2003  c-----temporary parameters  c-----temporary parameters
2004    
2005        real  zth,ff,xx,taup,sscp,gp,gm1,gm2,gm3,akk,alf1,alf2,        _RL  zth,ff,xx,taup,sscp,gp,gm1,gm2,gm3,akk,alf1,alf2,
2006       *     all,bll,st7,st8,cll,dll,fll,ell,st1,st2,st3,st4       *     all,bll,st7,st8,cll,dll,fll,ell,st1,st2,st3,st4
2007  c  c
2008                  zth = one / csm                  zth = one / csm
# Line 2082  c*************************************** Line 2105  c***************************************
2105    
2106  c-----Explicit Inline Directives    c-----Explicit Inline Directives  
2107        
2108  #if CRAY  #ifdef CRAY
2109  #if f77    #ifdef f77  
2110  cfpp$ expand (expmn)  cfpp$ expand (expmn)
2111  #endif    #endif  
2112  #endif  #endif
2113        real expmn        _RL expmn
2114    
2115        real  one,three,four        _RL  one,three,four
2116        parameter (one=1., three=3., four=4.)        parameter (one=1., three=3., four=4.)
2117    
2118  c-----output parameters:  c-----output parameters:
2119    
2120        real  tau,ssc,g0        _RL  tau,ssc,g0
2121    
2122  c-----output parameters:  c-----output parameters:
2123    
2124        real  rll,tll        _RL  rll,tll
2125    
2126  c-----temporary arrays  c-----temporary arrays
2127    
2128        real  xx,uuu,ttt,emt,up1,um1,st1        _RL  xx,uuu,ttt,emt,up1,um1,st1
2129    
2130               xx  = one-ssc*g0               xx  = one-ssc*g0
2131               uuu = sqrt( xx/(one-ssc))               uuu = sqrt( xx/(one-ssc))
# Line 2124  c*************************************** Line 2147  c***************************************
2147    
2148  c*******************************************************************  c*******************************************************************
2149  c compute exponential for arguments in the range 0> fin > -10.  c compute exponential for arguments in the range 0> fin > -10.
2150    c*******************************************************************
2151          implicit none
2152          _RL  fin,expmn
2153    
2154          _RL one,expmin,e1,e2,e3,e4
2155        parameter (one=1.0, expmin=-10.0)        parameter (one=1.0, expmin=-10.0)
2156        parameter (e1=1.0,        e2=-2.507213e-1)        parameter (e1=1.0,        e2=-2.507213e-1)
2157        parameter (e3=2.92732e-2, e4=-3.827800e-3)        parameter (e3=2.92732e-2, e4=-3.827800e-3)
       real  fin,expmn  
2158    
2159        if (fin .lt. expmin) fin = expmin        if (fin .lt. expmin) fin = expmin
2160        expmn = ((e4*fin + e3)*fin+e2)*fin+e1        expmn = ((e4*fin + e3)*fin+e2)*fin+e1
# Line 2178  c-----input parameters Line 2204  c-----input parameters
2204    
2205        integer m,n,np,ict,icb        integer m,n,np,ict,icb
2206    
2207        real  rr(m,n,np+1,2),tt(m,n,np+1,2),td(m,n,np+1,2)        _RL  rr(m,n,np+1,2),tt(m,n,np+1,2),td(m,n,np+1,2)
2208        real  rs(m,n,np+1,2),ts(m,n,np+1,2)        _RL  rs(m,n,np+1,2),ts(m,n,np+1,2)
2209        real  cc(m,n,3)        _RL  cc(m,n,3)
2210    
2211  c-----temporary array  c-----temporary array
2212    
2213        integer i,j,k,ih,im,is        integer i,j,k,ih,im,is
2214        real  rra(m,n,np+1,2,2),tta(m,n,np+1,2,2),tda(m,n,np+1,2,2)        _RL  rra(m,n,np+1,2,2),tta(m,n,np+1,2,2),tda(m,n,np+1,2,2)
2215        real  rsa(m,n,np+1,2,2),rxa(m,n,np+1,2,2)        _RL  rsa(m,n,np+1,2,2),rxa(m,n,np+1,2,2)
2216        real  ch(m,n),cm(m,n),ct(m,n),flxdn(m,n,np+1)        _RL  ch(m,n),cm(m,n),ct(m,n),flxdn(m,n,np+1)
2217        real  fdndir(m,n),fdndif(m,n),fupdif        _RL  fdndir(m,n),fdndif(m,n),fupdif
2218        real  denm,xx        _RL  denm,xx
2219    
2220  c-----output parameters  c-----output parameters
2221    
2222        real  fclr(m,n,np+1),fall(m,n,np+1)        _RL  fclr(m,n,np+1),fall(m,n,np+1)
2223        real  fsdir(m,n),fsdif(m,n)        _RL  fsdir(m,n),fsdif(m,n)
2224    
2225  c-----initialize all-sky flux (fall) and surface downward fluxes  c-----initialize all-sky flux (fall) and surface downward fluxes
2226    
# Line 2494  c     due to co2 absorption. Line 2520  c     due to co2 absorption.
2520  c-----input parameters  c-----input parameters
2521    
2522        integer m,n,np        integer m,n,np
2523        real  csm(m,n),swc(m,n,np+1),swh(m,n,np+1),cah(22,19)        _RL  csm(m,n),swc(m,n,np+1),swh(m,n,np+1),cah(22,19)
2524    
2525  c-----output (undated) parameter  c-----output (undated) parameter
2526    
2527        real  df(m,n,np+1)        _RL  df(m,n,np+1)
2528    
2529  c-----temporary array  c-----temporary array
2530    
2531        integer i,j,k,ic,iw        integer i,j,k,ic,iw
2532        real  xx,clog,wlog,dc,dw,x1,x2,y2        _RL  xx,clog,wlog,dc,dw,x1,x2,y2
2533    
2534  c********************************************************************  c********************************************************************
2535  c-----include co2 look-up table  c-----include co2 look-up table
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22