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

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

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

revision 1.5 by molod, Mon Jul 12 21:33:37 2004 UTC revision 1.26 by jmc, Tue Mar 16 00:19:33 2010 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"
5        subroutine lwrio (nymd,nhms,bi,bj,istrip,npcs,low_level,mid_level,        subroutine lwrio (nymd,nhms,bi,bj,myid,istrip,npcs,
6         .                  low_level,mid_level,
7         .                  im,jm,lm,
8       .                  pz,plz,plze,dpres,pkht,pkz,tz,qz,oz,       .                  pz,plz,plze,dpres,pkht,pkz,tz,qz,oz,
9       .                  co2,cfc11,cfc12,cfc22,methane,n2o,emissivity,       .                  co2,cfc11,cfc12,cfc22,methane,n2o,emissivity,
10       .                  tgz,radlwg,st4,dst4,       .                  tgz,radlwg,st4,dst4,
11       .                  dtradlw,dlwdtg,dtradlwc,lwgclr,       .                  dtradlw,dlwdtg,dtradlwc,lwgclr,
      .                  im,jm,lm,ptop,  
12       .                  nlwcld,cldlw,clwmo,nlwlz,lwlz,       .                  nlwcld,cldlw,clwmo,nlwlz,lwlz,
13       .                  lpnt,imstturb,qliqave,fccave,landtype)       .                  lpnt,imstturb,qliqave,fccave,landtype)
14    
15        implicit none        implicit none
 #ifdef ALLOW_DIAGNOSTICS  
 #include 'diagnostics.h'  
 #endif  
16    
17  c Input Variables  c Input Variables
18  c ---------------  c ---------------
19        integer nymd,nhms,istrip,npcs,bi,bj        integer nymd,nhms,istrip,npcs,bi,bj,myid
20        integer mid_level,low_level        integer mid_level,low_level
21        integer im,jm,lm                integer im,jm,lm        
22        real  ptop                      _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1)
23        real pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1)        _RL dpres(im,jm,lm),pkht(im,jm,lm+1),pkz(im,jm,lm)
24        real dpres(im,jm,lm),pkht(im,jm,lm+1),pkz(im,jm,lm)        _RL tz(im,jm,lm),qz(im,jm,lm),oz(im,jm,lm)
25        real tz(im,jm,lm),qz(im,jm,lm),oz(im,jm,lm)        _RL co2,cfc11,cfc12,cfc22,methane(lm),n2o(lm)    
26        real co2,cfc11,cfc12,cfc22,methane(lm),n2o(lm)            _RL emissivity(im,jm,10)
27        real emissivity(im,jm,10)        _RL tgz(im,jm),radlwg(im,jm),st4(im,jm),dst4(im,jm)    
28        real tgz(im,jm),radlwg(im,jm),st4(im,jm),dst4(im,jm)            _RL dtradlw(im,jm,lm),dlwdtg (im,jm,lm)
29        real dtradlw(im,jm,lm),dlwdtg (im,jm,lm)        _RL dtradlwc(im,jm,lm),lwgclr(im,jm)    
       real dtradlwc(im,jm,lm),lwgclr(im,jm)      
30        integer nlwcld,nlwlz        integer nlwcld,nlwlz
31        real cldlw(im,jm,lm),clwmo(im,jm,lm),lwlz(im,jm,lm)        _RL cldlw(im,jm,lm),clwmo(im,jm,lm),lwlz(im,jm,lm)
32        logical lpnt        logical lpnt
33        integer imstturb        integer imstturb
34        real qliqave(im,jm,lm),fccave(im,jm,lm)        _RL qliqave(im,jm,lm),fccave(im,jm,lm)
35        integer landtype(im,jm)        integer landtype(im,jm)
36    
37  c Local Variables  c Local Variables
38  c ---------------  c ---------------
39        integer i,j,l,n,nn        integer i,j,l,n,nn
40    
41        real cldtot (im,jm,lm)        _RL cldtot (im,jm,lm)
42        real cldmxo (im,jm,lm)        _RL cldmxo (im,jm,lm)
43    
44        real pl(istrip,lm)        _RL pl(istrip,lm)
45        real pk(istrip,lm)        _RL pk(istrip,lm)
46        real pke(istrip,lm)        _RL pke(istrip,lm)
47        real ple(istrip,lm+1)        _RL ple(istrip,lm+1)
48    
49        real ADELPL(ISTRIP,lm)        _RL ADELPL(ISTRIP,lm)
50        real dtrad(istrip,lm),dtradc(istrip,lm)        _RL dtrad(istrip,lm),dtradc(istrip,lm)
51        real OZL(ISTRIP,lm),TZL(ISTRIP,lm)        _RL OZL(ISTRIP,lm),TZL(ISTRIP,lm)
52        real SHZL(ISTRIP,lm),CLRO(ISTRIP,lm)        _RL SHZL(ISTRIP,lm),CLRO(ISTRIP,lm)
53        real CLMO(ISTRIP,lm)        _RL CLMO(ISTRIP,lm)
54        real flx(ISTRIP,lm+1),flxclr(ISTRIP,lm+1)        _RL flx(ISTRIP,lm+1),flxclr(ISTRIP,lm+1)
55        real cldlz(istrip,lm)        _RL cldlz(istrip,lm)
56        real dfdts(istrip,lm+1),dtdtg(istrip,lm)        _RL dfdts(istrip,lm+1),dtdtg(istrip,lm)
57    
58        real emiss(istrip,10)        _RL emiss(istrip,10)
59        real taual(istrip,lm,10)        _RL taual(istrip,lm,10)
60        real ssaal(istrip,lm,10)        _RL ssaal(istrip,lm,10)
61        real asyal(istrip,lm,10)        _RL asyal(istrip,lm,10)
62        real cwc(istrip,lm,3)        _RL cwc(istrip,lm,3)
63        real reff(istrip,lm,3)        _RL reff(istrip,lm,3)
64        real tauc(istrip,lm,3)        _RL tauc(istrip,lm,3)
65    
66        real SGMT4(ISTRIP),TSURF(ISTRIP),dsgmt4(ISTRIP)        _RL SGMT4(ISTRIP),TSURF(ISTRIP),dsgmt4(ISTRIP)
67        integer lwi(istrip)        integer lwi(istrip)
68    
69        real getcon,secday,convrt,pcheck        _RL tmpstrip(istrip,lm)
70          _RL tmpimjm(im,jm,lm)
71          _RL tempor1(im,jm),tempor2(im,jm)
72    
73          _RL getcon,secday,convrt
74    #ifdef ALLOW_DIAGNOSTICS
75          logical  diagnostics_is_on
76          external diagnostics_is_on
77          _RL tmpdiag(im,jm)
78    #endif
79    
80        logical high,  trace, cldwater        logical high,  trace, cldwater
81        data high /.true./  c     data high /.true./
82        data trace /.true./  c     data trace /.true./
83          data high /.false./
84          data trace /.false./
85        data cldwater /.false./        data cldwater /.false./
86    
87  C **********************************************************************  C **********************************************************************
# Line 89  c -------------------------------------- Line 97  c --------------------------------------
97          do L =1,lm          do L =1,lm
98          do j =1,jm          do j =1,jm
99          do i =1,im          do i =1,im
100           cldtot(i,j,L)=min(1.0,max(cldlw(i,j,L),fccave(i,j,L)/imstturb))             cldtot(i,j,L)=min(1.0 _d 0,max(cldlw(i,j,L),fccave(i,j,L)/
101           cldmxo(i,j,L) =  min( 1.0 ,      clwmo(i,j,L) )       $          imstturb))
102               cldmxo(i,j,L) =  min( 1.0 _d 0,      clwmo(i,j,L) )
103             lwlz(i,j,L) =  lwlz(i,j,L) + qliqave(i,j,L)/imstturb             lwlz(i,j,L) =  lwlz(i,j,L) + qliqave(i,j,L)/imstturb
104          enddo          enddo
105          enddo          enddo
# Line 99  c -------------------------------------- Line 108  c --------------------------------------
108          do L =1,lm          do L =1,lm
109          do j =1,jm          do j =1,jm
110          do i =1,im          do i =1,im
111           cldtot(i,j,L) =  min( 1.0,cldlw(i,j,L) )           cldtot(i,j,L) =  min( 1.0 _d 0,cldlw(i,j,L) )
112           cldmxo(i,j,L) =  min( 1.0,clwmo(i,j,L) )           cldmxo(i,j,L) =  min( 1.0 _d 0,clwmo(i,j,L) )
113          enddo          enddo
114          enddo          enddo
115          enddo          enddo
# Line 132  C ************************************** Line 141  C **************************************
141    
142         call stripitint (landtype,lwi,im*jm,im*jm,istrip,1,nn)         call stripitint (landtype,lwi,im*jm,im*jm,istrip,1,nn)
143    
144         DO I = 1,ISTRIP*lm         DO L = 1,lm
145          ADELPL(I,1) = convrt / ( ple(I,2)-ple(I,1) )         DO I = 1,ISTRIP
146            ADELPL(I,L) = convrt / ( ple(I,L+1)-ple(I,L) )
147           ENDDO
148         ENDDO         ENDDO
149    
150  C Compute Clouds  C Compute Clouds
# Line 141  C -------------- Line 152  C --------------
152         IF(NLWCLD.NE.0)THEN         IF(NLWCLD.NE.0)THEN
153         DO L = 1,lm         DO L = 1,lm
154         DO I = 1,ISTRIP         DO I = 1,ISTRIP
155          CLRO(I,L) = min( 1.0,clro(i,L) )          CLRO(I,L) = min( 1.0 _d 0,clro(i,L) )
156          CLMO(I,L) = min( 1.0,clmo(i,L) )          CLMO(I,L) = min( 1.0 _d 0,clmo(i,L) )
157         ENDDO         ENDDO
158         ENDDO         ENDDO
159         ENDIF         ENDIF
160    
161    C Convert to Temperature from Fizhi Theta
162    C ---------------------------------------
163        DO L = 1,lm        DO L = 1,lm
164        DO I = 1,ISTRIP        DO I = 1,ISTRIP
165        TZL(I,L) = TZL(I,L)*pk(I,L)        TZL(I,L) = TZL(I,L)*pk(I,L)
# Line 210  C ************************************** Line 223  C **************************************
223         do L = 1,lm         do L = 1,lm
224         do i = 1,istrip         do i = 1,istrip
225           dtrad(i,L) = (   flx(i,L)-   flx(i,L+1))*adelpl(i,L)           dtrad(i,L) = (   flx(i,L)-   flx(i,L+1))*adelpl(i,L)
226             tmpstrip(i,L) = flx(i,L)
227           dtdtg(i,L) = ( dfdts(i,L)- dfdts(i,L+1))*adelpl(i,L)           dtdtg(i,L) = ( dfdts(i,L)- dfdts(i,L+1))*adelpl(i,L)
228          dtradc(i,L) = (flxclr(i,L)-flxclr(i,L+1))*adelpl(i,L)          dtradc(i,L) = (flxclr(i,L)-flxclr(i,L+1))*adelpl(i,L)
229         enddo         enddo
# Line 238  C ************************************** Line 252  C **************************************
252  C ****            PASTE AND BUMP SOME DIAGNOSTICS                   ****  C ****            PASTE AND BUMP SOME DIAGNOSTICS                   ****
253  C **********************************************************************  C **********************************************************************
254    
255        IF(IOLR.GT.0)CALL PSTBMP(flx(1,1),QDIAG(1,1,IOLR,bi,bj),ISTRIP,        CALL PASTE(flx(1,1),tempor1,ISTRIP,im*jm,1,NN)
256       .                                                      im*jm, 1,NN)        CALL PASTE(flxclr(1,1),tempor2,ISTRIP,im*jm,1,NN)
       IF(IOLRCLR.GT.0)CALL PSTBMP(flxclr(1,1),QDIAG(1,1,IOLRCLR,bi,bj),  
      .                                                ISTRIP,im*jm,1,NN)  
       IF(IOZLW.GT.0)CALL PSTBMP(OZL(1,1),QDIAG(1,1,IOZLW,bi,bj),ISTRIP,  
      .                                                      im*jm,lm,NN)  
257    
258  C **********************************************************************  C **********************************************************************
259  C ****                 TENDENCY UPDATES                             ****  C ****                 TENDENCY UPDATES                             ****
# Line 251  C ************************************** Line 261  C **************************************
261    
262        DO L = 1,lm        DO L = 1,lm
263        DO I = 1,ISTRIP        DO I = 1,ISTRIP
264        DTRAD (I,L) = ( ple(i,lm+1)-PTOP ) * DTRAD (I,L)/pk(I,L)        DTRAD (I,L) = ple(i,lm+1) * DTRAD (I,L)/pk(I,L)
265        DTRADC(I,L) = ( ple(i,lm+1)-PTOP ) * DTRADC(I,L)/pk(I,L)        DTRADC(I,L) = ple(i,lm+1) * DTRADC(I,L)/pk(I,L)
266         dtdtg(I,L) = ( ple(i,lm+1)-PTOP ) * dtdtg (I,L)/pk(I,L)         dtdtg(I,L) = ple(i,lm+1) * dtdtg (I,L)/pk(I,L)
267        ENDDO        ENDDO
268        ENDDO        ENDDO
269          CALL PASTE ( tmpstrip ,tmpimjm ,ISTRIP,im*jm,lm,NN )
270        CALL PASTE ( DTRAD ,DTRADLW ,ISTRIP,im*jm,lm,NN )        CALL PASTE ( DTRAD ,DTRADLW ,ISTRIP,im*jm,lm,NN )
271        CALL PASTE ( DTRADC,DTRADLWC,ISTRIP,im*jm,lm,NN )        CALL PASTE ( DTRADC,DTRADLWC,ISTRIP,im*jm,lm,NN )
272        CALL PASTE ( dtdtg ,dlwdtg  ,ISTRIP,im*jm,lm,NN )        CALL PASTE ( dtdtg ,dlwdtg  ,ISTRIP,im*jm,lm,NN )
# Line 266  C ************************************** Line 277  C **************************************
277  C ****                     BUMP DIAGNOSTICS                         ****  C ****                     BUMP DIAGNOSTICS                         ****
278  C **********************************************************************  C **********************************************************************
279    
280        if(itgrlw.ne.0) then  #ifdef ALLOW_DIAGNOSTICS
281        do j = 1,jm        if(diagnostics_is_on('TGRLW   ',myid) ) then
282        do i = 1,im         call diagnostics_fill(tgz,'TGRLW   ',0,1,3,bi,bj,myid)
       qdiag(i,j,itgrlw,bi,bj) = qdiag(i,j,itgrlw,bi,bj) + tgz(i,j)  
       enddo  
       enddo  
283        endif        endif
284    
       if (itlw.ne.0) then  
285        do L = 1,lm        do L = 1,lm
       do j = 1,jm  
       do i = 1,im  
       qdiag(i,j,itlw+L-1,bi,bj) = qdiag(i,j,itlw+L-1,bi,bj) +  
      .                                             tz(i,j,L)*pkz(i,j,L)  
       enddo  
       enddo  
       enddo  
       endif  
286    
287        if (ishrad.ne.0) then         if(diagnostics_is_on('TLW     ',myid) ) then
288        do L = 1,lm          do j = 1,jm
289        do j = 1,jm          do i = 1,im
290        do i = 1,im           tmpdiag(i,j) = tz(i,j,L)*pkz(i,j,L)
291        qdiag(i,j,ishrad+L-1,bi,bj) = qdiag(i,j,ishrad+L-1,bi,bj) +          enddo
292       .                                             qz(i,j,L)*1000          enddo
293        enddo          call diagnostics_fill(tmpdiag,'TLW     ',L,1,3,bi,bj,myid)
294        enddo         endif
295    
296           if(diagnostics_is_on('SHRAD   ',myid) ) then
297            do j = 1,jm
298            do i = 1,im
299             tmpdiag(i,j) = qz(i,j,L)*1000.
300            enddo
301            enddo
302            call diagnostics_fill(tmpdiag,'SHRAD   ',L,1,3,bi,bj,myid)
303           endif
304    
305           if(diagnostics_is_on('OZLW    ',myid) ) then
306            do j = 1,jm
307            do i = 1,im
308             tmpdiag(i,j) = oz(i,j,L)
309            enddo
310            enddo
311            call diagnostics_fill(tmpdiag,'OZLW    ',L,1,3,bi,bj,myid)
312           endif
313    
314        enddo        enddo
315    
316          if(diagnostics_is_on('OLR     ',myid) ) then
317           call diagnostics_fill(tempor1,'OLR     ',0,1,3,bi,bj,myid)
318        endif        endif
319    
320          if(diagnostics_is_on('OLRCLR  ',myid) ) then
321           call diagnostics_fill(tempor2,'OLRCLR  ',0,1,3,bi,bj,myid)
322          endif
323    #endif
324    
325  C **********************************************************************  C **********************************************************************
326  C ****    Increment Diagnostics Counters and Zero-Out Cloud Info    ****  C ****    Increment Diagnostics Counters and Zero-Out Cloud Info    ****
327  C **********************************************************************  C **********************************************************************
328    
       ntlw     = ntlw     + 1  
       nshrad   = nshrad   + 1  
       nozlw    = nozlw    + 1  
       ntgrlw   = ntgrlw   + 1  
       nolr     = nolr     + 1  
       nolrclr  = nolrclr  + 1  
   
329        nlwlz    = 0        nlwlz    = 0
330        nlwcld   = 0        nlwcld   = 0
331        imstturb = 0        imstturb = 0
# Line 548  cfpp$ expand (b10kdis) Line 566  cfpp$ expand (b10kdis)
566  c---- input parameters ------  c---- input parameters ------
567    
568        integer m,n,ndim,np,ict,icb        integer m,n,ndim,np,ict,icb
569        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),
570       *     ts(m,ndim)       *     ts(m,ndim)
571        real co2,n2o(np),ch4(np),cfc11,cfc12,cfc22,emiss(m,ndim,10)        _RL co2,n2o(np),ch4(np),cfc11,cfc12,cfc22,emiss(m,ndim,10)
572        real cwc(m,ndim,np,3),taucl(m,ndim,np,3),reff(m,ndim,np,3),        _RL cwc(m,ndim,np,3),taucl(m,ndim,np,3),reff(m,ndim,np,3),
573       *     fcld(m,ndim,np)       *     fcld(m,ndim,np)
574        real taual(m,ndim,np,10),ssaal(m,ndim,np,10),asyal(m,ndim,np,10)        _RL taual(m,ndim,np,10),ssaal(m,ndim,np,10),asyal(m,ndim,np,10)
575        logical cldwater,high,trace        logical cldwater,high,trace
576    
577  c---- output parameters ------  c---- output parameters ------
578    
579        real flx(m,ndim,np+1),flc(m,ndim,np+1),dfdts(m,ndim,np+1),        _RL flx(m,ndim,np+1),flc(m,ndim,np+1),dfdts(m,ndim,np+1),
580       *     st4(m,ndim)       *     st4(m,ndim)
581    
582  c---- static data -----  c---- static data -----
583    
584        real cb(5,10)        _RL cb(5,10)
585        real xkw(9),aw(9),bw(9),pm(9),fkw(6,9),gkw(6,3),xke(9)        _RL xkw(9),aw(9),bw(9),pm(9),fkw(6,9),gkw(6,3),xke(9)
586        real aib(3,10),awb(4,10),aiw(4,10),aww(4,10),aig(4,10),awg(4,10)        _RL aib(3,10),awb(4,10),aiw(4,10),aww(4,10),aig(4,10),awg(4,10)
587        integer ne(9),mw(9)        integer ne(9),mw(9)
588    
589  c---- temporary arrays -----  c---- temporary arrays -----
590    
591        real pa(m,n,np),dt(m,n,np)        _RL pa(m,n,np),dt(m,n,np)
592        real sh2o(m,n,np+1),swpre(m,n,np+1),swtem(m,n,np+1)        _RL sh2o(m,n,np+1),swpre(m,n,np+1),swtem(m,n,np+1)
593        real sco3(m,n,np+1),scopre(m,n,np+1),scotem(m,n,np+1)        _RL sco3(m,n,np+1),scopre(m,n,np+1),scotem(m,n,np+1)
594        real dh2o(m,n,np),dcont(m,n,np),dco2(m,n,np),do3(m,n,np)        _RL dh2o(m,n,np),dcont(m,n,np),dco2(m,n,np),do3(m,n,np)
595        real dn2o(m,n,np),dch4(m,n,np)        _RL dn2o(m,n,np),dch4(m,n,np)
596        real df11(m,n,np),df12(m,n,np),df22(m,n,np)        _RL df11(m,n,np),df12(m,n,np),df22(m,n,np)
597        real th2o(m,n,6),tcon(m,n,3),tco2(m,n,6,2)        _RL th2o(m,n,6),tcon(m,n,3),tco2(m,n,6,2)
598        real tn2o(m,n,4),tch4(m,n,4),tcom(m,n,2)        _RL tn2o(m,n,4),tch4(m,n,4),tcom(m,n,2)
599        real tf11(m,n),tf12(m,n),tf22(m,n)        _RL tf11(m,n),tf12(m,n),tf22(m,n)
600        real h2oexp(m,n,np,6),conexp(m,n,np,3),co2exp(m,n,np,6,2)        _RL h2oexp(m,n,np,6),conexp(m,n,np,3),co2exp(m,n,np,6,2)
601        real n2oexp(m,n,np,4),ch4exp(m,n,np,4),comexp(m,n,np,2)        _RL n2oexp(m,n,np,4),ch4exp(m,n,np,4),comexp(m,n,np,2)
602        real f11exp(m,n,np),  f12exp(m,n,np),  f22exp(m,n,np)        _RL f11exp(m,n,np),  f12exp(m,n,np),  f22exp(m,n,np)
603        real clr(m,n,0:np+1),fclr(m,n)        _RL clr(m,n,0:np+1),fclr(m,n)
604        real blayer(m,n,0:np+1),dlayer(m,n,np+1),dbs(m,n)        _RL blayer(m,n,0:np+1),dlayer(m,n,np+1),dbs(m,n)
605        real clrlw(m,n),clrmd(m,n),clrhi(m,n)        _RL clrlw(m,n),clrmd(m,n),clrhi(m,n)
606        real cwp(m,n,np,3)        _RL cwp(m,n,np,3)
607        real trant(m,n),tranal(m,n),transfc(m,n,np+1),trantcr(m,n,np+1)        _RL trant(m,n),tranal(m,n),transfc(m,n,np+1),trantcr(m,n,np+1)
608        real flxu(m,n,np+1),flxd(m,n,np+1),flcu(m,n,np+1),flcd(m,n,np+1)        _RL flxu(m,n,np+1),flxd(m,n,np+1),flcu(m,n,np+1),flcd(m,n,np+1)
609        real rflx(m,n,np+1),rflc(m,n,np+1)        _RL rflx(m,n,np+1),rflc(m,n,np+1)
610    
611        logical oznbnd,co2bnd,h2otbl,conbnd,n2obnd        logical oznbnd,co2bnd,h2otbl,conbnd,n2obnd
612        logical ch4bnd,combnd,f11bnd,f12bnd,f22bnd,b10bnd        logical ch4bnd,combnd,f11bnd,f12bnd,f22bnd,b10bnd
613    
614        real c1 (nx,nc,nt),c2 (nx,nc,nt),c3 (nx,nc,nt)        _RL c1 (nx,nc,nt),c2 (nx,nc,nt),c3 (nx,nc,nt)
615        real o1 (nx,no,nt),o2 (nx,no,nt),o3 (nx,no,nt)        _RL o1 (nx,no,nt),o2 (nx,no,nt),o3 (nx,no,nt)
616        real h11(nx,nh,nt),h12(nx,nh,nt),h13(nx,nh,nt)        _RL h11(nx,nh,nt),h12(nx,nh,nt),h13(nx,nh,nt)
617        real h21(nx,nh,nt),h22(nx,nh,nt),h23(nx,nh,nt)        _RL h21(nx,nh,nt),h22(nx,nh,nt),h23(nx,nh,nt)
618        real h81(nx,nh,nt),h82(nx,nh,nt),h83(nx,nh,nt)        _RL h81(nx,nh,nt),h82(nx,nh,nt),h83(nx,nh,nt)
619    
620        real dp,xx,p1,dwe,dpe,a1,b1,fk1,a2,b2,fk2        _RL dp,xx,p1,dwe,dpe,a1,b1,fk1,a2,b2,fk2
621        real w1,w2,w3,g1,g2,g3,ww,gg,ff,taux,reff1,reff2        _RL w1,w2,w3,g1,g2,g3,ww,gg,ff,taux,reff1,reff2
622    
623  c-----the following coefficients (equivalent to table 2 of  c-----the following coefficients (equivalent to table 2 of
624  c     chou and suarez, 1995) are for computing spectrally  c     chou and suarez, 1995) are for computing spectrally
# Line 769  c     o3 (band 5), and h2o (bands 1, 2, Line 787  c     o3 (band 5), and h2o (bands 1, 2,
787        logical first        logical first
788        data first /.true./        data first /.true./
789    
790        include "h2o.tran3"  #include "h2o-tran3.h"
791        include "co2.tran3"  #include "co2-tran3.h"
792        include "o3.tran3"  #include "o3-tran3.h"
793    
794        save c1,c2,c3,o1,o2,o3  c     save c1,c2,c3,o1,o2,o3
795        save h11,h12,h13,h21,h22,h23,h81,h82,h83  c     save h11,h12,h13,h21,h22,h23,h81,h82,h83
796    
797        if (first) then        if (first) then
798    
# Line 1010  c     the fitting for the planck flux is Line 1028  c     the fitting for the planck flux is
1028          enddo          enddo
1029         enddo         enddo
1030    
1031  c-----the earth's surface, with an index "np+1", is treated as a layer  c-----the earth surface, with an index "np+1", is treated as a layer
1032    
1033         do j=1,n         do j=1,n
1034          do i=1,m          do i=1,m
# Line 1079  c     to 0.54 and 0.95, respectively. Line 1097  c     to 0.54 and 0.95, respectively.
1097    
1098            if (taux.gt.0.02 .and. fcld(i,j,k).gt.0.01) then            if (taux.gt.0.02 .and. fcld(i,j,k).gt.0.01) then
1099    
1100             reff1=min(reff(i,j,k,1),130.)             reff1=min(reff(i,j,k,1),130. _d 0)
1101             reff2=min(reff(i,j,k,2),20.0)             reff2=min(reff(i,j,k,2),20.0 _d 0)
1102    
1103             w1=taucl(i,j,k,1)*(aiw(1,ib)+(aiw(2,ib)+(aiw(3,ib)             w1=taucl(i,j,k,1)*(aiw(1,ib)+(aiw(2,ib)+(aiw(3,ib)
1104       *       +aiw(4,ib)*reff1)*reff1)*reff1)       *       +aiw(4,ib)*reff1)*reff1)*reff1)
# Line 1221  c-----initialize fluxes Line 1239  c-----initialize fluxes
1239         enddo         enddo
1240        enddo        enddo
1241    
   
1242        do 2000 k1=1,np        do 2000 k1=1,np
1243    
1244  c-----initialize fclr, th2o, tcon, tco2, and tranal  c-----initialize fclr, th2o, tcon, tco2, and tranal
# Line 1402  c-----compute water vapor transmittance Line 1419  c-----compute water vapor transmittance
1419            if (ib.eq.1) then            if (ib.eq.1) then
1420             call tablup(k1,k2,m,n,np,nx,nh,nt,sh2o,swpre,swtem,             call tablup(k1,k2,m,n,np,nx,nh,nt,sh2o,swpre,swtem,
1421       *                 w1,p1,dwe,dpe,h11,h12,h13,trant)       *                 w1,p1,dwe,dpe,h11,h12,h13,trant)
   
1422            endif            endif
1423            if (ib.eq.2) then            if (ib.eq.2) then
1424             call tablup(k1,k2,m,n,np,nx,nh,nt,sh2o,swpre,swtem,             call tablup(k1,k2,m,n,np,nx,nh,nt,sh2o,swpre,swtem,
# Line 1437  c-----compute co2 transmittance using ta Line 1453  c-----compute co2 transmittance using ta
1453            dpe=0.2            dpe=0.2
1454            call tablup(k1,k2,m,n,np,nx,nc,nt,sco3,scopre,scotem,            call tablup(k1,k2,m,n,np,nx,nc,nt,sco3,scopre,scotem,
1455       *                w1,p1,dwe,dpe,c1,c2,c3,trant)       *                w1,p1,dwe,dpe,c1,c2,c3,trant)
1456    
1457         else         else
1458    
1459  c-----compute co2 transmittance using k-distribution method  c-----compute co2 transmittance using k-distribution method
# Line 1455  c-----All use table look-up to compute o Line 1472  c-----All use table look-up to compute o
1472            dpe=0.2            dpe=0.2
1473            call tablup(k1,k2,m,n,np,nx,no,nt,sco3,scopre,scotem,            call tablup(k1,k2,m,n,np,nx,no,nt,sco3,scopre,scotem,
1474       *                w1,p1,dwe,dpe,o1,o2,o3,trant)       *                w1,p1,dwe,dpe,o1,o2,o3,trant)
1475    
1476        endif        endif
1477    
1478  c***** for trace gases *****  c***** for trace gases *****
# Line 1714  c*************************************** Line 1732  c***************************************
1732    
1733  c---- input parameters -----  c---- input parameters -----
1734    
1735        real pa(m,n,np),dt(m,n,np),sabs0(m,n,np)        _RL pa(m,n,np),dt(m,n,np),sabs0(m,n,np)
1736    
1737  c---- output parameters -----  c---- output parameters -----
1738    
1739        real sabs(m,n,np+1),spre(m,n,np+1),stem(m,n,np+1)        _RL sabs(m,n,np+1),spre(m,n,np+1),stem(m,n,np+1)
1740    
1741  c*********************************************************************  c*********************************************************************
1742          do j=1,n          do j=1,n
# Line 1769  c*************************************** Line 1787  c***************************************
1787    
1788  c---- input parameters ------  c---- input parameters ------
1789    
1790        real dh2o(m,n,np),pa(m,n,np),dt(m,n,np)        _RL dh2o(m,n,np),pa(m,n,np),dt(m,n,np)
1791    
1792  c---- output parameters -----  c---- output parameters -----
1793    
1794        real h2oexp(m,n,np,6)        _RL h2oexp(m,n,np,6)
1795    
1796  c---- static data -----  c---- static data -----
1797    
1798        integer mw(9)        integer mw(9)
1799        real xkw(9),aw(9),bw(9),pm(9)        _RL xkw(9),aw(9),bw(9),pm(9)
1800    
1801  c---- temporary arrays -----  c---- temporary arrays -----
1802    
1803        real xh,xh1        _RL xh,xh1
1804    
1805  c**********************************************************************  c**********************************************************************
1806  c    note that the 3 sub-bands in band 3 use the same set of xkw, aw,  c    note that the 3 sub-bands in band 3 use the same set of xkw, aw,
# Line 1885  c*************************************** Line 1903  c***************************************
1903    
1904  c---- input parameters ------  c---- input parameters ------
1905    
1906        real dcont(m,n,np)        _RL dcont(m,n,np)
1907    
1908  c---- updated parameters -----  c---- updated parameters -----
1909    
1910        real conexp(m,n,np,3)        _RL conexp(m,n,np,3)
1911    
1912  c---- static data -----  c---- static data -----
1913    
1914        real xke(9)        _RL xke(9)
1915    
1916  c**********************************************************************  c**********************************************************************
1917    
# Line 1946  c*************************************** Line 1964  c***************************************
1964    
1965  c---- input parameters -----  c---- input parameters -----
1966    
1967        real dco2(m,n,np),pa(m,n,np),dt(m,n,np)        _RL dco2(m,n,np),pa(m,n,np),dt(m,n,np)
1968    
1969  c---- output parameters -----  c---- output parameters -----
1970    
1971        real co2exp(m,n,np,6,2)        _RL co2exp(m,n,np,6,2)
1972    
1973  c---- temporary arrays -----  c---- temporary arrays -----
1974    
1975        real xc        _RL xc
1976    
1977  c**********************************************************************  c**********************************************************************
1978    
# Line 2048  c*************************************** Line 2066  c***************************************
2066    
2067  c---- input parameters -----  c---- input parameters -----
2068    
2069        real dn2o(m,n,np),pa(m,n,np),dt(m,n,np)        _RL dn2o(m,n,np),pa(m,n,np),dt(m,n,np)
2070    
2071  c---- output parameters -----  c---- output parameters -----
2072    
2073        real n2oexp(m,n,np,4)        _RL n2oexp(m,n,np,4)
2074    
2075  c---- temporary arrays -----  c---- temporary arrays -----
2076    
2077        real xc,xc1,xc2        _RL xc,xc1,xc2
2078    
2079  c**********************************************************************  c**********************************************************************
2080    
# Line 2124  c*************************************** Line 2142  c***************************************
2142    
2143  c---- input parameters -----  c---- input parameters -----
2144    
2145        real dch4(m,n,np),pa(m,n,np),dt(m,n,np)        _RL dch4(m,n,np),pa(m,n,np),dt(m,n,np)
2146    
2147  c---- output parameters -----  c---- output parameters -----
2148    
2149        real ch4exp(m,n,np,4)        _RL ch4exp(m,n,np,4)
2150    
2151  c---- temporary arrays -----  c---- temporary arrays -----
2152    
2153        real xc        _RL xc
2154    
2155  c**********************************************************************  c**********************************************************************
2156    
# Line 2196  c*************************************** Line 2214  c***************************************
2214    
2215  c---- input parameters -----  c---- input parameters -----
2216    
2217        real dcom(m,n,np),dt(m,n,np)        _RL dcom(m,n,np),dt(m,n,np)
2218    
2219  c---- output parameters -----  c---- output parameters -----
2220    
2221        real comexp(m,n,np,2)        _RL comexp(m,n,np,2)
2222    
2223  c---- temporary arrays -----  c---- temporary arrays -----
2224    
2225        real xc,xc1,xc2        _RL xc,xc1,xc2
2226    
2227  c**********************************************************************  c**********************************************************************
2228    
# Line 2273  c*************************************** Line 2291  c***************************************
2291    
2292  c---- input parameters -----  c---- input parameters -----
2293    
2294        real dcfc(m,n,np),dt(m,n,np)        _RL dcfc(m,n,np),dt(m,n,np)
2295    
2296  c---- output parameters -----  c---- output parameters -----
2297    
2298        real cfcexp(m,n,np)        _RL cfcexp(m,n,np)
2299    
2300  c---- static data -----  c---- static data -----
2301    
2302        real a1,b1,fk1,a2,b2,fk2        _RL a1,b1,fk1,a2,b2,fk2
2303    
2304  c---- temporary arrays -----  c---- temporary arrays -----
2305    
2306        real xf        _RL xf
2307    
2308  c**********************************************************************  c**********************************************************************
2309    
# Line 2335  c*************************************** Line 2353  c***************************************
2353    
2354  c---- input parameters -----  c---- input parameters -----
2355    
2356        real dh2o(m,n,np),dcont(m,n,np),dn2o(m,n,np)        _RL dh2o(m,n,np),dcont(m,n,np),dn2o(m,n,np)
2357        real dco2(m,n,np),pa(m,n,np),dt(m,n,np)        _RL dco2(m,n,np),pa(m,n,np),dt(m,n,np)
2358    
2359  c---- output parameters -----  c---- output parameters -----
2360    
2361        real h2oexp(m,n,np,6),conexp(m,n,np,3),co2exp(m,n,np,6,2)        _RL h2oexp(m,n,np,6),conexp(m,n,np,3),co2exp(m,n,np,6,2)
2362       *    ,n2oexp(m,n,np,4)       *    ,n2oexp(m,n,np,4)
2363    
2364  c---- temporary arrays -----  c---- temporary arrays -----
2365    
2366        real xx,xx1,xx2,xx3        _RL xx,xx1,xx2,xx3
2367    
2368  c**********************************************************************  c**********************************************************************
2369    
# Line 2486  c*************************************** Line 2504  c***************************************
2504    
2505  c---- input parameters -----  c---- input parameters -----
2506    
2507        real w1,p1,dwe,dpe        _RL w1,p1,dwe,dpe
2508        real sabs(m,n,np+1),spre(m,n,np+1),stem(m,n,np+1)        _RL sabs(m,n,np+1),spre(m,n,np+1),stem(m,n,np+1)
2509        real coef1(nx,nh,nt),coef2(nx,nh,nt),coef3(nx,nh,nt)        _RL coef1(nx,nh,nt),coef2(nx,nh,nt),coef3(nx,nh,nt)
2510    
2511  c---- update parameter -----  c---- update parameter -----
2512    
2513        real tran(m,n)        _RL tran(m,n)
2514    
2515  c---- temporary variables -----  c---- temporary variables -----
2516    
2517        real x1,x2,x3,we,pe,fw,fp,pa,pb,pc,ax,ba,bb,t1,ca,cb,t2        _RL x1,x2,x3,we,pe,fw,fp,pa,pb,pc,ax,ba,bb,t1,ca,cb,t2
2518        integer iw,ip,nn        integer iw,ip,nn
2519    
2520  c**********************************************************************  c**********************************************************************
# Line 2594  c*************************************** Line 2612  c***************************************
2612    
2613  c---- input parameters ------  c---- input parameters ------
2614    
2615        real conexp(m,n,np,3),h2oexp(m,n,np,6)        _RL conexp(m,n,np,3),h2oexp(m,n,np,6)
2616        integer ne(9)        integer ne(9)
2617        real  fkw(6,9),gkw(6,3)        _RL  fkw(6,9),gkw(6,3)
2618    
2619  c---- updated parameters -----  c---- updated parameters -----
2620    
2621        real th2o(m,n,6),tcon(m,n,3),tran(m,n)        _RL th2o(m,n,6),tcon(m,n,3),tran(m,n)
2622    
2623  c---- temporary arrays -----  c---- temporary arrays -----
2624    
2625        real trnth2o        _RL trnth2o
2626    
2627  c-----tco2 are the six exp factors between levels k1 and k2  c-----tco2 are the six exp factors between levels k1 and k2
2628  c     tran is the updated total transmittance between levels k1 and k2  c     tran is the updated total transmittance between levels k1 and k2
# Line 2728  c*************************************** Line 2746  c***************************************
2746    
2747  c---- input parameters -----  c---- input parameters -----
2748    
2749        real co2exp(m,n,np,6,2)        _RL co2exp(m,n,np,6,2)
2750    
2751  c---- updated parameters -----  c---- updated parameters -----
2752    
2753        real tco2(m,n,6,2),tran(m,n)        _RL tco2(m,n,6,2),tran(m,n)
2754    
2755  c---- temporary arrays -----  c---- temporary arrays -----
2756    
2757        real xc        _RL xc
2758    
2759  c-----tco2 is the 6 exp factors between levels k1 and k2.  c-----tco2 is the 6 exp factors between levels k1 and k2.
2760  c     xc is the total co2 transmittance given by eq. (53).  c     xc is the total co2 transmittance given by eq. (53).
# Line 2817  c*************************************** Line 2835  c***************************************
2835    
2836  c---- input parameters -----  c---- input parameters -----
2837    
2838        real n2oexp(m,n,np,4)        _RL n2oexp(m,n,np,4)
2839    
2840  c---- updated parameters -----  c---- updated parameters -----
2841    
2842        real tn2o(m,n,4),tran(m,n)        _RL tn2o(m,n,4),tran(m,n)
2843    
2844  c---- temporary arrays -----  c---- temporary arrays -----
2845    
2846        real xc        _RL xc
2847    
2848  c-----tn2o is the 2 exp factors between levels k1 and k2.  c-----tn2o is the 2 exp factors between levels k1 and k2.
2849  c     xc is the total n2o transmittance  c     xc is the total n2o transmittance
# Line 2894  c*************************************** Line 2912  c***************************************
2912    
2913  c---- input parameters -----  c---- input parameters -----
2914    
2915        real ch4exp(m,n,np,4)        _RL ch4exp(m,n,np,4)
2916    
2917  c---- updated parameters -----  c---- updated parameters -----
2918    
2919        real tch4(m,n,4),tran(m,n)        _RL tch4(m,n,4),tran(m,n)
2920    
2921  c---- temporary arrays -----  c---- temporary arrays -----
2922    
2923        real xc        _RL xc
2924    
2925  c-----tch4 is the 2 exp factors between levels k1 and k2.  c-----tch4 is the 2 exp factors between levels k1 and k2.
2926  c     xc is the total ch4 transmittance  c     xc is the total ch4 transmittance
# Line 2968  c*************************************** Line 2986  c***************************************
2986    
2987  c---- input parameters -----  c---- input parameters -----
2988    
2989        real comexp(m,n,np,2)        _RL comexp(m,n,np,2)
2990    
2991  c---- updated parameters -----  c---- updated parameters -----
2992    
2993        real tcom(m,n,2),tran(m,n)        _RL tcom(m,n,2),tran(m,n)
2994    
2995  c---- temporary arrays -----  c---- temporary arrays -----
2996    
2997        real xc        _RL xc
2998    
2999  c-----tcom is the 2 exp factors between levels k1 and k2.  c-----tcom is the 2 exp factors between levels k1 and k2.
3000  c     xc is the total co2-minor transmittance  c     xc is the total co2-minor transmittance
# Line 3036  c*************************************** Line 3054  c***************************************
3054    
3055  c---- input parameters -----  c---- input parameters -----
3056    
3057        real cfcexp(m,n,np)        _RL cfcexp(m,n,np)
3058    
3059  c---- updated parameters -----  c---- updated parameters -----
3060    
3061        real tcfc(m,n),tran(m,n)        _RL tcfc(m,n),tran(m,n)
3062    
3063  c-----tcfc is the exp factors between levels k1 and k2.  c-----tcfc is the exp factors between levels k1 and k2.
3064    
# Line 3092  c*************************************** Line 3110  c***************************************
3110    
3111  c---- input parameters -----  c---- input parameters -----
3112    
3113        real h2oexp(m,n,np,6),conexp(m,n,np,3),co2exp(m,n,np,6,2)        _RL h2oexp(m,n,np,6),conexp(m,n,np,3),co2exp(m,n,np,6,2)
3114       *    ,n2oexp(m,n,np,4)       *    ,n2oexp(m,n,np,4)
3115    
3116  c---- updated parameters -----  c---- updated parameters -----
3117    
3118        real th2o(m,n,6),tcon(m,n,3),tco2(m,n,6,2),tn2o(m,n,4)        _RL th2o(m,n,6),tcon(m,n,3),tco2(m,n,6,2),tn2o(m,n,4)
3119       *    ,tran(m,n)       *    ,tran(m,n)
3120    
3121  c---- temporary arrays -----  c---- temporary arrays -----
3122    
3123        real xx        _RL xx
3124    
3125  c-----initialize tran  c-----initialize tran
3126    
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.26
  ViewVC Help
Powered by ViewVC 1.1.22