14 |
|
|
15 |
implicit none |
implicit none |
16 |
|
|
|
#ifdef ALLOW_DIAGNOSTICS |
|
|
#include "SIZE.h" |
|
|
#include "DIAGNOSTICS_SIZE.h" |
|
|
#include "DIAGNOSTICS.h" |
|
|
#endif |
|
|
|
|
17 |
c Input Variables |
c Input Variables |
18 |
c --------------- |
c --------------- |
19 |
integer im,jm,lm |
integer im,jm,lm |
141 |
_RL rkappa,p0kappa,p0kinv,ptopkap,pcheck |
_RL rkappa,p0kappa,p0kinv,ptopkap,pcheck |
142 |
_RL tice,getcon,pi |
_RL tice,getcon,pi |
143 |
integer ntracer,ntracedim, ntracex |
integer ntracer,ntracedim, ntracex |
144 |
|
|
145 |
|
#ifdef ALLOW_DIAGNOSTICS |
146 |
|
logical diagnostics_is_on |
147 |
|
external diagnostics_is_on |
148 |
|
_RL tmpdiag(im,jm),tmpdiag2(im,jm) |
149 |
|
#endif |
150 |
|
|
151 |
C ********************************************************************** |
C ********************************************************************** |
152 |
C **** INITIALIZATION **** |
C **** INITIALIZATION **** |
606 |
C (use pkegather to hold detrainment and tmpgather for cloud mass flux) |
C (use pkegather to hold detrainment and tmpgather for cloud mass flux) |
607 |
C ********************************************************************** |
C ********************************************************************** |
608 |
|
|
609 |
if(icldmas .gt.0) call paste( cldmas,tmpgather,istrip,im*jm,lm,NN) |
call paste( cldmas,tmpgather,istrip,im*jm,lm,NN) |
610 |
if(idtrain .gt.0) call paste(detrain,pkegather,istrip,im*jm,lm,NN) |
call paste(detrain,pkegather,istrip,im*jm,lm,NN) |
|
if(ipsubcld.gt.0) then |
|
611 |
call paste(psubcld ,psubcldg ,istrip,im*jm,1,NN) |
call paste(psubcld ,psubcldg ,istrip,im*jm,1,NN) |
612 |
call paste(psubcld_cnt,psubcldgc,istrip,im*jm,1,NN) |
call paste(psubcld_cnt,psubcldgc,istrip,im*jm,1,NN) |
|
endif |
|
613 |
|
|
614 |
C ********************************************************************* |
C ********************************************************************* |
615 |
C **** RE-EVAPORATION OF PENETRATING CONVECTIVE RAIN **** |
C **** RE-EVAPORATION OF PENETRATING CONVECTIVE RAIN **** |
649 |
|
|
650 |
C Paste rain evap tendencies into arrays for diagnostic output |
C Paste rain evap tendencies into arrays for diagnostic output |
651 |
c ------------------------------------------------------------ |
c ------------------------------------------------------------ |
|
if(idtls.gt.0)then |
|
652 |
DO I =1,ISTRIP |
DO I =1,ISTRIP |
653 |
TMP1(I,L) = ((TL(I,L)/PLK(I,L))-saveth(i,l))*plk(i,l)*sday*tminv |
TMP1(I,L) = ((TL(I,L)/PLK(I,L))-saveth(i,l))*plk(i,l)*sday*tminv |
654 |
ENDDO |
ENDDO |
655 |
call paste(tmp1(1,L),deltrnev(1,L),istrip,im*jm,1,NN) |
call paste(tmp1(1,L),deltrnev(1,L),istrip,im*jm,1,NN) |
|
endif |
|
656 |
|
|
|
if(idqls.gt.0)then |
|
657 |
DO I =1,ISTRIP |
DO I =1,ISTRIP |
658 |
TMP1(I,L) = (SHL(I,L)-saveq(I,L)) * 1000. * sday * tminv |
TMP1(I,L) = (SHL(I,L)-saveq(I,L)) * 1000. * sday * tminv |
659 |
ENDDO |
ENDDO |
660 |
call paste(tmp1(1,L),delqrnev(1,L),istrip,im*jm,1,NN) |
call paste(tmp1(1,L),delqrnev(1,L),istrip,im*jm,1,NN) |
|
endif |
|
661 |
|
|
662 |
ENDDO |
ENDDO |
663 |
|
|
731 |
CALL paste (tmp1(1,1), lsp_new,ISTRIP,im*jm,1,NN) |
CALL paste (tmp1(1,1), lsp_new,ISTRIP,im*jm,1,NN) |
732 |
CALL paste (tmp1(1,2),conv_new,ISTRIP,im*jm,1,NN) |
CALL paste (tmp1(1,2),conv_new,ISTRIP,im*jm,1,NN) |
733 |
CALL paste (tmp1(1,3),snow_new,ISTRIP,im*jm,1,NN) |
CALL paste (tmp1(1,3),snow_new,ISTRIP,im*jm,1,NN) |
|
|
|
|
if(iprecon.gt.0) then |
|
734 |
CALL paste (pcnet,raincgath,ISTRIP,im*jm,1,NN) |
CALL paste (pcnet,raincgath,ISTRIP,im*jm,1,NN) |
|
endif |
|
735 |
|
|
736 |
C ********************************************************************* |
C ********************************************************************* |
737 |
C **** End Major Stripped Region **** |
C **** End Major Stripped Region **** |
744 |
call back2grd ( lsp_new,pblindex, lsp_new,im*jm) |
call back2grd ( lsp_new,pblindex, lsp_new,im*jm) |
745 |
call back2grd (conv_new,pblindex,conv_new,im*jm) |
call back2grd (conv_new,pblindex,conv_new,im*jm) |
746 |
call back2grd (snow_new,pblindex,snow_new,im*jm) |
call back2grd (snow_new,pblindex,snow_new,im*jm) |
|
|
|
|
if(iprecon.gt.0) then |
|
747 |
call back2grd (raincgath,pblindex,raincgath,im*jm) |
call back2grd (raincgath,pblindex,raincgath,im*jm) |
|
endif |
|
748 |
|
|
749 |
c Subcloud Layer Pressure |
c Subcloud Layer Pressure |
750 |
c ----------------------- |
c ----------------------- |
|
if(ipsubcld.gt.0) then |
|
751 |
call back2grd (psubcldg ,pblindex,psubcldg ,im*jm) |
call back2grd (psubcldg ,pblindex,psubcldg ,im*jm) |
752 |
call back2grd (psubcldgc,pblindex,psubcldgc,im*jm) |
call back2grd (psubcldgc,pblindex,psubcldgc,im*jm) |
|
endif |
|
753 |
|
|
754 |
do L = 1,lm |
do L = 1,lm |
755 |
C Delta theta,q, convective, max and ls clouds |
C Delta theta,q, convective, max and ls clouds |
763 |
|
|
764 |
C Diagnostics: |
C Diagnostics: |
765 |
c ------------ |
c ------------ |
766 |
if(icldmas.gt.0)call back2grd(tmpgather(1,L),pblindex, |
call back2grd(tmpgather(1,L),pblindex, |
767 |
. tmpgather(1,L),im*jm) |
. tmpgather(1,L),im*jm) |
768 |
if(idtrain.gt.0)call back2grd(pkegather(1,L),pblindex, |
call back2grd(pkegather(1,L),pblindex, |
769 |
. pkegather(1,L),im*jm) |
. pkegather(1,L),im*jm) |
770 |
if(idtls.gt.0)call back2grd(deltrnev(1,L),pblindex, |
call back2grd(deltrnev(1,L),pblindex, |
771 |
. deltrnev(1,L),im*jm) |
. deltrnev(1,L),im*jm) |
772 |
if(idqls.gt.0)call back2grd(delqrnev(1,L),pblindex, |
call back2grd(delqrnev(1,L),pblindex, |
773 |
. delqrnev(1,L),im*jm) |
. delqrnev(1,L),im*jm) |
774 |
if(icldnp.gt.0)call back2grd(cldsr(1,1,L),pblindex, |
call back2grd(cldsr(1,1,L),pblindex, |
775 |
. cldsr(1,1,L),im*jm) |
. cldsr(1,1,L),im*jm) |
776 |
enddo |
enddo |
777 |
|
|
817 |
C BUMP DIAGNOSTICS |
C BUMP DIAGNOSTICS |
818 |
C ********************************************************************** |
C ********************************************************************** |
819 |
|
|
820 |
|
#ifdef ALLOW_DIAGNOSTICS |
821 |
|
|
822 |
c Sub-Cloud Layer |
c Sub-Cloud Layer |
823 |
c ------------------------- |
c ------------------------- |
824 |
if( ipsubcld.ne.0 ) then |
if(diagnostics_is_on('PSUBCLD ',myid) .and. |
825 |
do j = 1,jm |
. diagnostics_is_on('PSUBCLDC',myid) ) then |
826 |
do i = 1,im |
call diagnostics_fill(psubcldg,'PSUBCLD ',0,1,3,bi,bj,myid) |
827 |
qdiag(i,j,ipsubcld,bi,bj) = qdiag(i,j,ipsubcld,bi,bj) + |
call diagnostics_fill(psubcldgc,'PSUBCLDC',0,1,3,bi,bj,myid) |
|
. psubcldg (i,j) |
|
|
qdiag(i,j,ipsubcldc,bi,bj) = qdiag(i,j,ipsubcldc,bi,bj) + |
|
|
. psubcldgc(i,j) |
|
|
enddo |
|
|
enddo |
|
828 |
endif |
endif |
829 |
|
|
830 |
c Non-Precipitating Cloud Fraction |
c Non-Precipitating Cloud Fraction |
831 |
c -------------------------------- |
c -------------------------------- |
832 |
if( icldnp.ne.0 ) then |
if(diagnostics_is_on('CLDNP ',myid) ) then |
833 |
do L = 1,lm |
do L=1,lm |
834 |
do j = 1,jm |
do j=1,jm |
835 |
do i = 1,im |
do i=1,im |
836 |
qdiag(i,j,icldnp+L-1,bi,bj) = qdiag(i,j,icldnp+L-1,bi,bj) + |
tmpdiag(i,j) = cldsr(i,j,L) |
837 |
. cldsr(i,j,L) |
enddo |
838 |
enddo |
enddo |
839 |
enddo |
call diagnostics_fill(tmpdiag,'CLDNP ',L,1,3,bi,bj,myid) |
840 |
enddo |
enddo |
|
ncldnp = ncldnp + 1 |
|
841 |
endif |
endif |
842 |
|
|
843 |
c Moist Processes Heating Rate |
c Moist Processes Heating Rate |
844 |
c ---------------------------- |
c ---------------------------- |
845 |
if(imoistt.gt.0) then |
if(diagnostics_is_on('MOISTT ',myid) ) then |
846 |
do L = 1,lm |
do L=1,lm |
847 |
do j = 1,jm |
do j=1,jm |
848 |
do i = 1,im |
do i=1,im |
849 |
indgath = (j-1)*im + i |
indgath = (j-1)*im + i |
850 |
qdiag(i,j,imoistt+L-1,bi,bj) = qdiag(i,j,imoistt+L-1,bi,bj) + |
tmpdiag(i,j)=(dtmoist(i,j,L)*sday*pkzgather(indgath,L)/pz(i,j)) |
851 |
. (dtmoist(i,j,L)*sday*pkzgather(indgath,L)/pz(i,j)) |
enddo |
852 |
enddo |
enddo |
853 |
enddo |
call diagnostics_fill(tmpdiag,'MOISTT ',L,1,3,bi,bj,myid) |
854 |
enddo |
enddo |
855 |
endif |
endif |
856 |
|
|
857 |
c Moist Processes Moistening Rate |
c Moist Processes Moistening Rate |
858 |
c ------------------------------- |
c ------------------------------- |
859 |
if(imoistq.gt.0) then |
if(diagnostics_is_on('MOISTQ ',myid) ) then |
860 |
do L = 1,lm |
do L=1,lm |
861 |
do j = 1,jm |
do j=1,jm |
862 |
do i = 1,im |
do i=1,im |
863 |
qdiag(i,j,imoistq+L-1,bi,bj) = qdiag(i,j,imoistq+L-1,bi,bj) + |
tmpdiag(i,j)=(dqmoist(i,j,L,1)*sday*1000./pz(i,j)) |
864 |
. (dqmoist(i,j,L,1)*sday*1000.0/pz(i,j)) |
enddo |
865 |
enddo |
enddo |
866 |
enddo |
call diagnostics_fill(tmpdiag,'MOISTQ ',L,1,3,bi,bj,myid) |
|
enddo |
|
|
endif |
|
|
|
|
|
c Moist Processes Change in U-Momentum (Cumulus Friction) |
|
|
c ------------------------------------------------------ |
|
|
if(iudiag1.gt.0) then |
|
|
do L = 1,lm |
|
|
do j = 1,jm |
|
|
do i = 1,im |
|
|
indgath = (j-1)*im + i |
|
|
qdiag(i,j,iudiag1+L-1,bi,bj) = qdiag(i,j,iudiag1+L-1,bi,bj) + |
|
|
. dumoist(i,j,L)*sday |
|
|
enddo |
|
|
enddo |
|
|
enddo |
|
|
endif |
|
|
|
|
|
c Moist Processes Change in V-Momentum (Cumulus Friction) |
|
|
c ------------------------------------------------------ |
|
|
if(iudiag2.gt.0) then |
|
|
do L = 1,lm |
|
|
do j = 1,jm |
|
|
do i = 1,im |
|
|
indgath = (j-1)*im + i |
|
|
qdiag(i,j,iudiag2+L-1,bi,bj) = qdiag(i,j,iudiag2+L-1,bi,bj) + |
|
|
. dvmoist(i,j,L)*sday |
|
|
enddo |
|
|
enddo |
|
867 |
enddo |
enddo |
868 |
endif |
endif |
869 |
|
|
870 |
c Cloud Mass Flux |
c Cloud Mass Flux |
871 |
c --------------- |
c --------------- |
872 |
if(icldmas.gt.0) then |
if(diagnostics_is_on('CLDMAS ',myid) ) then |
873 |
do L = 1,lm |
do L=1,lm |
874 |
do j = 1,jm |
do j=1,jm |
875 |
do i = 1,im |
do i=1,im |
876 |
indgath = (j-1)*im + i |
indgath = (j-1)*im + i |
877 |
qdiag(i,j,icldmas+L-1,bi,bj) = qdiag(i,j,icldmas+L-1,bi,bj) + |
tmpdiag(i,j)=tmpgather(indgath,L) |
878 |
. tmpgather(indgath,L) |
enddo |
879 |
enddo |
enddo |
880 |
enddo |
call diagnostics_fill(tmpdiag,'CLDMAS ',L,1,3,bi,bj,myid) |
881 |
enddo |
enddo |
882 |
endif |
endif |
883 |
|
|
884 |
c Detrained Cloud Mass Flux |
c Detrained Cloud Mass Flux |
885 |
c ------------------------- |
c ------------------------- |
886 |
if(idtrain.gt.0) then |
if(diagnostics_is_on('DTRAIN ',myid) ) then |
887 |
do L = 1,lm |
do L=1,lm |
888 |
do j = 1,jm |
do j=1,jm |
889 |
do i = 1,im |
do i=1,im |
890 |
indgath = (j-1)*im + i |
indgath = (j-1)*im + i |
891 |
qdiag(i,j,idtrain+L-1,bi,bj) = qdiag(i,j,idtrain+L-1,bi,bj) + |
tmpdiag(i,j)=pkegather(indgath,L) |
892 |
. pkegather(indgath,L) |
enddo |
893 |
enddo |
enddo |
894 |
enddo |
call diagnostics_fill(tmpdiag,'DTRAIN ',L,1,3,bi,bj,myid) |
895 |
enddo |
enddo |
896 |
endif |
endif |
897 |
|
|
898 |
c Grid-Scale Condensational Heating Rate |
c Grid-Scale Condensational Heating Rate |
899 |
c -------------------------------------- |
c -------------------------------------- |
900 |
if(idtls.gt.0) then |
if(diagnostics_is_on('DTLS ',myid) ) then |
901 |
do L = 1,lm |
do L=1,lm |
902 |
do j = 1,jm |
do j=1,jm |
903 |
do i = 1,im |
do i=1,im |
904 |
indgath = (j-1)*im + i |
indgath = (j-1)*im + i |
905 |
qdiag(i,j,idtls+L-1,bi,bj) = qdiag(i,j,idtls+L-1,bi,bj) + |
tmpdiag(i,j)=deltrnev(indgath,L) |
906 |
. deltrnev(indgath,L) |
enddo |
907 |
enddo |
enddo |
908 |
enddo |
call diagnostics_fill(tmpdiag,'DTLS ',L,1,3,bi,bj,myid) |
909 |
enddo |
enddo |
910 |
endif |
endif |
911 |
|
|
912 |
c Grid-Scale Condensational Moistening Rate |
c Grid-Scale Condensational Moistening Rate |
913 |
c ----------------------------------------- |
c ----------------------------------------- |
914 |
if(idqls.gt.0) then |
if(diagnostics_is_on('DQLS ',myid) ) then |
915 |
do L = 1,lm |
do L=1,lm |
916 |
do j = 1,jm |
do j=1,jm |
917 |
do i = 1,im |
do i=1,im |
918 |
indgath = (j-1)*im + i |
indgath = (j-1)*im + i |
919 |
qdiag(i,j,idqls+L-1,bi,bj) = qdiag(i,j,idqls+L-1,bi,bj) + |
tmpdiag(i,j)=delqrnev(indgath,L) |
920 |
. delqrnev(indgath,L) |
enddo |
921 |
enddo |
enddo |
922 |
enddo |
call diagnostics_fill(tmpdiag,'DQLS ',L,1,3,bi,bj,myid) |
923 |
enddo |
enddo |
924 |
endif |
endif |
925 |
|
|
926 |
c Total Precipitation |
c Total Precipitation |
927 |
c ------------------- |
c ------------------- |
928 |
if(ipreacc.gt.0) then |
if(diagnostics_is_on('PREACC ',myid) ) then |
929 |
do j = 1,jm |
do j=1,jm |
930 |
do i = 1,im |
do i=1,im |
931 |
qdiag(i,j,ipreacc,bi,bj) = qdiag(i,j,ipreacc,bi,bj) |
tmpdiag(i,j) = (lsp_new(I,j) + snow_new(I,j) + conv_new(i,j)) |
932 |
. + ( lsp_new(I,j) |
. *sday*tminv |
933 |
. + snow_new(I,j) |
enddo |
934 |
. + conv_new(i,j) ) *sday*tminv |
enddo |
935 |
enddo |
call diagnostics_fill(tmpdiag,'PREACC ',0,1,3,bi,bj,myid) |
|
enddo |
|
936 |
endif |
endif |
937 |
|
|
938 |
c Convective Precipitation |
c Convective Precipitation |
939 |
c ------------------------ |
c ------------------------ |
940 |
if(iprecon.gt.0) then |
if(diagnostics_is_on('PRECON ',myid) ) then |
941 |
do j = 1,jm |
do j=1,jm |
942 |
do i = 1,im |
do i=1,im |
943 |
indgath = (j-1)*im + i |
indgath = (j-1)*im + i |
944 |
qdiag(i,j,iprecon,bi,bj) = qdiag(i,j,iprecon,bi,bj) + |
tmpdiag(i,j) = raincgath(indgath)*sday*tminv |
945 |
. raincgath(indgath)*sday*tminv |
enddo |
946 |
enddo |
enddo |
947 |
enddo |
call diagnostics_fill(tmpdiag,'PRECON ',0,1,3,bi,bj,myid) |
948 |
endif |
endif |
949 |
|
|
950 |
|
#endif |
951 |
|
|
952 |
C ********************************************************************** |
C ********************************************************************** |
953 |
C **** Fill Rainfall and Snowfall Arrays for Land Surface Model **** |
C **** Fill Rainfall and Snowfall Arrays for Land Surface Model **** |
954 |
C **** Note: Precip Rates work when DT(turb)<DT(moist) **** |
C **** Note: Precip Rates work when DT(turb)<DT(moist) **** |
1063 |
C *** Fill Cloud Top Pressure and Temperature Diagnostic *** |
C *** Fill Cloud Top Pressure and Temperature Diagnostic *** |
1064 |
C ********************************************************************** |
C ********************************************************************** |
1065 |
|
|
1066 |
if(icldtmp.gt.0) then |
#ifdef ALLOW_DIAGNOSTICS |
1067 |
do j = 1,jm |
if(diagnostics_is_on('CLDTMP ',myid) .and. |
1068 |
do i = 1,im |
. diagnostics_is_on('CTTCNT ',myid) ) then |
1069 |
if( cldtmp(i,j).gt.0.0 ) then |
do j=1,jm |
1070 |
qdiag(i,j,icldtmp,bi,bj) = qdiag(i,j,icldtmp,bi,bj) + |
do i=1,im |
1071 |
. cldtmp(i,j)*totcld(i,j)/tmpimjm(i,j) |
if( cldtmp(i,j).gt.0. ) then |
1072 |
qdiag(i,j,icttcnt,bi,bj) = qdiag(i,j,icttcnt,bi,bj) + |
tmpdiag(i,j) = cldtmp(i,j)*totcld(i,j)/tmpimjm(i,j) |
1073 |
. totcld(i,j) |
tmpdiag2(i,j) = totcld(i,j) |
1074 |
endif |
else |
1075 |
enddo |
tmpdiag(i,j) = 0. |
1076 |
enddo |
tmpdiag2(i,j) = 0. |
1077 |
|
endif |
1078 |
|
enddo |
1079 |
|
enddo |
1080 |
|
call diagnostics_fill(tmpdiag,'CLDTMP ',0,1,3,bi,bj,myid) |
1081 |
|
call diagnostics_fill(tmpdiag2,'CTTCNT ',0,1,3,bi,bj,myid) |
1082 |
endif |
endif |
1083 |
|
|
1084 |
if(icldprs.gt.0) then |
if(diagnostics_is_on('CLDPRS ',myid) .and. |
1085 |
do j = 1,jm |
. diagnostics_is_on('CTPCNTC ',myid) ) then |
1086 |
do i = 1,im |
do j=1,jm |
1087 |
if( cldprs(i,j).gt.0.0 ) then |
do i=1,im |
1088 |
qdiag(i,j,icldprs,bi,bj) = qdiag(i,j,icldprs,bi,bj) + |
if( cldprs(i,j).gt.0. ) then |
1089 |
. cldprs(i,j)*totcld(i,j)/tmpimjm(i,j) |
tmpdiag(i,j) = cldprs(i,j)*totcld(i,j)/tmpimjm(i,j) |
1090 |
qdiag(i,j,ictpcnt,bi,bj) = qdiag(i,j,ictpcnt,bi,bj) + |
tmpdiag2(i,j) = totcld(i,j) |
1091 |
. totcld(i,j) |
else |
1092 |
endif |
tmpdiag(i,j) = 0. |
1093 |
enddo |
tmpdiag2(i,j) = 0. |
1094 |
enddo |
endif |
1095 |
|
enddo |
1096 |
|
enddo |
1097 |
|
call diagnostics_fill(tmpdiag,'CLDPRS ',0,1,3,bi,bj,myid) |
1098 |
|
call diagnostics_fill(tmpdiag2,'CTPCNT ',0,1,3,bi,bj,myid) |
1099 |
endif |
endif |
1100 |
|
|
1101 |
|
#endif |
1102 |
|
|
1103 |
C ********************************************************************** |
C ********************************************************************** |
1104 |
C **** INCREMENT COUNTERS **** |
C **** INCREMENT COUNTERS **** |
1110 |
nlwcld = nlwcld + 1 |
nlwcld = nlwcld + 1 |
1111 |
nswcld = nswcld + 1 |
nswcld = nswcld + 1 |
1112 |
|
|
|
#ifdef ALLOW_DIAGNOSTICS |
|
|
if( (bi.eq.1) .and. (bj.eq.1) ) then |
|
|
nmoistt = nmoistt + 1 |
|
|
nmoistq = nmoistq + 1 |
|
|
npreacc = npreacc + 1 |
|
|
nprecon = nprecon + 1 |
|
|
|
|
|
ncldmas = ncldmas + 1 |
|
|
ndtrain = ndtrain + 1 |
|
|
|
|
|
ndtls = ndtls + 1 |
|
|
ndqls = ndqls + 1 |
|
|
|
|
|
nudiag1 = nudiag1 + 1 |
|
|
nudiag2 = nudiag2 + 1 |
|
|
|
|
|
endif |
|
|
#endif |
|
|
|
|
1113 |
RETURN |
RETURN |
1114 |
END |
END |
1115 |
SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT |
SUBROUTINE RAS( NN, LNG, LENC, K, NLTOP, nlayr, DT |