MODULE CONTROL_VECTORS_OPER_MOD

!   Purpose.
!   --------
!     This module contains the basic operators associated
!     to the CONTROL_VECTOR type.
!
!   Author.
!   -------
!     Y. Tremolet
!
!   Modifications.
!   -------------- 
!     Original   25-Jul-2004 Split from CONTROL_VECTORS
!     A. Deckmyn 01-Oct-2008 LAM wavelets
! ------------------------------------------------------------------

USE PARKIND1, ONLY: JPIM, JPRB
USE SPECTRAL_FIELDS_MOD, ONLY: SPECTRAL_FIELD, ASSIGNMENT(=), &
                         & ALLOCATE_SPEC, DEALLOCATE_SPEC
USE CONTROL_VECTORS_BASE_MIX, ONLY: CONTROL_VECTOR, CHECK, OPERATOR(.NEQV.)
USE CONTROL_VECTORS_DATA_MIX, ONLY: nscales, ngptotl, ngptotg, nblocksl, &
                              & nlentovscv, nlentovscvg, nvatovv, mytovoff, &
                              & mylevs, nflevl, nflevg, lelam, ngrb, nproma, &
                              & n_regions, n_regions_ns, n_regions_ew, &
                              & my_region_ns, my_region_ew, &
                              & mytsoff, nobntvg, nobntv, ltscv, ngrbe

IMPLICIT NONE
PRIVATE
PUBLIC ASSIGNMENT(=), INVERSE

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

INTERFACE ASSIGNMENT (=)
MODULE PROCEDURE assign_cv_cv, assign_scalar_cv, assign_ar_cv, assign_cv_ar
END INTERFACE

INTERFACE INVERSE
MODULE PROCEDURE inverse_cv, inverse_cv_cv
END INTERFACE

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

SUBROUTINE assign_cv_cv(ydcv1,ydcv2)
TYPE(control_vector), INTENT(INOUT) :: ydcv1
TYPE(control_vector), INTENT(IN)    :: ydcv2
TYPE(spectral_field) :: ylsp1, ylsp2
LOGICAL :: ll_same_init, ll_same_moderr
INTEGER(KIND=JPIM) :: ilen,i1,i2,il1,il2,jj,j

CALL check(ydcv1)
CALL check(ydcv2)
IF (ydcv1.NEQV.ydcv2) THEN
  CALL ABOR1('Control vectors are incompatible')
ENDIF

ll_same_init = .true.
IF (ydcv1%linitcv) THEN
  IF (ydcv1%lwaveletjb) THEN
    ll_same_init = ydcv1%nscales==ydcv2%nscales.AND.(ydcv1%nserr==ydcv2%nserr)
  ELSE
    ll_same_init = ydcv1%nsmax==ydcv2%nsmax .AND. (ydcv1%nserr==ydcv2%nserr)
  ENDIF
ENDIF

IF (LELAM) THEN
  ll_same_init = ll_same_init .AND. (ydcv1%nmsmax==ydcv2%nmsmax)
ENDIF

IF (ydcv1%nmoderr>0) THEN
  ll_same_moderr = (ydcv1%nserr==ydcv2%nserr)
ELSE
  ll_same_moderr = .true.
ENDIF

IF (ll_same_init .AND. ll_same_moderr) THEN
  CALL GSTATS(1460,0)
!$OMP PARALLEL DO SCHEDULE(STATIC) PRIVATE(j)
  DO j=1,SIZE(ydcv1%data)
    ydcv1%data(j) = ydcv2%data(j)
  ENDDO
!$OMP END PARALLEL DO
  CALL GSTATS(1460,1)
ELSE
  IF (ydcv1%linitcv) THEN
    IF (ll_same_init) THEN
      ydcv1%initcv(:) = ydcv2%initcv(:)
    ELSEIF (ydcv1%lwaveletjb) THEN
     IF (lelam) CALL  ABOR1('LELAM-wavelets not implemented here.')
!--- NB: The finest scale of the lower-resolution control vector (ydcv2)
!    has a different grid than the corresponding scale of ydcv1. Ideally,
!    we should use the spherical transform to re-grid this scale. But,
!    for now we just zero it in ydcv1.

      ilen=ydcv1%ibgn_scale(ydcv1%nscales-ydcv2%nscales+2)-1
      ydcv1%initcv(1:ilen) = 0.0_JPRB
      IF (  SIZE(ydcv1%initcv(ilen+1:)) &
        & /=SIZE(ydcv2%initcv(ydcv2%ibgn_scale(2):))) THEN
        write(0,*)'size mismatch: ',SIZE(ydcv1%initcv(ilen+1:)), &
                 &                  SIZE(ydcv2%initcv(ydcv2%ibgn_scale(2):))
        write(0,*)'ydcv1%ibgn_scale=',ydcv1%ibgn_scale
        write(0,*)'ydcv2%ibgn_scale=',ydcv2%ibgn_scale
        CALL ABOR1 ('size mismatch')
      ENDIF
      ydcv1%initcv(ilen+1:) = ydcv2%initcv(ydcv2%ibgn_scale(2):)

    ELSE
      CALL allocate_spec(ylsp1,ydcv1%nsmax,ydcv1%nmsmax, &
                       & ydcv1%ns3d,ydcv1%ns2d,ydcv1%ns1d,ngrb)
      CALL allocate_spec(ylsp2,ydcv2%nsmax,ydcv2%nmsmax, &
                       & ydcv2%ns3d,ydcv2%ns2d,ydcv2%ns1d,ngrb)
      ylsp2=ydcv2%initcv(:)
      ylsp1=ylsp2        ! spectral_field type does change of resolution
      ydcv1%initcv(:)=ylsp1
      CALL deallocate_spec(ylsp1)
      CALL deallocate_spec(ylsp2)
    ENDIF
  ENDIF
  IF (ydcv1%nmoderr>0) THEN
    IF (ll_same_moderr) THEN
      ydcv1%moderr(:) = ydcv2%moderr(:)
    ELSE
      CALL allocate_spec(ylsp1,ydcv1%nserr,ydcv1%nserr, &
                       & ydcv1%nve3d,ydcv1%nve2d,0,ngrbe)
      CALL allocate_spec(ylsp2,ydcv2%nserr,ydcv2%nserr, &
                       & ydcv2%nve3d,ydcv2%nve2d,0,ngrbe)
      il1=ylsp1%nspsizel
      il2=ylsp2%nspsizel
      DO jj=1,ydcv1%nmoderr
        i1=(jj-1)*il1
        i2=(jj-1)*il2
        ylsp2=ydcv2%moderr(i2+1:i2+il2)
        ylsp1=ylsp2      ! spectral_field type does change of resolution
        ydcv1%moderr(i1+1:i1+il1)=ylsp1
      ENDDO
      CALL deallocate_spec(ylsp1)
      CALL deallocate_spec(ylsp2)
    ENDIF
  ENDIF
  IF (ydcv1%ltovscv) THEN
    ydcv1%tovscv(:) = ydcv2%tovscv(:)
  ENDIF
  IF (ydcv1%lam1d) THEN
    ydcv1%lamcv(:) = ydcv2%lamcv(:)
  ENDIF
  IF (ydcv1%npara>0) THEN
    ydcv1%params(:) = ydcv2%params(:)
  ENDIF
  IF (ydcv1%ltscv) THEN
      ydcv1%tscv(:) = ydcv2%tscv(:)
  ENDIF

ENDIF

END SUBROUTINE assign_cv_cv

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

SUBROUTINE assign_scalar_cv(ydcv,pscalar)
TYPE(control_vector), INTENT(INOUT) :: ydcv
REAL(KIND=JPRB), INTENT(IN) :: pscalar

CALL check(ydcv)
ydcv%data = pscalar

END SUBROUTINE assign_scalar_cv

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

SUBROUTINE assign_ar_cv(ydcv,pvec)
TYPE(control_vector), INTENT(INOUT) :: ydcv
REAL(KIND=JPRB), INTENT(IN) :: pvec(:)
INTEGER(KIND=JPIM) :: ilen,ioff,jf,ii,jj,jl,il,ibgn,iend,igptotg,jscale,ja,jb
TYPE(SPECTRAL_FIELD) :: ylsp

CALL check(ydcv)

IF (SIZE(pvec) == ydcv%nsizel) then
  ydcv%data = pvec
ELSEIF (SIZE(pvec) == ydcv%nsizeg) then
  IF (ydcv%linitcv) THEN
    IF (.not.ydcv%lwaveletjb) THEN
      CALL allocate_spec(ylsp,ydcv%nsmax,ydcv%nmsmax, &
                       & ydcv%ns3d,ydcv%ns2d,ydcv%ns1d,ngrb)
      ilen=ylsp%nspsizeg
      ylsp=pvec(1:ilen)
      ydcv%initcv(:)=ylsp
      ioff=ilen
      CALL deallocate_spec(ylsp)
    ELSE
      igptotg=0
      DO jscale=1,ydcv%nscales
        DO ja=1,N_REGIONS_NS
          DO jb=1,N_REGIONS(ja)
            if (ja==my_region_ns .and. jb==my_region_ew) then
              ibgn=ydcv%ibgn_scale(jscale)
              ilen=nproma*(nflevg*ydcv%ns3d+ydcv%ns2d) &
                       & *nblocksl(jscale+NSCALES-ydcv%nscales)
              iend=ibgn+ilen-1
              ydcv%initcv(ibgn:iend) = pvec(igptotg+1:igptotg+ilen)
            endif
            igptotg=igptotg+ngptotl(jscale+NSCALES-ydcv%nscales,ja,jb)
          ENDDO
        ENDDO
      ENDDO
      if (igptotg /= sum(ngptotg(1+NSCALES-ydcv%nscales:))) &
        & CALL ABOR1 ('assign_ar_cv: indexing problem')
      ioff = igptotg
    ENDIF
  ENDIF
  IF (ydcv%nmoderr>0) THEN
    CALL allocate_spec(ylsp,ydcv%nserr,ydcv%nserr, &
                     & ydcv%nve3d,ydcv%nve2d,0,ngrbe)
    ilen=ylsp%nspsizeg
    il=ylsp%nspsizel
    DO jj=1,ydcv%nmoderr
      ii=(jj-1)*il
      ylsp=pvec(ioff+1:ioff+ilen)
      ydcv%moderr(ii+1:ii+il)=ylsp
      ioff=ioff+ilen
    ENDDO
    CALL deallocate_spec(ylsp)
  ENDIF
  IF (ydcv%ltovscv) THEN
    jl=0
    DO jf=1,NVATOVV
      DO jj=1,NLENTOVSCV
        jl=jl+1
        ydcv%tovscv(jl)=pvec(ioff+mytovoff+jj)
      ENDDO
      ioff=ioff+NLENTOVSCVG
    ENDDO
  ENDIF
  IF (ydcv%ltscv) THEN
       jl=0
       DO jj=1,NOBNTV
         jl=jl+1
         ydcv%tscv(jl)=pvec(ioff+mytsoff+jj)
       ENDDO
       ioff=ioff+NOBNTV
  ENDIF

  IF (ydcv%lam1d) THEN
    jj=0
    DO jf=1,ydcv%ns1d
      DO jl=1,NFLEVL
        il=MYLEVS(jl)
        jj=jj+1
        ydcv%lamcv(jj)=pvec(ioff+il)
      ENDDO
      ioff=ioff+NFLEVG
    ENDDO
  ENDIF
  IF (ydcv%npara>0) THEN
    DO jf=1,ydcv%npara
      ydcv%params(jf)=pvec(ioff+jf)
    ENDDO
    ioff=ioff+ydcv%npara
  ENDIF
ELSE 
  CALL ABOR1('Error: cannot assign array to control vector')
ENDIF

END SUBROUTINE assign_ar_cv

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

SUBROUTINE assign_cv_ar(pvec,ydcv)
REAL(KIND=JPRB), INTENT(OUT) :: pvec(:)
TYPE(control_vector), INTENT(IN) :: ydcv

CALL check(ydcv)
IF (SIZE(pvec) == ydcv%nsizel) then
  pvec = ydcv%data
ELSEIF (SIZE(pvec) == ydcv%nsizeg) then
!  This case has to come after the preceeding one so that it isn't
!  executed if running on one processor.
  CALL ABOR1('Assign vector to global array would be very expensive')
ELSE 
  CALL ABOR1('Error: cannot assign control vector to array')
ENDIF

END SUBROUTINE assign_cv_ar

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

SUBROUTINE inverse_cv(ydcv)
TYPE(control_vector), INTENT(INOUT) :: ydcv

! divide_cv fails on zero, inverse sets output to zero.
CALL check(ydcv)
WHERE (ydcv%data /= 0.0_JPRB)
  ydcv%data = 1.0_JPRB/ydcv%data
ENDWHERE

END SUBROUTINE inverse_cv

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

SUBROUTINE inverse_cv_cv(ydin,ydout)
TYPE(control_vector), INTENT(IN)    :: ydin
TYPE(control_vector), INTENT(INOUT) :: ydout

! divide_cv fails on zero, inverse sets output to zero.
CALL check(ydin,ydout)

WHERE (ydin%data == 0.0_JPRB)
  ydout%data = 0.0_JPRB
ELSEWHERE
  ydout%data = 1.0_JPRB/ydin%data
ENDWHERE

END SUBROUTINE inverse_cv_cv

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

END MODULE CONTROL_VECTORS_OPER_MOD
