      SUBROUTINE ENERSVB (ENER,TTRAC,T,ES,TRAC,PHIS,PS,PRESS,
     1                    TCOL,ESCOL,TENER,TRACOL,       
     2                    QSRCRATL,TFICQL,TFICQ,
     3                    XSRCRATL,TFICXL,TFICX,TFICXM,TPHSXL,
     4                    XSRCRAT,XSRCRM1,ITRADV,XREF,XPP,XP0,XPM,
     5                    QMOM,SCAL,TMOM,TSCAL,TTOT,TSCM,
     6                    XSRC0,XSRCM,XSCL0,XSCLM,
     7                    DELT,MOIST,ITRVAR,LA,ILEV,LEVS,          
     8                    IEPR,KOUNT,FS,FX,
     9                    NTRAC,NTRACA,DOFILTR)
C
C     * APR 15/2009 - M.LAZARE.  NEW VERSION FOR GCM15I:
C     *                          - REMOVE "DOPHYS" AND OBSELETE
C     *                            S/L OPTIONS.  
C     *                          - REMOVE "ITRAC" and "NUPR".
C     *                          - REMOVE IF BLOCK ON SAVE SO THAT
C     *                            CONSERVATION CALCULATIONS ARE 
C     *                            ALWAYS DONE EACH STEP (NO IESAV). 
C     *                          - GENERAL CONSERVATION DONE EACH STEP
C     *                            REGARDLESS OF CHOICE OF "ITRVAR", BUT
C     *                            CONSISTENT WITH REST OF CHANGES IN
C     *                            THE MODEL, THIS INVOLVES "C" ARRAYS
C     *                            (IE TFICXM1C INSTEAD OF TFICXM1). 
C     *                          - CALLS NEW RLNCON5.
C     * OCT 02/2006 - F.MAJAESS. PREVIOUS VERSION FOR GCM15F/GCM15G/GCM15H:
C     *                          - REPLACE DIRECT BINARY "DATA" RECORD
C     *                            WRITES BY "PUTFLD2" CALLS.
C     * DEC 04/2004 - M.LAZARE/  PREVIOUS VERSION FOR GCM15C/D/E:
C     *               D.PLUMMER. - REVISED HOLE-FILLING CALCULATION,
C     *                            LEVEL-BY-LEVEL. THIS REQUIRES
C     *                            PASSING IN OF EXTRA LEVEL ARRAYS
C     *                            QSRCRATL,XSRCRATL,TFICQL,TFICXL.
C     *                          - DO VERTICAL SUMS OF TFICQ AND TFICX
C     *                            (ARRAYS ON EACH LEVEL COME OUT OF
C     *                            NEW ENER8).
C     * APR 01/2004 - M.LAZARE.  PREVIOUS VERSION ENERSV8X FOR GCM15B.
C     * 
C     * ENERGY/MASS CONSERVATION CALCULATION ROUTINE.
C
      IMPLICIT REAL (A-H,O-Z),
     +INTEGER (I-N)
C
      COMPLEX T(LA,ILEV),ES(LA,LEVS),TRAC(LA,ILEV,NTRACA)
      COMPLEX PS(LA),PHIS(LA),PRESS(LA) 
C
      REAL TTRAC(ILEV,NTRAC)
      REAL ENER(ILEV,7), TENER(7+NTRAC)
      REAL TCOL(ILEV), ESCOL(ILEV), TRACOL(ILEV) 
C
      REAL XREF(NTRAC), XPP(NTRAC), XP0(NTRAC), XPM(NTRAC)
C
      REAL QMOM(ILEV), SCAL(ILEV), TMOM(ILEV,NTRAC), TSCAL(ILEV,NTRAC)
      REAL TTOT(NTRAC), TSCM(NTRAC)
      REAL QSRCRATL(ILEV), XSRCRATL(ILEV,NTRAC)
      REAL TFICQL(ILEV), TFICXL(ILEV,NTRAC), TPHSXL(ILEV,NTRAC)
      REAL TFICX(NTRAC), TFICXM(NTRAC)
      REAL XSRCRAT(NTRAC),XSRCRM1(NTRAC)
      REAL XSRC0(NTRAC), XSRCM(NTRAC), XSCL0(NTRAC), XSCLM(NTRAC)
C
      INTEGER  ITRADV(NTRAC)
      INTEGER*4 MYNODE  
C
      LOGICAL PNT,DOFILTR
C      
      COMMON /CONSQ/ QSRCRAT,QSRCRM1,WPP,WP0,WPM,TFICQM,QSRC0,QSRCM,
     1               QSCL0,QSCLM,QCTOFF
      COMMON /KEEPTIM/ IYEAR,IMDH,MYRSSTI,ISAVDTS
      COMMON /MPINFO/ MYNODE

C     * ICOM IS A SHARED I/O AREA. IT MUST BE LARGE ENOUGH
C     * FOR AN 8 WORD LABEL FOLLOWED BY A PACKED GAUSSIAN GRID.
C
      COMMON /ICOM/ IBUF(8),IDAT(1)
C
      DATA SMIN / 1.E-09 /    
C----------------------------------------------------------------------
C     * DETERMINE PROPER IBUF(2) TO USE FOR SAVED FIELDS, BASED ON
C     * VALUE OF OPTION SWITCH "ISAVDTS".
C
      IF(ISAVDTS.NE.0)                   THEN
C        * IN 32-BIT, THIS ONLY WORKS UNTIL IYEAR=2147!
         IBUF2=1000000*IYEAR + IMDH
      ELSE
         IBUF2=KOUNT
      ENDIF
C      
      IF(IEPR.GT.0) THEN
         IF(MOD(KOUNT,IEPR).EQ.0 .AND. MYNODE.EQ.0) THEN
            PNT=.TRUE.
         ELSE 
            PNT=.FALSE. 
         ENDIF
      ELSE
         PNT=.FALSE.
      ENDIF 
C      
C     * FINISH CALCULATIONS ON ENERGIES AND THEN SAVE/PRINT. 
C        
      AVPS=REAL(PRESS(1))/SQRT(2.) 
C        
C     * ADD PHIS CONTRIBUTION TO CP*T FOR P.E., AND ADD TO K.E.
C        
      DO 200 L=1,ILEV
         ENER(L,2)=ENER(L,2) + REAL(PHIS(1))/SQRT(2.)
         ENER(L,3)=ENER(L,1) + ENER(L,2) 
  200 CONTINUE 
C
C     * SUM UP LEVEL CONTRIBUTIONS TO TFICQ.
C
      DO 225 L=1,ILEV
        TFICQ = TFICQ + TFICQL(L)
  225 CONTINUE
C        
C     * PERFORM VERTICAL INTEGRAL. 
C        
      NREC=7+NTRAC 
      DO 250 I=1,NREC
         TENER(I)=0.
  250 CONTINUE
C
      DO 300 I=1,7
      DO 300 L=1,ILEV
         TENER(I)=TENER(I) + ENER(L,I)             
  300 CONTINUE
C
      QTOT=0.
      SCL=0.
      DO 322 L=1,ILEV
         QTOT=QTOT + QMOM(L)             
         SCL=MAX(SCL,SCAL(L))
  322 CONTINUE
C
      IF(NTRAC.GT.0)                                            THEN 
         DO 330 I=8,NREC
         DO 330 L=1,ILEV 
            TENER(I)=TENER(I) + TTRAC(L,I-7)
  330    CONTINUE 
C
         DO 335 N=1,NTRAC 
            TTOT(N)=0.
            TSCM(N)=0.
            DO 333 L=1,ILEV 
               TTOT(N)=TTOT(N) + TMOM(L,N)
               TSCM(N)=MAX(TSCM(N),TSCAL(L,N))
  333       CONTINUE
C
C           * SUM UP LEVEL CONTRIBUTIONS TO TFICX.
C
            DO L=1,ILEV
               TFICX(N) = TFICX(N) + TPHSXL(L,N)
            ENDDO
  335    CONTINUE
      ENDIF
C 
      IF(MOIST.NE.NC4TO8("   Q"))            THEN 
C 
C        * CALCULATE "TIME-STEPPED" PRECIPITABLE WATER.
C        * THIS IS LATER USED AT NEXT STEP TO CONSERVE MOISTURE, 
C        * BY FORMING RATIO OF IT TO ACTUAL PRECIPITABLE WATER 
C        * OBTAINED BY GAUSSIAN QUADRATURE (IN SMALL LATITUDE
C        * LOOP PRIOR TO MAIN ONE) AND SUBSEQUENTLY MODIFYING
C        * MOISTURE FIELD ACCORDINGLY. 
C        * APPLY TIME FILTER ON GLOBAL PRECIPITABLE WATER TO BE
C        * CONSISTENT WITH MOISTURE FIELD. 
C 
         IF(KOUNT.EQ.0) THEN 
            WP0=TENER(4) 
            WPM=TENER(4) 
            TFICQM=TFICQ 
            QSRCRM1=QSRCRAT
            QSRCM=QSRC0
            QSCLM=QSCL0
            WPP=WP0 + DELT*TFICQ
         ELSE
            TEMP=WPP 
            WPM=WP0
            WP0=TEMP 
            WPP=WPM + 2.*DELT*TFICQ 
            TFICQM=TFICQ 
            QSRCRM1=QSRCRAT
            QSRCM=QSRC0
            QSCLM=QSCL0
C
            QSRCRAT=WPP/TENER(4)
            QSRCRAT=MAX(QSRCRAT,0.01)
            QSRCRAT=MIN(QSRCRAT,100.)
            QSRC0=TENER(4)/QTOT
C 
C           * FOLLOWING LINE IS TO BE INCLUDED IF DESIRE TIME
C           * FILTER.
C 
            WP0=FS*WPP + (1.-2.*FS)*TEMP + FS*WPM
C 
         ENDIF 
         QSCL0=0.
         IF (QSRCRAT.LT.1.) THEN
           QSCL0=((1.-SMIN)/(1.-QSRCRAT)-QSRC0*SCL)/(1.-QSRC0*SCL)
           QSCL0=MAX(MIN(QSCL0,1.),0.)
         END IF
         IF(PNT) WRITE(6,6060)QSRCRAT,TFICQ 
      ELSE 
C 
C        * EVALUATE RATIO OF GLOBAL ARTIFICIAL SOURCE OF MOISTURE
C        * DUE TO "HOLE-FILLING" AND ITS RATIO TO GLOBAL PRECIPITABLE
C        * WATER.
C        * THIS RATIO WILL BE USED TO TRY AND CORRECT MOISTURE FIELD 
C        * IF MOIST="   Q".
C        * INITIALIZE WPP,WP0,WPM,TFICQM IN ANY EVENT SO READ/WRITE
C        * FROM RESTART FILE WILL PROCEED OK.
C 
         XTRDEF=0.0
         DO L=1,ILEV
            IF(ENER(L,4).GT.0.0) THEN
               QSRCRATL(L) = TFICQL(L) / ENER(L,4)
               IF(QSRCRATL(L).GT.0.2) THEN
                  XTRDEF = XTRDEF +
     1                     (QSRCRATL(L)-0.2)*ENER(L,4)
                  QSRCRATL(L) = 0.2
               ENDIF
            ELSE
                  XTRDEF= XTRDEF + TFICQL(L)
                  QSRCRATL(L) = 0.0
            ENDIF
         ENDDO
         XTRDEF = XTRDEF / TENER(4)
         DO L=1,ILEV
            QSRCRATL(L) = MIN(QSRCRATL(L) + XTRDEF,1.0)
         ENDDO
         WPP=0.
         WP0=0.
         WPM=0.
         TFICQM=0. 
         IF(PNT) WRITE(6,6050) QSRCRAT,TFICQ 
      ENDIF
C
C     * NOW TRACERS.
C
      DO 360 N=1,NTRAC
         IF(ITRVAR.EQ.NC4TO8("   Q") .OR. 
     1      ITRVAR.EQ.NC4TO8("QHYB") .AND. XREF(N).EQ.0.)   THEN       
C  
C           * EVALUATE RATIO OF GLOBAL ARTIFICIAL SOURCE OF TRACER DUE
C           * TO "HOLE-FILLING".
C  
            IF(ITRADV(N).GT.0)                        THEN
               XTRDEF=0.0
               DO L=1,ILEV
                  IF(TTRAC(L,N).GT.0.0) THEN
                     XSRCRATL(L,N) = TFICXL(L,N) / TTRAC(L,N)
                     IF(XSRCRATL(L,N).GT.0.2) THEN
                        XTRDEF = XTRDEF +
     1                           (XSRCRATL(L,N)-0.2)*TTRAC(L,N)
                        XSRCRATL(L,N) = 0.2
                     ENDIF
                  ELSE
                     XTRDEF= XTRDEF + TFICXL(L,N)
                     XSRCRATL(L,N) = 0.0
                  ENDIF
               ENDDO
               IF(TENER(N+7).GT.0.)  XTRDEF = XTRDEF / TENER(N+7)
               DO L=1,ILEV
                  XSRCRATL(L,N) = MIN(XSRCRATL(L,N) + XTRDEF,1.0)
               ENDDO
            ELSE
               DO L=1,ILEV
                  XSRCRATL(L,N) = 1.
               ENDDO
            ENDIF     
         ENDIF
C
C        * GENERAL CONSERVATION FOR ALL TRACERS REGARDLESS OF "ITRVAR".
C        * CALCULATE THE "TIME-STEPPED" EXCESS OF MASS OF TRACER 
C        * ACCORDING TO THE UTILISATION OF A FUNCTION OF X.
C        * THIS IS LATER USED AT THE NEXT STEP TO CONSERVE TRACER. 
C
         CALL RLNCON5(TENER(7+N),TFICX(N),XSRCRAT(N),
     1                XSRCRM1(N),XPP(N),XP0(N),XPM(N),
     2                TFICXM(N),ITRADV(N),
     3                ITRVAR,DELT,FX,KOUNT,DOFILTR,
     4                XSRC0(N),XSRCM(N),XSCL0(N),XSCLM(N),
     5                TTOT(N),TSCM(N),SMIN)  
         IF(PNT) WRITE(6,6054) N,XSRCRAT(N),TFICX(N) 
C
         IF(PNT)THEN
            WRITE(6,'(A15,I4,1PE14.6)')'TRACER ',N,TENER(N+7)
            IF(ITRADV(N).GT.0) THEN
               DO L=1,ILEV
                  WRITE(6,'(I4,1P3E14.6)')L,TTRAC(L,N),
     1                  TFICXL(L,N),XSRCRATL(L,N)
               ENDDO
            ENDIF
         ENDIF
  360 CONTINUE 
C        
C     * PRINT ENERGIES AND VERTICAL PROFILES OF TEMP. AND ES.
C        
      IF(PNT) THEN 
         DO 400 L=1,ILEV 
            T COL(L)=REAL(T(1,L))/SQRT(2.) 
            ESCOL(L)=0.
  400    CONTINUE
         DO 450 M=1,LEVS 
            L=M+ILEV-LEVS
            ESCOL(L)=REAL(ES(1,M))/SQRT(2.)
  450    CONTINUE
         AVLNPS=REAL(PS(1))/SQRT(2.) 
C            
         WRITE(6,6080) KOUNT,AVLNPS,AVPS,TENER(4)
     1                ,TENER(1),TENER(2),TENER(3),TENER(5),TENER(6)
         WRITE(6,6082)(L,
     1                 ENER(L,1),ENER(L,2),ENER(L,3),
     2                 ENER(L,5),ENER(L,6),TCOL(L),ESCOL(L), 
     3                 L=1,ILEV) 
C
         NA=0
         DO 510 N=1,NTRAC 
            WRITE(6,6084) N,TENER(7+N) 
               IF(ITRADV(N).GT.0) THEN
                  NA=NA+1
                  DO 500 L=1,ILEV 
                     TRACOL(L)=REAL(TRAC(1,L,NA))/SQRT(2.) 
  500             CONTINUE
                  WRITE(6,6086)(L,TRACOL(L),L=1,ILEV)
               ENDIF
  510    CONTINUE 
      ENDIF
C       
      RETURN    
C-----------------------------------------------------------------------
 6050 FORMAT('0QSRCRAT,TFICQ= ',2(E12.5,1X))
 6054 FORMAT(72X,'TRACEUR ',I3,' XSRCRAT,TFICX:',3X,2(E12.5,1X)) 
 6060 FORMAT('0QSRCRAT,GLOBAL-AVERAGE E-P= ',2(E12.5,1X)) 
 6080 FORMAT('0KOUNT=',I6,1P,
     1       ', AVG LN SFC PRES=',E14.7, 
     2       ', AVG SFC PRES=',   E14.7, 
     3       ', PCPABLE WATER=',      E14.7,/, 
     3       10X,'K.E.',     11X,'P.E.',    11X,'KE+PE',
     4       10X,'M.SQ.VORT', 6X,'M.SQ.DIV', 7X,'TEMP', 11X,'ES', 
     5       /,  '   TOTAL',5E15.7) 
 6082 FORMAT(' ',I5,1P,2X,7E15.7) 
 6084 FORMAT('0MASSE TOT. TRACEUR',I3,':',5X,E15.7)
 6086 FORMAT(I6,2X,E15.7) 
      END 
