SUBROUTINE COSJR

!**** *COSJR*  - COST FUNCTION IN SPECTRAL SPACE

!     Purpose.
!     --------
!     EVALUATE THE COST-FUNCTION AND THE GRADIENT

!**   Interface.
!     ----------
!        *CALL* *COSJR

!        Explicit arguments :
!        --------------------
!        None

!        Implicit arguments :
!        --------------------
!        None

!     Method.
!     -------
!        See documentation

!     Externals.
!     ----------

!     Reference.
!     ----------
!        ECMWF Research Department documentation of the IFS

!     Author.
!     -------
!        Mats Hamrud and Philippe Courtier  *ECMWF*

!     Modifications.
!     --------------
!        M.Hamrud      01-Oct-2003 CY28 Cleaning

!                  Original : 87-10-15 under the name COSTRA
!       Modified F.Bouttier : 95-04-12 transferred to routine COSJR
!       Modified L.Isaksen  : 95-06-06 Reordering of spectral arrays
!       Modified M.Hamrud   : 95-10-30 removed CLCONF
!       Modified L.Isaksen  : 96-04-04 Adapted for Message Passing
!       Modified E.Holm     : 97-12-01 Ozone included
!       Modified F.Bouttier : 99-10-30 Fix L801TL cost-function computation
!       Modified 01-08-30 by K. YESSAD: pruning and some other cleanings.
!     ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMDIM   , ONLY : NFLEVL   ,NF3D     ,NFD2D    ,NSMAX    ,&
 & NSPEC2   ,NUMP  
USE YOMDYN   , ONLY : SIDELP   ,SITR     ,SIRPRG   ,SIRPRN
USE YOMLUN   , ONLY : NULOUT
USE YOMCT3   , ONLY : NSTEP
USE YOMCOSJR , ONLY : FALTSEL  ,FSURSEL  ,FSPALT   ,FSPSUR
USE YOMCST   , ONLY : RCPD     ,RLVTT
USE YOMSP    , ONLY : SPVOR    ,SPDIV    ,SP5VOR   ,SP5DIV   ,&
 & SPT      ,SPQ      ,SPO3     ,&
 & SP5T     ,SP5Q     ,SP5O3    ,&
 & SPSP     ,SP5SP
USE YOMSPJB , ONLY : SP7VOR   ,SP7DIV   ,SP7T     ,SP7Q  , SP7O3 , SP7SP
USE YOMLAP   , ONLY : NASM0    ,MYMS     ,RLAPIN
USE YOMVAR   , ONLY : NSIM4D   ,NDIAG    ,LZOWA   ,LREFINC
USE YOMVRTL  , ONLY : L801TL
USE YOMLCZ   , ONLY : LOCNORM  ,COENEWQTERM
USE YOMMP    , ONLY : MYLEVS   ,NPSP
USE MPL_MODULE
USE YOM_YGFL , ONLY : YO3

IMPLICIT NONE

!      -----------------------------------------------------------
REAL(KIND=JPRB) :: ZFSPALT(NFLEVL,NF3D,NUMP), ZFSPSUR(NFD2D,NUMP)
REAL(KIND=JPRB) :: ZSPVOR(NFLEVL,NSPEC2),ZSPDIV(NFLEVL,NSPEC2)
REAL(KIND=JPRB) :: ZSPT  (NFLEVL,NSPEC2),ZSPQ  (NFLEVL,NSPEC2)
REAL(KIND=JPRB) :: ZSPO3 (NFLEVL,NSPEC2),ZSPSP (       NSPEC2)

INTEGER(KIND=JPIM) :: ILEV, IM, INM, IX,&
 & JIR, JLEV, JMLOC, JN, JVAR  

REAL(KIND=JPRB) :: Z, ZDIV, ZMET, ZO3, ZQ, ZSP, ZT, ZVOR, ZZF
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "stepo.intfb.h"
#include "stepoad.intfb.h"
#include "stepotl.intfb.h"
#include "spnorm.intfb.h"

!     ZFSPALT(.,.,.) : CONTRIBUTION FOR THE COST FUNCTION FROM COSJR 

!           IF (LZOWA)      ==> ZONAL WAVE NUMBER
!           ELSE            ==> TOTAL WAVE NUMBER

!      --------------------------------------------------------------

!*       1. Starts COSTRA.
!           --------------
IF (LHOOK) CALL DR_HOOK('COSJR',0,ZHOOK_HANDLE)
ZFSPALT(:,:,:)=FSPALT(:,:,:)
IF (NPSP == 1) ZFSPSUR(:,:)=FSPSUR(:,:)

!      --------------------------------------------------------------

!*       2. COMPUTATION OF THE COST FUNCTION AND ITS GRADIENT.
!           -------------------------------------------------

!                           save current model state
ZSPVOR(:,:)=SPVOR(:,:)
ZSPDIV(:,:)=SPDIV(:,:)
ZSPT(:,:)  =SPT(:,:)
ZSPQ(:,:)  =SPQ(:,:)
IF (YO3%LSP)   ZSPO3(:,:)=SPO3(:,:)
IF (NPSP==1) ZSPSP(:)=SPSP(:)

!                       Check the TL version (or not) for the 801.
IF (L801TL) THEN

!                       Compute dX - Xfcast - Xref
!                       This only works at the end of the integration,
!                       because SPVOR (etc.) has not been touched since CNT3TL.
!                       SPVOR (etc.) contains dX fieldset.
!                       SP5 contains Xfcast fieldset.
!                       In case LREFINC = T, SP7 contains a delta fieldset (Xref1 - Xref2)
!                       In case LREFINC = F, SP7 contains a full fielset Xref
  IF (LREFINC) THEN
    SPVOR(:,:) = SP7VOR(:,:) + SPVOR(:,:)
    SPDIV(:,:) = SP7DIV(:,:) + SPDIV(:,:)
    SPT(:,:)   = SP7T(:,:)   + SPT(:,:)
    SPQ(:,:)   = SP7Q(:,:)   + SPQ(:,:)
    IF (YO3%LSP) SPO3(:,:) = SP7O3(:,:) + SPO3(:,:)
    IF (NPSP==1) SPSP(:)   = SP7SP(:)   + SPSP(:)
    WRITE(NULOUT,*) '1---------spnorm  spa7 in spa3'
    CALL SPNORM(0)
  ELSE
    SPVOR(:,:) = SP5VOR(:,:)- SP7VOR(:,:) + SPVOR(:,:)
    SPDIV(:,:) = SP5DIV(:,:)- SP7DIV(:,:) + SPDIV(:,:)
    SPT(:,:)   = SP5T(:,:)  - SP7T(:,:)   + SPT(:,:)
    SPQ(:,:)   = SP5Q(:,:)  - SP7Q(:,:)   + SPQ(:,:)
    IF (YO3%LSP) SPO3(:,:) = SP5O3(:,:) - SP7O3(:,:) + SPO3(:,:)
    IF (NPSP==1) SPSP(:)   = SP5SP(:)   - SP7SP(:)   + SPSP(:)
  ENDIF


ELSE                 !  L801TL = F
!                       Or, compute Xfcast - Xref (works at any time)
!                       SP5 contains Xfcast fieldset.
!                       In case LREFINC = T, SP7 contains a delta fieldset (Xref1 - Xref2)
!                       In case LREFINC = F, SP7 contains a full fielset Xref
  IF (LREFINC) THEN
    SPVOR(:,:) = SP7VOR(:,:)
    SPDIV(:,:) = SP7DIV(:,:)
    SPT(:,:)   = SP7T(:,:)
    SPQ(:,:)   = SP7Q(:,:)
    IF (YO3%LSP) SPO3(:,:) = SP7O3(:,:)
    IF (NPSP==1) SPSP(:)   = SP7SP(:)
    WRITE(NULOUT,*) '1---------spnorm  spa7 in spa3'
    CALL SPNORM(0)
  ELSE
    SPVOR(:,:) = SP5VOR(:,:) - SP7VOR(:,:)
    SPDIV(:,:) = SP5DIV(:,:) - SP7DIV(:,:)
    SPT(:,:)   = SP5T(:,:)   - SP7T(:,:)
    SPQ(:,:)   = SP5Q(:,:)   - SP7Q(:,:)
    IF (YO3%LSP) SPO3(:,:) = SP5O3(:,:) - SP7O3(:,:)
    IF (NPSP==1) SPSP(:)   = SP5SP(:)   - SP7SP(:)
  ENDIF
ENDIF

!                  Mask Operator
IF(LOCNORM) THEN
  CALL STEPO  ('0K0000000')
  CALL STEPOTL('0GB0L0AA0')
ENDIF

DO JMLOC=1,NUMP
  IM=MYMS(JMLOC)
  ZMET=1.0_JPRB+REAL(MIN(1,IM),JPRB)
  DO JIR=0,MIN(IM,1)
    DO JN=IM,NSMAX
      INM=NASM0(IM)+(JN-IM)*2+JIR
      IF(LZOWA)THEN
        IX=JMLOC
      ELSE
        IX=JN+1
      ENDIF
!              Jr & gradJr, Surface Pressure
      IF (NPSP == 1) THEN
        ZSP=SIRPRG/SIRPRN/2.0_JPRB
        Z=ZMET*ZSP*(SPSP(INM))**2
        SPSP(INM)=FSURSEL(1)*ZSP*SPSP(INM)*2.0_JPRB
        FSPSUR(1,IX) = FSPSUR(1,IX) + Z
      ENDIF
!              3D Weights
      DO JLEV=1,NFLEVL
        ILEV=MYLEVS(JLEV)
!            The gradient gets good if I put SIDELP=1. Why?(F. Bouttier)
        ZVOR=-RLAPIN(JN)*SIDELP(ILEV)/2.0_JPRB
        ZDIV=-RLAPIN(JN)*SIDELP(ILEV)/2.0_JPRB
        ZT  =RCPD*SIDELP(ILEV)/SITR/2.0_JPRB
        ZQ=COENEWQTERM**( (RLVTT**2)/(RCPD*SITR) )&
         & *SIDELP(ILEV)/2.0_JPRB  
!               Jr & gradJr, Vorticity
        Z=ZMET*ZVOR*(SPVOR(JLEV,INM))**2
        SPVOR(JLEV,INM)=FALTSEL(ILEV,1)*ZVOR*SPVOR(JLEV,INM)*2.0_JPRB
        FSPALT (JLEV,1,IX)=FSPALT (JLEV,1,IX)+Z
!               Jr & gradJr, Divergence
        Z=ZMET*ZDIV*(SPDIV(JLEV,INM))**2
        SPDIV(JLEV,INM)=FALTSEL(ILEV,2)*ZDIV*SPDIV(JLEV,INM)*2.0_JPRB
        FSPALT (JLEV,2,IX)=FSPALT (JLEV,2,IX)+Z
!               Jr & gradJr, Temperature
        Z=ZMET*ZT*(SPT(JLEV,INM))**2
        SPT(JLEV,INM)=FALTSEL(ILEV,3)*ZT*SPT(JLEV,INM)*2.0_JPRB
        FSPALT (JLEV,3,IX)=FSPALT (JLEV,3,IX)+Z
!               Jr & gradJr, Humidity
        Z=ZMET*ZQ*(SPQ(JLEV,INM))**2
        SPQ(JLEV,INM)=FALTSEL(ILEV,4)*ZQ*SPQ(JLEV,INM)*2.0_JPRB
        FSPALT (JLEV,4,IX)=FSPALT (JLEV,4,IX)+Z
      ENDDO
      IF (YO3%LSP) THEN
        DO JLEV=1,NFLEVL
          ILEV=MYLEVS(JLEV)
          ZO3=0.0_JPRB
!                 Jr & gradJr, Ozone
          Z=ZMET*ZO3*(SPO3(JLEV,INM))**2
          SPO3(JLEV,INM)=FALTSEL(ILEV,5)*ZO3*SPO3(JLEV,INM)*2.0_JPRB
          FSPALT (JLEV,5,IX)=FSPALT (JLEV,5,IX)+Z
        ENDDO
      ENDIF
    ENDDO
  ENDDO
ENDDO
!               Adjoint Mask operator
IF(LOCNORM)  THEN
  CALL STEPOAD('0GB0L0AA0')
ENDIF
!               gradJ = gradJ + gradJr
SPVOR(:,:)=SPVOR(:,:)+ZSPVOR(:,:)
SPDIV(:,:)=SPDIV(:,:)+ZSPDIV(:,:)
SPT(:,:)=SPT(:,:)+ZSPT(:,:)
SPQ(:,:)=SPQ(:,:)+ZSPQ(:,:)
IF (YO3%LSP) SPO3(:,:)=SPO3(:,:)+ZSPO3(:,:)

IF (NPSP == 1) THEN
  SPSP(:)=SPSP(:)+ZSPSP(:)
ENDIF

!     ------------------------------------------------------------------

!*       3. Writes diagnostics.
!           -------------------

IF (NDIAG /= 0) THEN
  ZFSPALT(:,:,:)=FSPALT(:,:,:)-ZFSPALT(:,:,:)
  ZZF=0.0_JPRB
  DO JMLOC=1,NUMP
    DO JVAR=1,NF3D
      DO JLEV=1,NFLEVL
        ZZF=ZZF+ZFSPALT(JLEV,JVAR,JMLOC)
      ENDDO
    ENDDO
  ENDDO
  IF (NPSP == 1) THEN
    ZFSPSUR(:,:)=FSPSUR(:,:)-ZFSPSUR(:,:)
    DO JMLOC=1,NUMP
      DO JVAR=1,NFD2D
        ZZF=ZZF+ZFSPSUR(JVAR,JMLOC)
      ENDDO
    ENDDO
  ENDIF

  CALL MPL_ALLREDUCE(ZZF,'SUM',LDREPROD=.FALSE.,CDSTRING='COSJR:')

  WRITE(UNIT=NULOUT,FMT='(1X,''SIMUL= '',I3,2X,''NSTEP = ''&
   & ,I3,2X,''CONTRIBUTION = '',E13.7)') NSIM4D, NSTEP, ZZF  
  WRITE(NULOUT,*) 'COENEWQTERM = ',COENEWQTERM
ENDIF

!     ------------------------------------------------------------------

IF (LHOOK) CALL DR_HOOK('COSJR',1,ZHOOK_HANDLE)
END SUBROUTINE COSJR
