SUBROUTINE SPC2(CDCONF,KM,KMLOC)

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

USE YOMDIM   , ONLY : NSMAX
USE YOMSP    , ONLY : SPVOR    ,SPDIV    ,SPSP
USE YOMCT0   , ONLY : NCONF    ,LSLAG    ,N2DINI
USE YOMCST   , ONLY : ROMEGA
USE YOMVODCST, ONLY : CSTVO, CSTDIV
USE YOMDYN   , ONLY : RDIVOR   ,RDIDIV   ,RDISP    ,RDHI     ,&
 & SCGMAP   ,SIVP     ,SIHEG    ,SIHEG2   ,TDT      ,LSTRHD   ,&
 & BETADT   ,VESL     ,LIMPF    ,LSIDG
USE YOMLAP   , ONLY : NASM0    ,NSE0L    ,RLAPDI   ,RLAPIN
USE YOMGEM   , ONLY : RSTRET

!**** *SPC2* - SPECTRAL SPACE COMPUTATIONS MULTITASKED ON ZONAL WAVE NUMBER.

!                Caution! Only works for a triangular troncature, i.e.
!                         NASRN(n)=n.

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

!**   Interface.
!     ----------
!        *CALL* *SPC2(CDCONF,KM)

!        Explicit arguments :
!        --------------------
!          INPUT:
!            CDCONF   - configuration of work.
!            KM       - wavenumber.
!            KMLOC    - wavenumber (DM-local numbering)

!     Method.
!     -------

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

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

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

!     Modifications.
!     --------------
!        Original : 87-11-24
!        =91-08-05= F.Rabier u,v formulation
!        =91-08-07= P.Courtier cleaning and optimisation
!        Modified DEC 1992 by K. YESSAD: decentering factor in semi-lag scheme.
!        Modified 93-04-15 L.labbe - NCONF=821 : 2D model
!        Modified JAN 1994 by K. YESSAD: semi-implicit computations
!           with not reduced divergence + new formulation of variable
!           mesh horizontal diffusion + multitasking on m instead of n.
!        K. YESSAD (APRIL 1994): Unified horizontal diffusion scheme.
!        Modified 94-08-31 M.Tolstykh: modified decentering in semi-Lag scheme
!        K. YESSAD (MARCH 1995):
!            - Optimisation of semi-implicit scheme if variable decentering
!              and remove of IMSL routines.
!            - Real/imag parts stored in conventional order in work arrays
!              as it is already made in SPC.
!            - Use new array NSE0 (of YOMLAP) to define IS0.
!        Modified 95-06-06 L.Isaksen: Reordering of spectral arrays
!        K. YESSAD (NOV 1995): removal of HDC horizontal diffusion scheme.
!        Modified OCT 1996 by K. YESSAD: removal of variable uncentering.
!        M. TOLSTYKH (OCT 1996): Fourier space horizontal diffusion.
!        Modified 97-05-21 by C. Temperton: LIMPF option added
!        Modified 98-01-19 by L. Isaksen: bugfix
!        J.PADILLA-BARBOSA 2001-03-12 numerical component of Fourier
!                                     Horizontal Diffusion removed.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        K.Yessad (Dec 2003): cleaning in horizontal diffusion
!        K. Yessad 15-May-2006: memory optimisations for stretched geometry

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

IMPLICIT NONE

CHARACTER(LEN=1)  ,INTENT(IN)    :: CDCONF 
INTEGER(KIND=JPIM),INTENT(IN)    :: KM 
INTEGER(KIND=JPIM),INTENT(IN)    :: KMLOC

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

REAL(KIND=JPRB) :: ZSPDIV(KM:NSMAX,2)
REAL(KIND=JPRB) :: ZSPVOR(KM:NSMAX,2)
REAL(KIND=JPRB) :: ZSPDIVG(KM:NSMAX,2)
REAL(KIND=JPRB) :: ZSPSP(KM:NSMAX,2)

REAL(KIND=JPRB) :: ZSDIV(KM:NSMAX,2)

REAL(KIND=JPRB) :: ZSPX(3,KM:NSMAX,2)
REAL(KIND=JPRB) :: ZSPY(3,KM:NSMAX,2)

REAL(KIND=JPRB) :: ZALPHA (KM:NSMAX+1)
REAL(KIND=JPRB) :: ZDENIM (KM:NSMAX+1)
REAL(KIND=JPRB) :: ZEPSI  (KM:NSMAX)
REAL(KIND=JPRB) :: ZFPLUS (KM:NSMAX+1)
REAL(KIND=JPRB) :: ZFMINUS(KM:NSMAX+1)

REAL(KIND=JPRB) :: ZY(2,KM:NSMAX)
REAL(KIND=JPRB) :: ZX(2,KM:NSMAX)

INTEGER(KIND=JPIM) :: II, ILL, ILO, IS0, IS02, ISE, JI, JL, JN

LOGICAL :: LLSHW

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

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

#include "abor1.intfb.h"
#include "mxptma.h"
#include "mxture.h"
#include "mxturhd.h"
#include "mxturs.h"
#include "simplico.h"

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

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

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

!     II=1 if KM=0, II=2 if KM different from 0.
II=1+MIN(1,IABS(KM))
IS0=NSE0L(KMLOC)
IS02=0

LLSHW=NCONF == 201.OR.NCONF == 421.OR.NCONF == 521

IF(.NOT.LLSHW) THEN
  CALL ABOR1(' = SPC2 = ERROR NCONF ')
ENDIF

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

!*       1.    INITIAL MEMORY TRANSFER.
!              ------------------------

DO JI=1,II
  DO JN=KM,NSMAX
    ISE=NASM0(KM)+(JN-KM)*2+JI-1
    ZSPDIV(JN,JI)=SPDIV(1,ISE)
    ZSPVOR(JN,JI)=SPVOR(1,ISE)
    ZSPSP(JN,JI)=SPSP(ISE)
  ENDDO
ENDDO

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

!*       2.    SEMI-IMPLICIT SPECTRAL COMPUTATIONS FOR SHALLOW WATER MODEL.
!              ------------------------------------------------------------

IF(CDCONF == 'A'.OR.CDCONF == 'I')THEN
  IF (LLSHW) THEN

!*      2.1  Preliminary initialisations.

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

!            Set up helper arrays for implicit Coriolis case

    IF (LIMPF) THEN
      ZEM=REAL(KM,JPRB)
      ZAL=2.0_JPRB*ZBDT*ROMEGA*ZEM
      ILO=KM
      IF (KM == 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)
        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 (KM == 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
    ENDIF

!*      2.2  Computes right-hand side of Helmholtz equation.

    IF (LSIDG) THEN
      DO JI=1,II
        IF (KM > 0) THEN
          DO JN=KM,NSMAX
            ZSDIV(JN,JI)=RLAPIN(JN)*ZSPDIV(JN,JI)-ZBDT*ZSPSP(JN,JI)
          ENDDO
        ELSEIF (KM == 0) THEN
          DO JN=KM,NSMAX
            ZSDIV(JN,JI)=ZSPDIV(JN,JI)-ZBDT*RLAPDI(JN)*ZSPSP(JN,JI)
          ENDDO
        ENDIF
      ENDDO
    ELSE
      DO JI=1,II
        DO JN=KM,NSMAX
          ZSDIV(JN,JI)=ZSPDIV(JN,JI)-ZBDT*RLAPDI(JN)*ZSPSP(JN,JI)
        ENDDO
      ENDDO
    ENDIF

!        For implicit Coriolis case, multiply rhs of vorticity equn by INV[J]
!        Careful : LIMPF assumes all n-values are available !

    IF (LIMPF) THEN
      IF (KM > 0) THEN
        DO JN=KM,NSMAX
          ZTEMP=ZDENIM(JN)*(ZSPVOR(JN,2)+ZALPHA(JN)*ZSPVOR(JN,1))
          ZSPVOR(JN,1)=ZDENIM(JN)*(ZSPVOR(JN,1)-ZALPHA(JN)*ZSPVOR(JN,2))
          ZSPVOR(JN,2)=ZTEMP
        ENDDO
      ENDIF

!        Add [F] * result to rhs of Helmholtz equation

      DO JI=1,II
        DO JN=KM+1,NSMAX
          ZSDIV(JN,JI)=ZSDIV(JN,JI)+ZFMINUS(JN)*ZSPVOR(JN-1,JI)
        ENDDO
        DO JN=KM,NSMAX-1
          ZSDIV(JN,JI)=ZSDIV(JN,JI)+ZFPLUS(JN)*ZSPVOR(JN+1,JI)
        ENDDO
      ENDDO
    ENDIF

!*      2.3  Solve Helmholtz equation

    IF (LSIDG) THEN
!              Inversion of two tridiagonal systems (Helmholtz equation)
!                 --> (DIVprim(t+dt)).
      IF (KM > 0) THEN
        CALL MXTURS(NSMAX+1-KM,1,1,II,&
         & SIHEG(1,IS0+1,1),SIHEG(1,IS0+1,2),SIHEG(1,IS0+1,3),&
         & ZSDIV(KM,1),ZSPDIV(KM,1))  
      ELSEIF (KM == 0) THEN
        CALL MXTURE(NSMAX+1-KM,1,1,II,-2,.TRUE.,&
         & SIHEG(1,IS0+1,1),SIHEG(1,IS0+1,2),SIHEG(1,IS0+1,3),&
         & ZSDIV(KM,1),ZSPDIV(KM,1))  
        CALL MXTURE(NSMAX+1-KM,1,1,II,3,.FALSE.,&
         & SIHEG(1,IS0+1,1),SIHEG2(1,IS02+1,2),&
         & SIHEG2(1,IS02+1,3),ZSDIV(KM,1),ZSPDIV(KM,1))  
      ENDIF
    ELSEIF (LIMPF) THEN

!              Solve complex pentadiagonal system

!           (first have to transpose right-hand side)
      DO JI=1,II
        DO JN=KM,NSMAX
          ZY(JI,JN)=ZSDIV(JN,JI)
        ENDDO
      ENDDO
      CALL SIMPLICO(KM,NSMAX,1,1,ZALPHA(KM),ZDENIM(KM),&
       & ZFPLUS(KM),ZFMINUS(KM),SIVP(1),RLAPDI(0),&
       & ZBDT2,ZY,ZX)  
!           (now transpose result)
      DO JI=1,II
        DO JN=KM,NSMAX
          ZSPDIV(JN,JI)=ZX(JI,JN)
        ENDDO
      ENDDO
    ELSE
!              Inversion of a diagonal system (Helmholtz equation)
!                 --> (DIVprim(t+dt)).
      DO JI=1,II
        DO JN=KM,NSMAX
          ZSPDIV(JN,JI)=ZSDIV(JN,JI)/(1.0_JPRB-ZBDT2*SIVP(1)*RLAPDI(JN))
        ENDDO
      ENDDO
    ENDIF

    IF (LSIDG) THEN
!           ZSPDIV=(DIVprim(t+dt)) --> ZSPDIVG=(GM**2 * DIVprim(t+dt)) .
      CALL MXPTMA(NSMAX+1-KM,1,1,II,SCGMAP(IS0+1,1),&
       & SCGMAP(IS0+1,2),SCGMAP(IS0+1,3),&
       & SCGMAP(IS0+1,2),SCGMAP(IS0+1,3),&
       & ZSPDIV(KM,1),ZSPDIVG(KM,1))  
    ELSE
!           ZSPDIV=(DIVprim(t+dt)) --> ZSPDIVG=(GMBAR**2 * DIVprim(t+dt)) .
      DO JI=1,II
        DO JN=KM,NSMAX
          ZSPDIVG(JN,JI)=ZSPDIV(JN,JI)*RSTRET*RSTRET
        ENDDO
      ENDDO
    ENDIF

!*      2.4  Increment equivalent height.

    DO JI=1,II
      DO JN=KM,NSMAX
        ZSPSP(JN,JI)=ZSPSP(JN,JI)-ZBDT*SIVP(1)*ZSPDIVG(JN,JI)
      ENDDO
    ENDDO

!*       2.5  Increment vorticity

    IF (LIMPF) THEN
      IF (KM == 0) THEN
        DO JN=2,NSMAX
          ZSPVOR(JN,1)=ZSPVOR(JN,1)-ZDENIM(JN)*ZFMINUS(JN)*ZSPDIVG(JN-1,1)
        ENDDO
        DO JN=1,NSMAX-1
          ZSPVOR(JN,1)=ZSPVOR(JN,1)-ZDENIM(JN)*ZFPLUS(JN)*ZSPDIVG(JN+1,1)
        ENDDO
      ELSE
        DO JN=KM+1,NSMAX
          ZSPVOR(JN,1)=ZSPVOR(JN,1)&
           & -ZDENIM(JN)*ZFMINUS(JN)*(ZSPDIVG(JN-1,1)&
           & -ZALPHA(JN)*ZSPDIVG(JN-1,2))  
          ZSPVOR(JN,2)=ZSPVOR(JN,2)&
           & -ZDENIM(JN)*ZFMINUS(JN)*(ZSPDIVG(JN-1,2)&
           & +ZALPHA(JN)*ZSPDIVG(JN-1,1))  
        ENDDO
        DO JN=KM,NSMAX-1
          ZSPVOR(JN,1)=ZSPVOR(JN,1)&
           & -ZDENIM(JN)*ZFPLUS(JN)*(ZSPDIVG(JN+1,1)&
           & -ZALPHA(JN)*ZSPDIVG(JN+1,2))  
          ZSPVOR(JN,2)=ZSPVOR(JN,2)&
           & -ZDENIM(JN)*ZFPLUS(JN)*(ZSPDIVG(JN+1,2)&
           & +ZALPHA(JN)*ZSPDIVG(JN+1,1))  
        ENDDO
      ENDIF
    ENDIF
  ENDIF
ENDIF

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

!*       5.    HORIZONTAL DIFFUSION ON WORK SPHERE.
!              ------------------------------------

IF (CDCONF == 'A') THEN

  IF (LSTRHD) THEN

!             5.1  Diffusion when stretching.

    DO JI=1,II
      DO JN=KM,NSMAX
        ZSPX(1,JN,JI)=ZSPVOR(JN,JI)*RLAPIN(JN)
        ZSPX(2,JN,JI)=ZSPDIV(JN,JI)*RLAPIN(JN)
        ZSPX(3,JN,JI)=ZSPSP (JN,JI)
      ENDDO
    ENDDO

    ILL=3
    CALL MXTURHD(NSMAX+1-KM,ILL,ILL,-2,.TRUE.,&
     & RDHI(1,IS0+1,1),RDHI(1,IS0+1,2),ZSPX(1,KM,1),ZSPY(1,KM,1))
    CALL MXTURHD(NSMAX+1-KM,ILL,ILL,3,.FALSE.,&
     & RDHI(1,IS0+1,1),RDHI(1,IS0+1,3),ZSPX(1,KM,1),ZSPY(1,KM,1))

    IF (KM > 0) THEN
      CALL MXTURHD(NSMAX+1-KM,ILL,ILL,-2,.TRUE.,&
       & RDHI(1,IS0+1,1),RDHI(1,IS0+1,2),ZSPX(1,KM,2),ZSPY(1,KM,2))
      CALL MXTURHD(NSMAX+1-KM,ILL,ILL,3,.FALSE.,&
       & RDHI(1,IS0+1,1),RDHI(1,IS0+1,3),ZSPX(1,KM,2),ZSPY(1,KM,2))
    ENDIF

    DO JI=1,II
      DO JN=KM,NSMAX
        ZSPVOR(JN,JI)=ZSPY(1,JN,JI)*RLAPDI(JN)
        ZSPDIV(JN,JI)=ZSPY(2,JN,JI)*RLAPDI(JN)
        ZSPSP (JN,JI)=ZSPY(3,JN,JI)
      ENDDO
    ENDDO

  ELSE

!             5.2  Diffusion when no stretching.

    DO JI=1,II
      DO JN=KM,NSMAX
        ZSPVOR(JN,JI)=ZSPVOR(JN,JI)/(1.0_JPRB+TDT*RDIVOR(1,JN))
        ZSPDIV(JN,JI)=ZSPDIV(JN,JI)/(1.0_JPRB+TDT*RDIDIV(1,JN))
        ZSPSP(JN,JI)=ZSPSP(JN,JI)/(1.0_JPRB+TDT*RDISP(JN))
      ENDDO
    ENDDO

  ENDIF

ENDIF

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

!*       6.    FINAL MEMORY TRANSFER.
!              ----------------------

DO JI=1,II
!OCL NOVREC
  DO JN=KM,NSMAX
    ISE=NASM0(KM)+(JN-KM)*2+JI-1
    SPDIV(1,ISE)=ZSPDIV(JN,JI)
    SPVOR(1,ISE)=ZSPVOR(JN,JI)
    SPSP(ISE)=ZSPSP(JN,JI)
  ENDDO
ENDDO

IF(NCONF == 201 .AND. N2DINI == 11) THEN
  DO JI=1,II
!OCL NOVREC
    DO JN=KM,NSMAX
      ISE=NASM0(KM)+(JN-KM)*2+JI-1
      SPDIV(1,ISE)=CSTDIV(1,ISE)
      SPVOR(1,ISE)=CSTVO(1,ISE)
    ENDDO
  ENDDO
ENDIF

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

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