SUBROUTINE SPCIMPFSOLVEAD(LDONEM,PSPDIVP,PSDIVP)

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

USE YOMLAP   , ONLY : MYMS, NASM0
USE YOMMP    , ONLY : MYSETN, NPTRMF, NSPSTAF, MYLEVS
USE YOMDIM   , ONLY : NFLEVG, NFLEVL, NFLSUR, NSMAX, NSPEC2, NUMP
USE YOMCST   , ONLY : ROMEGA
USE YOMCT0   , ONLY : LSLAG, LTWOTL
USE YOMDYN   , ONLY : SIVP, TDT, BETADT, VESL, XIDT  
USE YOMLAP   , ONLY : RLAPDI
USE YOMGEM   , ONLY : RSTRET

!**** *SPCIMPFSOLVEAD* - CALL SIMPLICO FROM S-SPACE SPECTRAL SPACE - ADJOINT

!     Purpose.
!     --------

!**   Interface.
!     ----------
!        *CALL* *SPCIMPFSOLVEAD(..)

!        Explicit arguments :  LDONEM  - T if only one m if processed
!                              PSDIVP  - solution
!                              PSPDIVP - right hand side

!     Method.
!     -------

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

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

!     Author.
!     -------
!        Tomas Wilhelmsson *ECMWF*

!     Modifications.
!     --------------
!         30-09-2009 Original with extracted code from spcsiad.F90
!     ------------------------------------------------------------------

IMPLICIT NONE

LOGICAL           ,INTENT(IN)    :: LDONEM 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PSPDIVP(:,:) 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: PSDIVP (:,:) 

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

REAL(KIND=JPRB) :: ZALPHA(0:NSMAX+1)
REAL(KIND=JPRB) :: ZDENIM(0:NSMAX+1)
REAL(KIND=JPRB) :: ZEPSI(0:NSMAX)
REAL(KIND=JPRB) :: ZFPLUS(-1:NSMAX+1)
REAL(KIND=JPRB) :: ZFMINUS(0:NSMAX+2)
REAL(KIND=JPRB) :: ZSIVP(NFLEVL)

REAL(KIND=JPRB),ALLOCATABLE :: ZSDIVP (:,:)
REAL(KIND=JPRB),ALLOCATABLE :: ZSPDIVP(:,:)

INTEGER(KIND=JPIM) :: ILO, IM, ISTA, IEND, JL, JMLOC

LOGICAL :: LL3D,LLDOSI

REAL(KIND=JPRB) :: ZAL, ZBDT, ZBDT2, ZEM, ZEN, ZF, ZTEMP
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

#include "simplico.h"
#include "trmtos.intfb.h"
#include "trstom.intfb.h"

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

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

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

ALLOCATE(ZSDIVP (NFLSUR,NSPEC2))
ALLOCATE(ZSPDIVP(NFLSUR,NSPEC2))

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

!*       1.    SEMI-IMPLICIT SPECTRAL COMPUTATIONS.
!              ------------------------------------

!*        1.1  Preliminary initialisations.

  IF (LSLAG) THEN
    IF (LTWOTL) THEN
      ZBDT=(1.0_JPRB+VESL)*0.5_JPRB*TDT*BETADT*(1.0_JPRB+XIDT)
    ELSE
      ZBDT=(1.0_JPRB+VESL)*0.5_JPRB*TDT*BETADT
    ENDIF
  ELSE
    ZBDT=0.5_JPRB*TDT*BETADT
  ENDIF
  ZBDT2=(ZBDT*RSTRET)**2

DO JL=1,NFLEVL
  ZSIVP(JL) = SIVP(MYLEVS(JL))
ENDDO

CALL GSTATS(36,2)
CALL GSTATS(87,0)
CALL TRSTOM(PSPDIVG=PSPDIVP,PSPDIV=ZSPDIVP,LDFULLM=LDONEM)
CALL GSTATS(87,2)
CALL GSTATS(36,3)

!           Solve complex pentadiagonal system

CALL GSTATS(1039,0)
!$OMP PARALLEL DO SCHEDULE(STATIC,1) PRIVATE(JMLOC,IM,ISTA,IEND) &
!$OMP&PRIVATE(ZEM,ZAL,ILO,ZALPHA,ZDENIM,ZEPSI,ZEN,ZFPLUS,ZFMINUS)
DO JMLOC=1,NUMP

  IM=MYMS(JMLOC)
  ISTA=NASM0(IM)
  IEND=ISTA+2*(NSMAX+1-IM)-1

!            Set up helper arrays for implicit Coriolis case

  ZEM=REAL(IM,JPRB)
  ZAL=2.0_JPRB*ZBDT*ROMEGA*ZEM
  ILO=IM
  IF (IM == 0) THEN
    ZALPHA(0)=0.0_JPRB
    ZDENIM(0)=0.0_JPRB
    ZEPSI(0)=0.0_JPRB
    ILO=1
  ENDIF
  DO JL=ILO,NSMAX
    ZEN=REAL(JL,JPRB)
! !!! N.B. ZALPHA is set up with the negative of the value used in
!     SPCSI, in order to simplify the manipulations with complex numbers
    ZALPHA(JL)=-ZAL/(ZEN*(ZEN+1.0_JPRB))
    ZDENIM(JL)=1.0_JPRB/(1.0_JPRB+ZALPHA(JL)**2)
    ZEPSI(JL)=SQRT((ZEN*ZEN-ZEM*ZEM)/(4.0_JPRB*ZEN*ZEN-1.0_JPRB))
  ENDDO
  ZALPHA(NSMAX+1)=0.0_JPRB
  ZDENIM(NSMAX+1)=0.0_JPRB

  IF (IM == 0) THEN
    ZFPLUS(0)=0.0_JPRB
    ZFMINUS(0)=0.0_JPRB
  ENDIF
  ZF=2.0_JPRB*ZBDT*ROMEGA
  DO JL=ILO,NSMAX-1
    ZEN=REAL(JL,JPRB)
    ZFPLUS(JL)=ZF*ZEN*ZEPSI(JL+1)/(ZEN+1.0_JPRB)
    ZFMINUS(JL)=ZF*(ZEN+1.0_JPRB)*ZEPSI(JL)/ZEN
  ENDDO
  ZEN=REAL(NSMAX,JPRB)
  ZFPLUS(NSMAX)=0.0_JPRB
  ZFMINUS(NSMAX)=ZF*(ZEN+1.0_JPRB)*ZEPSI(NSMAX)/ZEN
  ZFPLUS(NSMAX+1)=0.0_JPRB
  ZFMINUS(NSMAX+1)=0.0_JPRB
  ZFMINUS(NSMAX+2)=0.0_JPRB
      
!               Solve complex pentadiagonal system

  CALL SIMPLICO(IM,NSMAX,NFLEVL,NFLSUR,ZALPHA(IM),&
    & ZDENIM(IM),ZFMINUS(IM+1),ZFPLUS(IM-1),ZSIVP,RLAPDI(0),&
    & ZBDT2,ZSPDIVP(1,ISTA),ZSDIVP(1,ISTA))

ENDDO
!$OMP END PARALLEL DO
CALL GSTATS(1039,1)

CALL GSTATS(36,2)
CALL GSTATS(87,3)
CALL TRMTOS(PSPDIV=ZSDIVP,PSPDIVG=PSDIVP,LDFULLM=LDONEM)  
CALL GSTATS(87,1)
CALL GSTATS(36,3) 

DEALLOCATE(ZSDIVP)
DEALLOCATE(ZSPDIVP)
!     ------------------------------------------------------------------

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