      SUBROUTINE ENERSV4 (ENER,T,ES,TRAC,PHIS,PS,PRESS,TCOL,ESCOL,TENER,
     1                    TFICQ,TFICX,DELT,MOIST,ITRVAR,LA,ILEV,LEVS, 
     2                    IEPR,IESAV,KOUNT,FS,FX,TTRAC,TRACOL,ITRAC,
     3                    NTRAC,NUPR,XSRCRAT,XSRCRM1,XPP,XP0,XPM,TFICXM)

C     * MAY 29/95 - M.LAZARE. INCLUDE OPTION "ISAVDTS" TO SAVE
C     *                       GCM OUTPUT IN "yyyymmddhh" FORMAT
C     *                       (FORMAT STATEMENT ALSO MODIFIED TO
C     *                       HANDLE POSSIBLE 10-CHARACTERS).
C     * NOV 29/94 - M.LAZARE. PREVIOUS VERSION ENERSV3.
C     * 
C     * PRINT/SAVE ENERGETIC DIAGNOSTICS IN GENERALIZED 
C     * STAGGERED OR NOT VERSION OF GCM.
C     * 
      IMPLICIT REAL (A-H,O-Z),
     +INTEGER (I-N)

      COMPLEX T(LA,ILEV),ES(LA,LEVS),TRAC(LA,ILEV,NTRAC)
      COMPLEX PS(LA),PHIS(LA),PRESS(LA) 
C     * 
      REAL ENER(ILEV,7), TTRAC(ILEV,NTRAC), TENER(7+NTRAC)
      REAL TCOL(ILEV), ESCOL(ILEV), TRACOL(ILEV) 
      REAL XSRCRAT(NTRAC), XSRCRM1(NTRAC),    XPP(NTRAC)
      REAL     XP0(NTRAC),     XPM(NTRAC), TFICXM(NTRAC), TFICX(NTRAC)
C     * 
      INTEGER IBUF(8) 
C     * 
      LOGICAL SAV,PNT 
C     * 
      COMMON /CONSQ/ QSRCRAT,QSRCRM1,WPP,WP0,WPM,TFICQM 
      COMMON /KEEPTIM/ IYEAR,IYMDH,MYRSSTI,ISAVDTS
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
         IBUF2=IYMDH
      ELSE
         IBUF2=KOUNT
      ENDIF
C
C     * ABORT IF IESAV.NE.1.
C      
      IF(IESAV.EQ.1) THEN 
         SAV=.TRUE. 
      ELSE
         CALL XIT('ENERSV4',-1) 
      ENDIF 
C     * 
      IF(IEPR.GT.0) THEN
         IF(MOD(KOUNT,IEPR).EQ.0) THEN
            PNT=.TRUE.
         ELSE 
            PNT=.FALSE. 
         ENDIF
      ELSE
         PNT=.FALSE.
      ENDIF 
C     * 
      IF(.NOT.SAV .AND. .NOT.PNT) THEN
C        *
         RETURN 
C        *----- 
      ELSE
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        * PERFORM VERTICAL INTEGRAL. 
C        *
         NREC=7+NTRAC 
         DO 250 I=1,NREC
            TENER(I)=0.
  250    CONTINUE
C
         DO 320 I=1,7
            DO 300 L=1,ILEV
               TENER(I)=TENER(I) + ENER(L,I)             
  300       CONTINUE
  320    CONTINUE
C
         IF(NTRAC.GT.0)                                            THEN 
            DO 350 I=8,NREC
               DO 325 L=1,ILEV 
                  TENER(I)=TENER(I) + TTRAC(L,I-7)
  325          CONTINUE
  350       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
               WPP=WP0 + DELT*TFICQM
            ELSE
               TEMP=WPP 
               WPM=WP0
               WP0=TEMP 
               WPP=WPM + 2.*DELT*TFICQM 
               TFICQM=TFICQ 
               QSRCRM1=QSRCRAT
               QSRCRAT=(WP0-TENER(4))/TENER(7)
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 
         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=4H   Q.
C           * INITIALIZE WPP,WP0,WPM,TFICQM IN ANY EVENT SO READ/WRITE
C           * FROM RESTART FILE WILL PROCEED OK.
C 
            QSRCRAT = TFICQ/TENER(4)
            WPP=0.
            WP0=0.
            WPM=0.
            TFICQM=0. 
         ENDIF
  
         IF(ITRAC.NE.0) THEN
            IF(ITRVAR.EQ.NC4TO8("RLNQ").OR.ITRVAR.EQ.NC4TO8(" LNQ"))THEN
  
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. 
  
               IF(PNT.AND.MOIST.EQ.NC4TO8("   Q")) 
     1                                       WRITE(6,6052)QSRCRAT,TFICQ
               IF(PNT.AND.MOIST.NE.NC4TO8("   Q")) 
     1                                       WRITE(6,6062)QSRCRAT,TFICQ
               DO 365 N=1,NTRAC 
                  CALL RLNCONS(TENER(7+N),TFICX(N),XSRCRAT(N),XSRCRM1(N)
     1                        ,XPP(N),XP0(N),XPM(N),TFICXM(N),DELT,FX,
     2                         KOUNT) 
                  IF(PNT) WRITE(6,6054)N,XSRCRAT(N),TFICX(N)
  365          CONTINUE 
  
            ELSEIF(ITRVAR.EQ.NC4TO8("   Q"))THEN
  
C           * EVALUATE RATIO OF GLOBAL ARTIFICIAL SOURCE OF TRACER DUE
C           * TO "HOLE-FILLING".
  
               IF(PNT.AND.MOIST.EQ.NC4TO8("   Q")) 
     1                                       WRITE(6,6052)QSRCRAT,TFICQ
               IF(PNT.AND.MOIST.NE.NC4TO8("   Q")) 
     1                                       WRITE(6,6062)QSRCRAT,TFICQ
               DO 375 N=1,NTRAC 
                  XSRCRAT(N) = TFICX(N) / TENER(7+N)
                  XPP(N)=0. 
                  XP0(N)=0. 
                  XPM(N)=0. 
                  TFICXM(N)=0.
                  IF(PNT) WRITE(6,6054)N,XSRCRAT(N),TFICX(N)
  375          CONTINUE 
            ELSE
               CALL XIT('ENERSV4',-90)
            ENDIF 
         ELSE 
            IF(PNT) THEN
                IF(MOIST.EQ.NC4TO8("   Q")) THEN
                    WRITE(6,6050) QSRCRAT,TFICQ 
                ELSE
                    WRITE(6,6060) QSRCRAT,TFICQ 
                ENDIF 
            ENDIF 
         ENDIF
C        *
C        * SAVE VERTICAL INTEGRAL OF ENERGIES.
C        *
         IF(SAV) THEN 
            CALL SETLAB (IBUF,NC4TO8("ENRG"),IBUF2,NC4TO8("ENRG"),
     1                                            0,7+NTRAC,1,0,0)
            CALL FBUFOUT(NUPR,IBUF,-8,K)
            WRITE(NUPR)  TENER 
            WRITE(6,6000)IBUF 
         ENDIF
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) 
            IF(ITRAC.NE.0) THEN 
               DO 510 N=1,NTRAC 
                  DO 500 L=1,ILEV 
                     TRACOL(L)=REAL(TRAC(1,L,N))/SQRT(2.) 
  500             CONTINUE
                  WRITE(6,6084)N,TENER(7+N) 
                  WRITE(6,6086)(L,TRACOL(L),L=1,ILEV) 
  510          CONTINUE 
            ENDIF 
         ENDIF
C        *
         RETURN 
C        *----- 
      ENDIF 
C-----------------------------------------------------------------------
 6000 FORMAT(2X,A4,1X,I10,2X,A4,5I10)
 6050 FORMAT('0QSRCRAT,TFICQ= ',2(E12.5,1X))
 6052 FORMAT('0QSRCRAT,TFICQ= ',2(E12.5,1X),30X,'XSRCRAT,TFICX= ')
 6054 FORMAT(72X,'TRACEUR',I3,':',3X,2(E12.5,1X)) 
 6060 FORMAT('0QSRCRAT,GLOBAL-AVERAGE E-P= ',2(E12.5,1X)) 
 6062 FORMAT('0QSRCRAT,GLOBAL-AVERAGE E-P= ',2(E12.5,1X),17X, 
     1       'XSRCRAT,SOURCES ET/OU PUITS=')
 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 
