/[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.12 by molod, Mon Jul 26 18:45:17 2004 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3                                                                                        
4        subroutine swrio (nymd,nhms,ndswr,myid,istrip,npcs,  #include "FIZHI_OPTIONS.h"
5       .                  pz,tz,qz,pkht,oz,co2,        subroutine swrio (nymd,nhms,bi,bj,ndswr,myid,istrip,npcs,
6       .                  albvisdr,albvisdf,albnirdr,albnirdf,       .        low_level,mid_level,
7       .                  dtradsw,dtswclr,radswg,swgclr,albedo,       .        pz,plz,plze,dpres,pkht,pkz,tz,qz,oz,co2,
8       .                  fdifpar,fdirpar,osr,osrclr,       .        albvisdr,albvisdf,albnirdr,albnirdf,
9       .                  im,jm,lm,sige,sig,dsig,ptop,       .        dtradsw,dtswclr,radswg,swgclr,
10       .                  nswcld,cldsw,cswmo,nswlz,swlz,       .        fdifpar,fdirpar,osr,osrclr,
11       .                  lpnt,qdiag,nd,       .        im,jm,lm,ptop,
12       .                  imstturb,qliqave,fccave,landtype,xlats,xlons)       .        nswcld,cldsw,cswmo,nswlz,swlz,
13         .        lpnt,imstturb,qliqave,fccave,landtype,xlats,xlons)
14    
15        implicit none        implicit none
16        include 'diag.com'  #ifdef ALLOW_DIAGNOSTICS
17    #include "SIZE.h"
18    #include "diagnostics_SIZE.h"
19    #include "diagnostics.h"
20    #endif
21    
22  c Input Variables  c Input Variables
23  c ---------------  c ---------------
24        integer nymd,nhms,ndswr,istrip,npcs,nd        integer nymd,nhms,bi,bj,ndswr,myid,istrip,npcs
25          integer mid_level,low_level
26        integer im,jm,lm        ! Physics Grid        integer im,jm,lm        
27        real  ptop              ! Physics Grid        _RL  ptop
28        real  sige(lm+1)        ! Physics Grid        _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1),dpres(im,jm,lm)
29        real   sig(lm)          ! Physics Grid        _RL pkht(im,jm,lm+1),pkz(im,jm,lm)
30        real  dsig(lm)          ! Physics Grid        _RL tz(im,jm,lm),qz(im,jm,lm)
31          _RL oz(im,jm,lm)
32        real    pz(im,jm)       ! Dynamics State        _RL co2
33        real    tz(im,jm,lm)    ! Dynamics State        _RL albvisdr(im,jm),albvisdf(im,jm),albnirdr(im,jm)
34        real  pkht(im,jm,lm)    ! Dynamics State        _RL albnirdf(im,jm)
35          _RL radswg(im,jm),swgclr(im,jm),fdifpar(im,jm),fdirpar(im,jm)
36        real    co2             ! Chemistry State        _RL osr(im,jm),osrclr(im,jm),dtradsw(im,jm,lm),dtswclr(im,jm,lm)
37        real    oz(im,jm,lm)    ! Chemistry Coupling        integer nswcld,nswlz    
38        real    qz(im,jm,lm)    ! Chemistry Coupling + Dynamics State        _RL cldsw(im,jm,lm),cswmo(im,jm,lm),swlz(im,jm,lm)  
39          logical lpnt            
40        real albvisdr(im,jm)    ! Land Coupling        integer imstturb        
41        real albvisdf(im,jm)    ! Land Coupling        _RL qliqave(im,jm,lm),fccave(im,jm,lm)  
42        real albnirdr(im,jm)    ! Land Coupling        integer landtype(im,jm)
43        real albnirdf(im,jm)    ! Land Coupling        _RL xlats(im,jm),xlons(im,jm)
   
       real   radswg(im,jm)    ! Shortwave Coupling  
       real   swgclr(im,jm)    ! Shortwave Coupling  
       real   albedo(im,jm)    ! Shortwave Coupling  
       real  fdifpar(im,jm)    ! Shortwave Coupling  
       real  fdirpar(im,jm)    ! Shortwave Coupling  
       real      osr(im,jm)    ! Shortwave Coupling  
       real   osrclr(im,jm)    ! Shortwave Coupling  
       real  dtradsw(im,jm,lm) ! Shortwave Tendency  
       real  dtswclr(im,jm,lm) ! Shortwave Tendency  
   
       integer nswcld,nswlz    ! Moist Coupling  
       real  cldsw(im,jm,lm)   ! Moist Coupling  
       real  cswmo(im,jm,lm)   ! Moist Coupling  
       real   swlz(im,jm,lm)   ! Moist Coupling  
   
       real  qdiag(im,jm,nd)   ! Diagnostics  
       logical lpnt            ! Point by Point Flag  
       integer imstturb        ! Turb Coupling  
       real qliqave(im,jm,lm)  ! Turb Coupling  
       real  fccave(im,jm,lm)  ! Turb Coupling  
   
       integer landtype(im,jm) ! Surface Land Type  
44    
45  c Local Variables  c Local Variables
46  c ---------------  c ---------------
47        integer   i,j,L,nn,nsecf,mid_level, low_level        integer   i,j,L,nn,nsecf
48        integer   nb2,ntmstp,nymd2,nhms2        integer   ntmstp,nymd2,nhms2
49        real      getcon,grav,cp,undef,pcheck        _RL      getcon,grav,cp,undef
50        real      ra,alf,reffw,reffi,tminv        _RL      ra,alf,reffw,reffi,tminv
51    
52        parameter ( reffw = 10.0 )   ! Effective radius for water droplets        parameter ( reffw = 10.0 )  
53        parameter ( reffi = 65.0 )   ! Effective radius for ice   particles        parameter ( reffi = 65.0 )  
54    
55        real      alat(im,jm)        _RL tdry(im,jm,lm)
56        real      alon(im,jm)        _RL TEMP1(im,jm)
57          _RL TEMP2(im,jm)
58        real          PKZ(im,jm,lm)        _RL zenith (im,jm)
59        real          PLZ(im,jm,lm)        _RL cldtot (im,jm,lm)
60        real         tdry(im,jm,lm)        _RL cldmxo (im,jm,lm)
61        real         PLZE(im,jm,lm+1)        _RL totcld (im,jm)
62        real        TEMP1(im,jm)        _RL cldlow (im,jm)
63        real        TEMP2(im,jm)        _RL cldmid (im,jm)
64        real      zenith (im,jm)        _RL cldhi  (im,jm)
65        real      cldtot (im,jm,lm)        _RL taulow (im,jm)
66        real      cldmxo (im,jm,lm)        _RL taumid (im,jm)
67        real      totcld (im,jm)        _RL tauhi  (im,jm)
68        real      cldlow (im,jm)        _RL tautype(im,jm,lm,3)
69        real      cldmid (im,jm)        _RL tau(im,jm,lm)
70        real      cldhi  (im,jm)        _RL albedo(im,jm)    
71        real      taulow (im,jm)  
72        real      taumid (im,jm)        _RL PK(ISTRIP,lm)
73        real      tauhi  (im,jm)        _RL qzl(ISTRIP,lm),CLRO(ISTRIP,lm)
74        real      tautype(im,jm,lm,3)        _RL TZL(ISTRIP,lm)
75        real      tau    (im,jm,lm)        _RL OZL(ISTRIP,lm)
76          _RL PLE(ISTRIP,lm+1)
77        real          PK(ISTRIP,lm)        _RL COSZ(ISTRIP)
78        real         qzl(ISTRIP,lm),  CLRO(ISTRIP,lm)        _RL dpstrip(ISTRIP,lm)
79        real         TZL(ISTRIP,lm)  
80        real         OZL(ISTRIP,lm)        _RL albuvdr(ISTRIP),albuvdf(ISTRIP)
81        real         PLE(ISTRIP,lm+1)        _RL albirdr(ISTRIP),albirdf(ISTRIP)
82        real        COSZ(ISTRIP)        _RL difpar (ISTRIP),dirpar (ISTRIP)
83    
84        real      albuvdr(ISTRIP),albuvdf(ISTRIP)        _RL fdirir(istrip),fdifir(istrip)
85        real      albirdr(ISTRIP),albirdf(ISTRIP)        _RL fdiruv(istrip),fdifuv(istrip)
86        real      difpar (ISTRIP),dirpar (ISTRIP)  
87          _RL flux(istrip,lm+1)
88        real      fdirir(istrip),fdifir(istrip)        _RL fluxclr(istrip,lm+1)
89        real      fdiruv(istrip),fdifuv(istrip)        _RL dtsw(istrip,lm)
90          _RL dtswc(istrip,lm)
91        real      flux   (istrip,lm+1)  
92        real      fluxclr(istrip,lm+1)        _RL taul   (istrip,lm)
93        real      dtsw   (istrip,lm)        _RL reff   (istrip,lm,2)
94        real      dtswc  (istrip,lm)        _RL tauc   (istrip,lm,2)
95          _RL taua   (istrip,lm)
96        real      taul   (istrip,lm)        _RL tstrip (istrip)
97        real      reff   (istrip,lm,2)  
98        real      tauc   (istrip,lm,2)        logical first
99        real      taua   (istrip,lm)        data first /.true./
       real      tstrip (istrip)  
   
       logical   first  
       data      first /.true./  
   
       integer   koz, kh2o  
       data      KOZ  /20/  
       data      kh2o /18/  
100    
101  C **********************************************************************  C **********************************************************************
102  C ****                       INITIALIZATION                         ****  C ****                       INITIALIZATION                         ****
# Line 135  C ************************************** Line 109  C **************************************
109        NTMSTP = nsecf(NDSWR)        NTMSTP = nsecf(NDSWR)
110        TMINV  = 1./float(ntmstp)        TMINV  = 1./float(ntmstp)
111    
       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 )  
   
112  C Compute Temperature from Theta  C Compute Temperature from Theta
113  C ------------------------------  C ------------------------------
114        do L=1,lm        do L=1,lm
# Line 162  C ------------------------------ Line 119  C ------------------------------
119        enddo        enddo
120        enddo        enddo
121    
 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  
   
122        if (first .and. myid.eq.0 ) then        if (first .and. myid.eq.0 ) then
123        print *        print *
124        print *,'Low-Level Clouds are Grouped between levels: ',        print *,'Low-Level Clouds are Grouped between levels: ',
# Line 186  C ************************************** Line 133  C **************************************
133  C ****             CALCULATE COSINE OF THE ZENITH ANGLE             ****  C ****             CALCULATE COSINE OF THE ZENITH ANGLE             ****
134  C **********************************************************************  C **********************************************************************
135    
136        CALL ASTRO ( NYMD,   NHMS,  ALAT,ALON, im*jm, TEMP1,RA )        CALL ASTRO ( NYMD,   NHMS,  XLATS,XLONS, im*jm, TEMP1,RA )
137                     NYMD2 = NYMD                     NYMD2 = NYMD
138                     NHMS2 = NHMS                     NHMS2 = NHMS
139        CALL TICK  ( NYMD2,  NHMS2, NTMSTP )        CALL TICK  ( NYMD2,  NHMS2, NTMSTP )
140        CALL ASTRO ( NYMD2,  NHMS2, ALAT,ALON, im*jm, TEMP2,RA )        CALL ASTRO ( NYMD2,  NHMS2, XLATS,XLONS, im*jm, TEMP2,RA )
141    
142        do j = 1,jm        do j = 1,jm
143        do i = 1,im        do i = 1,im
# Line 223  c -------------------------------------- Line 170  c --------------------------------------
170          do L =1,lm          do L =1,lm
171          do j =1,jm          do j =1,jm
172          do i =1,im          do i =1,im
173           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))
174           cldmxo(i,j,L) =  min( 1.0,    cswmo(i,j,L) )           cldmxo(i,j,L)=min(1.0,cswmo(i,j,L))
175             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
176          enddo          enddo
177          enddo          enddo
178          enddo          enddo
# Line 277  c ------------------------- Line 224  c -------------------------
224        if(icldfrc.gt.0) then        if(icldfrc.gt.0) then
225        do j=1,jm        do j=1,jm
226        do i=1,im        do i=1,im
227        qdiag(i,j,icldfrc) =  qdiag(i,j,icldfrc) + totcld(i,j)        qdiag(i,j,icldfrc,bi,bj) =  qdiag(i,j,icldfrc,bi,bj) + totcld(i,j)
228        enddo        enddo
229        enddo        enddo
230        ncldfrc = ncldfrc + 1        ncldfrc = ncldfrc + 1
# Line 287  c ------------------------- Line 234  c -------------------------
234        do L=1,lm        do L=1,lm
235        do j=1,jm        do j=1,jm
236        do i=1,im        do i=1,im
237        qdiag(i,j,icldras+L-1) = qdiag(i,j,icldras+L-1) + cswmo(i,j,L)        qdiag(i,j,icldras+L-1,bi,bj) = qdiag(i,j,icldras+L-1,bi,bj) +
238         .                                                     cswmo(i,j,L)
239        enddo        enddo
240        enddo        enddo
241        enddo        enddo
# Line 298  c ------------------------- Line 246  c -------------------------
246        do L=1,lm        do L=1,lm
247        do j=1,jm        do j=1,jm
248        do i=1,im        do i=1,im
249        qdiag(i,j,icldtot+L-1) = qdiag(i,j,icldtot+L-1) + cldtot(i,j,L)        qdiag(i,j,icldtot+L-1,bi,bj) = qdiag(i,j,icldtot+L-1,bi,bj) +
250         .                                                     cldtot(i,j,L)
251        enddo        enddo
252        enddo        enddo
253        enddo        enddo
# Line 308  c ------------------------- Line 257  c -------------------------
257        if( icldlow.gt.0 ) then        if( icldlow.gt.0 ) then
258        do j=1,jm        do j=1,jm
259        do i=1,im        do i=1,im
260        qdiag(i,j,icldlow) = qdiag(i,j,icldlow) + cldlow(i,j)        qdiag(i,j,icldlow,bi,bj) = qdiag(i,j,icldlow,bi,bj) + cldlow(i,j)
261        enddo        enddo
262        enddo        enddo
263        ncldlow = ncldlow + 1        ncldlow = ncldlow + 1
# Line 317  c ------------------------- Line 266  c -------------------------
266        if( icldmid.gt.0 ) then        if( icldmid.gt.0 ) then
267        do j=1,jm        do j=1,jm
268        do i=1,im        do i=1,im
269        qdiag(i,j,icldmid) = qdiag(i,j,icldmid) + cldmid(i,j)        qdiag(i,j,icldmid,bi,bj) = qdiag(i,j,icldmid,bi,bj) + cldmid(i,j)
270        enddo        enddo
271        enddo        enddo
272        ncldmid = ncldmid + 1        ncldmid = ncldmid + 1
# Line 326  c ------------------------- Line 275  c -------------------------
275        if( icldhi.gt.0 ) then        if( icldhi.gt.0 ) then
276        do j=1,jm        do j=1,jm
277        do i=1,im        do i=1,im
278        qdiag(i,j,icldhi) = qdiag(i,j,icldhi) + cldhi(i,j)        qdiag(i,j,icldhi,bi,bj) = qdiag(i,j,icldhi,bi,bj) + cldhi(i,j)
279        enddo        enddo
280        enddo        enddo
281        ncldhi = ncldhi + 1        ncldhi = ncldhi + 1
# Line 336  c ------------------------- Line 285  c -------------------------
285        do L=1,lm        do L=1,lm
286        do j=1,jm        do j=1,jm
287        do i=1,im        do i=1,im
288        qdiag(i,j,ilzrad+L-1) = qdiag(i,j,ilzrad+L-1) + swlz(i,j,L)*1.0e6        qdiag(i,j,ilzrad+L-1,bi,bj) = qdiag(i,j,ilzrad+L-1,bi,bj) +
289         .                                                     swlz(i,j,L)*1.0e6
290        enddo        enddo
291        enddo        enddo
292        enddo        enddo
# Line 348  c ------------------ Line 298  c ------------------
298        if( ialbvisdr.gt.0 ) then        if( ialbvisdr.gt.0 ) then
299        do j=1,jm        do j=1,jm
300        do i=1,im        do i=1,im
301        qdiag(i,j,ialbvisdr) = qdiag(i,j,ialbvisdr) + albvisdr(i,j)        qdiag(i,j,ialbvisdr,bi,bj) = qdiag(i,j,ialbvisdr,bi,bj) +
302         .                                                     albvisdr(i,j)
303        enddo        enddo
304        enddo        enddo
305        nalbvisdr = nalbvisdr + 1        nalbvisdr = nalbvisdr + 1
# Line 357  c ------------------ Line 308  c ------------------
308        if( ialbvisdf.gt.0 ) then        if( ialbvisdf.gt.0 ) then
309        do j=1,jm        do j=1,jm
310        do i=1,im        do i=1,im
311        qdiag(i,j,ialbvisdf) = qdiag(i,j,ialbvisdf) + albvisdf(i,j)        qdiag(i,j,ialbvisdf,bi,bj) = qdiag(i,j,ialbvisdf,bi,bj) +
312         .                                                     albvisdf(i,j)
313        enddo        enddo
314        enddo        enddo
315        nalbvisdf = nalbvisdf + 1        nalbvisdf = nalbvisdf + 1
# Line 366  c ------------------ Line 318  c ------------------
318        if( ialbnirdr.gt.0 ) then        if( ialbnirdr.gt.0 ) then
319        do j=1,jm        do j=1,jm
320        do i=1,im        do i=1,im
321        qdiag(i,j,ialbnirdr) = qdiag(i,j,ialbnirdr) + albnirdr(i,j)        qdiag(i,j,ialbnirdr,bi,bj) = qdiag(i,j,ialbnirdr,bi,bj) +
322         .                                                     albnirdr(i,j)
323        enddo        enddo
324        enddo        enddo
325        nalbnirdr = nalbnirdr + 1        nalbnirdr = nalbnirdr + 1
# Line 375  c ------------------ Line 328  c ------------------
328        if( ialbnirdf.gt.0 ) then        if( ialbnirdf.gt.0 ) then
329        do j=1,jm        do j=1,jm
330        do i=1,im        do i=1,im
331        qdiag(i,j,ialbnirdf) = qdiag(i,j,ialbnirdf) + albnirdf(i,j)        qdiag(i,j,ialbnirdf,bi,bj) = qdiag(i,j,ialbnirdf,bi,bj) +
332         .                                                     albnirdf(i,j)
333        enddo        enddo
334        enddo        enddo
335        nalbnirdf = nalbnirdf + 1        nalbnirdf = nalbnirdf + 1
# Line 383  c ------------------ Line 337  c ------------------
337    
338  C Compute Optical Thicknesses and Diagnostics  C Compute Optical Thicknesses and Diagnostics
339  C -------------------------------------------  C -------------------------------------------
340        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,
341         .                                                          tautype)
342    
343        do L = 1,lm        do L = 1,lm
344        do j = 1,jm        do j = 1,jm
345        do i = 1,im        do i = 1,im
346        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)
347        enddo        enddo
348        enddo        enddo
349        enddo        enddo
# Line 397  C -------------------------------------- Line 352  C --------------------------------------
352        do L=1,lm        do L=1,lm
353        do j=1,jm        do j=1,jm
354        do i=1,im        do i=1,im
355        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,bi,bj) = qdiag(i,j,itauave+L-1,bi,bj) +
356         .                        tau(i,j,L)*100/(plze(i,j,L+1)-plze(i,j,L))
357        enddo        enddo
358        enddo        enddo
359        enddo        enddo
# Line 408  C -------------------------------------- Line 364  C --------------------------------------
364        do L=1,lm        do L=1,lm
365        do j=1,jm        do j=1,jm
366        do i=1,im        do i=1,im
367           if( cldtot(i,j,L).ne.0.0 ) then         if( cldtot(i,j,L).ne.0.0 ) then
368                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,bi,bj) = qdiag(i,j,itaucld +L-1,bi,bj) +
369                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))
370           endif          qdiag(i,j,itaucldc+L-1,bi,bj) =
371         .                             qdiag(i,j,itaucldc+L-1,bi,bj) + 1.0
372           endif
373        enddo        enddo
374        enddo        enddo
375        enddo        enddo
# Line 420  C -------------------------------------- Line 378  C --------------------------------------
378  c Compute Low, Mid, and High Cloud Optical Depth Diagnostics  c Compute Low, Mid, and High Cloud Optical Depth Diagnostics
379  c ----------------------------------------------------------  c ----------------------------------------------------------
380        if( itaulow.ne.0 ) then        if( itaulow.ne.0 ) then
381            do j = 1,jm         do j = 1,jm
382            do i = 1,im         do i = 1,im
383            if( cldlow(i,j).ne.0.0 ) then          if( cldlow(i,j).ne.0.0 ) then
384                taulow(i,j) =  0.0           taulow(i,j) =  0.0
385                do L = low_level,lm           do L = low_level,lm
386                taulow(i,j) = taulow(i,j) + tau(i,j,L)            taulow(i,j) = taulow(i,j) + tau(i,j,L)
387                enddo           enddo
388                 qdiag(i,j,itaulow ) = qdiag(i,j,itaulow ) + taulow(i,j)           qdiag(i,j,itaulow,bi,bj ) = qdiag(i,j,itaulow,bi,bj ) +
389                 qdiag(i,j,itaulowc) = qdiag(i,j,itaulowc) + 1.0       .                                                    taulow(i,j)
390            endif           qdiag(i,j,itaulowc,bi,bj) = qdiag(i,j,itaulowc,bi,bj) + 1.0
391            enddo          endif
392            enddo         enddo
393           enddo
394        endif        endif
395    
396        if( itaumid.ne.0 ) then        if( itaumid.ne.0 ) then
397            do j = 1,jm         do j = 1,jm
398            do i = 1,im         do i = 1,im
399            if( cldmid(i,j).ne.0.0 ) then          if( cldmid(i,j).ne.0.0 ) then
400                taumid(i,j) =  0.0           taumid(i,j) =  0.0
401                do L = mid_level,low_level+1           do L = mid_level,low_level+1
402                taumid(i,j) = taumid(i,j) + tau(i,j,L)            taumid(i,j) = taumid(i,j) + tau(i,j,L)
403                enddo           enddo
404                 qdiag(i,j,itaumid ) = qdiag(i,j,itaumid ) + taumid(i,j)           qdiag(i,j,itaumid,bi,bj ) = qdiag(i,j,itaumid,bi,bj ) +
405                 qdiag(i,j,itaumidc) = qdiag(i,j,itaumidc) + 1.0       .                                                    taumid(i,j)
406            endif           qdiag(i,j,itaumidc,bi,bj) = qdiag(i,j,itaumidc,bi,bj) + 1.0
407            enddo          endif
408            enddo         enddo
409           enddo
410        endif        endif
411    
412        if( itauhi.ne.0 ) then        if( itauhi.ne.0 ) then
413            do j = 1,jm         do j = 1,jm
414            do i = 1,im         do i = 1,im
415            if( cldhi(i,j).ne.0.0 ) then          if( cldhi(i,j).ne.0.0 ) then
416                tauhi(i,j) =  0.0           tauhi(i,j) =  0.0
417                do L = 1,mid_level+1           do L = 1,mid_level+1
418                tauhi(i,j) = tauhi(i,j) + tau(i,j,L)            tauhi(i,j) = tauhi(i,j) + tau(i,j,L)
419                enddo           enddo
420                 qdiag(i,j,itauhi ) = qdiag(i,j,itauhi ) + tauhi(i,j)           qdiag(i,j,itauhi,bi,bj ) = qdiag(i,j,itauhi,bi,bj ) +
421                 qdiag(i,j,itauhic) = qdiag(i,j,itauhic) + 1.0       .                                                   tauhi(i,j)
422            endif           qdiag(i,j,itauhic,bi,bj) = qdiag(i,j,itauhic,bi,bj) + 1.0
423            enddo          endif
424            enddo         enddo
425           enddo
426        endif        endif
427    
428  C***********************************************************************  C***********************************************************************
# Line 476  C ************************************** Line 437  C **************************************
437    
438        CALL STRIP ( zenith,COSZ,im*jm,ISTRIP,1,NN )        CALL STRIP ( zenith,COSZ,im*jm,ISTRIP,1,NN )
439    
440        CALL STRIP ( plze, ple   ,im*jm,ISTRIP,lm+1,NN)        CALL STRIP ( plze,  ple   ,im*jm,ISTRIP,lm+1,NN)
441        CALL STRIP ( pkz , pk    ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( pkz ,  pk    ,im*jm,ISTRIP,lm  ,NN)
442        CALL STRIP ( tdry, tzl   ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( dpres,dpstrip,im*jm,ISTRIP,lm  ,NN)
443        CALL STRIP ( qz  , qzl   ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( tdry,  tzl   ,im*jm,ISTRIP,lm  ,NN)
444        CALL STRIP ( oz  , ozl   ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( qz  ,  qzl   ,im*jm,ISTRIP,lm  ,NN)
445        CALL STRIP ( tau , taul  ,im*jm,ISTRIP,lm  ,NN)        CALL STRIP ( oz  ,  ozl   ,im*jm,ISTRIP,lm  ,NN)
446          CALL STRIP ( tau ,  taul  ,im*jm,ISTRIP,lm  ,NN)
447    
448        CALL STRIP ( albvisdr,albuvdr,im*jm,ISTRIP,1,NN )        CALL STRIP ( albvisdr,albuvdr,im*jm,ISTRIP,1,NN )
449        CALL STRIP ( albvisdf,albuvdf,im*jm,ISTRIP,1,NN )        CALL STRIP ( albvisdf,albuvdf,im*jm,ISTRIP,1,NN )
# Line 528  C ****     Compute Mass-Weighted Theta T Line 490  C ****     Compute Mass-Weighted Theta T
490  C **********************************************************************  C **********************************************************************
491    
492        do l=1,lm        do l=1,lm
       alf = grav/(cp*dsig(L)*100)  
493        do i=1,istrip        do i=1,istrip
494          alf = grav*(ple(i,L+1)-ptop)/(cp*dpstrip(i,L)*100)
495        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)
496        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)
497        enddo        enddo
# Line 550  C ************************************** Line 512  C **************************************
512  c Calculate Mean Albedo  c Calculate Mean Albedo
513  c ---------------------  c ---------------------
514        do i=1,istrip        do i=1,istrip
515        if( cosz(i).gt.0.0 ) then         if( cosz(i).gt.0.0 ) then
516              tstrip(i) = 1.0 - flux(i,lm+1)/( fdirir(i)+fdifir(i)+dirpar(i)+difpar(i)          tstrip(i) = 1.0 - flux(i,lm+1)/
517       .                                     + fdiruv(i)+fdifuv(i) )       . ( fdirir(i)+fdifir(i)+dirpar(i)+difpar(i) + fdiruv(i)+fdifuv(i) )
518          if( tstrip(i).lt.0.0 ) tstrip(i) = undef          if( tstrip(i).lt.0.0 ) tstrip(i) = undef
519        else         else
520              tstrip(i) = undef          tstrip(i) = undef
521        endif         endif
522        enddo        enddo
523        call paste ( tstrip,albedo,istrip,im*jm,1,nn )        call paste ( tstrip,albedo,istrip,im*jm,1,nn )
524    
# Line 568  c ---------------------- Line 530  c ----------------------
530        do j=1,jm        do j=1,jm
531        do i=1,im        do i=1,im
532        if( albedo(i,j).ne.undef ) then        if( albedo(i,j).ne.undef ) then
533        qdiag(i,j,ialbedo ) = qdiag(i,j,ialbedo ) + albedo(i,j)        qdiag(i,j,ialbedo,bi,bj ) = qdiag(i,j,ialbedo,bi,bj )+albedo(i,j)
534        qdiag(i,j,ialbedoc) = qdiag(i,j,ialbedoc) + 1.0        qdiag(i,j,ialbedoc,bi,bj) = qdiag(i,j,ialbedoc,bi,bj) + 1.0
535        endif        endif
536        enddo        enddo
537        enddo        enddo
# Line 623  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 672  c --------------- Line 632  c ---------------
632    
633  c Large-Scale Water  c Large-Scale Water
634  c -----------------  c -----------------
635    C Over Land
636           if( lwi(i,j).le.10 ) then           if( lwi(i,j).le.10 ) then
637                  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) )  
638                  tau(i,j,L,3) = fracls*alf*tauh2o*dp            tau(i,j,L,3) = fracls*alf*tauh2o*dp
639           else           else
640              if( lz(i,j,L).eq.0.0 ) then  C Non-Precipitation Clouds Over Ocean
641                  tauh2o = .12                      ! Non-Precipitation Clouds Over Ocean            if( lz(i,j,L).eq.0.0 ) then
642                  tau(i,j,L,2) = fracls*alf*tauh2o*dp             tauh2o = .12                      
643              else             tau(i,j,L,2) = fracls*alf*tauh2o*dp
644                  tauh2o = max( 0.0020, 0.120*min( 20*lz(i,j,L)*1000,1.0) )  ! Over Ocean            else
645                  tau(i,j,L,3) = fracls*alf*tauh2o*dp  C Over Ocean
646              endif             tauh2o = max( 0.0020, 0.120*min( 20*lz(i,j,L)*1000,1.0) )  
647               tau(i,j,L,3) = fracls*alf*tauh2o*dp
648              endif
649           endif           endif
650    
651  c Sub-Grid Convective  c Sub-Grid Convective
# Line 805  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
 #if f90  
 !DIR$ inline always expmn  
775  #endif  #endif
776  #endif        _RL expmn
       real 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 1050  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
1032    
1033        include 'cai.dat'  #include "cai-dat.h"
1034        save caib,caif  c     save caib,caif
1035    
1036    
1037  c-----clouds within each of the high, middle, and low clouds are  c-----clouds within each of the high, middle, and low clouds are
# Line 1268  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
 #if f90  
 !DIR$ inline always deledd  
 !DIR$ inline always sagpol  
 !DIR$ inline always expmn  
 #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 1683  c*************************************** Line 1637  c***************************************
1637    
1638  c-----Explicit Inline Directives    c-----Explicit Inline Directives  
1639        
1640  #if CRAY  #ifdef CRAY
1641  #if f77    #ifdef f77  
1642  cfpp$ expand (deledd)  cfpp$ expand (deledd)
1643  cfpp$ expand (sagpol)  cfpp$ expand (sagpol)
1644  #endif    #endif  
 #if f90    
 !DIR$ inline always deledd  
 !DIR$ inline always sagpol  
 #endif  
1645  #endif  #endif
1646    
1647  c-----input parameters  c-----input parameters
1648    
1649        integer m,n,ndim,np,ict,icb        integer m,n,ndim,np,ict,icb
1650        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)
1651        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)
1652        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)
1653        real  rsuvbm(m,ndim),rsuvdf(m,ndim),csm(m,n)        _RL  rsuvbm(m,ndim),rsuvdf(m,ndim),csm(m,n)
1654    
1655  c-----output (updated) parameter  c-----output (updated) parameter
1656    
1657        real  flx(m,ndim,np+1),flc(m,ndim,np+1)        _RL  flx(m,ndim,np+1),flc(m,ndim,np+1)
1658        real  fdirpar(m,ndim),fdifpar(m,ndim)        _RL  fdirpar(m,ndim),fdifpar(m,ndim)
1659        real  fdiruv(m,ndim),fdifuv(m,ndim)        _RL  fdiruv(m,ndim),fdifuv(m,ndim)
1660    
1661  c-----static parameters  c-----static parameters
1662    
1663        integer nband        integer nband
1664        parameter (nband=8)        parameter (nband=8)
1665        real  hk(nband),xk(nband),ry(nband)        _RL  hk(nband),xk(nband),ry(nband)
1666        real  asyal(nband),ssaal(nband),aig(3),awg(3)        _RL  asyal(nband),ssaal(nband),aig(3),awg(3)
1667    
1668  c-----temporary array  c-----temporary array
1669    
1670        integer i,j,k,ib        integer i,j,k,ib
1671        real  taurs,tauoz,tausto,ssatau,asysto,tauto,ssato,asyto        _RL  taurs,tauoz,tausto,ssatau,asysto,tauto,ssato,asyto
1672        real  taux,reff1,reff2,g1,g2,asycl(m,n,np)        _RL  taux,reff1,reff2,g1,g2,asycl(m,n,np)
1673        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),
1674       *       rs(m,n,np+1,2),ts(m,n,np+1,2)       *       rs(m,n,np+1,2),ts(m,n,np+1,2)
1675        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)
1676       *     rssab(m,n,np+1),rabx(m,n,np+1),rsabx(m,n,np+1)        _RL  asyclt(m,n)
1677        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)
1678        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)  
1679    
1680  c-----hk is the fractional extra-terrestrial solar flux.  c-----hk is the fractional extra-terrestrial solar flux.
1681  c     the sum of hk is 0.47074.  c     the sum of hk is 0.47074.
# Line 2004  c*************************************** Line 1952  c***************************************
1952    
1953  c-----Explicit Inline Directives    c-----Explicit Inline Directives  
1954        
1955  #if CRAY  #ifdef CRAY
1956  #if f77    #ifdef f77  
1957  cfpp$ expand (expmn)  cfpp$ expand (expmn)
1958  #endif    #endif  
 #if f90    
 !DIR$ inline always expmn  
 #endif  
1959  #endif  #endif
1960        real expmn        _RL expmn
1961    
1962        real  zero,one,two,three,four,fourth,seven,tumin        _RL  zero,one,two,three,four,fourth,seven,tumin
1963        parameter (one=1., three=3.)        parameter (one=1., three=3.)
1964        parameter (seven=7., two=2.)        parameter (seven=7., two=2.)
1965        parameter (four=4., fourth=.25)        parameter (four=4., fourth=.25)
1966        parameter (zero=0., tumin=1.e-20)        parameter (zero=0., tumin=1.e-20)
1967    
1968  c-----input parameters  c-----input parameters
1969        real  tau,ssc,g0,csm        _RL  tau,ssc,g0,csm
1970    
1971  c-----output parameters  c-----output parameters
1972        real  rr,tt,td        _RL  rr,tt,td
1973    
1974  c-----temporary parameters  c-----temporary parameters
1975    
1976        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,
1977       *     all,bll,st7,st8,cll,dll,fll,ell,st1,st2,st3,st4       *     all,bll,st7,st8,cll,dll,fll,ell,st1,st2,st3,st4
1978  c  c
1979                  zth = one / csm                  zth = one / csm
# Line 2131  c*************************************** Line 2076  c***************************************
2076    
2077  c-----Explicit Inline Directives    c-----Explicit Inline Directives  
2078        
2079  #if CRAY  #ifdef CRAY
2080  #if f77    #ifdef f77  
2081  cfpp$ expand (expmn)  cfpp$ expand (expmn)
2082  #endif    #endif  
 #if f90    
 !DIR$ inline always expmn  
 #endif  
2083  #endif  #endif
2084        real expmn        _RL expmn
2085    
2086        real  one,three,four        _RL  one,three,four
2087        parameter (one=1., three=3., four=4.)        parameter (one=1., three=3., four=4.)
2088    
2089  c-----output parameters:  c-----output parameters:
2090    
2091        real  tau,ssc,g0        _RL  tau,ssc,g0
2092    
2093  c-----output parameters:  c-----output parameters:
2094    
2095        real  rll,tll        _RL  rll,tll
2096    
2097  c-----temporary arrays  c-----temporary arrays
2098    
2099        real  xx,uuu,ttt,emt,up1,um1,st1        _RL  xx,uuu,ttt,emt,up1,um1,st1
2100    
2101               xx  = one-ssc*g0               xx  = one-ssc*g0
2102               uuu = sqrt( xx/(one-ssc))               uuu = sqrt( xx/(one-ssc))
# Line 2176  c*************************************** Line 2118  c***************************************
2118    
2119  c*******************************************************************  c*******************************************************************
2120  c compute exponential for arguments in the range 0> fin > -10.  c compute exponential for arguments in the range 0> fin > -10.
2121    c*******************************************************************
2122          implicit none
2123          _RL  fin,expmn
2124    
2125          _RL one,expmin,e1,e2,e3,e4
2126        parameter (one=1.0, expmin=-10.0)        parameter (one=1.0, expmin=-10.0)
2127        parameter (e1=1.0,        e2=-2.507213e-1)        parameter (e1=1.0,        e2=-2.507213e-1)
2128        parameter (e3=2.92732e-2, e4=-3.827800e-3)        parameter (e3=2.92732e-2, e4=-3.827800e-3)
       real  fin,expmn  
2129    
2130        if (fin .lt. expmin) fin = expmin        if (fin .lt. expmin) fin = expmin
2131        expmn = ((e4*fin + e3)*fin+e2)*fin+e1        expmn = ((e4*fin + e3)*fin+e2)*fin+e1
# Line 2230  c-----input parameters Line 2175  c-----input parameters
2175    
2176        integer m,n,np,ict,icb        integer m,n,np,ict,icb
2177    
2178        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)
2179        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)
2180        real  cc(m,n,3)        _RL  cc(m,n,3)
2181    
2182  c-----temporary array  c-----temporary array
2183    
2184        integer i,j,k,ih,im,is        integer i,j,k,ih,im,is
2185        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)
2186        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)
2187        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)
2188        real  fdndir(m,n),fdndif(m,n),fupdif        _RL  fdndir(m,n),fdndif(m,n),fupdif
2189        real  denm,xx        _RL  denm,xx
2190    
2191  c-----output parameters  c-----output parameters
2192    
2193        real  fclr(m,n,np+1),fall(m,n,np+1)        _RL  fclr(m,n,np+1),fall(m,n,np+1)
2194        real  fsdir(m,n),fsdif(m,n)        _RL  fsdir(m,n),fsdif(m,n)
2195    
2196  c-----initialize all-sky flux (fall) and surface downward fluxes  c-----initialize all-sky flux (fall) and surface downward fluxes
2197    
# Line 2546  c     due to co2 absorption. Line 2491  c     due to co2 absorption.
2491  c-----input parameters  c-----input parameters
2492    
2493        integer m,n,np        integer m,n,np
2494        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)
2495    
2496  c-----output (undated) parameter  c-----output (undated) parameter
2497    
2498        real  df(m,n,np+1)        _RL  df(m,n,np+1)
2499    
2500  c-----temporary array  c-----temporary array
2501    
2502        integer i,j,k,ic,iw        integer i,j,k,ic,iw
2503        real  xx,clog,wlog,dc,dw,x1,x2,y2        _RL  xx,clog,wlog,dc,dw,x1,x2,y2
2504    
2505  c********************************************************************  c********************************************************************
2506  c-----include co2 look-up table  c-----include co2 look-up table
2507    
2508        include 'cah.dat'  #include "cah-dat.h"
2509        save cah  c     save cah
2510    
2511  c********************************************************************  c********************************************************************
2512  c-----table look-up for the reduction of clear-sky solar  c-----table look-up for the reduction of clear-sky solar
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.12
  ViewVC Help
Powered by ViewVC 1.1.22