1 |
C $Header$ |
C $Header$ |
2 |
C $Name$ |
C $Name$ |
3 |
|
|
4 |
|
#include "CPP_OPTIONS.h" |
5 |
subroutine swrio (nymd,nhms,ndswr,myid,istrip,npcs, |
subroutine swrio (nymd,nhms,ndswr,myid,istrip,npcs, |
6 |
. pz,tz,qz,pkht,oz,co2, |
. pz,tz,qz,pkht,oz,co2, |
7 |
. albvisdr,albvisdf,albnirdr,albnirdf, |
. albvisdr,albvisdf,albnirdr,albnirdf, |
8 |
. dtradsw,dtswclr,radswg,swgclr,albedo, |
. dtradsw,dtswclr,radswg,swgclr,albedo, |
9 |
. fdifpar,fdirpar,osr,osrclr, |
. fdifpar,fdirpar,osr,osrclr, |
10 |
. im,jm,lm,sige,sig,dsig,ptop, |
. im,jm,lm,sige,sig,dsig,ptop, |
11 |
. nswcld,cldsw,cswmo,nswlz,swlz, |
. nswcld,cldsw,cswmo,nswlz,swlz, |
12 |
. lpnt,qdiag,nd, |
. lpnt,imstturb,qliqave,fccave,landtype,xlats,xlons) |
|
. imstturb,qliqave,fccave,landtype,xlats,xlons) |
|
13 |
|
|
14 |
implicit none |
implicit none |
15 |
include 'diag.com' |
#ifdef ALLOW_DIAGNOSTICS |
16 |
|
#include "diagnostics.h" |
17 |
|
#endif |
18 |
|
|
19 |
c Input Variables |
c Input Variables |
20 |
c --------------- |
c --------------- |
21 |
integer nymd,nhms,ndswr,istrip,npcs,nd |
integer nymd,nhms,ndswr,istrip,npcs |
22 |
|
|
23 |
integer im,jm,lm ! Physics Grid |
integer im,jm,lm |
24 |
real ptop ! Physics Grid |
real ptop |
25 |
real sige(lm+1) ! Physics Grid |
real sige(lm+1) |
26 |
real sig(lm) ! Physics Grid |
real sig(lm) |
27 |
real dsig(lm) ! Physics Grid |
real dsig(lm) |
28 |
|
|
29 |
real pz(im,jm) ! Dynamics State |
real pz(im,jm) |
30 |
real tz(im,jm,lm) ! Dynamics State |
real tz(im,jm,lm) |
31 |
real pkht(im,jm,lm) ! Dynamics State |
real pkht(im,jm,lm) |
32 |
|
|
33 |
real co2 ! Chemistry State |
real co2 |
34 |
real oz(im,jm,lm) ! Chemistry Coupling |
real oz(im,jm,lm) |
35 |
real qz(im,jm,lm) ! Chemistry Coupling + Dynamics State |
real qz(im,jm,lm) |
36 |
|
|
37 |
real albvisdr(im,jm) ! Land Coupling |
real albvisdr(im,jm) |
38 |
real albvisdf(im,jm) ! Land Coupling |
real albvisdf(im,jm) |
39 |
real albnirdr(im,jm) ! Land Coupling |
real albnirdr(im,jm) |
40 |
real albnirdf(im,jm) ! Land Coupling |
real albnirdf(im,jm) |
41 |
|
|
42 |
real radswg(im,jm) ! Shortwave Coupling |
real radswg(im,jm) |
43 |
real swgclr(im,jm) ! Shortwave Coupling |
real swgclr(im,jm) |
44 |
real albedo(im,jm) ! Shortwave Coupling |
real albedo(im,jm) |
45 |
real fdifpar(im,jm) ! Shortwave Coupling |
real fdifpar(im,jm) |
46 |
real fdirpar(im,jm) ! Shortwave Coupling |
real fdirpar(im,jm) |
47 |
real osr(im,jm) ! Shortwave Coupling |
real osr(im,jm) |
48 |
real osrclr(im,jm) ! Shortwave Coupling |
real osrclr(im,jm) |
49 |
real dtradsw(im,jm,lm) ! Shortwave Tendency |
real dtradsw(im,jm,lm) |
50 |
real dtswclr(im,jm,lm) ! Shortwave Tendency |
real dtswclr(im,jm,lm) |
51 |
|
|
52 |
integer nswcld,nswlz ! Moist Coupling |
integer nswcld,nswlz |
53 |
real cldsw(im,jm,lm) ! Moist Coupling |
real cldsw(im,jm,lm) |
54 |
real cswmo(im,jm,lm) ! Moist Coupling |
real cswmo(im,jm,lm) |
55 |
real swlz(im,jm,lm) ! Moist Coupling |
real swlz(im,jm,lm) |
56 |
|
|
57 |
real qdiag(im,jm,nd) ! Diagnostics |
logical lpnt |
58 |
logical lpnt ! Point by Point Flag |
integer imstturb |
59 |
integer imstturb ! Turb Coupling |
real qliqave(im,jm,lm) |
60 |
real qliqave(im,jm,lm) ! Turb Coupling |
real fccave(im,jm,lm) |
|
real fccave(im,jm,lm) ! Turb Coupling |
|
61 |
|
|
62 |
integer landtype(im,jm) ! Surface Land Type |
integer landtype(im,jm) |
63 |
|
|
64 |
c Local Variables |
c Local Variables |
65 |
c --------------- |
c --------------- |
68 |
real getcon,grav,cp,undef,pcheck |
real getcon,grav,cp,undef,pcheck |
69 |
real ra,alf,reffw,reffi,tminv |
real ra,alf,reffw,reffi,tminv |
70 |
|
|
71 |
parameter ( reffw = 10.0 ) ! Effective radius for water droplets |
parameter ( reffw = 10.0 ) |
72 |
parameter ( reffi = 65.0 ) ! Effective radius for ice particles |
parameter ( reffi = 65.0 ) |
73 |
|
|
74 |
real alat(im,jm) |
real alat(im,jm) |
75 |
real alon(im,jm) |
real alon(im,jm) |
224 |
do L =1,lm |
do L =1,lm |
225 |
do j =1,jm |
do j =1,jm |
226 |
do i =1,im |
do i =1,im |
227 |
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)) |
228 |
cldmxo(i,j,L) = min( 1.0, cswmo(i,j,L) ) |
cldmxo(i,j,L)=min(1.0,cswmo(i,j,L)) |
229 |
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 |
230 |
enddo |
enddo |
231 |
enddo |
enddo |
232 |
enddo |
enddo |
384 |
|
|
385 |
C Compute Optical Thicknesses and Diagnostics |
C Compute Optical Thicknesses and Diagnostics |
386 |
C ------------------------------------------- |
C ------------------------------------------- |
387 |
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, |
388 |
|
. tautype) |
389 |
|
|
390 |
do L = 1,lm |
do L = 1,lm |
391 |
do j = 1,jm |
do j = 1,jm |
392 |
do i = 1,im |
do i = 1,im |
393 |
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) |
394 |
enddo |
enddo |
395 |
enddo |
enddo |
396 |
enddo |
enddo |
399 |
do L=1,lm |
do L=1,lm |
400 |
do j=1,jm |
do j=1,jm |
401 |
do i=1,im |
do i=1,im |
402 |
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) = qdiag(i,j,itauave+L-1) + |
403 |
|
. tau(i,j,L)*100/(plze(i,j,L+1)-plze(i,j,L)) |
404 |
enddo |
enddo |
405 |
enddo |
enddo |
406 |
enddo |
enddo |
411 |
do L=1,lm |
do L=1,lm |
412 |
do j=1,jm |
do j=1,jm |
413 |
do i=1,im |
do i=1,im |
414 |
if( cldtot(i,j,L).ne.0.0 ) then |
if( cldtot(i,j,L).ne.0.0 ) then |
415 |
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) = qdiag(i,j,itaucld +L-1) + |
416 |
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)) |
417 |
endif |
qdiag(i,j,itaucldc+L-1) = qdiag(i,j,itaucldc+L-1) + 1.0 |
418 |
|
endif |
419 |
enddo |
enddo |
420 |
enddo |
enddo |
421 |
enddo |
enddo |
554 |
c Calculate Mean Albedo |
c Calculate Mean Albedo |
555 |
c --------------------- |
c --------------------- |
556 |
do i=1,istrip |
do i=1,istrip |
557 |
if( cosz(i).gt.0.0 ) then |
if( cosz(i).gt.0.0 ) then |
558 |
tstrip(i) = 1.0 - flux(i,lm+1)/( fdirir(i)+fdifir(i)+dirpar(i)+difpar(i) |
tstrip(i) = 1.0 - flux(i,lm+1)/ |
559 |
. + fdiruv(i)+fdifuv(i) ) |
. ( fdirir(i)+fdifir(i)+dirpar(i)+difpar(i) + fdiruv(i)+fdifuv(i) ) |
560 |
if( tstrip(i).lt.0.0 ) tstrip(i) = undef |
if( tstrip(i).lt.0.0 ) tstrip(i) = undef |
561 |
else |
else |
562 |
tstrip(i) = undef |
tstrip(i) = undef |
563 |
endif |
endif |
564 |
enddo |
enddo |
565 |
call paste ( tstrip,albedo,istrip,im*jm,1,nn ) |
call paste ( tstrip,albedo,istrip,im*jm,1,nn ) |
566 |
|
|
676 |
|
|
677 |
c Large-Scale Water |
c Large-Scale Water |
678 |
c ----------------- |
c ----------------- |
679 |
|
C Over Land |
680 |
if( lwi(i,j).le.10 ) then |
if( lwi(i,j).le.10 ) then |
681 |
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) ) |
682 |
tau(i,j,L,3) = fracls*alf*tauh2o*dp |
tau(i,j,L,3) = fracls*alf*tauh2o*dp |
683 |
else |
else |
684 |
if( lz(i,j,L).eq.0.0 ) then |
C Non-Precipitation Clouds Over Ocean |
685 |
tauh2o = .12 ! Non-Precipitation Clouds Over Ocean |
if( lz(i,j,L).eq.0.0 ) then |
686 |
tau(i,j,L,2) = fracls*alf*tauh2o*dp |
tauh2o = .12 |
687 |
else |
tau(i,j,L,2) = fracls*alf*tauh2o*dp |
688 |
tauh2o = max( 0.0020, 0.120*min( 20*lz(i,j,L)*1000,1.0) ) ! Over Ocean |
else |
689 |
tau(i,j,L,3) = fracls*alf*tauh2o*dp |
C Over Ocean |
690 |
endif |
tauh2o = max( 0.0020, 0.120*min( 20*lz(i,j,L)*1000,1.0) ) |
691 |
|
tau(i,j,L,3) = fracls*alf*tauh2o*dp |
692 |
|
endif |
693 |
endif |
endif |
694 |
|
|
695 |
c Sub-Grid Convective |
c Sub-Grid Convective |
816 |
#if f77 |
#if f77 |
817 |
cfpp$ expand (expmn) |
cfpp$ expand (expmn) |
818 |
#endif |
#endif |
|
#if f90 |
|
|
!DIR$ inline always expmn |
|
|
#endif |
|
819 |
#endif |
#endif |
820 |
real expmn |
real expmn |
821 |
|
|
1278 |
cfpp$ expand (sagpol) |
cfpp$ expand (sagpol) |
1279 |
cfpp$ expand (expmn) |
cfpp$ expand (expmn) |
1280 |
#endif |
#endif |
|
#if f90 |
|
|
!DIR$ inline always deledd |
|
|
!DIR$ inline always sagpol |
|
|
!DIR$ inline always expmn |
|
|
#endif |
|
1281 |
#endif |
#endif |
1282 |
real expmn |
real expmn |
1283 |
|
|
1687 |
cfpp$ expand (deledd) |
cfpp$ expand (deledd) |
1688 |
cfpp$ expand (sagpol) |
cfpp$ expand (sagpol) |
1689 |
#endif |
#endif |
|
#if f90 |
|
|
!DIR$ inline always deledd |
|
|
!DIR$ inline always sagpol |
|
|
#endif |
|
1690 |
#endif |
#endif |
1691 |
|
|
1692 |
c-----input parameters |
c-----input parameters |
2003 |
#if f77 |
#if f77 |
2004 |
cfpp$ expand (expmn) |
cfpp$ expand (expmn) |
2005 |
#endif |
#endif |
|
#if f90 |
|
|
!DIR$ inline always expmn |
|
|
#endif |
|
2006 |
#endif |
#endif |
2007 |
real expmn |
real expmn |
2008 |
|
|
2127 |
#if f77 |
#if f77 |
2128 |
cfpp$ expand (expmn) |
cfpp$ expand (expmn) |
2129 |
#endif |
#endif |
|
#if f90 |
|
|
!DIR$ inline always expmn |
|
|
#endif |
|
2130 |
#endif |
#endif |
2131 |
real expmn |
real expmn |
2132 |
|
|