!copyright (C) 2001 MSC-RPN COMM %%%RPNPHY%%%
***S/P LIN_CONDS1_AD
*
SUBROUTINE LIN_CONDS1_AD (TE,QE,SRR,SSR,TP1,QP1,PSP1,TP5,QP5,PSP5, 1
% SIGMA,TAU,N,NK)
*
#include "impnone.cdk"
INTEGER N, NK
REAL TE(N,NK),QE(N,NK),SRR(N),SSR(N)
REAL TP1(N,NK),QP1(N,NK),PSP1(N)
REAL TP5(N,NK),QP5(N,NK),PSP5(N)
REAL SIGMA(N,NK), TAU
*
*Author
* S. Laroche (May 2001)
*
*Revisions
* 001 S. Laroche (Nov 2002) - add effect of surface pressure perturbations
*
*
*Object
* to calculate the ADJ of T and Q tendencies due to large scale
* precipitation
*
*Arguments
*
* - Input -
* TE temperature tendency due to stratiform processes
* QE specific humidity tendency due to stratiform processes
*
* - Output -
* TP1 perturbation of temperature
* QP1 perturbation of specific humidity
* PSP1 perturbation of surface pressure
* SRR rate of liquid precipitation
* SSR rate of solid precipitation
*
* - Input -
* TP5 trajectory of temperature
* QP5 trajectory of specific humidity
* PSP5 trajectory of surface pressure
* SIGMA sigma levels
* TAU timestep
* N dimension of some arrays
* NK vertical dimension
**
*
#include "phy_macros_f.h"
#include "consphy.cdk"
INTEGER i,k,iter,niter
REAL A1,A3,A4,LC
REAL CHLS,ZCONS2
PARAMETER(niter=2)
REAL QS(niter),DQSDT(niter),DELQ(niter)
REAL TW(niter+1),QW(niter+1)
REAL QS5(niter),DQSDT5(niter),DELQ5(niter)
REAL TW5(niter+1),QW5(niter+1),ZRIT5
C
C* POINTEURS POUR ALLOCATION DYNAMIQUE
C* -----------------------------------
C
AUTOMATIC ( ZDSG, REAL , (N,NK) )
AUTOMATIC ( ZPP1, REAL , (N,NK) )
AUTOMATIC ( ZDPP1, REAL , (N,NK) )
AUTOMATIC ( ZRFLN, REAL , (N) )
AUTOMATIC ( ZRFL , REAL , (N) )
AUTOMATIC ( ZSFLN, REAL , (N) )
AUTOMATIC ( ZSFL , REAL , (N) )
AUTOMATIC ( ZFLN , REAL , (N) )
AUTOMATIC ( ZPP5, REAL , (N,NK) )
AUTOMATIC ( ZDPP5, REAL , (N,NK) )
AUTOMATIC ( ZRFLN5, REAL , (N) )
AUTOMATIC ( ZRFL5 , REAL , (N) )
AUTOMATIC ( ZSFLN5, REAL , (N) )
AUTOMATIC ( ZSFL5 , REAL , (N) )
AUTOMATIC ( ZFLN5 , REAL , (N) )
C
C* COMPUTATIONAL CONSTANTS
C* -----------------------
C
CHLS = CHLC + CHLF
ZCONS2 = 1./(TAU*GRAV)
A1 = 610.78
DO i=1,N
ZDSG(i,1) = 0.5*(SIGMA(i,2)-SIGMA(i,1))
DO k=2,NK-1
ZDSG(i,k) = 0.5*(SIGMA(i,k+1)-SIGMA(i,k-1))
ENDDO
ZDSG(i,NK) = 0.5*(1.-SIGMA(i,NK-1))+0.5*(1.-SIGMA(i,NK))
ENDDO
DO k=1,NK
DO i=1,N
ZPP1(i,k) = 0.
ZDPP1(i,k) = 0.
ZPP5(i,k) = SIGMA(i,k)*PSP5(i)
ZDPP5(i,k) = ZDSG(i,k) *PSP5(i)
ENDDO
ENDDO
DO i=1,N
ZRFLN(i) = 0.
ZSFLN(i) = 0.
ZRFL(i) = 0.
ZSFL(i) = 0.
ZFLN(i) = 0.
ZRFL5(i) = 0.
ZSFL5(i) = 0.
ZFLN5(i) = 0.
ENDDO
C
C THE FORCING FROM THE PRECIPITATION RATE AT THE GROUND LEVEL
C IS ASSUMED HERE EQUAL TO ZERO. IF THE ASSIMILATION OF
C PRECIPITATION RATE IS DONE, THEN SSR AND SRR SHOULD
C NOT BE SET TO ZERO
C
DO i=1,N
SSR(i) = 0.
SRR(i) = 0.
ENDDO
C
C* PRECIPITATION RATE AT THE GROUND LEVEL
C* --------------------------------------
C
DO i=1,N
ZSFL(i) = SSR(i) + ZSFL(i)
SSR(i) = 0.
ZRFL(i) = SRR(i) + ZRFL(i)
SRR(i) = 0.
ENDDO
C
C* CALCULATE TW AND QW IN SUPERSATURATED LAYERS
C* --------------------------------------------
C
DO k=NK,1,-1
DO i=N,1,-1
*
* ************************* TRAJECTORY ***********************
*
TW5(1) = TP5(i,k)
QW5(1) = QP5(i,k)
IF(TP5(i,k).ge.TGL) THEN
A3 = 17.269
A4 = 35.860
LC = CHLC
ELSE
A3 = 21.875
A4 = 7.660
LC = CHLS
ENDIF
QS5(1) = EPS1*A1*exp(A3*(TW5(1) - TGL)/(TW5(1) - A4))/ZPP5(i,k)
IF(QS5(1).lt.QP5(i,k)) THEN
DO iter = 1,niter
QS5(iter) = EPS1*A1*exp(A3*(TW5(iter) - TGL)/(TW5(iter) - A4))/ZPP5(i,k)
DQSDT5(iter) = QS5(iter)*A3*(TGL - A4)/((TW5(iter) - A4)**2)
DELQ5(iter) = (QW5(iter) - QS5(iter))/(1.0 + (LC/CPD)*DQSDT5(iter))
TW5(iter+1) = TW5(iter) + (LC/CPD)*DELQ5(iter)
QW5(iter+1) = QW5(iter) - DELQ5(iter)
ENDDO
ELSE
QW5(niter+1) = QW5(1)
TW5(niter+1) = TW5(1)
ENDIF
ZRFLN5(i) = ZRFL5(i)
ZSFLN5(i) = ZSFL5(i)
IF(QW5(niter+1).lt.QP5(i,k)) THEN
IF(TP5(i,k).gt.TGL) THEN
ZRFLN5(i) = ZRFLN5(i) + (QP5(i,k)-QW5(niter+1))*ZDPP5(i,k)*ZCONS2
ELSE
ZSFLN5(i) = ZSFLN5(i) + (QP5(i,k)-QW5(niter+1))*ZDPP5(i,k)*ZCONS2
ENDIF
ENDIF
IF (k.GT.1) THEN
ZFLN5(i) = ZRFLN5(i) + ZSFLN5(i)
IF(TP5(i,k).lt.TGL) ZRIT5 = 1.
IF(TP5(i,k).ge.TGL) ZRIT5 = 0.
ZSFLN5(i) = ZRIT5 *ZFLN5(i)
ZRFLN5(i) = (1.-ZRIT5)*ZFLN5(i)
ENDIF
*
* **************************** ADJ ****************************
*
*
C
C* TENDENCIES DUE TO CONDENSATION
C* ------------------------------
C
ZSFLN(i) = ZSFLN(i) + ZSFL(i)
ZSFL(i) = 0.
ZRFLN(i) = ZRFLN(i) + ZRFL(i)
ZRFL(i) = 0.
ZRFLN(i) = ZRFLN(i) + TE(i,k)*(CHLC/CPD)*(GRAV/ZDPP5(i,k))
ZRFL(i) = ZRFL(i) - TE(i,k)*(CHLC/CPD)*(GRAV/ZDPP5(i,k))
ZSFLN(i) = ZSFLN(i) + TE(i,k)*(CHLS/CPD)*(GRAV/ZDPP5(i,k))
ZSFL(i) = ZSFL(i) - TE(i,k)*(CHLS/CPD)*(GRAV/ZDPP5(i,k))
ZDPP1(i,k) = ZDPP1(i,k) - TE(i,k)*(GRAV/(ZDPP5(i,k)**2))
% *((ZRFLN5(i)-ZRFL5(i))*CHLC/CPD+(ZSFLN5(i)-ZSFL5(i))*CHLS/CPD)
TE(i,k) = 0.
ZRFLN(i) = ZRFLN(i) - QE(i,k)*(GRAV/ZDPP5(i,k))
ZRFL(i) = ZRFL(i) + QE(i,k)*(GRAV/ZDPP5(i,k))
ZSFLN(i) = ZSFLN(i) - QE(i,k)*(GRAV/ZDPP5(i,k))
ZSFL(i) = ZSFL(i) + QE(i,k)*(GRAV/ZDPP5(i,k))
ZDPP1(i,k) = ZDPP1(i,k) + QE(i,k)*(GRAV/(ZDPP5(i,k)**2))
% *((ZRFLN5(i)-ZRFL5(i))+(ZSFLN5(i)-ZSFL5(i)))
QE(i,k) = 0.
ZRFL5(i) = ZRFLN5(i)
ZSFL5(i) = ZSFLN5(i)
IF (k.GT.1) THEN
C
C* MELTING/FREEZING OF PRECIPITATIONS
C* ----------------------------------
C
ZFLN(i) = (1.-ZRIT5)*ZRFLN(i) + ZRIT5 *ZSFLN(i)
ZRFLN(i) = ZFLN(i)
ZSFLN(i) = ZFLN(i)
ZFLN(i) = 0.
ENDIF
C
C* CALCULATE RAIN/SNOW FLUX IN SUPERSATURATED LAYERS
C* -------------------------------------------------
C
TW(niter+1) = 0.
QW(niter+1) = 0.
IF(QW5(niter+1).lt.QP5(i,k)) THEN
IF(TP5(i,k).gt.TGL) THEN
QP1(i,k) = QP1(i,k) + ZRFLN(i)*ZDPP5(i,k)*ZCONS2
QW(niter+1) = -ZRFLN(i)*ZDPP5(i,k)*ZCONS2
ZDPP1(i,k) = ZDPP1(i,k) + ZRFLN(i)*(QP5(i,k)-QW5(niter+1))*ZCONS2
ELSE
QP1(i,k) = QP1(i,k) + ZSFLN(i)*ZDPP5(i,k)*ZCONS2
QW(niter+1) = -ZSFLN(i)*ZDPP5(i,k)*ZCONS2
ZDPP1(i,k) = ZDPP1(i,k) + ZSFLN(i)*(QP5(i,k)-QW5(niter+1))*ZCONS2
ENDIF
ENDIF
ZRFL(i) = ZRFL(i) + ZRFLN(i)
ZRFLN(i) = 0.
ZSFL(i) = ZSFL(i) + ZSFLN(i)
ZSFLN(i) = 0.
IF(QS5(1).lt.QP5(i,k)) THEN
DO iter = niter,1,-1
QS(iter) = 0.
DQSDT(iter) = 0.
DELQ(iter) = 0.
TW(iter) = 0.
QW(iter) = 0.
DELQ(iter) = DELQ(iter) - QW(iter+1)
QW(iter) = QW(iter) + QW(iter+1)
QW(iter+1) = 0.
DELQ(iter) = DELQ(iter) + (LC/CPD)*TW(iter+1)
TW(iter) = TW(iter) + TW(iter+1)
TW(iter+1) = 0.
QW(iter) = QW(iter) + DELQ(iter)/(1.0 + (LC/CPD)*DQSDT5(iter))
QS(iter) = QS(iter) - DELQ(iter)/(1.0 + (LC/CPD)*DQSDT5(iter))
DQSDT(iter) = DQSDT(iter) - DELQ5(iter)*(LC/CPD)*DELQ(iter)/(1.0+(LC/CPD)*DQSDT5(iter))
DELQ(iter) = 0.
QS(iter) = QS(iter) + DQSDT5(iter)*DQSDT(iter)/QS5(iter)
TW(iter) = TW(iter) - DQSDT5(iter)*2*DQSDT(iter)/(TW5(iter)-A4)
DQSDT(iter) = 0.
TW(iter) = TW(iter) + QS(iter)*(QS5(iter)*A3/(TW5(iter)-A4))
% *(1.0-(TW5(iter)-TGL)/(TW5(iter)-A4))
ZPP1(i,k) = ZPP1(i,k) - QS(iter)*QS5(iter)/ZPP5(i,k)
QS(iter) = 0.
ENDDO
ELSE
TW(1) = TW(niter+1)
TW(niter+1) = 0.
QW(1) = QW(niter+1)
QW(niter+1) = 0.
ENDIF
TP1(i,k) = TP1(i,k) + TW(1)
TW(1) = 0.
QP1(i,k) = QP1(i,k) + QW(1)
QW(1) = 0.
ENDDO !( DO ON i)
ENDDO !( DO ON k)
*
DO k=1,NK
DO i=1,N
PSP1(i) = PSP1(i) + SIGMA(i,k)*ZPP1(i,k)
PSP1(i) = PSP1(i) + ZDSG(i,k) *ZDPP1(i,k)
ENDDO
ENDDO
RETURN
END