      SUBROUTINE XTEND5( DUDT,DVDT,XGA,XFA,XUA,XDA,SCA,DXDT,XG,XF,XU,XD,
     1                   SC,RU,MU,MD,DSR,WRKX,WRKXA,SUMDX,WRK,DP,PFG,PG,
     2                   PRESSG,MB,AMBCOR,JB,JT,MX,ITRPHS,DT,GRAV,ROG,
     3                   ILG,ILEV,IL1G,IL2G,MSG,IU,IV,NTRAC,NTRACA )
C-----------------------------------------------------------------------
C     * APR 30/2012 - K.VONSALZEN.    NEW VERSION FOR GCM16:
C     *                               - BUGFIX TO ADD DSR IN LOOPS 395,
C     *                                 400,405.
C     *                               - BUGFIX TO REMOVE SCA IN LOOPS
C     *                                 675,680. 
C     * APR 23/2010 - M.LAZARE/       PREVIOUS VERSION XTEND4 FOR GCM15I:
C     *               K.VONSALZEN.    - BUGFIX FOR TRACER TENDENCIES AT
C     *                                 END TO INCLUDE "DSR".
C     * MAY 27/2006 - M.LAZARE.       PREVIOU VERSION XTEND3 FOR GCM15F/G/H:
C     *                               - CHANGE LOOP STARTING INDEX FOR 
C     *                                 LOOP 90 FROM "MSG+1" TO '2". THE
C     *                                 L=1 CASE IS HANDLED IN THE 
C     *                                 SUBSEQUENT LOOP 110 IN ANY EVENT.
C     *                                 MIGRATING TO INTERNAL WORK ARRAYS
C     *                                 FOR CONV11/CONTRA3 PRODUCED A NaN
C     *                                 WHICH WASN'T PROBLEMATIC PREVIOUSLY
C     *                                 (SAME ANSWER, ANYWAY). 
C     * DEC 13/2005 - K.VONSALZEN.    PREVIOUS VERSION XTEND2 FOR GCM15D/E:
C     *                               - CUMULUS MOMENTUM TENDENCY 
C     *                                 CALCULATIONS ADDED.
C     *                               - CORRECT VERTICAL LEVEL INDICES IN
C     *                                 LOOPS: 2,ILEV -> MSG+1,ILEV.
C     *                               - IMPOSE LIMIT ON AFRAC IN CASE THAT
C     *                                 AINTT IS TOO SMALL (BOUND).
C     *                               - REMOVE IF RESTRICTIONS ON TRACERS
C     *                                 BEING POSITIVE-DEFINITE, SINCE
C     *                                 NEW FORMULATION ENSURES THIS.  
C     * APR 13/2005 - K.VONSALZEN.    PREVIOUS VERSION XTEND FOR GCM15B/C.
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 PROFILES.
C-----------------------------------------------------------------------
      IMPLICIT REAL   (A-H,O-Z),
     +INTEGER (I-N)
C      
C     * MULTI-LEVEL WORK FIELDS. 
C      
      REAL   WRK (ILG,ILEV), PFG (ILG,ILEV), DP (ILG,ILEV),MU(ILG,ILEV),
     1       PG  (ILG,ILEV), MD  (ILG,ILEV), DSR(ILG,ILEV), 
     2       DUDT(ILG,ILEV), DVDT(ILG,ILEV)
C
      REAL   XGA  (ILG,ILEV,NTRACA), XUA (ILG,ILEV,NTRACA),
     1       XDA  (ILG,ILEV,NTRACA), XFA (ILG,ILEV,NTRACA),
     2       WRKXA(ILG,ILEV,NTRACA), SCA (ILG,ILEV,NTRACA)
C
      REAL   WRKX (ILG,ILEV,NTRAC), DXDT(ILG,ILEV,NTRAC),
     1       XG  (ILG,ILEV,NTRAC),  XF  (ILG,ILEV,NTRAC),
     2       XU  (ILG,ILEV,NTRAC),  XD  (ILG,ILEV,NTRAC),
     3       SC  (ILG,ILEV,NTRAC),  RU  (ILG,ILEV,NTRAC)
      REAL   SUMDX(ILG,NTRAC)
C     
C     * SINGLE-LEVEL WORK FIELDS. 
C      
      REAL      MB(ILG), PRESSG(ILG), AMBCOR(ILG)
      INTEGER MX(ILG), JT(ILG), JB(ILG)
      INTEGER ITRPHS(NTRAC)
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     * INITIALIZATIONS.
C
      DO 50 L=MSG+1,ILEV
      DO 50 IL=IL1G,IL2G
         WRK (IL,L)=0.
         DUDT(IL,L)=0.
         DVDT(IL,L)=0.
 50   CONTINUE
      DO 70 N=1,NTRAC
      DO 70 L=MSG+1,ILEV
      DO 70 IL=IL1G,IL2G
         WRKX(IL,L,N)=0.
         DXDT(IL,L,N)=0.
 70   CONTINUE
      DO 90 N=1,NTRAC
      DO 90 L=2,ILEV 
      DO 90 IL=IL1G,IL2G 
         ATMP=( PFG(IL,L)-PG(IL,L-1) )/( PG(IL,L)-PG(IL,L-1) )
         XF(IL,L,N)=ZINTP( XG(IL,L,N),XG(IL,L-1,N),ATMP )
  90  CONTINUE
      L=1
      DO 110 N=1,NTRAC
      DO 110 IL=IL1G,IL2G
         XF(IL,L,N)=XG(IL,L,N)
  110 CONTINUE
C
      DO 130 N=IU,IV
      DO 130 L=MSG+1,ILEV
      DO 130 IL=IL1G,IL2G
         WRKXA(IL,L,N)=0.
 130  CONTINUE
      DO 140 N=IU,IV
      DO 140 L=2,ILEV 
      DO 140 IL=IL1G,IL2G 
         ATMP=( PFG(IL,L)-PG(IL,L-1) )/( PG(IL,L)-PG(IL,L-1) )
         XFA(IL,L,N)=ZINTP( XGA(IL,L,N),XGA(IL,L-1,N),ATMP )
  140 CONTINUE
      L=1
      DO 150 N=IU,IV
      DO 150 IL=IL1G,IL2G
         XFA(IL,L,N)=XGA(IL,L,N)
  150 CONTINUE
C
C     * EFFECTIVE FLUXES OF CLOUD PROPERTIES AT GRID CELL 
C     * INTERFACES BELOW CLOUD BASE.
C
      DO 165 N=1,NTRAC
         IF ( ITRPHS(N).GT.0 ) THEN
            DO 160 L=MSG+1,ILEV
            DO 160 IL=IL1G,IL2G
              IF ( L.GT.JT(IL) .AND. L.LE.JB(IL) .AND. MB(IL).GT.0.
     1                                                         ) THEN
                 WRKX(IL,L,N)=WRKX(IL,L,N)+(MU(IL,L)*XU(IL,L,N)
     1                                     +MD(IL,L)*XD(IL,L,N))
     2                                     *AMBCOR(IL)
              ENDIF
 160        CONTINUE
         ENDIF
 165  CONTINUE
C
C     * SAME FOR MOMENTUM.
C
      DO 170 N=IU,IV
      DO 170 L=MSG+1,ILEV
      DO 170 IL=IL1G,IL2G
        IF ( L.GT.JT(IL) .AND. L.LE.JB(IL) .AND. MB(IL).GT.0.
     1                                                         ) THEN
           WRKXA(IL,L,N)=WRKXA(IL,L,N)+(MU(IL,L)*XUA(IL,L,N)
     1                                 +MD(IL,L)*XDA(IL,L,N))
     2                                 *AMBCOR(IL)
        ENDIF
 170  CONTINUE
C
C     * INTERMEDIATE TENDENCIES FROM EFFECTIVE FLUXES. 
C
      DO 365 N=1,NTRAC
         IF ( ITRPHS(N).GT.0 ) THEN
            DO 340 IL=IL1G,IL2G 
               IF ( MB(IL).GT.0. ) THEN
                 L=JB(IL)
                 DXDT(IL,L,N)=DXDT(IL,L,N)-WRKX(IL,L,N)*DSR(IL,L)
     1                                    /DP(IL,L)
               END IF
  340       CONTINUE
            DO 360 L=MSG+1,ILEV-1
            DO 360 IL=IL1G,IL2G 
               IF ( L.GT.JT(IL) .AND. L.LT.JB(IL) .AND. MB(IL).GT.0.
     1                                                         ) THEN
                  DXDT(IL,L,N)=DXDT(IL,L,N)
     1                        +( WRKX(IL,L+1,N)-WRKX(IL,L,N) )
     2                        *DSR(IL,L)/DP(IL,L)
               ENDIF
  360       CONTINUE
            DO 380 IL=IL1G,IL2G 
               IF ( MB(IL).GT.0. ) THEN
                 L=JT(IL)
                 DXDT(IL,L,N)=DXDT(IL,L,N)+WRKX(IL,L+1,N)*DSR(IL,L)
     1                                    /DP(IL,L)
               END IF
  380       CONTINUE
         ENDIF
  365 CONTINUE
C
C     * MOMENTUM TENDENCIES.
C
      DO 395 IL=IL1G,IL2G
        IF ( MB(IL).GT.0. ) THEN
          L=JB(IL)
          DUDT(IL,L)=DUDT(IL,L)-WRKXA(IL,L,IU)*DSR(IL,L)/DP(IL,L)
          DVDT(IL,L)=DVDT(IL,L)-WRKXA(IL,L,IV)*DSR(IL,L)/DP(IL,L)
        END IF
 395  CONTINUE
      DO 400 L=MSG+1,ILEV-1
      DO 400 IL=IL1G,IL2G
         IF ( L.GT.JT(IL) .AND. L.LT.JB(IL) .AND. MB(IL).GT.0.
     1                                                         ) THEN
           DUDT(IL,L)=DUDT(IL,L)
     1        +( WRKXA(IL,L+1,IU)-WRKXA(IL,L,IU) )*DSR(IL,L)/DP(IL,L)
           DVDT(IL,L)=DVDT(IL,L)
     1        +( WRKXA(IL,L+1,IV)-WRKXA(IL,L,IV) )*DSR(IL,L)/DP(IL,L)
          ENDIF
 400  CONTINUE
      DO 405 IL=IL1G,IL2G
         IF ( MB(IL).GT.0. ) THEN
           L=JT(IL)
           DUDT(IL,L)=DUDT(IL,L)+WRKXA(IL,L+1,IU)*DSR(IL,L)/DP(IL,L)
           DVDT(IL,L)=DVDT(IL,L)+WRKXA(IL,L+1,IV)*DSR(IL,L)/DP(IL,L)
         END IF
 405  CONTINUE
C
C     * LOWER VERTICAL BOUNDS FOR THE CALCULATION OF EFFECTIVE FLUXES.
C
      DO 500 L=MSG+1,ILEV
      DO 500 IL=IL1G,IL2G
         IF ( L.GT.JT(IL) .AND. L.LE.JB(IL) .AND. MB(IL).GT.0. ) THEN
            WRK(IL,L)=PFG(IL,L)-(MU(IL,L)+MD(IL,L))*AMBCOR(IL)
     1                          *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 HEIGHT. DISCRETIZATION ACCORDING TO BOTT (MWR, 1989).
C
      DO 530 N=1,NTRAC
      DO 530 L=MSG+1,ILEV
      DO 530 IL=IL1G,IL2G
         WRKX(IL,L,N)=0.
 530  CONTINUE
      DO 575 N=1,NTRAC
         IF ( ITRPHS(N).GT.0 ) THEN
            DO 570 L=MSG+1,ILEV-1
            DO 570 IL=IL1G,IL2G
               IF ( L.LE.JB(IL) .AND. L.GT.JT(IL) .AND. MB(IL).GT.0. 
     1                                                           ) THEN
                  IF ( WRK(IL,L).LT.PFG(IL,L) ) THEN
                    ZFH=PFG(IL,L-1)
                    ZFM=PG(IL,L-1)
                    ZFL=PFG(IL,L)
                    DPLDL=(XG(IL,L-1,N)-XF(IL,L  ,N))/(ZFM-ZFL)
                    DPLDH=(XF(IL,L-1,N)-XG(IL,L-1,N))/(ZFH-ZFM)
                    AINTT=ZMEAN(XF(IL,L,N),DPLDL,ZFL,ZFM,
     1                          DP(IL,L-1))
                    IF ( WRK(IL,L).LE.ZFM ) THEN
                       AINTP=AINTT+ZMEAN(XG(IL,L-1,N),DPLDH,ZFM,
     1                             WRK(IL,L),DP(IL,L-1))
                    ELSE
                       AINTP=ZMEAN(XF(IL,L,N),DPLDL,ZFL,WRK(IL,L),
     1                             DP(IL,L-1))
                    ENDIF
                    AINTT=AINTT+ZMEAN(XG(IL,L-1,N),DPLDH,ZFM,ZFH,
     1                             DP(IL,L-1))
                    IF ( ABS(AINTT).GT.1.E-20 ) THEN
                      AFRAC=XG(IL,L-1,N)/AINTT
                    ELSE
                      AFRAC=1.
                    ENDIF
                    WRKX(IL,L,N)=AINTP*AFRAC*DP(IL,L-1)
     1                          /(DT*GRAV*DSR(IL,L))
                  ELSE IF ( WRK(IL,L).GT.PFG(IL,L) ) THEN
                    ZFH=PFG(IL,L)
                    ZFM=PG(IL,L)
                    ZFL=PFG(IL,L+1)
                    DPLDL=(XG(IL,L,N)-XF(IL,L+1,N))/(ZFM-ZFL)
                    DPLDH=(XF(IL,L,N)-XG(IL,L  ,N))/(ZFH-ZFM)
                    AINTT=ZMEAN(XG(IL,L,N),DPLDH,ZFM,ZFH,
     1                          DP(IL,L))
                    IF ( WRK(IL,L).GE.ZFM ) THEN
                       AINTP=AINTT+ZMEAN(XG(IL,L,N),-DPLDL,WRK(IL,L),
     1                             ZFM,DP(IL,L))
                    ELSE
                       AINTP=ZMEAN(XF(IL,L,N),-DPLDH,WRK(IL,L),ZFL,
     1                             DP(IL,L))
                    ENDIF
                    AINTT=AINTT+ZMEAN(XF(IL,L+1,N),DPLDL,ZFL,ZFM,
     1                             DP(IL,L))
                    IF ( ABS(AINTT).GT.1.E-20 ) THEN
                      AFRAC=XG(IL,L,N)/AINTT
                    ELSE
                      AFRAC=1.
                    ENDIF
                    WRKX(IL,L,N)=AINTP*AFRAC*DP(IL,L)
     1                          /(DT*GRAV*DSR(IL,L))
                  ENDIF
               ENDIF
 570        CONTINUE
            L=ILEV
            DO 590 IL=IL1G,IL2G
               IF ( L.LE.JB(IL) .AND. L.GT.JT(IL) .AND. MB(IL).GT.0. 
     1                                                           ) THEN
                  IF ( WRK(IL,L).LT.PFG(IL,L) ) THEN
                    ZFH=PFG(IL,L-1)
                    ZFM=PG(IL,L-1)
                    ZFL=PFG(IL,L)
                    DPLDL=(XG(IL,L-1,N)-XF(IL,L  ,N))/(ZFM-ZFL)
                    DPLDH=(XF(IL,L-1,N)-XG(IL,L-1,N))/(ZFH-ZFM)
                    AINTT=ZMEAN(XF(IL,L,N),DPLDL,ZFL,ZFM,
     1                          DP(IL,L-1))
                    IF ( WRK(IL,L).LE.ZFM ) THEN
                       AINTP=AINTT+ZMEAN(XG(IL,L-1,N),DPLDH,ZFM,
     1                             WRK(IL,L),DP(IL,L-1))
                    ELSE
                       AINTP=ZMEAN(XF(IL,L,N),DPLDL,ZFL,WRK(IL,L),
     1                             DP(IL,L-1))
                    ENDIF
                    AINTT=AINTT+ZMEAN(XG(IL,L-1,N),DPLDH,ZFM,ZFH,
     1                             DP(IL,L-1))
                    IF ( ABS(AINTT).GT.1.E-20 ) THEN
                      AFRAC=XG(IL,L-1,N)/AINTT
                    ELSE
                      AFRAC=1.
                    ENDIF
                    WRKX(IL,L,N)=AINTP*AFRAC*DP(IL,L-1)
     1                          /(DT*GRAV*DSR(IL,L))
                  ELSE IF ( WRK(IL,L).GT.PFG(IL,L) ) THEN
                    ZFH=PFG(IL,L)
                    ZFM=PG(IL,L)
                    ZFL=PRESSG(IL)*0.01
                    DPLDL=0.
                    DPLDH=(XF(IL,L,N)-XG(IL,L  ,N))/(ZFH-ZFM)
                    AINTT=ZMEAN(XG(IL,L,N),DPLDH,ZFM,ZFH,
     1                          DP(IL,L))
                    IF ( WRK(IL,L).GE.ZFM ) THEN
                       AINTP=AINTT+ZMEAN(XG(IL,L,N),-DPLDL,WRK(IL,L),
     1                             ZFM,DP(IL,L))
                    ELSE
                       AINTP=ZMEAN(XF(IL,L,N),-DPLDH,WRK(IL,L),ZFL,
     1                             DP(IL,L))
                    ENDIF
                    AINTT=AINTT+ZMEAN(XG(IL,L,N),DPLDL,ZFL,ZFM,
     1                             DP(IL,L))
                    IF ( ABS(AINTT).GT.1.E-20 ) THEN
                      AFRAC=XG(IL,L,N)/AINTT
                    ELSE
                      AFRAC=1.
                    ENDIF
                    WRKX(IL,L,N)=AINTP*AFRAC*DP(IL,L)
     1                          /(DT*GRAV*DSR(IL,L))
                  ENDIF
               ENDIF
 590        CONTINUE
         ENDIF
 575  CONTINUE
C
C     * CALCULATE FLUXES FOR MOMENTUM.
C
      DO 605 N=IU,IV
      DO 605 L=MSG+1,ILEV
      DO 605 IL=IL1G,IL2G
         WRKXA(IL,L,N)=0.
 605  CONTINUE
      DO 610 N=IU,IV
         DO 620 L=2,ILEV
         DO 620 IL=IL1G,IL2G
            IF ( L.LE.JB(IL) .AND. L.GT.JT(IL) .AND. MB(IL).GT.0. ) THEN 
               IF ( WRK(IL,L).LT.PFG(IL,L) ) THEN
                 AINTP=(PFG(IL,L)-WRK(IL,L))*XGA(IL,L-1,N)/DP(IL,L-1)
                 WRKXA(IL,L,N)=AINTP*DP(IL,L-1)/(DT*GRAV*DSR(IL,L))
               ELSE IF ( WRK(IL,L).GT.PFG(IL,L) ) THEN
                 AINTP=(PFG(IL,L)-WRK(IL,L))*XGA(IL,L,N)/DP(IL,L)
                 WRKXA(IL,L,N)=AINTP*DP(IL,L)/(DT*GRAV*DSR(IL,L))
               ENDIF
            ENDIF
 620     CONTINUE
 610  CONTINUE
C
      L=ILEV
      DO 675 IL=IL1G,IL2G
         DUDT(IL,L)=DUDT(IL,L)+WRKXA(IL,L,IU)*GRAV/DP(IL,L)
     1             *DSR(IL,L)
         DVDT(IL,L)=DVDT(IL,L)+WRKXA(IL,L,IV)*GRAV/DP(IL,L)
     1             *DSR(IL,L)
 675  CONTINUE
      DO 680 L=MSG+1,ILEV-1
      DO 680 IL=IL1G,IL2G
         DUDT(IL,L)=DUDT(IL,L)
     1               -( WRKXA(IL,L+1,IU)-WRKXA(IL,L,IU) )*GRAV
     2                 *DSR(IL,L)/DP(IL,L)
         DVDT(IL,L)=DVDT(IL,L)
     1               -( WRKXA(IL,L+1,IV)-WRKXA(IL,L,IV) )*GRAV
     2                 *DSR(IL,L)/DP(IL,L)
 680  CONTINUE 
C
C     * TENDENCIES FROM VERTICAL FLUXES IN CLOUD AND ENVIRONMENT, 
C     * INCLUDING SOURCES AND SINKS. 
C
      DO 660 N=1,NTRAC
         IF ( ITRPHS(N).GT.0 ) THEN
            L=ILEV
            DO 645 IL=IL1G,IL2G 
               DXDT(IL,L,N)=DXDT(IL,L,N)+WRKX(IL,L,N)*GRAV/DP(IL,L)
     1                     *DSR(IL,L)+SC(IL,L,N)-RU(IL,L,N)
 645        CONTINUE
            DO 650 L=MSG+1,ILEV-1
            DO 650 IL=IL1G,IL2G 
                  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)+SC(IL,L,N)-RU(IL,L,N)
 650        CONTINUE
         ENDIF
 660  CONTINUE
C
C     * INCLUDE DOWNDRAFT EFFECTS.
C
      DO 700 N=1,NTRAC
        IF(ITRPHS(N).GT.0) THEN    
         DO 720 IL=IL1G,IL2G                                            
           J=MX(IL)
           DXDT(IL,J,N)=DXDT(IL,J,N)+SUMDX(IL,N)
  720    CONTINUE
        ENDIF      
  700 CONTINUE
C                                                                       
      RETURN                                                            
      END
