SUBROUTINE MULTFAD(PVEC,PFP,PFQ,PROD,KM)

!**** *MULTFAD* - MULTIPLY "PVEC" BY IMPLICIT OPERATOR "F". ADJOINT

!     PURPOSE. - TO MULTIPLY "PVEC" BY OPERATOR "F" OF IMPLICIT NMI
!     --------   SCHEME. PVEC IS FIRST PUT IN A "SPECTRAL" ORGANIZATION
!                (WHERE F IS TRIDIAGONAL). PVEC IS THEN MULTIPLIED BY THE
!                SUBDIAGONAL (PFP) AND THE SUPERDIAGONAL (PFQ). THE PRODUCT
!                "PROD" IS FINALLY SET UP BACK IN IMPLICIT ORGANIZATION.

!**   INTERFACE.
!     ----------
!        *CALL* *MULTFAD(PVEC,PFP,PFQ,PROD,KM)

!        EXPLICIT ARGUMENTS :  PVEC  - ARRAY (IMPLICIT NMI)   / OUTPUT
!        --------------------  PFP   - SUBDIAGONAL   OF "F"   / INPUT
!                              PFQ    SUPERDIAGONAL OF "F"   /
!                              PROD  - PRODUCT (IMPLICIT NMI) : INPUT
!                              KM    - ZONAL WAVE NUMBER        INPUT

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

!     METHOD.
!     -------

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

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

!     AUTHOR.
!     -------
!        PASCAL MARQUET                     *METEO FRANCE*

!     MODIFICATIONS.
!     --------------
!        ORIGINAL : 90-12-15
!        LARS ISAKSEN : 95-06-06 Reordering of spectral arrays
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!     ------------------------------------------------------------------

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

USE YOMDIM   , ONLY : NCMAX

IMPLICIT NONE

INTEGER(KIND=JPIM),INTENT(IN)    :: KM 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PVEC(2*(NCMAX+1-KM)) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PFP(KM:NCMAX) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: PFQ(KM:NCMAX) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: PROD(2*(NCMAX+1-KM)) 
REAL(KIND=JPRB) ::  ZW1(2*(NCMAX+1-KM)),ZW2(2*(NCMAX+1-KM))

INTEGER(KIND=JPIM) :: IJ, JJ, JN
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('MULTFAD',0,ZHOOK_HANDLE)
DO JJ=1,2*(NCMAX+1-KM)
  ZW1(JJ)=0.0_JPRB
  ZW2(JJ)=0.0_JPRB
ENDDO
!     ------------------------------------------------------------------

!*       3.    COPY FROM "SPECTRAL" TO "IMPLICIT NMI"
!              ---------------------------------------

IJ= 0

!*    3.1  SAME PARITY (loop 312) AND
!*         THEN OPPOSITE PARITY (loop 314, if KM is not NCMAX)
IF(KM /= 0) THEN
  DO JN=KM,NCMAX,2
    IJ=IJ+1
    ZW2(JN+1-KM) = ZW2(JN+1-KM) + PROD(IJ)
    PROD(IJ) = 0.0_JPRB
  ENDDO
  IF(KM /= NCMAX) THEN
    DO JN=KM+1,NCMAX,2
      IJ=IJ+1
      ZW2(JN+1-KM) = ZW2(JN+1-KM) + PROD(IJ)
      PROD(IJ) = 0.0_JPRB
    ENDDO
  ENDIF

!*       3.2  SAME PARITY (loop 322)
!*            AND THEN OPPOSITE PARITY (loop 324 if JN is not NCMAX)
  DO JN=KM,NCMAX,2
    IJ=IJ+1
    ZW2(NCMAX+1-KM+JN+1-KM) = ZW2(NCMAX+1-KM+JN+1-KM) + PROD(IJ)
    PROD(IJ) = 0.0_JPRB
  ENDDO
  IF(KM /= NCMAX) THEN
    DO JN=KM+1,NCMAX,2
      IJ=IJ+1
      ZW2(NCMAX+1-KM+JN+1-KM) = ZW2(NCMAX+1-KM+JN+1-KM) + PROD(IJ)
      PROD(IJ) = 0.0_JPRB
    ENDDO
  ENDIF
ELSE

!*       3.3  SPECIAL CASE " KM=0 " : EVEN PARITY (loop 332)
!*            AND THEN ODD PARITY (loop 334)
  DO JN=0,NCMAX,2
    IJ=IJ+1
    ZW2(JN+1) = ZW2(JN+1) + PROD(IJ)
    PROD(IJ) = 0.0_JPRB
  ENDDO
  DO JN=1,NCMAX,2
    IJ=IJ+1
    ZW2(JN+1) = ZW2(JN+1) + PROD(IJ)
    PROD(IJ) = 0.0_JPRB
  ENDDO
ENDIF

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

!*       2.    MULTIPLY BY "F" = "PFP,PFQ"
!              -------------------------

!*    2.1  SPECIAL CASES "JN=0" AND "JN=ABS(KM)=NCMAX" :
IF (KM == 0) ZW2(1) = 0.0_JPRB
IF (KM == NCMAX) THEN
  ZW2(1) = 0.0_JPRB
  ZW2(2) = 0.0_JPRB
ENDIF

!*    2.2  OTHER CASES "JN=NCMAX" :
IF (KM == 0) THEN
  ZW1(NCMAX) = ZW1(NCMAX) + PFP(NCMAX) * ZW2(NCMAX+1)
  ZW2(NCMAX+1) = 0.0_JPRB
ELSEIF (KM >= 1.AND.KM <= NCMAX-1) THEN
  ZW1(NCMAX-KM) = ZW1(NCMAX-KM)+ PFP(NCMAX) * ZW2(NCMAX+1-KM)
  ZW2(NCMAX+1-KM) = 0.0_JPRB
  ZW1(2*(NCMAX+1-KM)-1) = ZW1(2*(NCMAX+1-KM)-1)&
   & + PFP(NCMAX) * ZW2(2*(NCMAX+1-KM))  
  ZW2(2*(NCMAX+1-KM)) = 0.0_JPRB
ENDIF

!*    2.3  CASES "KM=JN" OR "KM=-JN" :
IF (KM >= 1.AND.KM <= NCMAX-1) THEN
  ZW1(2) = ZW1(2) + PFQ(KM) * ZW2(1)
  ZW2(1) = 0.0_JPRB
  ZW1(NCMAX+1-KM+2) = ZW1(NCMAX+1-KM+2)+ PFQ(KM) * ZW2(NCMAX-KM+2)
  ZW2(NCMAX-KM+2) = 0.0_JPRB
ENDIF

!*    2.4  GENERAL CASE :
IF (KM == 0) THEN
  DO JN=1,NCMAX-1
    ZW1(JN) = ZW1(JN) + PFP(JN) * ZW2(JN+1)
    ZW1(JN+2)  = ZW1(JN+2) + PFQ(JN) * ZW2(JN+1)
    ZW2(JN+1) = 0.0_JPRB
  ENDDO
ELSE
  DO JN=KM+1,NCMAX-1
    ZW1(JN-KM) = ZW1(JN-KM) + PFP(JN) * ZW2(JN+1-KM)
    ZW1(JN+2-KM) = ZW1(JN+2-KM) + PFQ(JN) * ZW2(JN+1-KM)
    ZW2(JN+1-KM) = 0.0_JPRB

    ZW1(NCMAX+1-KM+JN+1-KM-1) = ZW1(NCMAX+1-KM+JN+1-KM-1)&
     & + PFP(JN) * ZW2(NCMAX+1-KM+JN+1-KM)  
    ZW1(NCMAX+1-KM+JN+1-KM+1) = ZW1(NCMAX+1-KM+JN+1-KM+1)&
     & + PFQ(JN) * ZW2(NCMAX+1-KM+JN+1-KM)  
    ZW2(NCMAX+1-KM+JN+1-KM) = 0.0_JPRB
  ENDDO
ENDIF

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

!*       1.    COPY FROM "IMPLICIT NMI" TO "SPECTRAL"
!              ---------------------------------------

IJ= 0

!*    1.1  STORING IN THE REAL PART OF ZW1 : SAME PARITY (loop 112)
!*         AND THEN OPPOSITE PARITY (loop 114, if KM is not NCMAX)
IF(KM /= 0) THEN
  DO JN=KM,NCMAX,2
    IJ=IJ+1
    PVEC(IJ) = PVEC(IJ) + ZW1(JN+1-KM)
    ZW1(JN+1-KM) = 0.0_JPRB
  ENDDO
  IF(KM /= NCMAX) THEN
    DO JN=KM+1,NCMAX,2
      IJ=IJ+1
      PVEC(IJ) = PVEC(IJ) + ZW1(JN+1-KM)
      ZW1(JN+1-KM) = 0.0_JPRB
    ENDDO
  ENDIF

!*       1.2  STORING IN IMAGINARY PART OF ZW1 : SAME PARITY (loop 122)
!*            AND THEN OPPOSITE PARITY (loop 124 if JN is not NCMAX)
  DO JN=KM,NCMAX,2
    IJ=IJ+1
    PVEC(IJ) = PVEC(IJ) + ZW1(NCMAX+1-KM+JN+1-KM)
    ZW1(NCMAX+1-KM+JN+1-KM) = 0.0_JPRB
  ENDDO
  IF(KM /= NCMAX) THEN
    DO JN=KM+1,NCMAX,2
      IJ=IJ+1
      PVEC(IJ) = PVEC(IJ) + ZW1(NCMAX+1-KM+JN+1-KM)
      ZW1(NCMAX+1-KM+JN+1-KM) = 0.0_JPRB
    ENDDO
  ENDIF
ELSE

!*       1.3  SPECIAL CASE " KM=0 " : EVEN PARITY (loop 132)
!*            AND THEN ODD PARITY (loop 134)
  DO JN=0,NCMAX,2
    IJ=IJ+1
    PVEC(IJ) = PVEC(IJ) + ZW1(JN+1-KM)
    ZW1(JN+1-KM) = 0.0_JPRB
  ENDDO
  DO JN=1,NCMAX,2
    IJ=IJ+1
    PVEC(IJ) = PVEC(IJ) + ZW1(JN+1-KM)
    ZW1(JN+1-KM) = 0.0_JPRB
  ENDDO
ENDIF

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

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

