/[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.17 by molod, Wed Aug 4 22:23:43 2004 UTC revision 1.20 by molod, Thu Aug 26 14:41:56 2004 UTC
# Line 238  c ------------------------- Line 238  c -------------------------
238        enddo        enddo
239        enddo        enddo
240        enddo        enddo
241        ncldras = ncldras + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) ncldras = ncldras + 1
242        endif        endif
243    
244        if( icldtot.gt.0 ) then        if( icldtot.gt.0 ) then
# Line 250  c ------------------------- Line 250  c -------------------------
250        enddo        enddo
251        enddo        enddo
252        enddo        enddo
253        ncldtot = ncldtot + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) ncldtot = ncldtot + 1
254        endif        endif
255    
256        if( icldlow.gt.0 ) then        if( icldlow.gt.0 ) then
# Line 259  c ------------------------- Line 259  c -------------------------
259        qdiag(i,j,icldlow,bi,bj) = qdiag(i,j,icldlow,bi,bj) + cldlow(i,j)        qdiag(i,j,icldlow,bi,bj) = qdiag(i,j,icldlow,bi,bj) + cldlow(i,j)
260        enddo        enddo
261        enddo        enddo
262        ncldlow = ncldlow + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) ncldlow = ncldlow + 1
263        endif        endif
264    
265        if( icldmid.gt.0 ) then        if( icldmid.gt.0 ) then
# Line 268  c ------------------------- Line 268  c -------------------------
268        qdiag(i,j,icldmid,bi,bj) = qdiag(i,j,icldmid,bi,bj) + cldmid(i,j)        qdiag(i,j,icldmid,bi,bj) = qdiag(i,j,icldmid,bi,bj) + cldmid(i,j)
269        enddo        enddo
270        enddo        enddo
271        ncldmid = ncldmid + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) ncldmid = ncldmid + 1
272        endif        endif
273    
274        if( icldhi.gt.0 ) then        if( icldhi.gt.0 ) then
# Line 277  c ------------------------- Line 277  c -------------------------
277        qdiag(i,j,icldhi,bi,bj) = qdiag(i,j,icldhi,bi,bj) + cldhi(i,j)        qdiag(i,j,icldhi,bi,bj) = qdiag(i,j,icldhi,bi,bj) + cldhi(i,j)
278        enddo        enddo
279        enddo        enddo
280        ncldhi = ncldhi + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) ncldhi = ncldhi + 1
281        endif        endif
282    
283        if( ilzrad.gt.0 ) then        if( ilzrad.gt.0 ) then
# Line 289  c ------------------------- Line 289  c -------------------------
289        enddo        enddo
290        enddo        enddo
291        enddo        enddo
292        nlzrad = nlzrad + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) nlzrad = nlzrad + 1
293        endif        endif
294    
295  c Albedo Diagnostics  c Albedo Diagnostics
# Line 301  c ------------------ Line 301  c ------------------
301       .                                                     albvisdr(i,j)       .                                                     albvisdr(i,j)
302        enddo        enddo
303        enddo        enddo
304        nalbvisdr = nalbvisdr + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) nalbvisdr = nalbvisdr + 1
305        endif        endif
306    
307        if( ialbvisdf.gt.0 ) then        if( ialbvisdf.gt.0 ) then
# Line 311  c ------------------ Line 311  c ------------------
311       .                                                     albvisdf(i,j)       .                                                     albvisdf(i,j)
312        enddo        enddo
313        enddo        enddo
314        nalbvisdf = nalbvisdf + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) nalbvisdf = nalbvisdf + 1
315        endif        endif
316    
317        if( ialbnirdr.gt.0 ) then        if( ialbnirdr.gt.0 ) then
# Line 321  c ------------------ Line 321  c ------------------
321       .                                                     albnirdr(i,j)       .                                                     albnirdr(i,j)
322        enddo        enddo
323        enddo        enddo
324        nalbnirdr = nalbnirdr + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) nalbnirdr = nalbnirdr + 1
325        endif        endif
326    
327        if( ialbnirdf.gt.0 ) then        if( ialbnirdf.gt.0 ) then
# Line 331  c ------------------ Line 331  c ------------------
331       .                                                     albnirdf(i,j)       .                                                     albnirdf(i,j)
332        enddo        enddo
333        enddo        enddo
334        nalbnirdf = nalbnirdf + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) nalbnirdf = nalbnirdf + 1
335        endif        endif
336    
337  C Compute Optical Thicknesses and Diagnostics  C Compute Optical Thicknesses and Diagnostics
# Line 356  C -------------------------------------- Line 356  C --------------------------------------
356        enddo        enddo
357        enddo        enddo
358        enddo        enddo
359        ntauave = ntauave + 1        if ( (bi.eq.1) .and. (bj.eq.1) ) ntauave = ntauave + 1
360        endif        endif
361    
362        if( itaucld.gt.0 ) then        if( itaucld.gt.0 ) then
# Line 490  C ************************************** Line 490  C **************************************
490    
491        do l=1,lm        do l=1,lm
492        do i=1,istrip        do i=1,istrip
493        alf = grav*(ple(i,L+1)-ptop)/(cp*dpstrip(i,L)*100)        alf = grav*(ple(i,Lm+1)-ptop)/(cp*dpstrip(i,L)*100)
494        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)
495        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)
496        enddo        enddo
# Line 2002  c-----output parameters Line 2002  c-----output parameters
2002  c-----temporary parameters  c-----temporary parameters
2003    
2004        _RL  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,
2005       *     all,bll,st7,st8,cll,dll,fll,ell,st1,st2,st3,st4       *     all1,bll,st7,st8,cll,dll,fll,ell,st1,st2,st3,st4
2006  c  c
2007                  zth = one / csm                  zth = one / csm
2008    
# Line 2039  c   alf1 and alf2 are alpha1 and alpha2 Line 2039  c   alf1 and alf2 are alpha1 and alpha2
2039                  alf1 = gm1 - gm3 * xx                  alf1 = gm1 - gm3 * xx
2040                  alf2 = gm2 + gm3 * xx                  alf2 = gm2 + gm3 * xx
2041    
2042  c  all is last term in eq(21) of K & H  c  all1 is last term in eq(21) of K & H
2043  c  bll is last term in eq(22) of K & H  c  bll is last term in eq(22) of K & H
2044    
2045                  xx  = akk * two                  xx  = akk * two
2046                  all = (gm3 - alf2 * zth    )*xx*td                  all1 = (gm3 - alf2 * zth    )*xx*td
2047                  bll = (one - gm3 + alf1*zth)*xx                  bll = (one - gm3 + alf1*zth)*xx
2048    
2049                  xx  = akk * zth                  xx  = akk * zth
# Line 2069  c  bll is last term in eq(22) of K & H Line 2069  c  bll is last term in eq(22) of K & H
2069  c   rr is r-hat of eq(21) of K & H  c   rr is r-hat of eq(21) of K & H
2070  c   tt is diffuse part of t-hat of eq(22) of K & H  c   tt is diffuse part of t-hat of eq(22) of K & H
2071    
2072                  rr =   ( cll-dll*st4    -all*st2)*st1                  rr =   ( cll-dll*st4    -all1*st2)*st1
2073                  tt = - ((fll-ell*st4)*td-bll*st2)*st1                  tt = - ((fll-ell*st4)*td-bll*st2)*st1
2074    
2075                  rr = max(rr,zero)                  rr = max(rr,zero)
# Line 2528  c-----output (undated) parameter Line 2528  c-----output (undated) parameter
2528  c-----temporary array  c-----temporary array
2529    
2530        integer i,j,k,ic,iw        integer i,j,k,ic,iw
2531        _RL  xx,clog,wlog,dc,dw,x1,x2,y2        _RL  xx,clog1,wlog,dc,dw,x1,x2,y2
2532    
2533  c********************************************************************  c********************************************************************
2534  c-----include co2 look-up table  c-----include co2 look-up table
# Line 2545  c     extraterrestrial solar flux in the Line 2545  c     extraterrestrial solar flux in the
2545         do j= 1, n         do j= 1, n
2546          do i= 1, m          do i= 1, m
2547            xx=1./.3            xx=1./.3
2548            clog=log10(swc(i,j,k)*csm(i,j))            clog1=log10(swc(i,j,k)*csm(i,j))
2549            wlog=log10(swh(i,j,k)*csm(i,j))            wlog=log10(swh(i,j,k)*csm(i,j))
2550            ic=int( (clog+3.15)*xx+1.)            ic=int( (clog1+3.15)*xx+1.)
2551            iw=int( (wlog+4.15)*xx+1.)            iw=int( (wlog+4.15)*xx+1.)
2552            if(ic.lt.2)ic=2            if(ic.lt.2)ic=2
2553            if(iw.lt.2)iw=2            if(iw.lt.2)iw=2
2554            if(ic.gt.22)ic=22            if(ic.gt.22)ic=22
2555            if(iw.gt.19)iw=19                if(iw.gt.19)iw=19    
2556            dc=clog-float(ic-2)*.3+3.            dc=clog1-float(ic-2)*.3+3.
2557            dw=wlog-float(iw-2)*.3+4.              dw=wlog-float(iw-2)*.3+4.  
2558            x1=cah(1,iw-1)+(cah(1,iw)-cah(1,iw-1))*xx*dw            x1=cah(1,iw-1)+(cah(1,iw)-cah(1,iw-1))*xx*dw
2559            x2=cah(ic-1,iw-1)+(cah(ic-1,iw)-cah(ic-1,iw-1))*xx*dw            x2=cah(ic-1,iw-1)+(cah(ic-1,iw)-cah(ic-1,iw-1))*xx*dw
Legend:
Removed from v.1.17  
changed lines
  Added in v.1.20
  ViewVC Help
Powered by ViewVC 1.1.22