      SUBROUTINE TDCAL6 (DQDT,DTDT,DXDT,QG,XG,QFO,XFO,ZG,DCT,DSRC,DSNG,
     1                   DSNFO,ZFO,PG,PFO,DP,DZ,DZO,QCT,XCT,MC,WRK1,
     2                   WRK2,WRK3,TFE,WRKX,MBG,LMAG,LCL,LNB,ISKIP,
     3                   ITRPHS,ILEV,ILEVM,ILG,ILGG,MSGG,MSG,NTRAC,
     4                   ITRAC,CPRES,RRL,GRAV,ACOR,ACORX,DSR,WC,SC,RU,
     5                   AUTO,QLCT,RHOA,PCP,DT,SCLF,ISO2,ISO4,IHPO,
     6                   IDUA,IDUC,XSRC,XSNK,
     8                   ISHALL,ISVCONV,ISVCHEM,ISULF)
C-----------------------------------------------------------------------
C     * JUN 25/2013 - M.LAZARE.    NEW VERSION FOR GCM17:
C     *                            - ALWAYS DO LOOP 950(NOT JUST FOR
C     *                              ISVCHEM AS WAS PREVIOUSLY THE CASE).  
C     * APR 23/2010 - K.VONSALZEN. PREVIOUS VERSION TDCAL5 FOR GCM15I/16:
C     *                            - ADDITION OF CALCULATION OF EXPLICIT
C     *                              SOURCES AND SINK ARRAYS.
C     * DEC 18/2007 - M.LAZARE/    PREVIOUS VERSION TDCAL4 FOR GCM15G/H:
C     *               K.VONSALZEN. ADD CALCULATIONS FOR DIAGNOSTIC FIELDS
C     *                            WDS4ROL,WDS6ROL.
C     * NOV 25/2006 - M.LAZARE.    PREVIOUS VERSION TDCAL3 FOR GCM15F.
C     *                            - SELECTIVE PROMOTION OF VARIABLES TO
C     *                              REAL*8 TO SUPPORT 32-BIT MODE.
C     * JUN 15/2006 - M.LAZARE.    - "ZERO" DATA CONSTANT ADDED AND USED
C     *                              IN CALL TO INTRINSICS.
C     * DEC 13/2005 - K.VONSALZEN. PREVIOUS VERSION FOR GCM15D/GCM15E:
C     *                            - DEFINE SHALLOW CLOUD AMOUNT (SCLF)
C     *                              AND PASS OUT TO TRANSC3.
C     * MAY 14/2004 - M.LAZARE/    PREVIOUS VERSION TDCAL FOR GCM15B/C.
C     *               K.VONSALZEN. 
C
C     * CALCULATES FINAL TENDENCIES FROM VERTICAL FLUXES AND
C     * CLOUD PROPERTIES WITH AN EXPLICIT METHOD. UPDRAFTS AND
C     * DOWNDRAFTS ARE DETERMINED FOR THE SAME ENVIRONMENTAL
C     * PROFILES.
C-----------------------------------------------------------------------
      IMPLICIT REAL (A-H,O-Z),
     +INTEGER (I-N)
C      
C     * MULTI-LEVEL WORK FIELDS (FIRST SET ARE PROMOTED FOR CONSISTENCY
C     * WITH REST OF SHALLOW). 
C      
      REAL*8 DZ(ILG,ILEV),  ZG(ILG,ILEV),QCT(ILG,ILEV),  WC(ILG,ILEV)
C
      REAL WRK1(ILG,ILEV),WRK2(ILG,ILEV), MC(ILG,ILEV),DSRC(ILG,ILEV),
     1     WRK3(ILG,ILEV),DQDT(ILG,ILEV),PFO(ILG,ILEV),  DP(ILG,ILEV),
     2     RHOA(ILG,ILEV), QFO(ILG,ILEV),DZO(ILG,ILEV),  QG(ILG,ILEV),
     3     DTDT(ILG,ILEV), DCT(ILG,ILEV),ZFO(ILG,ILEV),  
     4     AUTO(ILG,ILEV),DSNG(ILG,ILEV), PG(ILG,ILEV), TFE(ILG,ILEV),
     5    DSNFO(ILG,ILEV),QLCT(ILG,ILEV),DSR(ILG,ILEV),SCLF(ILG,ILEV)
      REAL WRKX(ILG,ILEV,NTRAC), XCT(ILG,ILEV,NTRAC), 
     1     DXDT(ILG,ILEV,NTRAC),  XG(ILG,ILEV,NTRAC),
     2      XFO(ILG,ILEV,NTRAC),  SC(ILG,ILEV,NTRAC),
     3       RU(ILG,ILEV,NTRAC)
C     
C     * SINGLE-LEVEL WORK FIELDS. 
C      
      REAL   MBG(ILG),    ACOR(ILG),     PCP(ILG)
      REAL ACORX(ILG,NTRAC), XSRC(ILG,NTRAC), XSNK(ILG,NTRAC)
      INTEGER LMAG(ILG), LCL(ILG), LNB(ILG), ISKIP(ILG), ISHALL(ILG)
      INTEGER ITRPHS(NTRAC)
C
      DATA ZERO   / 0.    /
C
C     * INTERNAL FUNCTIONS.
C
      ZINTP( ARG1,ARG2,ARG3 )=ARG3*ARG1+(1.-ARG3)*ARG2
      ZMEAN( ARG1,ARG2,ARG3,ARG4,ARG5 )=(ARG1+.5*ARG2*(ARG4-ARG3))
     1                                 *(ARG4-ARG3)/ARG5
C                                                   
C-----------------------------------------------------------------------
C
C     * INITIALIZATIONS.
C
      DO 50 L=MSG+1,ILEV
      DO 50 IL=1,ILGG 
         WRK1(IL,L)=0.
         WRK2(IL,L)=0.
         DQDT(IL,L)=0.
         DTDT(IL,L)=0.
         DSRC(IL,L)=0.
 50   CONTINUE
      IF ( ITRAC.NE.0 ) THEN
         DO 70 N=1,NTRAC
         DO 70 L=MSG+1,ILEV
         DO 70 IL=1,ILGG
            WRKX(IL,L,N)=0.
            DXDT(IL,L,N)=0.
 70     CONTINUE
      ENDIF
C
C     * EFFECTIVE FLUXES OF CLOUD PROPERTIES AT GRID CELL 
C     * INTERFACES BELOW CLOUD BASE.
C
      L=ILEV
      DO 100 IL=1,ILGG
         IF (       L.LE.LMAG(IL) .AND. L.GT.LCL(IL) 
     1        .AND. ISKIP(IL).EQ.0  ) THEN
            DPST=MBG(IL)*MC(IL,L)
            WRK1(IL,L)=WRK1(IL,L)+QCT(IL,L)*DPST
            WRK2(IL,L)=WRK2(IL,L)+DCT(IL,L)*DPST
         ENDIF
 100  CONTINUE
      IF ( ITRAC.NE.0 ) THEN
         DO 125 N=1,NTRAC
            IF ( ITRPHS(N).GT.0 ) THEN
               DO 120 IL=1,ILGG
                  IF (      L.LE.LMAG(IL) .AND. L.GT.LCL(IL) 
     1                .AND. ISKIP(IL).EQ.0  ) THEN
                     DPST=MBG(IL)*MC(IL,L)
                     WRKX(IL,L,N)=WRKX(IL,L,N)+XCT(IL,L,N)*DPST
                  ENDIF
 120           CONTINUE
            ENDIF
 125     CONTINUE
      ENDIF
      DO 140 L=ILEVM,MSGG+2,-1
      DO 140 IL=1,ILGG
         IF ( L.LE.LMAG(IL) .AND. L.GT.LCL(IL) 
     1        .AND. ISKIP(IL).EQ.0  ) THEN
            DPST=MBG(IL)*MC(IL,L)
            WRK1(IL,L)=WRK1(IL,L)+QCT(IL,L+1)*DPST
            WRK2(IL,L)=WRK2(IL,L)+DCT(IL,L+1)*DPST
         ENDIF
 140  CONTINUE
      IF ( ITRAC.NE.0 ) THEN
         DO 165 N=1,NTRAC
            IF ( ITRPHS(N).GT.0 ) THEN
               DO 160 L=ILEVM,MSGG+2,-1
               DO 160 IL=1,ILGG
                 IF ( L.LE.LMAG(IL) .AND. L.GT.LCL(IL) 
     1                .AND. ISKIP(IL).EQ.0  ) THEN
                    DPST=MBG(IL)*MC(IL,L)
                    WRKX(IL,L,N)=WRKX(IL,L,N)+XCT(IL,L+1,N)*DPST
                 ENDIF
 160           CONTINUE
            ENDIF
 165     CONTINUE
      ENDIF
C
C     * EFFECTIVE FLUXES OF CLOUD PROPERTIES AT GRID CELL 
C     * INTERFACES AT AND ABOVE CLOUD BASE. THE VERTICAL PROFILES
C     * OF IN-CLOUD PROPERTIES ARE IDENTICAL TO THOSE ASSUMED
C     * IN SCPRP.
C
      DO 200 L=ILEVM,MSGG+2,-1
      DO 200 IL=1,ILGG
         IF (       L.LE.LCL(IL) .AND. L.GE.LNB(IL) 
     1        .AND. ISKIP(IL).EQ.0  ) THEN
            WRK1(IL,L)=WRK1(IL,L)+MBG(IL)*MC(IL,L)*QCT(IL,L)
            WRK2(IL,L)=WRK2(IL,L)+MBG(IL)*MC(IL,L)*DCT(IL,L)
         ENDIF
 200  CONTINUE
      IF ( ITRAC.NE.0 ) THEN
         DO 225 N=1,NTRAC
            IF ( ITRPHS(N).GT.0 ) THEN
               DO 220 L=ILEVM,MSGG+2,-1
               DO 220 IL=1,ILGG
                  IF ( L.LE.LCL(IL) .AND. L.GE.LNB(IL) 
     1                .AND. ISKIP(IL).EQ.0  ) THEN
                     WRKX(IL,L,N)=WRKX(IL,L,N)
     1                           +MBG(IL)*MC(IL,L)*XCT(IL,L,N)
                  ENDIF
 220           CONTINUE
            ENDIF
 225     CONTINUE
      ENDIF
C
C     * INTERMEDIATE TENDENCIES FROM EFFECTIVE FLUXES. 
C
      L=ILEV
      DO 300 IL=1,ILGG 
         IF ( L.GE.(LNB(IL)-1) .AND. ISKIP(IL).EQ.0 ) THEN
            DQDT(IL,L)=DQDT(IL,L)-WRK1(IL,L)*GRAV*DSR(IL,L)/DP(IL,L)
            DTDT(IL,L)=DTDT(IL,L)-WRK2(IL,L)*GRAV*DSR(IL,L)/DP(IL,L)
     1                                                     /CPRES
         ENDIF
 300  CONTINUE
      DO 320 L=MSGG+2,ILEVM
      DO 320 IL=1,ILGG 
         IF ( L.GE.(LNB(IL)-1) .AND. ISKIP(IL).EQ.0 ) THEN
            DQDT(IL,L)=DQDT(IL,L)+( WRK1(IL,L+1)-WRK1(IL,L) )
     1                *GRAV*DSR(IL,L)/DP(IL,L)
            DTDT(IL,L)=DTDT(IL,L)+( WRK2(IL,L+1)-WRK2(IL,L) )
     1                *GRAV*DSR(IL,L)/DP(IL,L)/CPRES
         ENDIF
 320  CONTINUE
      IF ( ITRAC.NE.0 ) THEN
         DO 365 N=1,NTRAC
            IF ( ITRPHS(N).GT.0 ) THEN
               L=ILEV
               DO 340 IL=1,ILGG 
                  IF ( L.GE.(LNB(IL)-1) .AND. ISKIP(IL).EQ.0 ) THEN
                     DXDT(IL,L,N)=DXDT(IL,L,N)-WRKX(IL,L,N)*GRAV
     1                                        *DSR(IL,L)/DP(IL,L)
                  ENDIF
 340           CONTINUE
C
               DO 360 L=MSGG+2,ILEVM
               DO 360 IL=1,ILGG 
                  IF ( L.GE.(LNB(IL)-1) .AND. ISKIP(IL).EQ.0 ) THEN
                     DXDT(IL,L,N)=DXDT(IL,L,N)
     1                     +( WRKX(IL,L+1,N)-WRKX(IL,L,N) )*GRAV
     2                       *DSR(IL,L)/DP(IL,L)
                  ENDIF
 360           CONTINUE
            ENDIF
 365     CONTINUE
      ENDIF
C
C     * LOWER VERTICAL BOUNDS FOR THE CALCULATION OF EFFECTIVE FLUXES.
C
      DO 500 L=MSGG+2,ILEV
      DO 500 IL=1,ILGG
         IF ( ISKIP(IL).EQ.0 .AND. L.GE.LNB(IL) ) THEN
            WRK3(IL,L)=PFO(IL,L)-GRAV*MBG(IL)*MC(IL,L)*DSR(IL,L)*DT
         ENDIF
 500  CONTINUE
C
C     * EFFECTIVE FLUXES OF LARGE-SCALE PROPERTIES AT GRID CELL INTERFAC
C     * THE ENVIRONMENTAL PROFILES BETWEEN THE MIDPOINTS OF THE
C     * GRID CELLS ARE OBTAINED FROM LINEAR INTERPOLATION AS FUNCTION 
C     * OF PRESSURE. DISCRETIZATION ACCORDING TO BOTT (MWR, 1989).
C
      DO 520 L=MSG+2,ILEV
      DO 520 IL=1,ILGG 
         WRK1(IL,L)=0.
         WRK2(IL,L)=0.
 520  CONTINUE
      IF ( ITRAC.NE.0 ) THEN
         DO 530 N=1,NTRAC
         DO 530 L=MSG+1,ILEV
         DO 530 IL=1,ILGG
            WRKX(IL,L,N)=0.
 530     CONTINUE
      ENDIF
      DO 550 L=ILEV,MSGG+2,-1
      DO 550 IL=1,ILGG
         IF (       L.LE.LMAG(IL) .AND. L.GE.LNB(IL) 
     1        .AND. ISKIP(IL).EQ.0 ) THEN
            ZFH=PFO(IL,L-1)
            ZFM=100.*PG(IL,L-1)
            ZFL=PFO(IL,L)
C
            IF ( QG(IL,L-1).GT.0. .AND. QFO(IL,L).GT.0. ) THEN
               DPLDL=(QG (IL,L-1)-QFO(IL,L  ))/(ZFM-ZFL)
               DPLDH=(QFO(IL,L-1)-QG (IL,L-1))/(ZFH-ZFM)
               AINTT=ZMEAN(QFO(IL,L),DPLDL,ZFL,ZFM,DP(IL,L-1))
               IF ( WRK3(IL,L).LE.ZFM ) THEN
                  AINTP=AINTT+ZMEAN(QG(IL,L-1),DPLDH,ZFM,WRK3(IL,L),
     1                              DP(IL,L-1))
               ELSE
                  AINTP=ZMEAN(QFO(IL,L),DPLDL,ZFL,WRK3(IL,L),
     1                        DP(IL,L-1))
               ENDIF
               AINTT=AINTT+ZMEAN(QG(IL,L-1),DPLDH,ZFM,ZFH,DP(IL,L-1))
               AFRAC=QG(IL,L-1)/AINTT
               WRK1(IL,L)=AINTP*AFRAC*DP(IL,L-1)/(DT*GRAV*DSR(IL,L))
            ENDIF
C
            DPLDL=(DSNG (IL,L-1)-DSNFO(IL,L  ))/(ZFM-ZFL)
            DPLDH=(DSNFO(IL,L-1)-DSNG (IL,L-1))/(ZFH-ZFM)
            AINTT=ZMEAN(DSNFO(IL,L),DPLDL,ZFL,ZFM,DP(IL,L-1))
            IF ( WRK3(IL,L).LE.ZFM ) THEN
               AINTP=AINTT+ZMEAN(DSNG(IL,L-1),DPLDH,ZFM,WRK3(IL,L),
     1                           DP(IL,L-1))
            ELSE
               AINTP=ZMEAN(DSNFO(IL,L),DPLDL,ZFL,WRK3(IL,L),
     1                     DP(IL,L-1))
            ENDIF
            AINTT=AINTT+ZMEAN(DSNG(IL,L-1),DPLDH,ZFM,ZFH,DP(IL,L-1))
            AFRAC=DSNG(IL,L-1)/AINTT
            WRK2(IL,L)=AINTP*AFRAC*DP(IL,L-1)/(DT*GRAV*DSR(IL,L))
         ENDIF
 550  CONTINUE
      IF ( ITRAC.NE.0 ) THEN
         DO 575 N=1,NTRAC
            IF ( ITRPHS(N).GT.0 ) THEN
               DO 570 L=ILEV,MSGG+2,-1
               DO 570 IL=1,ILGG
                  IF ( L.LE.LMAG(IL) .AND. L.GE.LNB(IL) 
     1                .AND. XG(IL,L-1,N).GT.0. .AND. XFO(IL,L,N).GT.0.
     2                .AND. ISKIP(IL).EQ.0 ) THEN
                     ZFH=PFO(IL,L-1)
                     ZFM=100.*PG(IL,L-1)
                     ZFL=PFO(IL,L)
                     DPLDL=(XG (IL,L-1,N)-XFO(IL,L  ,N))/(ZFM-ZFL)
                     DPLDH=(XFO(IL,L-1,N)-XG (IL,L-1,N))/(ZFH-ZFM)
                     AINTT=ZMEAN(XFO(IL,L,N),DPLDL,ZFL,ZFM,
     1                           DP(IL,L-1))
                     IF ( WRK3(IL,L).LE.ZFM ) THEN
                        AINTP=AINTT+ZMEAN(XG(IL,L-1,N),DPLDH,ZFM,
     1                              WRK3(IL,L),DP(IL,L-1))
                     ELSE
                        AINTP=ZMEAN(XFO(IL,L,N),DPLDL,ZFL,WRK3(IL,L),
     1                              DP(IL,L-1))
                     ENDIF
                     AINTT=AINTT+ZMEAN(XG(IL,L-1,N),DPLDH,ZFM,ZFH,
     1                                 DP(IL,L-1))
                     AFRAC=XG(IL,L-1,N)/AINTT
                     WRKX(IL,L,N)=AINTP*AFRAC*DP(IL,L-1)
     1                           /(DT*GRAV*DSR(IL,L))
                  ENDIF
 570           CONTINUE
            ENDIF
 575     CONTINUE
      ENDIF
C
C     * FINAL TENDENCIES FROM EFFECTIVE FLUXES. 
C
      L=ILEV
      DO 600 IL=1,ILGG 
         IF ( L.GE.(LNB(IL)-1) .AND. ISKIP(IL).EQ.0 ) THEN
            DQDT(IL,L)=DQDT(IL,L)+WRK1(IL,L)*GRAV*DSR(IL,L)/DP(IL,L)
            DTDT(IL,L)=DTDT(IL,L)+WRK2(IL,L)*GRAV*DSR(IL,L)/DP(IL,L)
     1                           /CPRES
         ENDIF
 600  CONTINUE
      DO 620 L=MSGG+2,ILEVM
      DO 620 IL=1,ILGG 
         IF ( L.GE.(LNB(IL)-1) .AND. ISKIP(IL).EQ.0 ) THEN
            DQDT(IL,L)=DQDT(IL,L)-( WRK1(IL,L+1)-WRK1(IL,L) )*GRAV
     1                             *DSR(IL,L)/DP(IL,L)
            DTDT(IL,L)=DTDT(IL,L)-( WRK2(IL,L+1)-WRK2(IL,L) )*GRAV
     1                             *DSR(IL,L)/DP(IL,L)/CPRES
         ENDIF
 620  CONTINUE
      IF ( ITRAC.NE.0 ) THEN
         DO 660 N=1,NTRAC
            IF ( ITRPHS(N).GT.0 ) THEN
               L=ILEV
               DO 645 IL=1,ILGG 
                  IF ( L.GE.(LNB(IL)-1) .AND. ISKIP(IL).EQ.0 ) THEN
                     DXDT(IL,L,N)=DXDT(IL,L,N)+WRKX(IL,L,N)*GRAV
     1                                        *DSR(IL,L)/DP(IL,L)
                  ENDIF
 645           CONTINUE
C
               DO 650 L=MSGG+2,ILEVM
               DO 650 IL=1,ILGG 
                  IF ( L.GE.(LNB(IL)-1) .AND. ISKIP(IL).EQ.0 ) THEN
                     DXDT(IL,L,N)=DXDT(IL,L,N)
     1                     -( WRKX(IL,L+1,N)-WRKX(IL,L,N) )*GRAV
     2                       *DSR(IL,L)/DP(IL,L)
                  ENDIF
 650           CONTINUE
            ENDIF
 660     CONTINUE
      END IF
C
C     * VOLUME CLOUD AMOUNT PER GRID CELL.
C
      DO 680 IL=1,ILGG 
         IF ( ISKIP(IL).EQ.0 ) THEN
            L=LCL(IL)
            WRK3(IL,L)=DZ(IL,L)/DZO(IL,L)*MBG(IL)
     1                *.5*( MC(IL,L  )/(RHOA(IL,L  )*WC(IL,L  ))     
     2                     +MC(IL,L+1)/(RHOA(IL,L+1)*WC(IL,L+1)) )   
         ENDIF
 680  CONTINUE
      DO 700 L=MSGG+2,ILEVM
      DO 700 IL=1,ILGG 
         IF (      L.LT.LCL(IL) .AND. L.GE.LNB(IL)
     1       .AND. ISKIP(IL).EQ.0 ) THEN
            WRK3(IL,L)=.5*MBG(IL)
     1                *( MC(IL,L  )/(RHOA(IL,L  )*WC(IL,L  ))        
     2                  +MC(IL,L+1)/(RHOA(IL,L+1)*WC(IL,L+1)) )      
         ENDIF
 700  CONTINUE
      DO 720 IL=1,ILGG 
         IF ( ISKIP(IL).EQ.0 ) THEN
            L=LNB(IL)-1
            WRK3(IL,L)=DZ(IL,L)/DZO(IL,L)*MBG(IL)
     1                *.5*MC(IL,L+1)/(RHOA(IL,L+1)*WC(IL,L+1))
         ENDIF
 720  CONTINUE
C
C     * DEFINE SHALLOW CLOUD FRACTION.
C     * NOTE THAT SCLF IS INITIALIZED TO ZERO IN TRANSC3!
C
      DO L=MSGG+2,ILEVM
      DO IL=1,ILGG 
         IF ( ISKIP(IL).EQ.0. .AND. L.LE.LCL(IL) .AND. L.GE.(LNB(IL)-1) 
     1                                                           ) THEN
           SCLF(ISHALL(IL),L)=WRK3(IL,L)
         ENDIF
      ENDDO
      ENDDO
C
C     * ADD SINKS DUE TO PRECIPITATION TO MOISTURE.
C
      DO 730 L=MSGG+2,ILEVM
      DO 730 IL=1,ILGG 
         IF (       L.LE.LCL(IL) .AND. L.GE.(LNB(IL)-1) 
     1        .AND. ISKIP(IL).EQ.0 ) THEN
            DQDT(IL,L)=DQDT(IL,L)-AUTO(IL,L)*WRK3(IL,L)
         END IF
 730  CONTINUE
C
C     * ADD SOURCES/SINKS DUE TO CONDENSATION/EVAPORATION
C     * AND PRECIPITATION TO TEMPERATURE. IT ASSUMED THAT
C     * THE CLOUD IS IN A CLEAR-SKY ENVIRONMENT. THE SOURCES/SINKS
C     * ARE DIAGNOSED FROM LARGE-SCALE LIQUID WATER CONTINUITY 
C     * UNDER STEADY CONDITIONS.
C
      DO 731 L=MSG+2,ILEV
      DO 731 IL=1,ILGG 
         WRK1(IL,L)=0.
 731  CONTINUE
      DO 732 L=MSGG+2,ILEVM
      DO 732 IL=1,ILGG 
         IF (       L.LE.LCL(IL) .AND. L.GE.LNB(IL)
     1        .AND. ISKIP(IL).EQ.0 ) THEN
            DPST=MBG(IL)*MC(IL,L)
            WRK1(IL,L)=QLCT(IL,L)*DPST
         END IF
 732  CONTINUE
      DO 733 L=MSGG+2,ILEVM
      DO 733 IL=1,ILGG 
         IF (       L.LE.LCL(IL) .AND. L.GE.(LNB(IL)-1) 
     1        .AND. ISKIP(IL).EQ.0 ) THEN
            DSRC(IL,L)=RRL*(( WRK1(IL,L)-WRK1(IL,L+1) )*GRAV
     1                      *DSR(IL,L)/DP(IL,L)
     2                      +AUTO(IL,L)*WRK3(IL,L))
         END IF
 733  CONTINUE
      DO 735 L=MSGG+2,ILEVM
      DO 735 IL=1,ILGG 
         IF (       L.LE.LCL(IL) .AND. L.GE.(LNB(IL)-1) 
     1        .AND. ISKIP(IL).EQ.0 ) THEN
            DTDT(IL,L)=DTDT(IL,L)+DSRC(IL,L)/CPRES
         END IF
 735  CONTINUE
C
C     * INCLUDE TRACER SINKS/SOURCES.
C
      IF ( ITRAC.NE.0 ) THEN
         DO 745 N=1,NTRAC
            IF ( ITRPHS(N).GT.0 ) THEN
               DO 740 L=MSGG+2,ILEVM
               DO 740 IL=1,ILGG 
                  IF ( L.LE.LCL(IL)
     1           .AND. L.GE.(LNB(IL)-1) .AND. ISKIP(IL).EQ.0 ) THEN
                     DXDT(IL,L,N)=DXDT(IL,L,N)+(SC(IL,L,N)-RU(IL,L,N))
     1                                         *WRK3(IL,L)
                  ENDIF
 740           CONTINUE
            ENDIF
 745     CONTINUE
       END IF
C
C     * SAFETY FEATURE. THE CLOUD BASE MASS FLUX IS REDUCED IF
C     * EXCESSIVE TENDENCIES LEAD TO NEGATIVE VALUES OF THE IN-CLOUD
C     * PROPERTIES DUE TO THE EXPLICITY OF THE NUMERICAL SCHEME
C     * USED IN THE TENDENCY CALCULATIONS. THE FOLLOWING LIMITS SHOULD
C     * NOT BE INVOKED UNDER REGULAR OPERATIONAL CONDITIONS AND CAUTION 
C     * IS ADVICED IF THIS IS HOWEVER THE CASE.
C
      AFS=0.999999999
      DO 800 IL=1,ILGG
         ACOR (IL)=1.
 800  CONTINUE
      DO 820 L=MSGG+2,ILEV
      DO 820 IL=1,ILGG
            DQDTMIN=-AFS*QG  (IL,L)/DT
            IF ( DQDT(IL,L).LT.DQDTMIN .AND. ISKIP(IL).EQ.0 ) THEN
            ACOR(IL)=MAX(MIN(-AFS*QG  (IL,L)/(DQDT(IL,L)*DT),
     1                                                   ACOR(IL)),ZERO)
         ENDIF
            DTDTMIN=-AFS*DSNG(IL,L)/(CPRES*DT)
            IF ( DTDT(IL,L).LT.DTDTMIN .AND. ISKIP(IL).EQ.0 ) THEN
            ACOR(IL)=MAX(MIN(-AFS*DSNG(IL,L)/(CPRES*DTDT(IL,L)*DT),
     1                                                   ACOR(IL)),ZERO)
         ENDIF
 820  CONTINUE
      IF ( ITRAC.NE.0 ) THEN
         DO 843 N=1,NTRAC
         DO 843 IL=1,ILGG
           ACORX(IL,N)=1.
 843     CONTINUE
         DO 845 N=1,NTRAC
            IF ( ITRPHS(N).GT.0 ) THEN
               DO 840 L=MSGG+2,ILEV
               DO 840 IL=1,ILGG 
                  DXDTMIN=-AFS*XG(IL,L,N)/DT
                  IF (DXDT(IL,L,N).LT.DXDTMIN .AND. ISKIP(IL).EQ.0) THEN
                     ACORX(IL,N)=MAX(MIN(-AFS*XG(IL,L,N)
     1                             /(DXDT(IL,L,N)*DT),ACORX(IL,N)),ZERO)
                  ENDIF
 840           CONTINUE
            ENDIF
 845     CONTINUE
      ENDIF
      DO 860 IL=1,ILGG
         MBG(IL)=MBG(IL)*ACOR(IL)
 860  CONTINUE
      DO 880 L=MSGG+2,ILEV
      DO 880 IL=1,ILGG
         IF ( ACOR(IL).LT.1. .AND. ISKIP(IL).EQ.0 ) THEN
            DQDT(IL,L)=DQDT(IL,L)*ACOR(IL)
            DTDT(IL,L)=DTDT(IL,L)*ACOR(IL)
         ENDIF
 880  CONTINUE
C
C     * PRECIPITATION.
C
      DO 930 L=MSGG+2,ILEVM 
      DO 930 IL=1,ILGG 
         IF (       L.LE.LCL(IL) .AND. L.GE.(LNB(IL)-1) 
     1        .AND. ISKIP(IL).EQ.0 ) THEN
            PCP(ISHALL(IL))=PCP(ISHALL(IL))
     1             +DT*AUTO(IL,L)*WRK3(IL,L)*DP(IL,L)/DSR(IL,L)
     2             *ACOR(IL)/GRAV/1.E+03
         ENDIF
 930  CONTINUE
C
C     * CORRECTED TRACER TENDENCIES.
C
      IF ( ITRAC.NE.0 ) THEN
         DO 895 N=1,NTRAC
            IF ( ITRPHS(N).GT.0 ) THEN
               DO 890 L=MSGG+2,ILEV
               DO 890 IL=1,ILGG
                  IF ( ACORX(IL,N).LT.1. .AND. ISKIP(IL).EQ.0 ) THEN
                     DXDT(IL,L,N)=DXDT(IL,L,N)*ACORX(IL,N)
                  ENDIF
 890           CONTINUE
            ENDIF
 895     CONTINUE
C
C        * TRACER SOURCES AND SINKS (VERTICAL INTEGRALS).
C
         XSRC(1:ILGG,:)=0.
         XSNK(1:ILGG,:)=0.
         DO 950 N=1,NTRAC
         DO 950 L=MSGG+2,ILEVM
         DO 950 IL=1,ILGG 
            IF (       L.LE.LCL(IL) .AND. L.GE.(LNB(IL)-1) 
     1           .AND. ISKIP(IL).EQ.0 ) THEN
               XSRC(IL,N)=XSRC(IL,N)+WRK3(IL,L)*SC(IL,L,N)
     1                          *ACORX(IL,N)*DP(IL,L)/GRAV/DSR(IL,L)
               XSNK(IL,N)=XSNK(IL,N)+WRK3(IL,L)*RU(IL,L,N)
     1                          *ACORX(IL,N)*DP(IL,L)/GRAV/DSR(IL,L)
            ENDIF
 950     CONTINUE
      ENDIF
C
      RETURN
      END
