phylmd/Conflx/flxbase.f90

      SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph, &
           ptu, pqu, plu, ldcum, kcbot, klab)
      use dimens_m
      use dimphy
      use SUPHEC_M
      use yoethf_m
      IMPLICIT none
!----------------------------------------------------------------------
! THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
!
! INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
! IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
!   klab=1 FOR SUBCLOUD LEVELS
!   klab=2 FOR CONDENSATION LEVEL
!
! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
! (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
!----------------------------------------------------------------------
!       ----------------------------------------------------------------
      REAL ptenh(klon,klev), pqenh(klon,klev)
      REAL pgeoh(klon,klev), paph(klon,klev+1)
!
      REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
      INTEGER  klab(klon,klev), kcbot(klon)
!
      LOGICAL llflag(klon), ldcum(klon)
      INTEGER i, k, icall, is
      REAL zbuo, zqold(klon)
!----------------------------------------------------------------------
! INITIALIZE VALUES AT LIFTING LEVEL
!----------------------------------------------------------------------
      DO i = 1, klon
         klab(i,klev)=1
         kcbot(i)=klev-1
         ldcum(i)=.FALSE.
      ENDDO
!----------------------------------------------------------------------
! DO ASCENT IN SUBCLOUD LAYER,
! CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
! ADJUST T,Q AND L ACCORDINGLY
! CHECK FOR BUOYANCY AND SET FLAGS
!----------------------------------------------------------------------
      DO 290 k = klev-1, 2, -1
!
      is = 0
      DO i = 1, klon
         IF (klab(i,k+1).EQ.1) is = is + 1
         llflag(i) = .FALSE.
         IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE.
      ENDDO
      IF (is.EQ.0) GOTO 290
!
      DO i = 1, klon
      IF(llflag(i)) THEN
         pqu(i,k) = pqu(i,k+1)
         ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD
         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))- &
                ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
         IF (zbuo.GT.0.) klab(i,k) = 1
         zqold(i) = pqu(i,k)
      ENDIF
      ENDDO
!
      icall=1
      CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
!
      DO i = 1, klon
      IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
         klab(i,k) = 2
         plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k)
         zbuo = ptu(i,k)*(1.+RETV*pqu(i,k))- &
                ptenh(i,k)*(1.+RETV*pqenh(i,k))+0.5
         IF (zbuo.GT.0.) kcbot(i) = k
         IF (zbuo.GT.0.) ldcum(i) = .TRUE.
      ENDIF
      ENDDO
!
  290 CONTINUE
!
      RETURN
      END
1	SUBROUTINE flxbase(ptenh, pqenh, pgeoh, paph, &
2	ptu, pqu, plu, ldcum, kcbot, klab)
3	use dimens_m
4	use dimphy
5	use SUPHEC_M
6	use yoethf_m
7	IMPLICIT none
8	!----------------------------------------------------------------------
9	! THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q)
10	!
11	! INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS.
12	! IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS;
13	! klab=1 FOR SUBCLOUD LEVELS
14	! klab=2 FOR CONDENSATION LEVEL
15	!
16	! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE
17	! (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX)
18	!----------------------------------------------------------------------
19	! ----------------------------------------------------------------
20	REAL ptenh(klon,klev), pqenh(klon,klev)
21	REAL pgeoh(klon,klev), paph(klon,klev+1)
22	!
23	REAL ptu(klon,klev), pqu(klon,klev), plu(klon,klev)
24	INTEGER klab(klon,klev), kcbot(klon)
25	!
26	LOGICAL llflag(klon), ldcum(klon)
27	INTEGER i, k, icall, is
28	REAL zbuo, zqold(klon)
29	!----------------------------------------------------------------------
30	! INITIALIZE VALUES AT LIFTING LEVEL
31	!----------------------------------------------------------------------
32	DO i = 1, klon
33	klab(i,klev)=1
34	kcbot(i)=klev-1
35	ldcum(i)=.FALSE.
36	ENDDO
37	!----------------------------------------------------------------------
38	! DO ASCENT IN SUBCLOUD LAYER,
39	! CHECK FOR EXISTENCE OF CONDENSATION LEVEL,
40	! ADJUST T,Q AND L ACCORDINGLY
41	! CHECK FOR BUOYANCY AND SET FLAGS
42	!----------------------------------------------------------------------
43	DO 290 k = klev-1, 2, -1
44	!
45	is = 0
46	DO i = 1, klon
47	IF (klab(i,k+1).EQ.1) is = is + 1
48	llflag(i) = .FALSE.
49	IF (klab(i,k+1).EQ.1) llflag(i) = .TRUE.
50	ENDDO
51	IF (is.EQ.0) GOTO 290
52	!
53	DO i = 1, klon
54	IF(llflag(i)) THEN
55	pqu(i,k) = pqu(i,k+1)
56	ptu(i,k) = ptu(i,k+1)+(pgeoh(i,k+1)-pgeoh(i,k))/RCPD
57	zbuo = ptu(i,k)(1.+RETVpqu(i,k))- &
58	ptenh(i,k)(1.+RETVpqenh(i,k))+0.5
59	IF (zbuo.GT.0.) klab(i,k) = 1
60	zqold(i) = pqu(i,k)
61	ENDIF
62	ENDDO
63	!
64	icall=1
65	CALL flxadjtq(paph(1,k), ptu(1,k), pqu(1,k), llflag, icall)
66	!
67	DO i = 1, klon
68	IF (llflag(i).AND.pqu(i,k).NE.zqold(i)) THEN
69	klab(i,k) = 2
70	plu(i,k) = plu(i,k) + zqold(i)-pqu(i,k)
71	zbuo = ptu(i,k)(1.+RETVpqu(i,k))- &
72	ptenh(i,k)(1.+RETVpqenh(i,k))+0.5
73	IF (zbuo.GT.0.) kcbot(i) = k
74	IF (zbuo.GT.0.) ldcum(i) = .TRUE.
75	ENDIF
76	ENDDO
77	!
78	290 CONTINUE
79	!
80	RETURN
81	END