cuadjtq.f90
!+ produce t,q and l values for cloud ascent
!+ $Id: cuadjtq.f90,v 1.11 1999/10/01 13:09:46 m214003 Exp $
!#define DEBUG
5:
SUBROUTINE cuadjtq(klp2,klon,klev,kk,pp,pt,pq,ldflag,kcall)
! Description:
!
10: ! Produce t,q and l values for cloud ascent
!
! Method:
!
! This routine is called from subroutines:
15: ! *cubase* (t and q at condenstion level)
! *cuasc* (t and q at cloud levels)
! *cuini* (environmental t and qs values at half levels)
! input are unadjusted t and q values,
! it returns adjusted values of t and q
20: ! note: input parameter kcall defines calculation as
! kcall=0 env. t and qs in*cuini*
! kcall=1 condensation in updrafts (e.g. cubase, cuasc)
! kcall=2 evaporation in downdrafts (e.g. cudlfs,cuddraf)
!
25: ! Externals:
! 3 lookup tables ( tlucua, tlucub, tlucuc )
! for condensation calculations.
! the tables are initialised in *setphys*.
!
30: ! Authors:
!
! M. Tiedtke, ECMWF, December 1989, original source
! D. Salmond, CRAY(UK), August 1991, changed
! L. Kornblueh, MPI, May 1998, f90 rewrite
35: ! U. Schulzweida, MPI, May 1998, f90 rewrite
! A. Rhodin, MPI, December 1998, lookup tables removed
!
! for more details see file AUTHORS
!
40:
USE mo_constants, ONLY: alsdcp, alvdcp, c2es, c3ies, c3les, c4ies, &
c4les, c5alscp, c5alvcp, vtmpc1, tmelt
#ifndef NOLOOKUP
USE mo_convect_tables, ONLY: tlucua, & ! table a
45: tlucub, & ! table b
tlucuc, & ! table c
jptlucu1, jptlucu2
#endif
50: IMPLICIT NONE
! Scalar arguments with intent(In):
INTEGER, INTENT (IN) :: kcall, kk, klev, klon, klp2
55: ! Array arguments with intent(In):
REAL, INTENT (IN) :: pp(klp2)
LOGICAL, INTENT (IN) :: ldflag(klp2)
! Array arguments with intent(InOut):
60: REAL, INTENT (INOUT) :: pq(klp2,klev), pt(klp2,klev)
! Local scalars:
REAL :: zcond1, zcor, zqsat
INTEGER :: isum, jl
65: #ifndef NOLOOKUP
INTEGER :: it
#else
LOGICAL :: lo
#endif
70:
! Local arrays:
REAL :: zcond(klp2), zqp(klp2)
! Intrinsic functions
75: INTRINSIC MAX, MIN
#ifndef NOLOOKUP
INTRINSIC INT
#endif
80: ! Executable statements
! 1. Calculate condensation and adjust t and q accordingly
zcond = 0.
85: IF (kcall==1) THEN
isum = 0
!DIR$ IVDEP
!OCL NOVREC
90: DO jl = 1, klon
IF (ldflag(jl)) THEN
zqp(jl) = 1./pp(jl)
#ifndef NOLOOKUP
it = INT(pt(jl,kk)*1000.)
95: #ifdef DEBUG
IF (it<jptlucu1 .OR. it>jptlucu2) THEN
WRITE(*,*) 'cuadjtq: 1 it=',it,jl,kk
END IF
#endif
100: it = MAX(MIN(it,jptlucu2),jptlucu1)
zqsat = tlucua(it)*zqp(jl)
zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
105: zcond(jl) = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(it))
zcond(jl) = MAX(zcond(jl),0.)
pt(jl,kk) = pt(jl,kk) + tlucuc(it)*zcond(jl)
#else
lo = pt(jl,kk) > tmelt
110: zqsat = c2es*EXP(MERGE(c3les,c3ies,lo)*(pt(jl,kk)-tmelt) &
/ (pt(jl,kk)-MERGE(c4les,c4ies,lo)))*zqp(jl)
zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
115: zcond(jl) = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor &
* (MERGE(c5alvcp,c5alscp,lo) / (pt(jl,kk)-MERGE(c4les,c4ies,lo))**2))
zcond(jl) = MAX(zcond(jl),0.)
pt(jl,kk) = pt(jl,kk) + MERGE(alvdcp, alsdcp, lo)*zcond(jl)
#endif
120: pq(jl,kk) = pq(jl,kk) - zcond(jl)
IF (ABS(zcond(jl)) > 0.) isum = isum + 1
END IF
END DO
125: IF (isum/=0) THEN
!DIR$ IVDEP
!OCL NOVREC
DO jl = 1, klon
IF (ldflag(jl) .AND. ABS(zcond(jl)) > 0.) THEN
130: #ifndef NOLOOKUP
it = INT(pt(jl,kk)*1000.)
#ifdef DEBUG
IF (it<jptlucu1 .OR. it>jptlucu2) THEN
WRITE(*,*) 'cuadjtq: 2 it=',it,jl,kk
135: END IF
#endif
it = MAX(MIN(it,jptlucu2),jptlucu1)
zqsat = tlucua(it)*zqp(jl)
zqsat = MIN(0.5,zqsat)
140: zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(it))
pt(jl,kk) = pt(jl,kk) + tlucuc(it)*zcond1
#else
145: lo = pt(jl,kk) > tmelt
zqsat = c2es*EXP(MERGE(c3les,c3ies,lo)*(pt(jl,kk)-tmelt) &
/ (pt(jl,kk)-MERGE(c4les,c4ies,lo)))*zqp(jl)
zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
150: zqsat = zqsat*zcor
zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor &
* (MERGE(c5alvcp,c5alscp,lo) / (pt(jl,kk)-MERGE(c4les,c4ies,lo))**2) )
pt(jl,kk) = pt(jl,kk) + MERGE(alvdcp, alsdcp, lo) * zcond1
#endif
155: pq(jl,kk) = pq(jl,kk) - zcond1
END IF
END DO
END IF
160: END IF
IF (kcall==2) THEN
isum = 0
165: !DIR$ IVDEP
!OCL NOVREC
DO jl = 1, klon
IF (ldflag(jl)) THEN
zqp(jl) = 1./pp(jl)
170: #ifndef NOLOOKUP
it = INT(pt(jl,kk)*1000.)
#ifdef DEBUG
IF (it<jptlucu1 .OR. it>jptlucu2) THEN
WRITE(*,*) 'cuadjtq: 3 it=',it,jl,kk
175: END IF
#endif
it = MAX(MIN(it,jptlucu2),jptlucu1)
zqsat = tlucua(it)*zqp(jl)
zqsat = MIN(0.5,zqsat)
180: zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond(jl) = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(it))
zcond(jl) = MIN(zcond(jl),0.)
pt(jl,kk) = pt(jl,kk) + tlucuc(it)*zcond(jl)
185: #else
lo = pt(jl,kk) > tmelt
zqsat = c2es*EXP(MERGE(c3les,c3ies,lo)*(pt(jl,kk)-tmelt) &
/ (pt(jl,kk)-MERGE(c4les,c4ies,lo))) *zqp(jl)
zqsat = MIN(0.5,zqsat)
190: zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond(jl) = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor &
* (MERGE(c5alvcp,c5alscp,lo) / (pt(jl,kk)-MERGE(c4les,c4ies,lo))**2))
zcond(jl) = MIN(zcond(jl),0.)
195: pt(jl,kk) = pt(jl,kk) + MERGE(alvdcp, alsdcp, lo) * zcond(jl)
#endif
pq(jl,kk) = pq(jl,kk) - zcond(jl)
IF (ABS(zcond(jl)) > 0.) isum = isum + 1
END IF
200: END DO
IF (isum/=0) THEN
!DIR$ IVDEP
!OCL NOVREC
205: DO jl = 1, klon
IF (ldflag(jl) .AND. ABS(zcond(jl)) > 0.) THEN
#ifndef NOLOOKUP
it = INT(pt(jl,kk)*1000.)
#ifdef DEBUG
210: IF (it<jptlucu1 .OR. it>jptlucu2) THEN
WRITE(*,*) 'cuadjtq: 4 it=',it,jl,kk
END IF
#endif
it = MAX(MIN(it,jptlucu2),jptlucu1)
215: zqsat = tlucua(it)*zqp(jl)
zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(it))
220: pt(jl,kk) = pt(jl,kk) + tlucuc(it)*zcond1
#else
lo = pt(jl,kk) > tmelt
zqsat = c2es*EXP(MERGE(c3les,c3ies,lo)*(pt(jl,kk)-tmelt) &
/ (pt(jl,kk)-MERGE(c4les,c4ies,lo))) *zqp(jl)
225: zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor &
* (MERGE(c5alvcp,c5alscp,lo) / (pt(jl,kk)-MERGE(c4les,c4ies,lo))**2))
230: pt(jl,kk) = pt(jl,kk) + MERGE(alvdcp, alsdcp, lo) *zcond1
#endif
pq(jl,kk) = pq(jl,kk) - zcond1
END IF
END DO
235: END IF
END IF
IF (kcall==0) THEN
240:
isum = 0
!DIR$ IVDEP
!OCL NOVREC
DO jl = 1, klon
245: zqp(jl) = 1./pp(jl)
#ifndef NOLOOKUP
it = INT(pt(jl,kk)*1000.)
#ifdef DEBUG
IF (it<jptlucu1 .OR. it>jptlucu2) THEN
250: WRITE(*,*) 'cuadjtq: 5 it=',it,jl,kk
END IF
#endif
it = MAX(MIN(it,jptlucu2),jptlucu1)
zqsat = tlucua(it)*zqp(jl)
255: zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond(jl) = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(it))
pt(jl,kk) = pt(jl,kk) + tlucuc(it)*zcond(jl)
260: #else
lo = pt(jl,kk) > tmelt
zqsat = c2es*EXP(MERGE(c3les,c3ies,lo)*(pt(jl,kk)-tmelt) &
/ (pt(jl,kk)-MERGE(c4les,c4ies,lo))) *zqp(jl)
zqsat = MIN(0.5,zqsat)
265: zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond(jl) = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor &
* (MERGE(c5alvcp,c5alscp,lo) / (pt(jl,kk)-MERGE(c4les,c4ies,lo))**2))
pt(jl,kk) = pt(jl,kk) + MERGE(alvdcp, alsdcp, lo)*zcond(jl)
270: #endif
pq(jl,kk) = pq(jl,kk) - zcond(jl)
IF (ABS(zcond(jl)) > 0.) isum = isum + 1
END DO
275: IF (isum/=0) THEN
!DIR$ IVDEP
!OCL NOVREC
DO jl = 1, klon
#ifndef NOLOOKUP
280: it = INT(pt(jl,kk)*1000.)
#ifdef DEBUG
IF (it<jptlucu1 .OR. it>jptlucu2) THEN
WRITE(*,*) 'cuadjtq: 6 it=',it,jl,kk
END IF
285: #endif
it = MAX(MIN(it,jptlucu2),jptlucu1)
zqsat = tlucua(it)*zqp(jl)
zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
290: zqsat = zqsat*zcor
zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(it))
pt(jl,kk) = pt(jl,kk) + tlucuc(it)*zcond1
#else
lo = pt(jl,kk) > tmelt
295: zqsat = c2es*EXP(MERGE(c3les,c3ies,lo)*(pt(jl,kk)-tmelt) &
/ (pt(jl,kk)-MERGE(c4les,c4ies,lo)))*zqp(jl)
zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
300: zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor &
* (MERGE(c5alvcp,c5alscp,lo) / (pt(jl,kk)-MERGE(c4les,c4ies,lo))**2))
pt(jl,kk) = pt(jl,kk) + MERGE(alvdcp, alsdcp, lo) * zcond1
#endif
pq(jl,kk) = pq(jl,kk) - zcond1
305: END DO
END IF
END IF
310: IF (kcall==4) THEN
!DIR$ IVDEP
!OCL NOVREC
DO jl = 1, klon
315: zqp(jl) = 1./pp(jl)
#ifndef NOLOOKUP
it = INT(pt(jl,kk)*1000.)
#ifdef DEBUG
IF (it<jptlucu1 .OR. it>jptlucu2) THEN
320: WRITE(*,*) 'cuadjtq: 7 it=',it,jl,kk
END IF
#endif
it = MAX(MIN(it,jptlucu2),jptlucu1)
zqsat = tlucua(it)*zqp(jl)
325: zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond(jl) = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(it))
pt(jl,kk) = pt(jl,kk) + tlucuc(it)*zcond(jl)
330: #else
lo = pt(jl,kk) > tmelt
zqsat = c2es*EXP(MERGE(c3les,c3ies,lo)*(pt(jl,kk)-tmelt) &
/ (pt(jl,kk)-MERGE(c4les,c4ies,lo)))*zqp(jl)
zqsat = MIN(0.5,zqsat)
335: zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond(jl) = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor &
* (MERGE(c5alvcp,c5alscp,lo) / (pt(jl,kk)-MERGE(c4les,c4ies,lo))**2))
pt(jl,kk) = pt(jl,kk) + MERGE(alvdcp, alsdcp, lo) * zcond(jl)
340: #endif
pq(jl,kk) = pq(jl,kk) - zcond(jl)
END DO
!DIR$ IVDEP
345: !OCL NOVREC
DO jl = 1, klon
#ifndef NOLOOKUP
it = INT(pt(jl,kk)*1000.)
#ifdef DEBUG
350: IF (it<jptlucu1 .OR. it>jptlucu2) THEN
WRITE(*,*) 'cuadjtq: 8 it=',it,jl,kk
END IF
#endif
it = MAX(MIN(it,jptlucu2),jptlucu1)
355: zqsat = tlucua(it)*zqp(jl)
zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(it))
360: pt(jl,kk) = pt(jl,kk) + tlucuc(it)*zcond1
#else
lo = pt(jl,kk) > tmelt
zqsat = c2es*EXP(MERGE(c3les,c3ies,lo)*(pt(jl,kk)-tmelt) &
/ (pt(jl,kk)-MERGE(c4les,c4ies,lo)))*zqp(jl)
365: zqsat = MIN(0.5,zqsat)
zcor = 1./(1.-vtmpc1*zqsat)
zqsat = zqsat*zcor
zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor &
* (MERGE(c5alvcp,c5alscp,lo) / (pt(jl,kk)-MERGE(c4les,c4ies,lo))**2))
370: pt(jl,kk) = pt(jl,kk) + MERGE(alvdcp, alsdcp, lo) * zcond1
#endif
pq(jl,kk) = pq(jl,kk) - zcond1
END DO
375: END IF
RETURN
END SUBROUTINE cuadjtq
Info Section
uses: mo_constants, mo_convect_tables
back to top
ECHAM 4 vf90 (C) 1998 Max-Planck-Institut für Meteorologie, Hamburg
Wed Nov 24 01:25:21 CST 1999
HTML derived from FORTRAN source by f2html.pl v0.3 (C) 1997,98 Beroud Jean-Marc.