SUBROUTINE DOT_PRODUCT_CTLVEC(ydcv1,ydcv2,prod1,prod2,prod3,prod4,prod5, &
  & prod6,ldnorm)

!   Purpose.
!   --------
!     Scalar product for distributed control variable

! DO NOT CALL THIS SUBROUTINE DIRECTLY. USE INTERFACE PROVIDED
! IN MODULE CONTROL_VECTORS INSTEAD.

!   Author.
!   -------
!     Yannick Tremolet

!   Modifications.
!   --------------
!     Original   02-03-19
!     C.Fischer  03-03-05 Aladin spectral treatment added.
!        M.Hamrud      01-Oct-2003 CY28 Cleaning
!        M.Hamrud      01-Dec-2003 CY28R1 Cleaning
!        M.Fisher      17-Mar-2004 Wavelet Jb
!        Y.Tremolet    23-Mar-2004 Made initial condition optional
!        Y.Tremolet    29-Sep-2004 Model error
!        A.Deckmyn     01-Oct-2008 LAM wavelet Jb
! ------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
USE YOMVAR, ONLY: LTOVSREP, LTSCV, LREPRO4DVAR
USE YOMCT0, ONLY: NPRTRV, NPRTRW, LELAM, NPROC
USE YOMMP , ONLY: MYSETV, MYPROC
USE YOMLAP, ONLY: MYMS
USE YOMCVA, ONLY: NVATOVV, NVATOV,YSCALP
USE YOMDIM, ONLY: NFLEVL, NFLEVG, NPROMA
USE YOMTVRAD, ONLY: NVATOVOFF, NVATOVINDX,NVATOVLEN,NVATOVLENP,NVATOVLENG
USE YOMDIMO, ONLY: NOBNTV
USE YOMWAVELET, ONLY: N_WAVELET_SCALES, GRID_DEFINITION
USE CONTROL_VECTORS, ONLY : CONTROL_VECTOR
USE SPECTRAL_FIELDS_MOD, ONLY : SPECTRAL_FIELD, INQ_SPEC, DEALLOCATE_SPEC
USE MPL_MODULE, ONLY : MPL_ALLGATHERV, MPL_ALL_LEVS_COMM, MPL_ALL_MS_COMM, &
                     & MPL_ALLREDUCE,MPL_BROADCAST

IMPLICIT NONE

TYPE(CONTROL_VECTOR),INTENT(IN) :: ydcv1 
TYPE(CONTROL_VECTOR),INTENT(IN) :: ydcv2 
REAL(KIND=JPRB)   ,INTENT(OUT)  :: PROD1 
REAL(KIND=JPRB)   ,INTENT(OUT)  :: PROD2 
REAL(KIND=JPRB)   ,INTENT(OUT)  :: PROD3 
REAL(KIND=JPRB)   ,INTENT(OUT)  :: PROD4 
REAL(KIND=JPRB)   ,INTENT(OUT)  :: PROD5 
REAL(KIND=JPRB)   ,INTENT(OUT)  :: PROD6 
LOGICAL           ,INTENT(IN)   :: LDNORM 
TYPE(SPECTRAL_FIELD) :: ylic, ylme
INTEGER(KIND=JPIM) :: ioff,ilic,ilme,iltv,ilens,ja,jb,jp,ilevl,ilevg,itvw, &
                    & ileng,ii,jj,IOMASTER, ITAG, JSCALE, JPT, JFLD, JKGLO, &
                    & IGP, IPT, IPT2, IBL, ICEND, IOFFGP, IOFFPT, &
                    & ifldic,ifldme,is,jcomp,ilts,itsw
INTEGER(KIND=JPIM) :: IOFFPTA(N_WAVELET_SCALES+1)
INTEGER(KIND=JPIM) :: ilenr(NPRTRW),idisp(NPRTRW),inumlev(NPRTRV),jdisp(NPRTRV)
INTEGER(KIND=JPIM) :: IOFFGPX(N_WAVELET_SCALES+1)
REAL(KIND=JPRB), ALLOCATABLE :: zprodms(:), zallms(:), zloclevs(:), &
                              & zalllevs(:),zlocgp(:),zglobgp(:,:),zprodarr(:)
REAL(KIND=JPRB) :: ZZLOCGPX(16,NFLEVG*ydcv1%NS3D+ydcv1%NS2D)
REAL(KIND=JPRB) :: ZZLOCGP
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "abor1.intfb.h"
#include "gathergpf_wavelet.intfb.h"
#include "set2pe.intfb.h"

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


CALL GSTATS(255,0)
CALL GSTATS(1962,0)

ilens=0
ilenr(:)=0.0_JPRB
ilevl=0
ilevg=0
inumlev(:)=0

IF (ydcv1%linitcv .AND. .not.ydcv1%lwaveletjb) THEN
  CALL inq_spec(ylic,ydcv1%nsmax,ydcv1%nmsmax,ydcv1%ns3d,ydcv1%ns2d,ydcv1%ns1d)
  ifldic=ylic%nflevl
  IF (ylic%ns2d>0) ifldic=ifldic+1
  ilic=ifldic*ylic%NUMP
  ilens=ilens+ilic
  ilenr(:)=ilenr+ifldic*ylic%numpp(:)
  ilevl=ilevl+ifldic
  ilevg=ilevg+ylic%nflevg
  IF (ydcv1%ns2d>0) ilevg=ilevg+1
  inumlev(:)=inumlev(:)+ylic%numll(:)
  WHERE (ylic%ns2l(:)>0) inumlev(:)=inumlev(:)+1
ENDIF

IF (ydcv1%nmoderr>0) THEN
  CALL inq_spec(ylme,ydcv1%nserr,ydcv1%nserr,ydcv1%nve3d,ydcv1%nve2d,0)
  ifldme=ylme%nflevl
  IF (ylme%ns2d>0) ifldme=ifldme+1
  ilme=ifldme*ylme%NUMP
  ilens=ilens+ilme
  ilenr(:)=ilenr(:)+ifldme*ylme%numpp(:)
  ilevl = ilevl + ifldme
  ilevg = ilevg + ylme%nflevg
  IF (ydcv1%ns2d>0) ilevg = ilevg + 1
  inumlev(:)=inumlev(:)+ylme%numll(:)
  WHERE (ylme%ns2l(:)>0) inumlev(:)=inumlev(:)+1
ENDIF

IF (ydcv1%ltovscv) THEN
  IF (LTOVSREP) THEN
    iltv=NVATOVLEN
    itvw=0
    DO ja=1,NPRTRW
      CALL SET2PE(jp,0,0,ja,MYSETV)
      ilenr(ja)=ilenr(ja)+NVATOVLENP(jp)
      itvw=itvw+NVATOVLENP(jp)
    ENDDO
    DO jb=1,NPRTRV
      DO ja=1,NPRTRW
        CALL SET2PE(jp,0,0,ja,jb)
        inumlev(jb)=inumlev(jb)+NVATOVLENP(jp)
      ENDDO
    ENDDO
    ilevl=ilevl+itvw
    ilevg=ilevg+NVATOV
  ELSE
    iltv=1
    itvw=1
    ilenr(:)=ilenr(:)+1
    ilevl=ilevl+1
    ilevg=ilevg+NPRTRV
    inumlev(:)=inumlev(:)+1
  ENDIF
  ilens=ilens+iltv
ENDIF

IF (ydcv1%ltscv) THEN
 ilts=1
 itsw=1
 ilevl=ilevl+itsw
 ilens=ilens+ilts
 ilenr(:)=ilenr(:)+1
 inumlev(:)=inumlev(:)+1
 ilevg=ilevg+NPRTRV
ENDIF


!cf this is needed to save place for the U**2+V**2(jlev) from pack_loc_lam
! (computed - hopefully - the same way on every processor)
IF (ydcv1%lam1d) THEN
!ad: with wavelet Jb, ylic isn't allocated yet, so first call inq_spec
  IF  (ydcv1%lwaveletjb) THEN
    CALL inq_spec(ylic,ydcv1%nsmax,ydcv1%nmsmax,ydcv1%ns3d,ydcv1%ns2d,ydcv1%ns1d)
  ENDIF
  ilevl=ilevl+ylic%nflevl
  ilevg=ilevg+ylic%nflevg
  inumlev(:)=inumlev(:)+ylic%numll(:)
ENDIF

ALLOCATE(zprodms(ilens))
zprodms(:)=0.0_JPRB

CALL GSTATS(1962,1)

ioff=0

IF (ydcv1%linitcv .AND. .not.ydcv1%lwaveletjb) THEN
  CALL pack_loc_ms(ylic,ydcv1%initcv(:),ydcv2%initcv(:),zprodms(1:ilic))
  ioff=ioff+ilic
ENDIF

IF (ydcv1%nmoderr>0) THEN
! Sum contributions from all components here
  ii=0
  is=ylme%nspsizel
  DO jcomp=1,ydcv1%nmoderr
    CALL pack_loc_ms(ylme,ydcv1%moderr(ii+1:ii+is),ydcv2%moderr(ii+1:ii+is), &
                   & zprodms(ioff+1:ioff+ilme))
    ii=ii+is
  ENDDO
  IF (ii/=SIZE(ydcv1%moderr)) CALL ABOR1('DOT_PRODUCT_CTLVEC: Error size ME')
  ioff=ioff+ilme
ENDIF

IF (ydcv1%ltovscv) THEN
  CALL pack_loc_tovs(ydcv1%tovscv(:),ydcv2%tovscv(:),zprodms(ioff+1:ioff+iltv))
  ioff=ioff+ilts
ENDIF

IF (ydcv1%ltscv) THEN
  CALL pack_loc_ts(ydcv1%tscv(:), ydcv2%tscv(:),zprodms(ioff+1:ioff+ilts))
ENDIF


! Get all the Ms
! --------------
ileng=SUM(ilenr(:))
ALLOCATE(zallms(ileng))

CALL GSTATS_BARRIER(781)
CALL GSTATS(656,0)
CALL MPL_ALLGATHERV(PSENDBUF=zprodms(1:ilens),PRECVBUF=zallms,&
 & KRECVCOUNTS=ilenr,KCOMM=MPL_ALL_MS_COMM,CDSTRING='DOT_PRODUCT_CTLVEC')
CALL GSTATS(656,1)
CALL GSTATS_BARRIER2(781)

IF (ALLOCATED(zprodms)) DEALLOCATE(zprodms)
idisp(1)=0
DO ja=2,NPRTRW
  idisp(ja)=idisp(ja-1)+ilenr(ja-1)
ENDDO
ALLOCATE(zloclevs(ilevl))

ioff=0

IF (ydcv1%linitcv .AND. .not.ydcv1%lwaveletjb) THEN
  CALL pack_all_ms(ylic,zallms,zloclevs(1:ifldic),idisp,ldnorm)
  ioff=ioff+ifldic
ENDIF

IF (ydcv1%nmoderr>0) THEN
  CALL pack_all_ms(ylme,zallms,zloclevs(ioff+1:ioff+ifldme),idisp,ldnorm)
  ioff=ioff+ifldme
ENDIF
IF (ydcv1%ltovscv) THEN
  CALL pack_more_tovs(zallms,zloclevs(ioff+1:ioff+itvw),idisp)
  ioff=ioff+itvw
ENDIF

IF (ydcv1%ltscv) THEN
   CALL pack_more_ts(zallms,zloclevs(ioff+1:ioff+itsw),idisp)
   ioff=ioff+itsw
ENDIF

IF (ALLOCATED(zallms)) DEALLOCATE(zallms)
IF (ydcv1%lam1d) THEN
! Nothing until now because this stuff is already on all procs
  CALL pack_loc_lam(ylic,ydcv1%lamcv(:),ydcv2%lamcv(:), &
   & zloclevs(ioff+1:ioff+ylic%nflevl))  
ENDIF

! Gather values for all levels
! ----------------------------
ALLOCATE(zalllevs(ilevg))

CALL GSTATS_BARRIER(746)
CALL GSTATS(656,0)
CALL MPL_ALLGATHERV(PSENDBUF=zloclevs(1:ilevl),PRECVBUF=zalllevs, &
 & KRECVCOUNTS=inumlev,KCOMM=MPL_ALL_LEVS_COMM,CDSTRING='DOT_PRODUCT_CTLVEC')
CALL GSTATS(656,1)
CALL GSTATS_BARRIER2(746)

IF (ALLOCATED(zloclevs)) DEALLOCATE(zloclevs)
jdisp(1)=0
DO jb=2,NPRTRV
  jdisp(jb)=jdisp(jb-1)+inumlev(jb-1)
ENDDO

IF (ydcv1%lwaveletjb .AND. .NOT. lelam) THEN
  IF( LREPRO4DVAR )THEN
    ALLOCATE (zprodarr(N_WAVELET_SCALES+1))
    ALLOCATE (ZLOCGP(SUM(GRID_DEFINITION(1:N_WAVELET_SCALES+1)%NGPTOT)))
    ALLOCATE (ZGLOBGP(SUM(GRID_DEFINITION(1:N_WAVELET_SCALES+1)%NGPTOTG),1))

!--- First, we calculate partial dot products for each grid column.
!--- Parallelization is over NPROMA packets. Each thread updates different
!--- parts of ZLOCGP.

    CALL GSTATS(1232,0)
    IOFFGP=0
    DO JSCALE=1,N_WAVELET_SCALES+1

!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JKGLO,ICEND,IBL,JFLD,JPT,IGP,IPT,IPT2)
      DO JKGLO=1,GRID_DEFINITION(JSCALE)%NGPTOT,NPROMA
        ICEND=MIN(NPROMA,GRID_DEFINITION(JSCALE)%NGPTOT-JKGLO+1)
        IBL=(JKGLO-1)/NPROMA+1

        DO JPT=1,ICEND
          IGP = JPT+NPROMA*(IBL-1)+IOFFGP
          ZLOCGP(IGP) = 0.0_JPRB
        ENDDO

!--- This loop over fields is unrolled to improve memory access on IBM.
        DO JFLD=1,(NFLEVG*ydcv1%NS3D+ydcv1%NS2D)/2
          DO JPT=1,ICEND
            IGP = JPT+NPROMA*(IBL-1)+IOFFGP
            IPT = JPT+NPROMA*(JFLD-1+(NFLEVG*ydcv1%NS3D+ydcv1%NS2D)*(IBL-1)) &
               & +ydcv1%ibgn_scale(JSCALE)-1
            IPT2= JPT+NPROMA*(JFLD-1+(NFLEVG*ydcv1%NS3D+ydcv1%NS2D)*(IBL-1)  &
               &                    +(NFLEVG*ydcv1%NS3D+ydcv1%NS2D)/2      ) &
               & +ydcv1%ibgn_scale(JSCALE)-1
            IF (ldnorm) THEN
              ZLOCGP(IGP) = ZLOCGP(IGP)  &
                         & +ydcv1%initcv(IPT )*ydcv2%initcv(IPT )*YSCALP%initcv(IPT ) &
                         & +ydcv1%initcv(IPT2)*ydcv2%initcv(IPT2)*YSCALP%initcv(IPT2)
            ELSE
              ZLOCGP(IGP) = ZLOCGP(IGP) + ydcv1%initcv(IPT )*ydcv2%initcv(IPT ) &
                         &              + ydcv1%initcv(IPT2)*ydcv2%initcv(IPT2)
            ENDIF
          ENDDO
        ENDDO

        IF (MOD(NFLEVG*ydcv1%NS3D+ydcv1%NS2D,2)/=0) THEN
          DO JPT=1,ICEND
            IGP = JPT+NPROMA*(IBL-1)+IOFFGP
            IPT = JPT+NPROMA*(NFLEVG*ydcv1%NS3D+ydcv1%NS2D-1 &
              &  +(NFLEVG*ydcv1%NS3D+ydcv1%NS2D)*(IBL-1)) &
              &  +ydcv1%ibgn_scale(JSCALE)-1
            IF (ldnorm) THEN
              ZLOCGP(IGP) = ZLOCGP(IGP) + ydcv1%initcv(IPT)*ydcv2%initcv(IPT)*YSCALP%initcv(IPT)
            ELSE
              ZLOCGP(IGP) = ZLOCGP(IGP) + ydcv1%initcv(IPT)*ydcv2%initcv(IPT)
            ENDIF
          ENDDO
        ENDIF

      ENDDO
!$OMP END PARALLEL DO

      IOFFGP = IOFFGP + GRID_DEFINITION(JSCALE)%NGPTOT
    ENDDO
    CALL GSTATS(1232,1)

!--- Next, we gather the field of partial dot products onto one processor, and sum.

!!  CALL GSTATS(1990,0)
    IF (NPROC==1) THEN
      IOFFGP=0
      DO JSCALE=1,N_WAVELET_SCALES+1
        zprodarr(JSCALE) = SUM(ZLOCGP(IOFFGP+1:IOFFGP+GRID_DEFINITION(JSCALE)%NGPTOT))
        IOFFGP = IOFFGP + GRID_DEFINITION(JSCALE)%NGPTOT
      ENDDO
    ELSE
      IOMASTER=1
      CALL GATHERGPF_WAVELET (ZLOCGP,ZGLOBGP,1,IOMASTER,GRID_DEFINITION)

      IF (MYPROC==IOMASTER) THEN
        CALL GSTATS(1234,0)
        IOFFPT=0
!       DO JSCALE=1,N_WAVELET_SCALES+1
!         zprodarr(JSCALE) = SUM(ZGLOBGP(IOFFPT+1:IOFFPT+GRID_DEFINITION(JSCALE)%NGPTOTG,1))
!         IOFFPT = IOFFPT + GRID_DEFINITION(JSCALE)%NGPTOTG
!       ENDDO
        DO JSCALE=1,N_WAVELET_SCALES+1
          IOFFPTA(JSCALE) = IOFFPT 
          IOFFPT = IOFFPT + GRID_DEFINITION(JSCALE)%NGPTOTG
        ENDDO
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JSCALE,IOFFPT)
        DO JSCALE=1,N_WAVELET_SCALES+1
          IOFFPT=IOFFPTA(JSCALE)
          zprodarr(JSCALE) = SUM(ZGLOBGP(IOFFPT+1:IOFFPT+GRID_DEFINITION(JSCALE)%NGPTOTG,1))
        ENDDO
!$OMP END PARALLEL DO 
        CALL GSTATS(1234,1)
      ENDIF
    ENDIF
!!  CALL GSTATS(1990,1)

    DEALLOCATE (ZLOCGP)
    DEALLOCATE (ZGLOBGP)

!--- Finally, we sum over wavelet scales

    IF (NPROC==1) THEN
      zprodarr(1) = SUM(zprodarr(:))
    ELSE
      IOMASTER=1
      IF (MYPROC==IOMASTER) THEN
        zprodarr(1) = SUM(zprodarr(:))
      ENDIF
      ITAG=99
      CALL GSTATS_BARRIER(747)
      CALL GSTATS(657,0)
      CALL MPL_BROADCAST(zprodarr(1:1),KROOT=IOMASTER,KTAG=ITAG, &
       & CDSTRING='DOT_PRODUCT_CTLVEC')
      CALL GSTATS(657,1)
      CALL GSTATS_BARRIER2(747)
    ENDIF

    prod1 = zprodarr(1)
    DEALLOCATE (zprodarr)

  ELSE ! non reproducible

    CALL GSTATS(1232,0)
    IOFFGP=0
    DO JSCALE=1,N_WAVELET_SCALES+1
      IOFFGPX(JSCALE)=IOFFGP
      IOFFGP = IOFFGP + GRID_DEFINITION(JSCALE)%NGPTOT
    ENDDO

    ZZLOCGPX(1,:)=0.0_JPRB
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JFLD,JSCALE,JKGLO,ICEND,IBL,JPT,IGP,IPT)
    DO JFLD=1,NFLEVG*ydcv1%NS3D+ydcv1%NS2D
      DO JSCALE=1,N_WAVELET_SCALES+1
        DO JKGLO=1,GRID_DEFINITION(JSCALE)%NGPTOT,NPROMA
          ICEND=MIN(NPROMA,GRID_DEFINITION(JSCALE)%NGPTOT-JKGLO+1)
          IBL=(JKGLO-1)/NPROMA+1
          DO JPT=1,ICEND
            IGP = JPT+NPROMA*(IBL-1)+IOFFGPX(JSCALE)
            IPT = JPT+NPROMA*(JFLD-1+(NFLEVG*ydcv1%NS3D+ydcv1%NS2D)*(IBL-1)) &
               & +ydcv1%ibgn_scale(JSCALE)-1
            IF (ldnorm) THEN
              ZZLOCGPX(1,JFLD) = ZZLOCGPX(1,JFLD) + ydcv1%initcv(IPT )*ydcv2%initcv(IPT )*YSCALP%initcv(IPT )
            ELSE
              ZZLOCGPX(1,JFLD) = ZZLOCGPX(1,JFLD) + ydcv1%initcv(IPT )*ydcv2%initcv(IPT )
            ENDIF
          ENDDO
        ENDDO
      ENDDO
    ENDDO
!$OMP END PARALLEL DO
    ZZLOCGP=SUM(ZZLOCGPX(1,:))
    CALL GSTATS(1232,1)
    CALL GSTATS_BARRIER(747)
    CALL GSTATS(657,0)
    CALL MPL_ALLREDUCE(ZZLOCGP,'SUM',LDREPROD=.TRUE.,CDSTRING='DOT_PRODUCT_CTLVEC:')
    prod1 = ZZLOCGP
    CALL GSTATS(657,1)
    CALL GSTATS_BARRIER2(747)

  ENDIF
ELSEIF (ydcv1%lwaveletjb .AND. lelam) THEN
  ZZLOCGP=0.0_JPRB
  DO II=1,SIZE(ydcv1%initcv)
    ZZLOCGP=ZZLOCGP + ydcv1%initcv(II)*ydcv2%initcv(II)
  ENDDO
  CALL MPL_ALLREDUCE(PSENDBUF=ZZLOCGP,CDOPER='SUM',LDREPROD=.TRUE.,&
     & CDSTRING='DOT_PRODUCT_CTLVEC:wavlam')
  prod1=ZZLOCGP
ELSE
  IF (ydcv1%linitcv) THEN
    CALL sum_all_levs(ylic,zalllevs,jdisp,prod1)
  ELSE
    prod1=0.0_JPRB
  ENDIF
ENDIF

CALL GSTATS(1963,0)
IF (ydcv1%nmoderr>0) THEN
  CALL sum_all_levs(ylme,zalllevs,jdisp,prod2)
ELSE
  prod2=0.0_JPRB
ENDIF

IF (ydcv1%ltovscv) THEN
  CALL sum_all_tovs(zalllevs,jdisp,prod3)
ELSE
  prod3=0.0_JPRB
ENDIF

IF (ydcv1%lam1d) THEN
  ylic%ns2g=0
  ylic%ns2d=0
  ylic%ns2l(:)=0
  CALL sum_all_levs(ylic,zalllevs,jdisp,prod4)
ELSE
  prod4=0.0_JPRB
ENDIF

IF (ydcv1%npara>0) THEN
  prod5=0.0_JPRB
  DO jj=1,ydcv1%npara
    prod5=prod5+ydcv1%params(jj)*ydcv2%params(jj)
  ENDDO
ELSE
  prod5=0.0_JPRB
ENDIF

IF (ydcv1%ltscv) THEN
   CALL sum_all_ts(zalllevs,jdisp,prod6)
 ELSE
   prod6=0.0_JPRB
 ENDIF


IF (ydcv1%linitcv .AND. .not.ydcv1%lwaveletjb) CALL deallocate_spec(ylic)
IF (ydcv1%nmoderr>0) CALL deallocate_spec(ylme)
IF (ALLOCATED(zalllevs)) DEALLOCATE(zalllevs)
CALL GSTATS(1963,1)

CALL GSTATS(255,1)

IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC',1,ZHOOK_HANDLE)

! ------------------------------------------------------------------
CONTAINS
! ------------------------------------------------------------------

SUBROUTINE PACK_LOC_MS(ydspec,psp1,psp2,prodms)

TYPE(SPECTRAL_FIELD), INTENT(IN) :: ydspec
REAL(KIND=JPRB), INTENT(IN)  :: psp1(:), psp2(:)
REAL(KIND=JPRB), INTENT(OUT) :: prodms(:)

INTEGER(KIND=JPIM) :: jf, jm, jl, js, js1, iflds, im, ilen, jmoff, jfoff, jsoff, j2d,j3d
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_LOC_MS',0,ZHOOK_HANDLE)
iflds=ydspec%nflevl
IF (ydspec%ns2d>0) iflds=iflds+1

IF (SIZE(prodms)/=iflds*ydspec%NUMP) CALL ABOR1('prodms wrong size')
IF (SIZE(psp1)/=ydspec%nspsizel) CALL ABOR1('psp1 wrong size')
IF (SIZE(psp2)/=ydspec%nspsizel) CALL ABOR1('psp2 wrong size')

! Partial products for local Ms in send buffer
! --------------------------------------------
! For OpenMP, parallelisation on jf loop will NOT give
! reproducible results, parallelisation on jm will. YT
j2d=ydspec%ns2d*ydspec%nspec2

CALL GSTATS(1054,0)
IF (.NOT.LELAM) THEN
!$OMP PARALLEL DO SCHEDULE(STATIC)&
!$OMP&PRIVATE(JM,JF,JFOFF,JMOFF,IM,JS1,ILEN,JS,JSOFF,JL)
  DO jm=1,ydspec%NUMP
    DO jf=1,ydspec%ns3d
      jfoff=j2d+(jf-1)*ydspec%nspec2*ydspec%nflevl
      jmoff=(jm-1)*ydspec%nflevl
      im=MYMS(jm)
      js1=ydspec%NASM0(im)-1
      ilen=2*(ydspec%NSMAX-im+1)
      DO js=js1+1,js1+ilen
        jsoff=jfoff+(js-1)*ydspec%nflevl
        DO jl=1,ydspec%nflevl
          prodms(jmoff+jl) = prodms(jmoff+jl) + psp1(jsoff+jl)*psp2(jsoff+jl)
        ENDDO
      ENDDO
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ELSE
!$OMP PARALLEL DO SCHEDULE(STATIC)&
!$OMP&PRIVATE(JM,JF,JFOFF,JMOFF,IM,JS1,ILEN,JS,JSOFF,JL)
  DO jm=1,ydspec%NUMP
    DO jf=1,ydspec%ns3d
      jfoff=j2d+(jf-1)*ydspec%nspec2*ydspec%nflevl
      jmoff=(jm-1)*ydspec%nflevl
      im=MYMS(jm)
      js1=ydspec%NESM0(im)-1
      ilen=ydspec%NCPL4M(im)
      DO js=js1+1,js1+ilen
        jsoff=jfoff+(js-1)*ydspec%nflevl
        DO jl=1,ydspec%nflevl
          prodms(jmoff+jl) = prodms(jmoff+jl) + psp1(jsoff+jl)*psp2(jsoff+jl)
        ENDDO
      ENDDO
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ENDIF

j3d=0
jmoff=ydspec%nflevl*ydspec%NUMP
IF (.NOT.LELAM) THEN
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JF,JFOFF,IM,ILEN,JS,JSOFF)
  DO jm=1,ydspec%NUMP
    DO jf=1,ydspec%ns2d
      jfoff=j3d+(jf-1)*ydspec%nspec2
      im=MYMS(jm)
      jsoff=jfoff+ydspec%NASM0(im)-1
      ilen=2*(ydspec%NSMAX-im+1)
      DO js=1,ilen
        prodms(jmoff+jm) = prodms(jmoff+jm) + psp1(jsoff+js) * psp2(jsoff+js)
      ENDDO
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ELSE
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(JM,JF,JFOFF,IM,ILEN,JS,JSOFF)
  DO jm=1,ydspec%NUMP
    DO jf=1,ydspec%ns2d
      jfoff=j3d+(jf-1)*ydspec%nspec2
      im=MYMS(jm)
      jsoff=jfoff+ydspec%NESM0(im)-1
      ilen=ydspec%NCPL4M(im)
      DO js=1,ilen
        prodms(jmoff+jm) = prodms(jmoff+jm) + psp1(jsoff+js) * psp2(jsoff+js)
      ENDDO
    ENDDO
  ENDDO
!$OMP END PARALLEL DO
ENDIF
CALL GSTATS(1054,1)
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_LOC_MS',1,ZHOOK_HANDLE)

END SUBROUTINE PACK_LOC_MS

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

SUBROUTINE PACK_ALL_MS(ydspec,pallms,prodsp,kdisp,ldnorm)

TYPE(SPECTRAL_FIELD), INTENT(IN) :: ydspec
REAL(KIND=JPRB), INTENT(IN) :: pallms(:)
REAL(KIND=JPRB), INTENT(OUT) :: prodsp(:)
INTEGER(KIND=JPIM), INTENT(INOUT) :: kdisp(NPRTRW)
LOGICAL, INTENT(IN) :: ldnorm

INTEGER(KIND=JPIM) :: jm, jl, ja, iflds, im, jj, iiismax
REAL(KIND=JPRB), ALLOCATABLE :: zallms(:,:)
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_ALL_MS',0,ZHOOK_HANDLE)
iflds=ydspec%nflevl
IF (ydspec%ns2d>0) iflds=iflds+1
IF (SIZE(prodsp)/=iflds) CALL ABOR1('prodsp wrong size')

IF (LELAM) THEN
  iiismax=ydspec%nmsmax
ELSE
  iiismax=ydspec%nsmax
ENDIF

ALLOCATE(zallms(iflds,0:iiismax))

! Reorder Ms for reproducibility
! ------------------------------
DO ja=1,NPRTRW
  jj=kdisp(ja)
  DO jm=1,ydspec%numpp(ja)
    im=ydspec%ms_proc(jm,ja)
    DO jl=1,ydspec%nflevl
      jj=jj+1
      zallms(jl,im)=pallms(jj)
    ENDDO
  ENDDO
  IF (ydspec%ns2d>0) THEN
    DO jm=1,ydspec%numpp(ja)
      im=ydspec%ms_proc(jm,ja)
      jj=jj+1
      zallms(iflds,im)=pallms(jj)
    ENDDO
  ENDIF
  kdisp(ja)=jj
ENDDO

! Total scalar products
! ---------------------
prodsp(:) = 0.0_JPRB
DO jm=1,iiismax
  prodsp(:) = prodsp(:) + zallms(:,jm)
ENDDO
IF (LDNORM.AND..NOT.LELAM) prodsp(:) = 2.0_JPRB * prodsp(:)
prodsp(:) = prodsp(:) + zallms(:,0)

IF (ALLOCATED(zallms)) DEALLOCATE(zallms)
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_ALL_MS',1,ZHOOK_HANDLE)

END SUBROUTINE PACK_ALL_MS

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

SUBROUTINE SUM_ALL_LEVS(ydspec,prodlevs,kdisp,prod)

TYPE(SPECTRAL_FIELD), INTENT(IN) :: ydspec
REAL(KIND=JPRB), INTENT(IN) :: prodlevs(:)
INTEGER(KIND=JPIM), INTENT(INOUT) :: kdisp(NPRTRV)
REAL(KIND=JPRB), INTENT(OUT) :: prod

INTEGER(KIND=JPIM) :: ii,jb,jl,il
REAL(KIND=JPRB), ALLOCATABLE :: zprod3(:)
REAL(KIND=JPRB) :: zprod2
REAL(KIND=JPRB) :: ZHOOK_HANDLE

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

IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:SUM_ALL_LEVS',0,ZHOOK_HANDLE)
ALLOCATE(zprod3(ydspec%nflevg))

! Reorder levels for reproducibility
! ----------------------------------
DO jb=1,NPRTRV
  ii=kdisp(jb)
  DO jl=1,ydspec%numll(jb)
    il=ydspec%nptrll(jb)+jl-1
    ii=ii+1
    zprod3(il)=prodlevs(ii)
  ENDDO
  IF (ydspec%ns2l(jb)>0) THEN
    ii=ii+1
    zprod2=prodlevs(ii)
  ENDIF
  kdisp(jb)=ii
ENDDO

! Sum all levels for 3D fields
! ----------------------------
prod=0.0_JPRB
DO jl=1,ydspec%nflevg
  prod=prod+zprod3(jl)
ENDDO
IF (ydspec%ns2g>0) THEN
  prod=prod+zprod2
ENDIF

IF (ALLOCATED(zprod3)) DEALLOCATE(zprod3)
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:SUM_ALL_LEVS',1,ZHOOK_HANDLE)

END SUBROUTINE SUM_ALL_LEVS

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

SUBROUTINE PACK_LOC_TOVS(P_TOVSCV1,P_TOVSCV2,prods)

REAL(KIND=JPRB), INTENT(IN) :: P_TOVSCV1(NVATOVLEN*NVATOVV), P_TOVSCV2(NVATOVLEN*NVATOVV)
REAL(KIND=JPRB), INTENT(OUT) :: prods(:)
INTEGER(KIND=JPIM) :: ii,jj
REAL(KIND=JPRB) :: ZHOOK_HANDLE

! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_LOC_TOVS',0,ZHOOK_HANDLE)
CALL GSTATS(1942,0)
prods(:)=0.0_JPRB
IF (LTOVSREP) THEN
  IF (SIZE(prods)/=NVATOVLEN) CALL ABOR1('prods wrong size NVATOVLEN')
  DO ii=1,NVATOVV
    ioff=(ii-1)*NVATOVLEN
    DO jj=1,NVATOVLEN
      prods(jj) = prods(jj) + P_TOVSCV1(ioff+jj) * P_TOVSCV2(ioff+jj)
    ENDDO
  ENDDO
ELSE
  IF (SIZE(prods)/=1) CALL ABOR1('prods wrong size 1')
  DO ii=1,NVATOVV*NVATOVLEN
    prods(1) = prods(1) + P_TOVSCV1(ii)*P_TOVSCV2(ii)
  ENDDO
ENDIF
CALL GSTATS(1942,1)
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_LOC_TOVS',1,ZHOOK_HANDLE)

END SUBROUTINE PACK_LOC_TOVS


SUBROUTINE PACK_LOC_TS(P_TSCV1,P_TSCV2,prods)
REAL(KIND=JPRB), INTENT(IN) :: P_TSCV1(NOBNTV), P_TSCV2(NOBNTV)
REAL(KIND=JPRB), INTENT(OUT) :: prods(:)
INTEGER(KIND=JPIM) :: ii
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_LOC_TS',0,ZHOOK_HANDLE)
prods(:)=0.0_JPRB
IF (SIZE(prods)/=1) CALL ABOR1('prods wrong size 1')
DO ii=1,NOBNTV
  prods(1)=prods(1)+P_TSCV1(ii)*P_TSCV2(ii)
ENDDO
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_LOC_TS',1,ZHOOK_HANDLE)

END SUBROUTINE PACK_LOC_TS


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

SUBROUTINE PACK_MORE_TOVS(precvd,pallw,kdisp)

REAL(KIND=JPRB), INTENT(IN) :: precvd(:)
REAL(KIND=JPRB), INTENT(OUT) :: pallw(:)
INTEGER(KIND=JPIM), INTENT(INOUT) :: kdisp(NPRTRW)

INTEGER(KIND=JPIM) :: ii,jj,ja,jp
REAL(KIND=JPRB) :: ZHOOK_HANDLE

! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_MORE_TOVS',0,ZHOOK_HANDLE)
IF (LTOVSREP) THEN
  ii=0
  DO ja=1,NPRTRW
    CALL SET2PE(jp,0,0,ja,MYSETV)
    DO jj=1,NVATOVLENP(jp)
      ii=ii+1
      pallw(ii)=precvd(kdisp(ja)+jj)
    ENDDO
    kdisp(ja)=kdisp(ja)+NVATOVLENP(jp)
  ENDDO
ELSE
  IF (SIZE(pallw)/=1) CALL ABOR1('pallw wrong size')
  pallw(1)=0.0_JPRB
  DO ja=1,NPRTRW
    kdisp(ja)=kdisp(ja)+1
    pallw(1)=pallw(1)+precvd(kdisp(ja))
  ENDDO
ENDIF
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_MORE_TOVS',1,ZHOOK_HANDLE)

END SUBROUTINE PACK_MORE_TOVS

SUBROUTINE PACK_MORE_TS(precvd,pallw,kdisp)
                                                                                                                   
REAL(KIND=JPRB), INTENT(IN) :: precvd(:)
REAL(KIND=JPRB), INTENT(OUT) :: pallw(:)
INTEGER(KIND=JPIM), INTENT(INOUT) :: kdisp(NPRTRW)
REAL(KIND=JPRB) :: ZHOOK_HANDLE
                                                                                                                   
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_MORE_TS',0,ZHOOK_HANDLE)
pallw(:)=0.0_JPRB
  IF (SIZE(pallw)/=1) CALL ABOR1('pallw wrong size')
  DO ja=1,NPRTRW
    kdisp(ja)=kdisp(ja)+1
    pallw(1)=pallw(1)+precvd(kdisp(ja))
  ENDDO
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_MORE_TS',1,ZHOOK_HANDLE)
                                                                                                                   
END SUBROUTINE PACK_MORE_TS



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

SUBROUTINE SUM_ALL_TOVS(precvd,kdisp,prod)

REAL(KIND=JPRB), INTENT(IN) :: precvd(:)
REAL(KIND=JPRB), INTENT(OUT) :: prod
INTEGER(KIND=JPIM), INTENT(INOUT) :: kdisp(NPRTRV)

REAL(KIND=JPRB), ALLOCATABLE :: zalltovs(:)
INTEGER(KIND=JPIM) :: jj,ja,jb,jp
REAL(KIND=JPRB) :: ZHOOK_HANDLE

! @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:SUM_ALL_TOVS',0,ZHOOK_HANDLE)
prod=0.0_JPRB
IF (LTOVSREP) THEN
  ALLOCATE(zalltovs(NVATOVLENG))
  DO jb=1,NPRTRV
    DO ja=1,NPRTRW
      CALL SET2PE(jp,0,0,ja,jb)
      DO jj=1,NVATOVLENP(jp)
        zalltovs(NVATOVOFF(jp)+jj)=precvd(kdisp(jb)+jj)
      ENDDO
      kdisp(jb)=kdisp(jb)+NVATOVLENP(jp)
    ENDDO
  ENDDO
  DO jj=1,NVATOVLENG
    prod = prod + zalltovs(NVATOVINDX(jj))
  ENDDO
  DEALLOCATE(zalltovs)
ELSE
  DO jb=1,NPRTRV
    kdisp(jb)=kdisp(jb)+1
    prod = prod + precvd(kdisp(jb))
  ENDDO
ENDIF
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:SUM_ALL_TOVS',1,ZHOOK_HANDLE)

END SUBROUTINE SUM_ALL_TOVS

SUBROUTINE SUM_ALL_TS(precvd,kdisp,prod)

REAL(KIND=JPRB), INTENT(IN) :: precvd(:)
REAL(KIND=JPRB), INTENT(OUT) :: prod
INTEGER(KIND=JPIM), INTENT(INOUT) :: kdisp(NPRTRV)
INTEGER(KIND=JPIM) :: jb
REAL(KIND=JPRB) :: ZHOOK_HANDLE
                                                                                                                   
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:SUM_ALL_TS',0,ZHOOK_HANDLE)
IF (LTSCV) THEN
  prod=0.0_JPRB
  DO jb=1,NPRTRV
    kdisp(jb)=kdisp(jb)+1
    prod=prod+precvd(kdisp(jb))
  ENDDO
ENDIF
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:SUM_ALL_TS',1,ZHOOK_HANDLE)
END SUBROUTINE SUM_ALL_TS



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

SUBROUTINE PACK_LOC_LAM(ydspec,psp1d1,psp1d2,prods)

TYPE(SPECTRAL_FIELD), INTENT(IN) :: ydspec
REAL(KIND=JPRB), INTENT(IN) :: psp1d1(:), psp1d2(:)
REAL(KIND=JPRB), INTENT(OUT) :: prods(:)
INTEGER(KIND=JPIM) :: ii, jf, jl
REAL(KIND=JPRB) :: ZHOOK_HANDLE

! 1st loop: U*U / 2nd loop: V*V for every vertical level

IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_LOC_LAM',0,ZHOOK_HANDLE)
prods(:)=0.0_JPRB
ii=1

DO jf=1,ydspec%ns1d
  DO jl=1,ydspec%nflevl
    prods(jl)=prods(jl) + psp1d1(ii)*psp1d2(ii)
    ii=ii+1
  ENDDO
ENDDO
IF (LHOOK) CALL DR_HOOK('DOT_PRODUCT_CTLVEC:PACK_LOC_LAM',1,ZHOOK_HANDLE)

END SUBROUTINE PACK_LOC_LAM

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

END SUBROUTINE DOT_PRODUCT_CTLVEC
