SUBROUTINE SUNHBMAT_GEOGW(PDIAG)

!**** *SUNHBMAT_GEOGW*  Initialize vertical structure matrix for
!                       Phi-gw NH model.

!     Purpose.
!     --------
!      Initialize vertical structure matrix BB used for semi-implicit
!      scheme in the Phi-gw NH model.
!      This matrix is stored in the array SIB.

!      BB = [ I + beta**2 (Delta t)**2 BB4 ]**(-1)
!        * [ beta**2 (Delta t)**2 BB2 BB3 - beta**2 (Delta t)**2 BB4 BB1 - BB1 ]
!      where:
!       BB1 = - [ Rd**2 SITR/cvdry + Rd SITR nu ]
!             + [ Rd SITR (sivderi + 1) (nu - (cpdry/(Rd SITR)) tau) ]
!       BB2 = g (Rd/cvdry (SITR/SITRA) + 1) sivderi + g
!       BB3 = g (Rd/cvdry) (SITR/SITRA) (sivderi + 1)
!            - g (SITR/SITRA) (sivderi + 1) sivderi (nu - (cpdry/(Rd SITR)) tau)
!       BB4 = - g**2/SITRA**2 (SITR/cvdry + SITRA/Rd) sivderi (sivderi + 1)
!       "sivderi" is the reference vertical derivative.

!      The assumption "sivderi2=sivderi sivderi"
!       (the second-order vertical derivative is equal to apply twice the
!       first-order derivative) has been taken into account.
!       The consequence is that BB4 BB2 = BB2 BB4

!      Top and bottom values of 'sivderi(X)' are assumed to be equal to zero.

!      The intermediate factor:
!       [ I + beta**2 (Delta t)**2 BB4 ]
!       is stored in SIFAC.

!      The intermediate factor:
!       [ I + beta**2 (Delta t)**2 BB4 ]**(-1)
!       is stored in SIFACI. It is required in the RHS of the Helmholtz
!       equation.

!      The LHS of the Helmholtz equation writes:
!       (I - beta**2 (Delta t)**2 BB Mbabar2 vnablaprim**2) D'
!      where
!       Mbabar2 = c**2 if LSIDG=F
!       Mbabar2 = M**2 if LSIDG=T (in this case a pentadiagonal operator
!        must be computed in the routine SUNHHEG).
!       "D'" is the reduced horizontal divergence variable.

!      Replace "beta" by "(1+epsilon_uncentering) * beta"
!       in the previous formulae
!       when there is uncentering (in the SL scheme).

!     Remark: the upper boundary condition is well specified at least
!      for models with "prehyd_top = 0" but it is not sure that it
!      is well specied if "prehyd_top > 0" (more generally it is
!      not currently desirable to run the NH model with "prehyd_top > 0").
!      This point has not been studied in detail.

!**   Interface.
!     ----------
!        *CALL* *SUNHBMAT_GEOGW

!     Explicit arguments :  None
!     --------------------
!      PDIAG : output for diagnostics

!     Implicit arguments :
!     --------------------
!        Matrix SIB, SIFAC, SIFACI in YOMDYN

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

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

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

!     Author.
!     -------
!        K. YESSAD (after routines SUNHBMAT).

!     Modifications.
!     --------------
!   Original : Nov 2007
!     ------------------------------------------------------------------

USE YOMLUN   , ONLY : NULOUT
USE YOMDIM   , ONLY : NFLEVG   
USE YOMDYN   , ONLY : SIB      ,SIFAC    ,SIFACI   ,&
 & BETADT   ,SITR    ,SITRA    ,SITIME   ,VESL     ,XIDT
USE YOMCT0   , ONLY : LSLAG    ,LTWOTL   ,NPRINTLEV 
USE YOMCST   , ONLY : RG       ,RD       ,RCPD     ,RCVD
USE YOMCVER  , ONLY : LVFE_DBCS,LVFE_DBCT,LVFE_DERIB

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

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

IMPLICIT NONE

REAL(KIND=JPRB),INTENT(OUT) :: PDIAG(NFLEVG,NFLEVG)

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

INTEGER(KIND=JPIM) :: JL1, JL2

REAL(KIND=JPRB) :: ZBETADT, ZBT, ZBT2
REAL(KIND=JPRB) :: ZCOEF, ZDET, ZEPS, ZDIAG_AVG
REAL(KIND=JPRB) :: ZD(0:NFLEVG+1,0:NFLEVG+1)
REAL(KIND=JPRB) :: ZBB1(NFLEVG,NFLEVG)
REAL(KIND=JPRB) :: ZBB3(0:NFLEVG+1,NFLEVG)
REAL(KIND=JPRB) :: ZVDERI_BB3(0:NFLEVG+1,NFLEVG)
REAL(KIND=JPRB) :: ZBB4(0:NFLEVG+1,0:NFLEVG+1)
REAL(KIND=JPRB) :: ZBB2BB3(0:NFLEVG+1,NFLEVG)
REAL(KIND=JPRB) :: ZT(NFLEVG,NFLEVG)
REAL(KIND=JPRB) :: ZSP(NFLEVG)
REAL(KIND=JPRB) :: ZNT(0:NFLEVG+1,NFLEVG)
REAL(KIND=JPRB) :: ZLAPL_NT(0:NFLEVG+1,NFLEVG)
REAL(KIND=JPRB) :: ZVDERIP_NT(0:NFLEVG+1,NFLEVG)
REAL(KIND=JPRB) :: ZVDERITP_I(0:NFLEVG+1,NFLEVG)
REAL(KIND=JPRB) :: ZSIB(NFLEVG,NFLEVG)
REAL(KIND=JPRB) :: ZSIBOUT(0:NFLEVG+1,NFLEVG)
REAL(KIND=JPRB) :: ZSIFAC(0:NFLEVG+1,0:NFLEVG+1)
REAL(KIND=JPRB) :: ZSIFACI(0:NFLEVG+1,0:NFLEVG+1)
REAL(KIND=JPRB) :: ZMO(0:NFLEVG+1,0:NFLEVG+1)
REAL(KIND=JPRB) :: ZWORK(2*(NFLEVG+2))

REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

INTERFACE
#include "mxmaop.h"
END INTERFACE

#include "sitnu.intfb.h"
#include "sivderi.intfb.h"

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

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

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

!*       1.    INITIALIZE.
!              -----------

! * ZD contains the identity matrix "I":
DO JL1=0,NFLEVG+1
  DO JL2=0,NFLEVG+1
    ZD(JL2,JL1)=1.0_JPRB-MIN(ABS(REAL(JL2-JL1,JPRB)),1.0_JPRB)
  ENDDO
ENDDO

! * Compute ZBT2 = (1+epsilon_uncentering)**2 * BETADT**2 * TSTEP**2:
IF (LSLAG) THEN
  IF (LTWOTL) THEN
    ZBETADT=(1.0_JPRB+VESL)*(1.0_JPRB+XIDT)*BETADT
  ELSE
    ZBETADT=(1.0_JPRB+VESL)*BETADT
  ENDIF
ELSE
  ZBETADT=BETADT
ENDIF
ZBT=ZBETADT*SITIME*0.5_JPRB
ZBT2=ZBT*ZBT

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

!*       2.    COMPUTES THE MATRIX SIFAC.
!              --------------------------

! * Constant - g**2/SITRA**2 (SITR/cvdry + SITRA/Rd):
ZCOEF=-RG*RG*(SITR/RCVD+SITRA/RD)/(SITRA*SITRA)

! * Compute BB4:
CALL SIVDERI(NFLEVG+2,2,LDVDERIB=LVFE_DERIB,LDBCS=LVFE_DBCS,LDBCT=LVFE_DBCT, &
 & PSPIN=ZD,PSPOUT=ZBB4)

! * Multiply by ZCOEF:
ZBB4(0:NFLEVG+1,0:NFLEVG+1)=ZCOEF*ZBB4(0:NFLEVG+1,0:NFLEVG+1)

! * Compute SIFAC:
DO JL1=1,NFLEVG
  DO JL2=1,NFLEVG
    SIFAC(JL2,JL1)=ZD(JL2,JL1)+ZBT2*ZBB4(JL2,JL1)
  ENDDO
ENDDO
! ky: maybe needed in other routines (-> in SIFAC?)
DO JL1=0,NFLEVG+1
  DO JL2=0,NFLEVG+1
    ZSIFAC(JL2,JL1)=ZD(JL2,JL1)+ZBT2*ZBB4(JL2,JL1)
  ENDDO
ENDDO

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

!*       3.    INVERTS THE MATRIX SIFAC.
!              --------------------------

ZMO(0:NFLEVG+1,0:NFLEVG+1)=ZSIFAC(0:NFLEVG+1,0:NFLEVG+1)

!* 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=0,NFLEVG+1
  ZDIAG_AVG = ZDIAG_AVG + ABS(ZMO(JL1,JL1))
ENDDO
ZDIAG_AVG = ZDIAG_AVG/REAL(NFLEVG+2,JPRB)
! rescaling
IF( ZDIAG_AVG > 0.0_JPRB )THEN
  DO JL1=0,NFLEVG+1
    DO JL2=0,NFLEVG+1
      ZMO(JL1,JL2)=ZMO(JL1,JL2)/ZDIAG_AVG
    ENDDO
  ENDDO
ENDIF

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

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

SIFACI(1:NFLEVG,1:NFLEVG)=ZMO(1:NFLEVG,1:NFLEVG)
ZSIFACI(0:NFLEVG+1,0:NFLEVG+1)=ZMO(0:NFLEVG+1,0:NFLEVG+1)

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

!*       4.    COMPUTES THE MATRIX SIB.
!              ------------------------

!        4.1   Compute matrix BB1:

! * Apply 'nu' and 'tau':
CALL SITNU(1,NFLEVG,ZD(1:NFLEVG,1:NFLEVG),ZT,ZSP,NFLEVG)

! * Compute (nu - (cpdry/(Rd SITR)) tau):
!   Top BBC : [nu - (cpdry/(Rd SITR)) tau]_top=nu
!   Surf BBC: [nu - (cpdry/(Rd SITR)) tau]_surf=0
DO JL1=1,NFLEVG
  DO JL2=1,NFLEVG
    ZNT(JL2,JL1)=ZSP(JL1)-(RCPD/(RD*SITR))*ZT(JL2,JL1)
  ENDDO
ENDDO
ZNT(0,1:NFLEVG)=ZSP(1:NFLEVG)
ZNT(NFLEVG+1,1:NFLEVG)=0.0_JPRB

! * Compute (sivderi+1)(nu - (cpdry/(Rd SITR)) tau):
CALL SIVDERI(NFLEVG,1,LDVDERIB=LVFE_DERIB,LDBCS=LVFE_DBCS,LDBCT=LVFE_DBCT, &
 & PSPIN=ZNT,PSPOUT=ZVDERIP_NT)

! * Compute BB1:
DO JL1=1,NFLEVG
  DO JL2=1,NFLEVG
    ZBB1(JL2,JL1)=-(RD*RD*SITR/RCVD*ZD(JL2,JL1) + RD*SITR*ZSP(JL1)) &
     & + RD*SITR*ZVDERIP_NT(JL2,JL1)
  ENDDO
ENDDO

!        4.2   Compute matrix BB3:

! * Compute (sivderi+1)I
!   Surf BBC = 0
!   Top BBC  = 0
CALL SIVDERI(NFLEVG,1,LDVDERIB=LVFE_DERIB,LDBCS=LVFE_DBCS,LDBCT=LVFE_DBCT, &
 & PSPIN=ZD(0:NFLEVG+1,1:NFLEVG),PSPOUT=ZVDERITP_I)

! * Compute (sivderi2+sivderi)(nu - (cpdry/(Rd SITR)) tau):
CALL SIVDERI(NFLEVG,2,LDVDERIB=LVFE_DERIB,LDBCS=LVFE_DBCS,LDBCT=LVFE_DBCT, &
 & PSPIN=ZNT,PSPOUT=ZLAPL_NT)

! * Compute BB3:
DO JL1=1,NFLEVG
  DO JL2=0,NFLEVG+1
    ZBB3(JL2,JL1)=(RG*SITR/SITRA)* &
     & ((RD/RCVD)*ZVDERITP_I(JL2,JL1)-ZLAPL_NT(JL2,JL1))
  ENDDO
ENDDO

!        4.3   Compute matrix BB2*BB3:

! * Compute (sivderi)BB3
CALL SIVDERI(NFLEVG,0,LDVDERIB=LVFE_DERIB,LDBCS=LVFE_DBCS,LDBCT=LVFE_DBCT, &
 & PSPIN=ZBB3,PSPOUT=ZVDERI_BB3)

! * Compute BB2*BB3:
!   (implicitly that provides the following top and bottom values
!   for BB2*BB3: g**2 (Rd/cvdry) (SITR/SITRA))
DO JL1=1,NFLEVG
  DO JL2=0,NFLEVG+1
    ZBB2BB3(JL2,JL1)= &
     & RG*(( RD*SITR/(RCVD*SITRA)+1 )*ZVDERI_BB3(JL2,JL1)+ZBB3(JL2,JL1))
  ENDDO
ENDDO

!        4.4   Compute matrix SIB:

! * Multiply by SIFACI to compute (I+(beta dt)**2 BB4)**-1 *BB2*BB3:
CALL MXMAOP(ZSIFACI,1,NFLEVG+2,ZBB2BB3,1,NFLEVG+2,ZSIBOUT,1,NFLEVG+2,&
 & NFLEVG+2,NFLEVG+2,NFLEVG)

DO JL1=1,NFLEVG
  DO JL2=1,NFLEVG
    ZSIB(JL2,JL1)=ZBT2*ZSIBOUT(JL2,JL1)-ZBB1(JL2,JL1)
  ENDDO
ENDDO

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

!*       5.    STORAGE OF MATRIX.
!              ------------------

SIB(1:NFLEVG,1:NFLEVG)=ZSIB(1:NFLEVG,1:NFLEVG)

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

!*       6.    ADDITIONAL DIAGNOSTICS.
!              -----------------------

! These diagnostics are done to check that -BB1
!  has positive real eigenvalues (necessary but not sufficient conditions
!  to be able to invert Helmholtz equation).

!        6.1   Store and print -BB1:

PDIAG(1:NFLEVG,1:NFLEVG)=-ZBB1(1:NFLEVG,1:NFLEVG)

IF (NPRINTLEV > 0) THEN
  WRITE(NULOUT,*) ''
  WRITE(NULOUT,*) ' Matrix -BB1:'
  DO JL2=1,NFLEVG
    WRITE(NULOUT,'(7(1X,E9.3))') (PDIAG(JL2,JL1),JL1=1,NFLEVG)
  ENDDO
ENDIF

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

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