SUBROUTINE SUMODE3I(KVIMOD)

!**** *SUMODE3I* - COMPUTE IMPLICIT NORMAL MODES FOR MULTI-LEVEL MODEL

!     PURPOSE. - TO COMPUTE THE IMPLICIT NORMAL MODES FOR A STRETCHED
!     --------   COORDINATE MULTI-LEVEL MODEL ON THE SPHERE.
!              - STORING OF HELP ARRAYS    (IMPLICIT MODES)

!**   INTERFACE.
!     ----------
!        *CALL* *SUMODE3I(KVIMOD)*

!        EXPLICIT ARGUMENTS
!        ------------------
!                          KVIMOD : Number if vertical modes to be catered for.

!        IMPLICIT ARGUMENTS :  in YOMNMI : LTYPGR,... ; FREQ, ...
!        --------------------  in YOMDYN : (SIVP(JK),JK=1,KVIMOD)
!                              in YOMLAP : NACNO(JN),...
!                              in YOMGEM : RSTRET
!                              in YOMLUN : NSPHMO,NHOUMO,NPINMI,NFREQ2,NLTYPE
!                              in YOMCST : ROMEGA,RA,RPI
!                              in YOMGC  : RCOR0,RCOR1
!                                       RCOR0  - EXPANSION OF CORIOLIS PARAMETER
!                                       RCOR1  - EXPANSION OF CORIOLIS PARAMETER
!                        f = 2 * ROMEGA * [ RCOR0 + (SQRT(3) * RCOR1)  * RMU ]

!     METHOD.  SEE DOCUMENTATION.
!     -------

!     EXTERNALS.  
!     ----------  

!     REFERENCE.
!     ----------

!     AUTHOR.
!     -------
!        LARS ISAKSEN *ECMWF*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 97-05-05 (Split off from of old SUMODE3)
!        Modifications : 97-12-01 P.Moll Correct buffer length (IREC > 2)
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ---------------------------------------------------------------------

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

USE YOMDIM   , ONLY : NCMAX    ,NCPEC    ,NCPEC2   ,NUMP
USE YOMDYN   , ONLY : SIVP
USE YOMLAP   , ONLY : NACM0    ,MYMS
USE YOMCST   , ONLY : ROMEGA   ,RA
USE YOMPINB  , ONLY : RPINBUF  ,NSTAPINB

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KVIMOD 
!     ------------------------------------------------------------------

REAL(KIND=JPRB) :: ZC(NCPEC2,KVIMOD),ZB(NCPEC2),ZZEPS(NCPEC2)
REAL(KIND=JPRB) :: ZLOW(NCPEC2),ZDIAG(NCPEC2,KVIMOD),ZUP(NCPEC2),ZG(NCPEC2)
REAL(KIND=JPRB) :: ZFP(NCPEC),ZFQ(NCPEC)
REAL(KIND=JPRB) :: ZZK(-NCMAX:NCMAX),ZZP(-NCMAX:NCMAX),ZZQ(-NCMAX:NCMAX)
REAL(KIND=JPRB) :: ZZF(-NCMAX:NCMAX),ZZG(-NCMAX:NCMAX),ZZH(-NCMAX:NCMAX)

INTEGER(KIND=JPIM) ::  ICMVAL, ICMVAL1, IJ, IM,&
 & IREC,  J, J2, JJ, JK, JMLOC, JN  

REAL(KIND=JPRB) ::  ZOM2, ZPHI, ZPS
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

!*       1.    COMPUTE HELP ARRAYS FOR IMPLICIT NMI
!              ------------------------------------

IF (LHOOK) CALL DR_HOOK('SUMODE3I',0,ZHOOK_HANDLE)
ZOM2 = ROMEGA * 2
ZPS  = 1.0_JPRB/(ZOM2*RA)

ZZEPS(:)=0.0_JPRB
ZB(:)=0.0_JPRB
ZLOW(:)=0.0_JPRB
ZG(:)=0.0_JPRB
ZUP(:)=0.0_JPRB

ZZK(0) = 0._JPRB
ZZP(NCMAX) = 0.0_JPRB
ZZQ(NCMAX) = 0.0_JPRB
ZZK(NCMAX) = - REAL(NCMAX,JPRB) / REAL(NCMAX*(NCMAX+1),JPRB)
ZZF(NCMAX) = 0.0_JPRB
ZZG(NCMAX) = 0.0_JPRB
ZZH(NCMAX) = 0.0_JPRB

!     *** BEGINNING OF OUTER LOOP OVER IM (ZONAL MODES) ***

IMP_WAVE_LOOP: DO JMLOC=1,NUMP
  IM=MYMS(JMLOC)
  ICMVAL=NACM0(IM)
  ICMVAL1=(NACM0(IM)-1)/2+1

  IF (IM < NCMAX) THEN

!*        1.1   COMPUTE ARRAYS "p", "q" AND "k"  OF  "F" AND "B" OPERATORS
!*              (STORING IN THE REAL PART OF SPECTRAL ORGANIZATION)

    ZZP(IM) = 0.0_JPRB
    IF(IM /= 0) THEN
      ZZK(IM) = - REAL(IM,JPRB)/REAL(IM*(IM+1),JPRB)
    ENDIF
    ZZQ(IM)  =  REAL(IM,JPRB)/REAL(IM+1,JPRB)&
     & *SQRT(REAL((IM+1)*(IM+1)-IM*IM,JPRB)/REAL(4*(IM+1)*(IM+1)-1,JPRB))  
    DO JN=IM+1,NCMAX-1
      ZZP(JN)=  REAL(JN+1,JPRB) / REAL(JN,JPRB)&
       & * SQRT(REAL(JN*JN-IM*IM,JPRB) / REAL(4*JN*JN-1,JPRB))  
      ZZK(JN)=  - REAL(IM,JPRB) / REAL(JN*(JN+1),JPRB)
      ZZQ(JN)=  REAL(JN,JPRB)   / REAL(JN+1,JPRB)&
       & * SQRT(REAL((JN+1)*(JN+1)-IM*IM,JPRB)/REAL(4*(JN+1)*(JN+1)-1,JPRB))  
    ENDDO
    ZZP(NCMAX)=  REAL(NCMAX+1,JPRB) / REAL(NCMAX,JPRB)&
     & * SQRT(REAL(NCMAX*NCMAX-IM*IM,JPRB) / REAL(4*NCMAX*NCMAX-1,JPRB))  
    ZZK(NCMAX)= - REAL(IM,JPRB)/REAL(NCMAX*(NCMAX+1),JPRB)
    ZZQ(NCMAX)=   0.0_JPRB

!*        1.2   COMPUTE ARRAYS "f", "g", "h"  OF  "F*F" OPERATOR
!*              (STORING IN THE REAL PART OF SPECTRAL ORGANIZATION)

    ZZF(IM) = 0.0_JPRB
    ZZF(IM+1) = 0.0_JPRB
    ZZG(IM) = ZZQ(IM)*ZZP(IM+1)
    ZZG(NCMAX) = ZZP(NCMAX)*ZZQ(NCMAX-1)
    ZZH(NCMAX-1) = 0.0_JPRB
    ZZH(NCMAX) = 0.0_JPRB
    IF(IM < NCMAX-2) THEN
      ZZF(NCMAX)   = ZZP(NCMAX)*ZZP(NCMAX-1)
      ZZF(NCMAX-1) = ZZP(NCMAX-1)*ZZP(NCMAX-2)
      ZZG(IM+1)    = ZZP(IM+1)*ZZQ(IM) + ZZQ(IM+1)*ZZP(IM+2)
      ZZG(NCMAX-1) = ZZP(NCMAX-1)*ZZQ(NCMAX-2)+ ZZQ(NCMAX-1)*ZZP(NCMAX)
      ZZH(IM)      = ZZQ(IM)*ZZQ(IM+1)
      ZZH(IM+1)    = ZZQ(IM+1)*ZZQ(IM+2)
    ELSEIF(IM == NCMAX-2) THEN
      ZZF(NCMAX) = ZZP(NCMAX)*ZZP(NCMAX-1)
      ZZG(IM+1) = ZZP(IM+1)*ZZQ(IM) + ZZQ(IM+1)*ZZP(IM+2)
      ZZH(IM) = ZZQ(IM)*ZZQ(IM+1)
    ENDIF
    DO JN=IM+2,NCMAX-2
      ZZF(JN) = ZZP(JN)*ZZP(JN-1)
      ZZG(JN) = ZZP(JN)*ZZQ(JN-1) + ZZQ(JN)*ZZP(JN+1)
      ZZH(JN) = ZZQ(JN)*ZZQ(JN+1)
    ENDDO

!*        1.3   SET UP IMPLICIT NMI ORGANIZATION OF HELP ARRAYS

!         Parts of operators acting on real (J2=1) or imaginary (J2=2)
!         coefficients of model state variables (implicit organisation)  :

    IJ=ICMVAL-1
    DO J2=1,MIN(1,IM)+1

!           All JN with same parity as IM :

      DO JN=IM,NCMAX,2
        IJ=IJ+1
        ZZEPS(IJ)=SQRT(REAL(JN*(JN+1),JPRB))
        ZB  (IJ)=ZZK(JN)
        ZLOW(IJ)=ZZF(JN)
        ZG  (IJ)=ZZG(JN)
        ZUP (IJ)=ZZH(JN)
      ENDDO

!           All JN  with oposite parity :

      DO JN=IM+1,NCMAX,2
        IJ=IJ+1
        ZZEPS(IJ)=SQRT(REAL(JN*(JN+1),JPRB))
        ZB  (IJ)=ZZK(JN)
        ZLOW(IJ)=ZZF(JN)
        ZG  (IJ)=ZZG(JN)
        ZUP (IJ)=ZZH(JN)
      ENDDO
    ENDDO

    DO JN=IM,NCMAX
      ZFP (ICMVAL1-IM+JN)=ZZP(JN)
      ZFQ (ICMVAL1-IM+JN)=ZZQ(JN)
    ENDDO
  ELSE
    ZZEPS(ICMVAL)   = SQRT( REAL(NCMAX*(NCMAX+1),JPRB) )
    ZZEPS(ICMVAL+1) = SQRT( REAL(NCMAX*(NCMAX+1),JPRB) )
    ZB   (ICMVAL)   = - REAL(NCMAX,JPRB) / REAL(NCMAX*(NCMAX+1),JPRB)
    ZB   (ICMVAL+1) = - REAL(NCMAX,JPRB) / REAL(NCMAX*(NCMAX+1),JPRB)
    ZLOW (ICMVAL)   = 0.0_JPRB
    ZLOW (ICMVAL+1) = 0.0_JPRB
    ZG   (ICMVAL)   = 0.0_JPRB
    ZG   (ICMVAL+1) = 0.0_JPRB
    ZUP  (ICMVAL)   = 0.0_JPRB
    ZUP  (ICMVAL+1) = 0.0_JPRB
  ENDIF

ENDDO IMP_WAVE_LOOP

!*    1.4   COMPUTE ARRAYS  "eps"  AND    " g + eps*eps "
!*          OF OPERATORS    " C "  AND  diag(" F*F + C*C ")

DO JK=1,KVIMOD
  ZPHI=SIVP(JK)
  DO JJ=1,NCPEC2
    ZC(JJ,JK)=ZZEPS(JJ)*SQRT(ZPHI)*ZPS
    ZDIAG(JJ,JK)=ZG(JJ)+ZZEPS(JJ)*ZZEPS(JJ)*ZPHI*ZPS*ZPS
  ENDDO
ENDDO

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

!*    2.    STORING OF HELP ARRAYS (IMPLICIT NMI)
!           -------------------------------------

!*    2.1   IF "LCOIMP"=.TRUE. :

IREC=1
DO J=1,NCPEC
  RPINBUF(NSTAPINB(IREC)+J)=ZFP(J)
ENDDO

IREC=2
DO J=1,NCPEC
  RPINBUF(NSTAPINB(IREC)+J)=ZFQ(J)
ENDDO

IREC=3
DO J=1,NCPEC2
  RPINBUF(NSTAPINB(IREC)+J)=ZB(J)
ENDDO

IREC=4
DO J=1,NCPEC2
  RPINBUF(NSTAPINB(IREC)+J)=ZLOW(J)
ENDDO

IREC=5
DO J=1,NCPEC2
  RPINBUF(NSTAPINB(IREC)+J)=ZUP(J)
ENDDO

DO JK=1,KVIMOD
  IREC=IREC+1
  DO J=1,NCPEC2
    RPINBUF(NSTAPINB(IREC)+J)=ZC(J,JK)
  ENDDO
  IREC=IREC+1
  DO J=1,NCPEC2
    RPINBUF(NSTAPINB(IREC)+J)=ZDIAG(J,JK)
  ENDDO
ENDDO

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

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