SUBROUTINE SUVERTFE3D

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

USE YOMDIM   , ONLY : NFLEVG
USE YOMGEM   , ONLY : VFE_ETAH ,VFE_ETAF
USE YOMCVER  , ONLY : RDERI

!**** *SUVERTFE3D*  - Setup VERTical Finite Element Derivative based on
!                    cubic (3) elements

!     Purpose.
!     --------
!           Compute matrix for the vertical differentiation based on
!           cubic B-spline finite elements

!**   Interface.
!     ----------

!     *CALL* SUVERTFE3D
!        Explicit arguments :
!        --------------------
!        None

!        Implicit arguments :
!        --------------------
!        YOMDIM
!        YOMLUN
!        YOMGEM
!        YOMCVER
!        YOMMP

!     Method.
!     -------

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

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

!     Author.
!     -------
!        Mariano Hortal (after SUVERTFE3) ECMWF

!     Modifications.
!     --------------
!        Original : 2004-10
!        K. Yessad (Sep 2008): use VFE_ETAH and VFE_ETAF
!     ------------------------------------------------------------------

IMPLICIT NONE

INTEGER(KIND=JPIM) :: IDIM, J, JK, I_K, JKC, JD, JR, JKR, J1, J2, J3, JC
REAL(KIND=JPRB)    :: ZDELTA(-3:NFLEVG+4)
REAL(KIND=JPRB)    :: ZFAA(4,-1:NFLEVG+2), ZFBB(4,-1:NFLEVG+2), &
                     &ZFCC(4,-1:NFLEVG+2), ZFDD(4,-1:NFLEVG+2)
REAL(KIND=JPRB)    :: ZDAA(4,-1:NFLEVG+2), ZDBB(4,-1:NFLEVG+2), &
                     &ZDCC(4,-1:NFLEVG+2), ZDDD(4,-1:NFLEVG+2)
REAL(KIND=JPRB)    :: ZA(NFLEVG+4,NFLEVG+4), ZAINV(NFLEVG+4,NFLEVG+4), &
                     &ZWORK(2*(NFLEVG+3)), ZPROD(NFLEVG+4,NFLEVG+4), &
                     &ZB(NFLEVG+4,NFLEVG+4)
REAL(KIND=JPRB)    :: ZDERI(NFLEVG+4,NFLEVG+4), ZSF(NFLEVG+4,NFLEVG+4), &
                     &ZSFINV(NFLEVG+4,NFLEVG+4), ZSD(NFLEVG+4,NFLEVG+4)
REAL(KIND=JPRB)    :: ZEPS, ZALPHA(4,4), ZBETA(2,2), ZHH(4,4)
REAL(KIND=JPRB)    :: ZRHS(2)
REAL(KIND=JPRB)    :: ZD0 , ZD0H, ZBMAX, ZD1, ZD2, ZD3, ZD4, ZDETB, ZDEL, ZDEL2, ZDEL3
REAL(KIND=JPRB)    :: ZDDD1, ZDDD2, ZDDD3, ZDDD4, ZDNH, ZDET
REAL(KIND=JPRB)    :: ZAAA2, ZBBB2, ZCCC2, ZAAA3, ZBBB3, ZCCC3
REAL(KIND=JPRB)    :: FHH, FDD
REAL(KIND=JPRB)    :: XA,XB,XC,XD,YA,YB,YC,YD, XX
REAL(KIND=JPRB)    :: ZHOOK_HANDLE

! indefiniteINTEGRAL(EJ*EI)dx
FHH(XX,XA,XB,XC,XD,YA,YB,YC,YD)=                &
 &   XX*(  XA*YA                                &
 & + XX*( (XA*YB+XB*YA)/2._JPRB                 &
 & + XX*( (XA*YC+XB*YB+XC*YA)/3._JPRB           &
 & + XX*( (XA*YD+XB*YC+XC*YB+XD*YA)/4._JPRB     &
 & + XX*( (      XB*YD+XC*YC+XD*YB)/5._JPRB     &
 & + XX*( (            XC*YD+XD*YC)/6._JPRB     &
 & + XX*                     XD*YD /7._JPRB))))))  

! indefiniteINTEGRAL(EJ*EI')dx                '
FDD(XX,XA,XB,XC,XD,YA,YB,YC,YD)=                  &
 &   XX*(     XA*YB                               &
 & + XX*( (2._JPRB*XA*YC+XB*YB         )/2._JPRB  &
 & + XX*( (3._JPRB*XA*YD+2._JPRB*XB*YC+XC*YB)/3._JPRB   &
 & + XX*( (3._JPRB*XB*YD+2._JPRB*XC*YC+XD*YB)/4._JPRB   &
 & + XX*( (3._JPRB*XC*YD+2._JPRB*XD*YC      )/5._JPRB   &
 & + XX*( (3._JPRB*XD*YD               )/6._JPRB))))))

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('SUVERTFE3D',0,ZHOOK_HANDLE)
!     ------------------------------------------------------------------

IDIM=NFLEVG+4
ZEPS=100.0_JPRB*TINY(1.0_JPRB)

! compute distance between nodes (full eta levels)

ZDELTA( 0)=2._JPRB*(VFE_ETAF(1)-VFE_ETAH(0))
ZD0=ZDELTA( 0)
ZD0H=0.5_JPRB*ZD0
ZDELTA(-3)=ZDELTA(0)
ZDELTA(-2)=ZDELTA(0)
ZDELTA(-1)=ZDELTA(0)
DO JK=1,NFLEVG-1
  ZDELTA(JK)=VFE_ETAF(JK+1)-VFE_ETAF(JK)
ENDDO
ZDELTA(NFLEVG)=2._JPRB*(VFE_ETAH(NFLEVG) -VFE_ETAF(NFLEVG))
ZDNH=ZDELTA(NFLEVG)*0.5_JPRB
ZDELTA(NFLEVG+1)=ZDELTA(NFLEVG)
ZDELTA(NFLEVG+2)=ZDELTA(NFLEVG)
ZDELTA(NFLEVG+3)=ZDELTA(NFLEVG)
ZDELTA(NFLEVG+4)=ZDELTA(NFLEVG)

! compute basis functions    

ZBMAX=4._JPRB/6._JPRB 
  
DO JK=-1,NFLEVG+2
  ZD1=ZDELTA(JK-2)
  ZD2=ZDELTA(JK-1)
  ZD3=ZDELTA(JK  )
  ZD4=ZDELTA(JK+1)
! matrix alpha
  ZALPHA(1,1)=0.0_JPRB     
  ZALPHA(1,2)=0.0_JPRB      
  ZALPHA(1,3)=ZD3**3      
  ZALPHA(1,4)=ZD4**3+3._JPRB*ZD3*ZD4**2+3._JPRB*ZD3**2*ZD4  
  ZALPHA(2,1)=ZD1**2+2._JPRB*ZD1*ZD2
  ZALPHA(2,2)=ZD2**2
  ZALPHA(2,3)=ZD3**2
  ZALPHA(2,4)=ZD4**2+2._JPRB*ZD3*ZD4
  ZALPHA(3,1)= ZD1
  ZALPHA(3,2)= ZD2
  ZALPHA(3,3)=-ZD3
  ZALPHA(3,4)=-ZD4
  ZALPHA(4,1)=ZD1**3+3._JPRB*ZD1**2*ZD2+3._JPRB*ZD1*ZD2**2
  ZALPHA(4,2)=ZD2**3
  ZALPHA(4,3)=0.0_JPRB
  ZALPHA(4,4)=0.0_JPRB

! matrix beta
  ZBETA(1,1)=ZALPHA(2,2)-ZALPHA(2,1)*ZALPHA(4,2)/ZALPHA(4,1)
  ZBETA(1,2)=ZALPHA(2,3)-ZALPHA(2,4)*ZALPHA(1,3)/ZALPHA(1,4)
  ZBETA(2,1)=ZALPHA(3,2)-ZALPHA(3,1)*ZALPHA(4,2)/ZALPHA(4,1)
  ZBETA(2,2)=ZALPHA(3,3)-ZALPHA(3,4)*ZALPHA(1,3)/ZALPHA(1,4)

! right-hand side vector
  ZRHS(1)=-ZBMAX*(ZALPHA(2,1)/ZALPHA(4,1)+ZALPHA(2,4)/ZALPHA(1,4))
  ZRHS(2)=-ZBMAX*(ZALPHA(3,1)/ZALPHA(4,1)+ZALPHA(3,4)/ZALPHA(1,4))

! determinant of beta 
  ZDETB=ZBETA(1,1)*ZBETA(2,2)-ZBETA(1,2)*ZBETA(2,1)

! coefficients 
  ZDDD2=(ZRHS(1)*ZBETA(2,2)-ZRHS(2)*ZBETA(1,2))/ZDETB
  ZDDD3=(ZRHS(2)*ZBETA(1,1)-ZRHS(1)*ZBETA(2,1))/ZDETB
  ZDDD1=(ZBMAX - ZALPHA(4,2)*ZDDD2)/ZALPHA(4,1)    
  ZDDD4=(ZBMAX - ZALPHA(1,3)*ZDDD3)/ZALPHA(1,4) 

  ZAAA2=   ZD1**3*ZDDD1
  ZBBB2=3._JPRB*ZD1**2*ZDDD1
  ZCCC2=3._JPRB*ZD1   *ZDDD1

  ZAAA3=   ZD4**3*ZDDD4
  ZBBB3=3._JPRB*ZD4**2*ZDDD4
  ZCCC3=3._JPRB*ZD4   *ZDDD4

! coefficients of explicit cubic polynomials in each interval
! (x=0 at the left of the corresponding interval)
  
  ZFAA(1,JK)=0.0_JPRB
  ZFBB(1,JK)=0.0_JPRB
  ZFCC(1,JK)=0.0_JPRB
  ZFDD(1,JK)=ZDDD1
 
  ZFAA(2,JK)=ZAAA2
  ZFBB(2,JK)=ZBBB2
  ZFCC(2,JK)=ZCCC2
  ZFDD(2,JK)=ZDDD2  
  
  ZDEL=ZDELTA(JK)
  ZDEL2=ZDEL*ZDEL
  ZDEL3=ZDEL2*ZDEL
  ZFAA(3,JK)=ZAAA3+ZBBB3*ZDEL+   ZCCC3*ZDEL2   +ZDDD3*ZDEL3
  ZFBB(3,JK)=     -ZBBB3     -2._JPRB*ZCCC3*ZDEL -3._JPRB*ZDDD3*ZDEL2
  ZFCC(3,JK)=                    ZCCC3      +3._JPRB*ZDDD3*ZDEL
  ZFDD(3,JK)=                                  -ZDDD3

  ZDEL=ZDELTA(JK+1)
  ZDEL2=ZDEL*ZDEL
  ZDEL3=ZDEL2*ZDEL
  ZFAA(4,JK)=    ZDDD4*ZDEL3
  ZFBB(4,JK)=-3._JPRB*ZDDD4*ZDEL2
  ZFCC(4,JK)= 3._JPRB*ZDDD4*ZDEL
  ZFDD(4,JK)=   -ZDDD4 
ENDDO

ZDAA(:,:)=ZFAA(:,:)
ZDBB(:,:)=ZFBB(:,:)
ZDCC(:,:)=ZFCC(:,:)
ZDDD(:,:)=ZFDD(:,:)

! COMPUTE MATRIX SF ( SF(I,J)=BASISFUNC_J(X_I) )  (from FE space of the function
!                                                 to be differenciated into physical space)
! ---------------------------------------------

ZSF(:,:)=0.0_JPRB
DO JR=1,IDIM
  DO JC=1,IDIM
    JKC=JC-2
    IF(JC == JR-1) ZSF(JR,JC)=ZFAA(4,JKC)
    IF(JC == JR  ) ZSF(JR,JC)=ZFAA(3,JKC)
    IF(JC == JR+1) ZSF(JR,JC)=ZFAA(2,JKC)
  ENDDO
ENDDO

! Instead of the value at node -1 and NFLEVG+2 we should use the derivative
!   at node 1 and at NFLEVG:

ZSF(1,1)=ZFBB(4, 0)
ZSF(1,2)=ZFBB(3, 1)
ZSF(1,3)=ZFBB(2, 2)
ZSF(IDIM,IDIM-2)=ZFBB(4,NFLEVG-1)
ZSF(IDIM,IDIM-1)=ZFBB(3,NFLEVG  )
ZSF(IDIM,IDIM  )=ZFBB(2,NFLEVG+1)


! invert SF:       (ZSFINV projects the function to be integrated
!                  from physical space onto FE space)
ZDET=0.0_JPRB
ZSFINV(:,:)=ZSF(:,:)*3._JPRB/2._JPRB
CALL MINV(ZSFINV,IDIM,IDIM,ZWORK,ZDET,ZEPS,0,1)
ZSFINV(:,:)=ZSFINV(:,:)*3._JPRB/2._JPRB

! COMPUTE MATRIX SD ( SD(I,J)=BASISDER_J(X_I) )  (To project the derivative from FE space
!                                                to physical space 
! -------------------------------------------

ZSD(:,:)=0.0_JPRB
DO JR=1,IDIM
  DO JC=1,IDIM
    JKC=JC-2
    IF(JC == JR-1) ZSD(JR,JC)=ZDAA(4,JKC)
    IF(JC == JR  ) ZSD(JR,JC)=ZDAA(3,JKC)
    IF(JC == JR+1) ZSD(JR,JC)=ZDAA(2,JKC)
  ENDDO
ENDDO



! COMPUTE MATRIX A
! ----------------

ZA(:,:)=0.0_JPRB

DO JR=1,IDIM                                 ! JR is the row number of matrix A
  JKR=JR-2                                   ! JKR is the index of the test function
  ZHH(:,:)=0.0_JPRB                          ! ZHH is an auxiliary 4x4 matrix
  DO J=1,4                                   ! J is the index of the interval belonging to function JKR
    JD=JKR-3+J                               ! JD is the absolute number of interval J
    IF(JD >= 0 .AND. JD <= NFLEVG) THEN      ! Integration is from node 0 to node NFLEVG+1
      DO I_K=1,4                             ! I_K
        JKC=JKR+J-I_K                        ! JKC is the I_Kth basis number covering interval J
        IF(JKC >= -1 .AND. JKC <= NFLEVG+2) THEN
          ZHH(J,I_K)=FHH(ZDELTA(JD) &
             & ,ZFAA(J,JKR),ZFBB(J,JKR),ZFCC(J,JKR),ZFDD(J,JKR)&
             & ,ZFAA(I_K,JKC),ZFBB(I_K,JKC),ZFCC(I_K,JKC),ZFDD(I_K,JKC))  
        ENDIF
      ENDDO
    ENDIF
  ENDDO
  ZA(JR,JR  )=ZHH(1,1)+ZHH(2,2)+ZHH(3,3)+ZHH(4,4)
  IF(JR+1 <= IDIM) &
   & ZA(JR,JR+1)=      ZHH(2,1)+ZHH(3,2)+ZHH(4,3)  
  IF(JR+2 <= IDIM) &
   & ZA(JR,JR+2)=               ZHH(3,1)+ZHH(4,2)  
  IF(JR+3 <= IDIM) &
   & ZA(JR,JR+3)=                        ZHH(4,1)
  IF(JR-1 >= 1)    &
   & ZA(JR,JR-1)=      ZHH(1,2)+ZHH(2,3)+ZHH(3,4)
  IF(JR-2 >= 1)    &
   & ZA(JR,JR-2)=               ZHH(1,3)+ZHH(2,4)
  IF(JR-3 >= 1)    &
   & ZA(JR,JR-3)=                        ZHH(1,4)     

ENDDO

! invert A: 
ZDET=0.0_JPRB
ZAINV(:,:)=ZA(:,:)*NFLEVG*7._JPRB/2._JPRB
CALL MINV(ZAINV,IDIM,IDIM,ZWORK,ZDET,ZEPS,0,1)
ZAINV(:,:)=ZAINV(:,:)*NFLEVG*7._JPRB/2._JPRB

DO J1=1,IDIM
  DO J2=1,IDIM
    ZPROD(J1,J2)=0.0_JPRB
      DO J3=1,IDIM
        ZPROD(J1,J2)=ZPROD(J1,J2)+ZAINV(J1,J3)*ZA(J3,J2)
      ENDDO
  ENDDO
ENDDO

! COMPUTE MATRIX B
! ----------------

ZB(:,:)=0.0_JPRB

DO JR=1,IDIM                                 ! JR is the row number of matrix B
  JKR=JR-2                                   ! JKR is the index of the test function
  ZHH(:,:)=0.0_JPRB                               ! ZHH is an auxiliary 4x4 matrix
  DO J=1,4                                   ! J is the index of the interval belonging to function JKR
    JD=JKR-3+J                               ! JD is the absolute number of interval J
    IF(JD >= 0 .AND. JD <= NFLEVG) THEN      ! Integration is from node 0 to node NFLEVG+1
      DO I_K=1,4                             ! I_K 
        JKC=JKR+J-I_K                        ! JKC is the I_Kth basis number covering interval J
        IF(JKC >= -1 .AND. JKC <= NFLEVG+2) THEN
          ZHH(J,I_K)=FDD(ZDELTA(JD) &
             & ,ZFAA(J,JKR),ZFBB(J,JKR),ZFCC(J,JKR),ZFDD(J,JKR)&
             & ,ZFAA(I_K,JKC),ZFBB(I_K,JKC),ZFCC(I_K,JKC),ZFDD(I_K,JKC))  
        ENDIF
      ENDDO
    ENDIF
  ENDDO
  ZB(JR,JR  )=ZHH(1,1)+ZHH(2,2)+ZHH(3,3)+ZHH(4,4)
  IF(JR+1 <= IDIM) &
   & ZB(JR,JR+1)=      ZHH(2,1)+ZHH(3,2)+ZHH(4,3)  
  IF(JR+2 <= IDIM) &
   & ZB(JR,JR+2)=               ZHH(3,1)+ZHH(4,2)  
  IF(JR+3 <= IDIM) &
   & ZB(JR,JR+3)=                        ZHH(4,1)
  IF(JR-1 >= 1)    &
   & ZB(JR,JR-1)=      ZHH(1,2)+ZHH(2,3)+ZHH(3,4)
  IF(JR-2 >= 1)    &
   & ZB(JR,JR-2)=               ZHH(1,3)+ZHH(2,4)
  IF(JR-3 >= 1)    &
   & ZB(JR,JR-3)=                        ZHH(1,4)     

ENDDO

! COMPUTE PRODUCT SD*A^-1*B*SF^-1=ZDERI
! ------------------------------------

ZDERI(:,:)=0.0_JPRB
DO JC=1,IDIM
  DO JR=1,IDIM
    DO JK=1,IDIM
      ZDERI(JR,JC)=ZDERI(JR,JC)+ZB(JR,JK)*ZSFINV(JK,JC)
    ENDDO
  ENDDO
ENDDO

ZPROD(:,:)=0.0_JPRB
DO JC=1,IDIM
  DO JR=1,IDIM
    DO JK=1,IDIM
      ZPROD(JR,JC)=ZPROD(JR,JC)+ZAINV(JR,JK)*ZDERI(JK,JC)
    ENDDO
  ENDDO
ENDDO

ZDERI(:,:)=0.0_JPRB
DO JC=1,IDIM
  DO JR=1,IDIM
    DO JK=1,IDIM
      ZDERI(JR,JC)=ZDERI(JR,JC)+ZSD(JR,JK)*ZPROD(JK,JC)
    ENDDO
  ENDDO
ENDDO

! Boundary values chosen: linear extrapolation to nodes 0 and NFLEVG+1
!                         derivative at nodes 1 and NFLEVG
DO JR=1,NFLEVG
  DO JC=3,NFLEVG-2
    RDERI(JR,JC)=ZDERI(JR+2,JC+2)
  ENDDO
  RDERI(JR,1)=ZDERI(JR+2,3)+2._JPRB* ZDERI(JR+2,2)- &
                    &ZDERI(JR+2,1)/(VFE_ETAF(2)-VFE_ETAF(1))
  RDERI(JR,NFLEVG)=ZDERI(JR+2,NFLEVG+2)+2._JPRB* ZDERI(JR+2,NFLEVG+3)- &
                    &ZDERI(JR+2,NFLEVG+4)/(VFE_ETAF(NFLEVG-1)-VFE_ETAF(NFLEVG))
  RDERI(JR,2)= ZDERI(JR+2,4)-ZDERI(JR+2,2)+ZDERI(JR+2,1)/(VFE_ETAF(2)-VFE_ETAF(1))
  RDERI(JR,NFLEVG-1)= ZDERI(JR+2,NFLEVG+1)-ZDERI(JR+2,NFLEVG+3)+&
                    &ZDERI(JR+2,NFLEVG+4)/(VFE_ETAF(NFLEVG-1)-VFE_ETAF(NFLEVG))
ENDDO

!     ------------------------------------------------------------------
IF (LHOOK) CALL DR_HOOK('SUVERTFE3D',1,ZHOOK_HANDLE)
END SUBROUTINE SUVERTFE3D
