/[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.15 by molod, Wed Aug 4 22:23:43 2004 UTC revision 1.26 by jmc, Tue Mar 16 00:19:33 2010 UTC
# Line 2  C $Header$ Line 2  C $Header$
2  C $Name$  C $Name$
3    
4  #include "FIZHI_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,       .                  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,
12       .                  ptop,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 "SIZE.h"  
 #include "diagnostics_SIZE.h"  
 #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        
       _RL  ptop                
22        _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1)        _RL pz(im,jm),plz(im,jm,lm),plze(im,jm,lm+1)
23        _RL dpres(im,jm,lm),pkht(im,jm,lm+1),pkz(im,jm,lm)        _RL dpres(im,jm,lm),pkht(im,jm,lm+1),pkz(im,jm,lm)
24        _RL tz(im,jm,lm),qz(im,jm,lm),oz(im,jm,lm)        _RL tz(im,jm,lm),qz(im,jm,lm),oz(im,jm,lm)
# Line 71  c --------------- Line 66  c ---------------
66        _RL SGMT4(ISTRIP),TSURF(ISTRIP),dsgmt4(ISTRIP)        _RL SGMT4(ISTRIP),TSURF(ISTRIP),dsgmt4(ISTRIP)
67        integer lwi(istrip)        integer lwi(istrip)
68    
69          _RL tmpstrip(istrip,lm)
70          _RL tmpimjm(im,jm,lm)
71          _RL tempor1(im,jm),tempor2(im,jm)
72    
73        _RL getcon,secday,convrt        _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 91  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 101  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 134  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 143  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 212  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 240  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 253  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 268  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 775  c     o3 (band 5), and h2o (bands 1, 2, Line 791  c     o3 (band 5), and h2o (bands 1, 2,
791  #include "co2-tran3.h"  #include "co2-tran3.h"
792  #include "o3-tran3.h"  #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  c     if (first) then        if (first) then
798    
799  c-----tables co2 and h2o are only used with 'high' option  c-----tables co2 and h2o are only used with 'high' option
800    
# Line 846  c-----always use table look-up for ozone Line 862  c-----always use table look-up for ozone
862           enddo           enddo
863          enddo          enddo
864    
865  c      first=.false.         first=.false.
866    
867  c     endif        endif
868    
869  c-----set the pressure at the top of the model atmosphere  c-----set the pressure at the top of the model atmosphere
870  c     to 1.0e-4 if it is zero  c     to 1.0e-4 if it is zero
# Line 1012  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 1081  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 1456  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 *****
Legend:
Removed from v.1.15  
changed lines
  Added in v.1.26
  ViewVC Help
Powered by ViewVC 1.1.22