#ifdef VPP
!OCL SCALAR
#endif
SUBROUTINE SUNHSI(KULOUT,LDEB)

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

USE YOMDIM   , ONLY : NFLEVG   
USE YOMGEM   , ONLY : VBH      ,VAH      ,VC       ,VDELB    
USE YOMDYNA  , ONLY : LNH_PDVD ,LNH_GEOGW
USE YOMDYN   , ONLY : SIALPH   ,SILNPR   ,SIDELP   ,SIRDEL   ,SITLAH   ,&
 & SITLAF   ,SIDPHI   ,SIB      ,SIMO     ,SIMI     ,SIVP     ,&
 & SIPR     ,SITR     ,SITIME   ,TDT      ,VNORM    ,LSIDG    ,NDLNPR
USE YOMCT0   , ONLY : LSITRIC
USE YOMCST   , ONLY : RD       ,RCVD     ,RCPD
USE YOMJG    , ONLY : SIBI
USE YOMCVER  , ONLY : LRNHC1

!**** *SUNHSI*   - Initialize constants and control for the dynamics:
!                  Semi-implicit scheme operators.
!                  NH model.

!     Purpose.
!     --------
!        Computes the operator B=mu*nu+gamma*tau which is used in
!        the semi-implicit scheme
!        in order to work on the Hough space.
!        The inverse 1/B and also the eigenvalues and the eigenvectors
!        of B are computed.
!        * B is stored in array SIB.
!        * The eigenvalues of B are stored in array SIVP.
!        * The eigenvectors of B are stored in array SIMO.
!        * The inverse of SIMO is stored in array SIMI.
!        * The inverse of B is stored in array SIBI.
!        * The call to SUHEG or SUNHHEG fills the arrays SIHEG and SIHEG2.
!        In the NH model, all these quantities depend on Delta t.

!**   Interface.
!     ----------
!        *CALL* *SUNHSI(KULOUT)

!     Explicit arguments :
!     --------------------
!        KULOUT : Logical unit for the output
!        LDEB   : .T.: Computations of Part 1.1 are done.

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

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

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

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

!     Author.
!     -------
!        K. YESSAD (after old part 7 of SUDYN).

! Modifications
! -------------
!   Original : 08-Dec-2004
!   Modified : 09-Oct-2007 by K. YESSAD: possibility to have a specific
!              value of (LVERTFE,NDLNPR) in the SI linear model.
!   N. Wedi and K. Yessad (Jan 2008): different dev for NH model and PC scheme
!------------------------------------------------------------------------------

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KULOUT
LOGICAL,INTENT(IN)               :: LDEB

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

INTEGER(KIND=JPIM) :: JPLL
PARAMETER(JPLL=1)

REAL(KIND=JPRB) :: ZPRES(JPLL,0:NFLEVG),ZPRESF(JPLL,NFLEVG)
REAL(KIND=JPRB) :: ZRPRE(JPLL,  NFLEVG),ZRPP  (JPLL,NFLEVG)
REAL(KIND=JPRB) :: ZDELP(JPLL,NFLEVG),ZRDELP(JPLL,NFLEVG),ZLNPR(JPLL,NFLEVG)
REAL(KIND=JPRB) :: ZALPH(JPLL,NFLEVG),ZRTGR(JPLL,NFLEVG)
REAL(KIND=JPRB) :: ZWORK(2*NFLEVG)
REAL(KIND=JPRB) :: ZWO(NFLEVG+1),ZA(NFLEVG,NFLEVG),ZFR(NFLEVG)
REAL(KIND=JPRB) :: ZFI(NFLEVG),ZMO(NFLEVG,NFLEVG)
REAL(KIND=JPRB) :: ZFN(NFLEVG)
REAL(KIND=JPRB) :: ZIN(NFLEVG,NFLEVG),ZOU(NFLEVG,NFLEVG)
REAL(KIND=JPRB) :: ZDIAG(NFLEVG,NFLEVG)

INTEGER(KIND=JPIM) :: IWO(NFLEVG+1)
INTEGER(KIND=JPIM) :: IER, ISIGN, JL1, JL2, JLEV, JLON, J

REAL(KIND=JPRB) :: ZDET, ZEPS, ZSUM, ZTES
REAL(KIND=JPRB) :: ZDIAG_AVG

LOGICAL :: LLNH_NOC1
LOGICAL :: LLSI

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "abor1.intfb.h"
#include "eigsol.h"
#include "gppref.intfb.h"
#include "gppreh.intfb.h"
#include "gpxyb.intfb.h"
#include "scordo.intfb.h"
#include "si_cccor.intfb.h"
#include "suheg.intfb.h"
#include "sunhbmat.intfb.h"
#include "sunhbmat_geogw.intfb.h"
#include "sunhheg.intfb.h"

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

IF (LHOOK) CALL DR_HOOK('SUNHSI',0,ZHOOK_HANDLE)

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

!*       1.    INITIALIZE SEMI-IMPLICIT AND VERTICAL NORMAL MODES
!              FOR THE 3D PRIMITIVE EQUATION MODEL.
!              --------------------------------------------------

!*       1.1   INITIALIZE SEMI-IMPLICIT COMPUTATION.

IF (LDEB) THEN

! * This part does not depend on Delta t.

  DO JLON=1,JPLL
    ZPRES(JLON,NFLEVG)=SIPR
  ENDDO

  LLSI=.TRUE.
  CALL GPPREH(JPLL,JPLL,JPLL,NFLEVG,VAH,VBH,ZPRES)
  CALL GPXYB(JPLL,JPLL,JPLL,NFLEVG,VDELB,VC,&
   & ZPRES,ZDELP,ZRDELP,ZLNPR,ZALPH,ZRTGR,ZRPRE,ZRPP,LLSI)
  CALL GPPREF(JPLL,JPLL,JPLL,NFLEVG,ZALPH,ZPRES,ZPRESF,LLSI)

  DO JLEV=1,NFLEVG
    SIDELP(JLEV)=ZDELP(1,JLEV)
    SIRDEL(JLEV)=ZRDELP(1,JLEV)
    SILNPR(JLEV)=ZLNPR(1,JLEV)
    SIALPH(JLEV)=ZALPH(1,JLEV)
    SITLAH(JLEV)=ZPRES(1,JLEV)
  ENDDO
  DO JLEV=1,NFLEVG
    SITLAF(JLEV)=ZDELP(1,JLEV)/ZLNPR(1,JLEV)
    SIDPHI(JLEV)=RD*SITR*ZLNPR(1,JLEV)
  ENDDO
  DO JLEV=1,NFLEVG
    WRITE(UNIT=KULOUT,FMT='('' JLEV = '',I3.3,&
     & '' SITLAF = '',E14.8,'' SIDPHI = '',E14.8)')&
     & JLEV,SITLAF(JLEV),SIDPHI(JLEV)  
  ENDDO

  SITLAH(0)=ZPRES(1,0)

  SITIME=-1.0_JPRB

  IF (LSITRIC) CALL ABOR1(' SUNHSI: LSITRIC=T not coded in NH model')

  ! * Case where the C1 constraint is not matched.
  LLNH_NOC1=LNH_PDVD.AND.(.NOT.(NDLNPR == 1)).AND.(.NOT.LRNHC1)
  IF (LLNH_NOC1) THEN

    ! * Compute COR * I = (C**2 * COR) * ( (1/C**2) * I )
    DO JLEV=1,NFLEVG
      DO JLON=1,NFLEVG
        ZIN(JLON,JLEV)=1.0_JPRB-MIN(ABS(REAL(JLON-JLEV,JPRB)),1.0_JPRB)
        ZIN(JLON,JLEV)=ZIN(JLON,JLEV)*RCVD/(RD*RCPD*SITR)
      ENDDO
    ENDDO
    CALL SI_CCCOR(1,NFLEVG,NFLEVG,ZIN,ZOU)

    !! WRITE(KULOUT,'(A)') ''
    !! WRITE(KULOUT,'(A)') ' SUNHSI: Content of COR:'
    !! DO JLEV=1,NFLEVG
    !!   DO JLON=1,NFLEVG
    !!     WRITE(KULOUT,'(A,I3,A,I3,A,E10.4)') &
    !!      & ' COR(',JLON,',',JLEV,') = ',ZOU(JLON,JLEV)
    !!   ENDDO
    !!   WRITE(KULOUT,'(A)') ''
    !! ENDDO

    ! * Compute the eigenvalues of COR.
    CALL EIGSOL(NFLEVG,NFLEVG,ZOU,ZFR,ZFI,1,ZMO,IWO,ZWO,IER)

    DO JLEV=1,NFLEVG
      ZFN(JLEV)=SQRT(ZFR(JLEV)*ZFR(JLEV)+ZFI(JLEV)*ZFI(JLEV))
    ENDDO

    WRITE(KULOUT,'(A)') ''
    WRITE(KULOUT,'(A,E10.4)') ' SUNHSI: Highest eigenvalue module of COR:', &
     & MAXVAL(ZFN)

  ENDIF

ENDIF

IF(SITIME /= TDT)THEN

  SITIME=TDT
  ZDET=0.0_JPRB

  !*       1.2   INITIALIZE MATRIX B (SIB)

  IF (LNH_GEOGW) THEN
    CALL SUNHBMAT_GEOGW(ZDIAG)
  ELSEIF (LNH_PDVD) THEN
    CALL SUNHBMAT
  ENDIF

  ! For Phi-gw NH model, check that -BB1 and BB4**-1 BB2 BB3 - BB1
  !  have real positive eigenvalues. This is a necessary (but not
  !  sufficient) condition to be able to invert the Helmholtz
  !  equation for a large range of values of BETADT and TSTEP.

  IF (LNH_GEOGW) THEN

    ! * Checkings on matrix -BB1.

    WRITE(KULOUT,*)
    WRITE(KULOUT,*) ' Checkings on matrix -BB1:'

    IER=0
    ZTES=0.0_JPRB

    ZA(1:NFLEVG,1:NFLEVG)=ZDIAG(1:NFLEVG,1:NFLEVG)
    CALL EIGSOL(NFLEVG,NFLEVG,ZA,ZFR,ZFI,1,ZMO,IWO,ZWO,IER)
    IF(IER /= 0)THEN
      CALL ABOR1('SUNHSI: ABORT 1.2a IN SUNHSI AFTER CALL TO RG')
    ENDIF
    CALL SCORDO(NFLEVG,ZFR,ZFI,ZMO,ZA)

    ZTES=MAXVAL(ZFI)
    WRITE(KULOUT,482) ZTES
    IF (ZTES > 0.0_JPRB) THEN
      WRITE(KULOUT,*) '  -BB1 has not real eigenvalues!! '
    ENDIF

    ZTES=MINVAL(ZFR)
    IF (ZTES <= 0.0_JPRB) THEN
      WRITE(KULOUT,*) '  -BB1 has some real eigenvalues < or = 0!! '
    ENDIF

    WRITE(UNIT=KULOUT,FMT='(''  -BB1: REAL PARTS OF EIGENVALUES'')')
    WRITE(KULOUT,FMT='(7(1X,E9.3))')(ZFR(NFLEVG+1-J),J=1,NFLEVG)
    WRITE(UNIT=KULOUT,FMT='(''  -BB1: IMAGINARY PARTS OF EIGENVALUES'')')
    WRITE(KULOUT,FMT='(7(1X,E9.3))')(ZFI(NFLEVG+1-J),J=1,NFLEVG)

  ENDIF
  
  !*       1.3   SOLVE EIGEN PROBLEM

  IER=0
  ZTES=0.0_JPRB

  DO JL1=1,NFLEVG
    DO JL2=1,NFLEVG
      ZA(JL1,JL2)=SIB(JL1,JL2)
    ENDDO
  ENDDO

  CALL EIGSOL(NFLEVG,NFLEVG,ZA,ZFR,ZFI,1,ZMO,IWO,ZWO,IER)
  IF(IER /= 0)THEN
    CALL ABOR1('SUNHSI: ABORT 1.3 IN SUNHSI AFTER CALL TO RG')
  ENDIF
  CALL SCORDO(NFLEVG,ZFR,ZFI,ZMO,ZA)

  DO JL1=1,NFLEVG
    DO JL2=1,NFLEVG
      SIMO(JL1,NFLEVG+1-JL2)=ZMO(JL1,JL2)
    ENDDO
  ENDDO

  DO JL1=1,NFLEVG
    SIVP(NFLEVG+1-JL1)=ZFR(JL1)
  ENDDO

  ZTES=MAXVAL(ZFI)

  !        1.4   NORMALIZE THE VERTICAL MODES
  !                               --
  ! NEW SCALING     , > X(J)**2 *DP(J)/PSOL = VNORM
  !                               --
  !  (PRESERVING THE AMPLITUDE OF THE EIGENMODE AS THE VERTICAL RESOLUTION
  !   -NFLEVG- CHANGES , C.TEMPERTON  09/91)

  DO JL1=1,NFLEVG
    ZSUM = 0._JPRB
    DO JL2=1,NFLEVG
      ZSUM=ZSUM+SIMO(JL2,JL1)*SIMO(JL2,JL1)*SIDELP(JL2)
    ENDDO
    ZSUM = ZSUM/SIPR/VNORM
    ZSUM = SQRT(ZSUM)
    DO JL2=1,NFLEVG
      SIMO(JL2,JL1) = SIMO(JL2,JL1)/ZSUM
    ENDDO
  ENDDO

  !        1.5   CHECK SIGNS OF VERTICAL MODES

  DO JL1=1,NFLEVG
    ISIGN = +1
    IF (SIMO(NFLEVG,JL1) < 0.0_JPRB) ISIGN = -ISIGN
    IF (ISIGN == -1) THEN
      DO JL2=1,NFLEVG
        SIMO(JL2,JL1) = -SIMO(JL2,JL1)
      ENDDO
    ENDIF
  ENDDO

  DO JL1=1,NFLEVG
    DO JL2=1,NFLEVG
      ZMO(JL1,JL2) = SIMO(JL1,JL2)
    ENDDO
  ENDDO

  !*       1.6   INVERSE MODE MATRIX

  !* for more than 83 levels it is not possible to pass through MINV
  !  and therefore matrix has to be rescaled before inversion
  !  and than set back. We use average absolute value on diagonal
  !  ZDIAG_AVG to rescale matrix
  ZDIAG_AVG=0.0_JPRB
  DO JL1=1,NFLEVG
    ZDIAG_AVG = ZDIAG_AVG + ABS(ZMO(JL1,JL1))
  ENDDO
  ZDIAG_AVG = ZDIAG_AVG/REAL(NFLEVG,JPRB)
  ! rescaling
  IF( ZDIAG_AVG > 0.0_JPRB )THEN
    DO JL1=1,NFLEVG
      DO JL2=1,NFLEVG
        ZMO(JL1,JL2)=ZMO(JL1,JL2)/ZDIAG_AVG
      ENDDO
    ENDDO
  ENDIF

  ZEPS=100.0_JPRB*TINY(1.0_JPRB)
  CALL MINV(ZMO,NFLEVG,NFLEVG,ZWORK,ZDET,ZEPS,0,1)

  ! rescaling back to original values
  IF( ZDIAG_AVG > 0.0_JPRB )THEN
    DO JL1=1,NFLEVG
      DO JL2=1,NFLEVG
        ZMO(JL1,JL2)=ZMO(JL1,JL2)/ZDIAG_AVG
      ENDDO
    ENDDO
  ENDIF

  DO JL1=1,NFLEVG
    DO JL2=1,NFLEVG
      SIMI(JL1,JL2) = ZMO(JL1,JL2)
    ENDDO
  ENDDO

  !*       1.7   PRINT OUT INFORMATION ON VERTICAL MODES

  WRITE(KULOUT,*) ''
  WRITE(KULOUT,481) SITR,SIPR,(J,VAH(J-1),VBH(J-1),SIVP(J),J=1,NFLEVG)
  481 FORMAT('1VERTICAL MODES FOR SITR=',F6.1,' K;   SIPR=',F8.0,&
   & ' PA'///,' VERTICAL RESOLUTION         A(K)            B(K)',&
   & 26X,'EIGENVALUES '/&
   & (20X,I4,G13.5,4X,G13.5,18X,G13.5))  
  WRITE(KULOUT,482) ZTES
  482 FORMAT(///'0LARGEST IMAGINARY PART OF EIGENVALUES:',G13.5)
  IF (ZTES /= 0.0_JPRB) THEN
    ! * Print the imaginary part of eigenvalues.
    WRITE(UNIT=KULOUT,FMT='('' IMAGINARY PARTS OF EIGENVALUES'')')
    WRITE(KULOUT,FMT='(14(1X,E8.2))')(ZFI(NFLEVG+1-J),J=1,NFLEVG)
    ! * For the non-zero imaginary parts, print the eigenvectors.
    DO JL2=1,NFLEVG
      IF (ABS(ZFI(NFLEVG+1-JL2)) > 0.0_JPRB) THEN
        WRITE(UNIT=KULOUT,FMT='(1X)')
        WRITE(KULOUT,FMT='(A,I4)') ' SIMO for VP number ',JL2
        WRITE(KULOUT,FMT='(14(1X,E8.2))')(SIMO(JL1,JL2),JL1=1,NFLEVG)
      ENDIF
    ENDDO
    WRITE(UNIT=KULOUT,FMT='(1X)')
    CALL ABOR1(' SUNHSI: Eigenvalues of B are not all real > 0')
  ENDIF

  !*       1.8   SOLVE INVERSE HELMOLTZ EQUATION IF LSIDG=.T.

  IF (LSIDG) THEN
    IF (LNH_GEOGW) THEN
      CALL SUHEG
    ELSEIF (LNH_PDVD) THEN
      CALL SUNHHEG
    ENDIF
  ENDIF

  !*       1.9   CALCULATE INVERSE OF THE B MATRIX.

  DO JL1=1,NFLEVG
    DO JL2=1,NFLEVG
      SIBI(JL1,JL2) = SIB(JL1,JL2)
    ENDDO
  ENDDO

  !* rescaling with ZDIAG_AVG: see comment above.
  ZDIAG_AVG=0.0_JPRB
  DO JL1=1,NFLEVG
    ZDIAG_AVG = ZDIAG_AVG + ABS(SIBI(JL1,JL1))
  ENDDO
  ZDIAG_AVG = ZDIAG_AVG/REAL(NFLEVG,JPRB)
  ! rescaling
  IF( ZDIAG_AVG > 0.0_JPRB )THEN
    DO JL1=1,NFLEVG
      DO JL2=1,NFLEVG
        SIBI(JL1,JL2)=SIBI(JL1,JL2)/ZDIAG_AVG
      ENDDO
    ENDDO
  ENDIF

  ZEPS=100.0_JPRB*TINY(1.0_JPRB)
  CALL MINV(SIBI,NFLEVG,NFLEVG,ZWORK,ZDET,ZEPS,0,1)

  ! rescaling back to original values
  IF( ZDIAG_AVG > 0.0_JPRB )THEN
    DO JL1=1,NFLEVG
      DO JL2=1,NFLEVG
        SIBI(JL1,JL2)=SIBI(JL1,JL2)/ZDIAG_AVG
      ENDDO
    ENDDO
  ENDIF


ENDIF

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

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