SUBROUTINE OPM(YD_PX,YD_PY)

!**** *OPM*  - Matrix M in Lanczos code (A*x=l*M*x)

!     Purpose.
!     --------
!           For input PX gives the output PY=M*PX

!**   Interface.
!     ----------
!        *CALL* *OPM(PX,PY)

!        Explicit arguments :
!        --------------------
!        PX   : input vector (do NOT modify inside the subroutine)
!        PY   : output vector

!     Implicit arguments : none
!     --------------------

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

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

!     SPTRLCZTL,SPTRLCZAD,SIM4D,SUSCAL,   

!     Reference.
!     ----------
!        Lanczos code

!     Author.
!     -------
!        Roberto Buizza  *ECMWF*

!     Modifications.
!     --------------
!        Original :       92-02-25
!        Jan Barkmeijer : 96-10-21 option to evaluate the Hessian
!        M.Hamrud       : 98-01-10 Extend use of parallel vectors
!        Y.Tremolet     : 02-08-08 control_vectors and clean up
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

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

USE YOMCT0   , ONLY : NCONF    ,NSTOP    ,LSIMOB
USE YOMLUN   , ONLY : NULOUT
USE YOMSP    , ONLY : SPQ
USE YOMCVA   , ONLY : YSCALPSQRT,YRSCALPSQRT
USE YOMVAR   , ONLY : NSIM4D
USE YOMLCZ   , ONLY : NLANTYPE ,NWTRMIN0 ,NWTRMAX0 ,COEQTERM ,&
 & LSPTRLC0, NOPMSTOP ,YVAZX0    ,YVAZG0    ,LJACDAV  
USE YOMJG    , ONLY : LSUBBG
USE CONTROL_VECTORS

IMPLICIT NONE

TYPE(CONTROL_VECTOR),INTENT(IN)    :: YD_PX 
TYPE(CONTROL_VECTOR),INTENT(INOUT) :: YD_PY 
REAL(KIND=JPRB) :: ZF, ZPS
INTEGER(KIND=JPIM) :: ISTOPJ ,ICONF, IDUM
TYPE(CONTROL_VECTOR) :: YL_ZVAZY,YL_ZVAZH
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "cain.intfb.h"
#include "cainin.intfb.h"
#include "sim4d.intfb.h"
#include "sptrlcz.intfb.h"
#include "suscal.intfb.h"

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

!*    1. Compute y=Mx for Lanczos algorithm
!     -------------------------------------

!---------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('OPM',0,ZHOOK_HANDLE)
WRITE(NULOUT,*) 'SUBROUTINE OPM'
IF (LJACDAV) THEN
  ICONF =NCONF
  ISTOPJ=NSTOP
  NSTOP=NOPMSTOP
ENDIF

CALL ALLOCATE_CTLVEC(YL_ZVAZY)
CALL ALLOCATE_CTLVEC(YL_ZVAZH)
!---------------------------------------------------------   

YD_PY=YD_PX

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

IF (NLANTYPE==6 .OR. NLANTYPE==8) THEN

!     - spectral truncation

!*  copy of the input vector

  YL_ZVAZY=YD_PX

  IF (LJACDAV.AND.LSPTRLC0) THEN
    CALL SPTRLCZ(YL_ZVAZY,NWTRMIN0,NWTRMAX0)
  ENDIF

! setting q to zero

  IF (LJACDAV .AND. ABS(COEQTERM)<TINY(COEQTERM)) THEN
    CALL CAIN (YL_ZVAZY)
    SPQ(:,:)=0.0_JPRB
    CALL CAININ (YL_ZVAZY)
  ENDIF 

! nconf=131 is essential

  IF (LJACDAV) THEN
    NCONF=131
    CALL SUSCAL
    LSIMOB=.FALSE.
    LSUBBG=.TRUE.
  ENDIF

! scale to avoid rounding error problems

  ZPS = SQRT(DOT_PRODUCT (YL_ZVAZY,YL_ZVAZY))
  IF (ZPS > SQRT(TINY(ZPS))) YL_ZVAZY%data=YL_ZVAZY%data/ZPS

  YL_ZVAZY%data=YL_ZVAZY%data*YRSCALPSQRT%data

!* compute the second gradient ZVAZH needed for the Hessian

  YL_ZVAZY%data = YL_ZVAZY%data + YVAZX0%data

  IDUM=-999
  CALL SIM4D(4,IDUM,YL_ZVAZY,ZF,YL_ZVAZH,NSIM4D)

! YVAZG0 is the gradient at YVAZX0

  YL_ZVAZH%data=ZPS*(YL_ZVAZH%data-YVAZG0%data)

  YD_PY%data=0.5_JPRB*YL_ZVAZH%data*YSCALPSQRT%data

  IF (LJACDAV .AND. ABS(COEQTERM)<TINY(COEQTERM)) THEN
    CALL CAIN (YD_PY)
    SPQ(:,:)=0.0_JPRB
    CALL CAININ (YD_PY)
  ENDIF

  IF(LJACDAV .AND. LSPTRLC0) THEN
    CALL SPTRLCZ(YD_PY,NWTRMIN0,NWTRMAX0)
  ENDIF

ENDIF

!-------------------------------------
! return namelist value to nstop and NCONF
IF (LJACDAV) THEN
  NSTOP=ISTOPJ
  NCONF=ICONF
!-------------------------------------
! problems with high values of nsim4d
! QC (LVARQCG) starts with nsim4d=30

  NSIM4D=20
ENDIF

CALL DEALLOCATE_CTLVEC(YL_ZVAZY)
CALL DEALLOCATE_CTLVEC(YL_ZVAZH)

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('OPM',1,ZHOOK_HANDLE)
END SUBROUTINE OPM
!     ------------------------------------------------------------------

