!> @file
!!  Routines to check the accuracy of the gaussian expansion
!! @author
!!    Copyright (C) 2007-2015 BigDFT group (LG)
!!    This file is distributed under the terms of the
!!    GNU General Public License, see ~/COPYING file
!!    or http://www.gnu.org/copyleft/gpl.txt .
!!    For the list of contributors, see ~/AUTHORS


!> Control the accuracy of the expansion in gaussian
subroutine check_gaussian_expansion(iproc,nproc,orbs,Lzd,psi,G,coeffs)
  use module_precisions
  use module_bigdft_mpi
  use module_types
  use yaml_output
  use module_bigdft_arrays
  implicit none
  !Arguments
  integer, intent(in) :: iproc,nproc
  type(orbitals_data), intent(in) :: orbs
  type(local_zone_descriptors), intent(in) :: Lzd
  type(gaussian_basis), intent(in) :: G
  real(wp), dimension(Lzd%Glr%wfd%nvctr_c+7*Lzd%Glr%wfd%nvctr_f,orbs%norbp), intent(in) :: psi
  real(wp), dimension(G%ncoeff,orbs%norbp), intent(in) :: coeffs
  !local variables
  character(len=*), parameter :: subname='check_gaussian_expansion'
  integer :: iorb,i,j,ierr
!! integer :: i_stat,i_all,
  real(wp) :: maxdiffp,maxdiff,orbdiff
  real(wp), dimension(:), allocatable :: workpsi

  workpsi = f_malloc((Lzd%Glr%wfd%nvctr_c+7*Lzd%Glr%wfd%nvctr_f)*orbs%norbp,id='workpsi')

  !call gaussians_to_wavelets(iproc,nproc,lr%geocode,orbs,lr%d,hx,hy,hz,&
  !     lr%wfd,G,coeffs,workpsi)

  call gaussians_to_wavelets_new(iproc,nproc,Lzd,orbs,G,coeffs,workpsi)

  maxdiffp=0.0_wp
  do iorb=1,orbs%norbp
     orbdiff=0.0_wp
     !if (iorb+iproc*norbp <= norb) then
        do i=1,Lzd%Glr%wfd%nvctr_c+7*Lzd%Glr%wfd%nvctr_f
           j=i+(iorb-1)*(Lzd%Glr%wfd%nvctr_c+7*Lzd%Glr%wfd%nvctr_f)
           orbdiff=max(orbdiff,(psi(i,iorb)-workpsi(j))**2)
        end do
     !end if
     maxdiffp=max(maxdiffp,orbdiff)
     !print *,'iproc,iorb,orbdiff',iorb,orbdiff
  end do

  !! @todo MPI_REDUCE call not safe for serial version
  if (nproc > 1) then
     call MPI_REDUCE(maxdiffp,maxdiff,1,mpidtypw,MPI_MAX,0,bigdft_mpi%mpi_comm,ierr)
  else
     maxdiff=maxdiffp
  end if

  if (iproc == 0) call yaml_map('Mean L2 norm of gaussian-wavelet difference', &
     & trim(yaml_toa(sqrt(maxdiff/real(orbs%norb,wp)),fmt='(1pe12.4)')))
  !   write(*,'(1x,a,1pe12.4)')'Mean L2 norm of gaussian-wavelet difference:',&
  !        sqrt(maxdiff/real(orbs%norb,wp))
  call f_free(workpsi)

END SUBROUTINE check_gaussian_expansion


!> Parse the output of CP2K to read the basis set information
subroutine parse_cp2k_files(iproc,basisfile,orbitalfile,nat,ntypes,orbs,iatype,rxyz,&
     CP2K,wfn_cp2k)
  use module_precisions
  use module_types, only: orbitals_data, gaussian_basis
  use gaussians
  use module_bigdft_output
  use module_bigdft_arrays
  implicit none
  character(len=*), intent(in) :: basisfile,orbitalfile
  integer, intent(in) :: iproc,nat,ntypes
  type(orbitals_data), intent(in) :: orbs
  integer, dimension(nat), intent(in) :: iatype
  real(gp), dimension(3,nat), target, intent(in) :: rxyz
  type(gaussian_basis), intent(out) :: CP2K
  real(wp), dimension(:,:), pointer :: wfn_cp2k
  !local variables
  character(len=*), parameter :: subname='parse_cp2k_files'
  character(len=6) :: string,symbol
  character(len=100) :: line
  !n(c) integer, parameter :: nterm_max=3
  integer :: ngx,nbx,nst,nend,num,mmax,myshift,i,ipar,ipg,jat
  integer :: iorb,jorb,iat,ityp,i_stat,ibas,ig,iset,jbas,ishell,lmax
!! integer :: i_all,
  integer :: isat,iexpo,icoeff,iam
  real(dp) :: tt
  real(gp) :: exponent,coefficient
  integer, dimension(:), allocatable :: nshell,iorbtmp
  integer, dimension(:,:), allocatable :: nam,ndoc
  real(gp), dimension(:), allocatable :: ctmp
  real(gp), dimension(:,:,:), allocatable :: contcoeff,expo
  real(wp), dimension(:,:,:,:), allocatable :: cimu

  if (iproc==0) call yaml_comment('Reading Basis Set information and wavefunctions coefficients')
  !if (iproc==0) write(*,'(1x,a)',advance='no') 'Reading Basis Set information and wavefunctions coefficients...'

  ngx=0
  nbx=0
  lmax=0

  nshell = f_malloc(ntypes,id='nshell')

  open(unit=35,file=trim(basisfile),action='read')

  !read the lines for analyzing the maximum number of primitive gaussian functions
  !and also for the maximum angular momentum
  ityp=0
  ngx=0
  nbx=0
  lmax=0
  ipg=0
  for_ngx: do
     if (ityp > ntypes) exit for_ngx
     read(35,'(a100)')line
     !analyzing the different possibilities
     read(line,*,iostat=i_stat)tt,string,symbol
     if (i_stat == 0 .and. string=='Atomic' .and. symbol=='kind:') then
        ityp=ityp+1
        if (ityp > 1) then
           nshell(ityp-1)=ishell
           nbx=max(nbx,ishell)
        end if
        ishell=0
        cycle for_ngx
     end if
     read(line,*,iostat=i_stat)iset,num,num,num,exponent,coefficient
     if (i_stat==0) then
        !print *,num,exponent,coefficient
        ishell=ishell+1
        lmax=max(lmax,num)
        ngx=max(ngx,ipg)
        !print *,ishell,ipg,lmax
        ipg=1
        cycle for_ngx
     end if
     read(line,*,iostat=i_stat)exponent,coefficient
     if (i_stat==0) then
        ipg=ipg+1
        cycle for_ngx
     end if
  end do for_ngx

  !now store the values
  rewind(35)

  !here allocate arrays
  nam = f_malloc((/ nbx, ntypes /),id='nam')
  ndoc = f_malloc((/ nbx, ntypes /),id='ndoc')
  contcoeff = f_malloc((/ ngx, nbx, ntypes /),id='contcoeff')
  expo = f_malloc((/ ngx, nbx, ntypes /),id='expo')

  ityp=0
  ipg=0
  store_basis: do
     if (ityp > ntypes) exit store_basis
     read(35,'(a100)')line
     !analyzing the different possibilities
     read(line,*,iostat=i_stat)tt,string,symbol
     if (i_stat == 0 .and. string=='Atomic' .and. symbol=='kind:') then
        ityp=ityp+1
        if (ityp > 1) then
           ndoc(ishell,ityp-1)=ipg
        end if
        ishell=0
        cycle store_basis
     end if
     read(line,*,iostat=i_stat)iset,num,num,num,exponent,coefficient
     if (i_stat==0) then
        !print *,num,exponent,coefficient
        ishell=ishell+1
        nam(ishell,ityp)=num
        lmax=max(lmax,num)
        if (ishell > 1) ndoc(ishell-1,ityp)=ipg
        expo(1,ishell,ityp)=exponent
        contcoeff(1,ishell,ityp)=coefficient
        ipg=1
        cycle store_basis
     end if
     read(line,*,iostat=i_stat)exponent,coefficient
     if (i_stat==0) then
        ipg=ipg+1
        expo(ipg,ishell,ityp)=exponent
        contcoeff(ipg,ishell,ityp)=coefficient
        cycle store_basis
     end if
  end do store_basis

  !close the file of the basis definition
  close(35)

  !renormalize the coefficients in each shell
  do ityp=1,ntypes
     do ishell=1,nshell(ityp)
        call normalize_shell(ndoc(ishell,ityp),nam(ishell,ityp),&
             expo(1,ishell,ityp),contcoeff(1,ishell,ityp))
     end do
  end do


  !the number of gaussian centers are thus nat
  CP2K%nat=nat
  CP2K%rxyz => rxyz
  !copy the parsed values in the gaussian structure
  !count also the total number of shells
  CP2K%nshell = f_malloc_ptr(nat,id='CP2K%nshell')

  CP2K%nshltot=0
  do iat=1,nat
     ityp=iatype(iat)
     CP2K%nshell(iat)=nshell(ityp)
     CP2K%nshltot=CP2K%nshltot+nshell(ityp)
  end do

  CP2K%ndoc = f_malloc_ptr(CP2K%nshltot,id='CP2K%ndoc')
  CP2K%nam = f_malloc_ptr(CP2K%nshltot,id='CP2K%nam')

  !assign shell IDs and count the number of exponents and coefficients
  CP2K%ncplx=1
  CP2K%nexpo=0
  CP2K%ncoeff=0
  ishell=0
  do iat=1,nat
     ityp=iatype(iat)
     do isat=1,CP2K%nshell(iat)
        ishell=ishell+1
        CP2K%ndoc(ishell)=ndoc(isat,ityp)
        CP2K%nam(ishell)=nam(isat,ityp)+1
        CP2K%nexpo=CP2K%nexpo+ndoc(isat,ityp)
        CP2K%ncoeff=CP2K%ncoeff+2*nam(isat,ityp)+1
     end do
  end do

  !allocate and assign the exponents and the coefficients
  CP2K%xp = f_malloc_ptr((/ CP2K%ncplx, CP2K%nexpo /),id='CP2K%xp')
  CP2K%psiat = f_malloc_ptr((/ CP2K%ncplx, CP2K%nexpo /),id='CP2K%psiat')

  ishell=0
  iexpo=0
  do iat=1,nat
     ityp=iatype(iat)
     do isat=1,CP2K%nshell(iat)
        ishell=ishell+1
        do ig=1,CP2K%ndoc(ishell)
           iexpo=iexpo+1
           CP2K%psiat(1,iexpo)=contcoeff(ig,isat,ityp)
           CP2K%xp(1,iexpo)=sqrt(0.5_gp/expo(ig,isat,ityp))
        end do
     end do
  end do


!!!  !print the found values
!!!  do ityp=1,ntypes
!!!     do ishell=1,nshell(ityp)
!!!        print *,'ityp=',ityp,'ishell=',ishell,'l=',nam(ishell,ityp),'ndoc=',ndoc(ishell,ityp)
!!!        do ipg=1,ndoc(ishell,ityp)
!!!           print *,'expo=',expo(ipg,ishell,ityp),'coeff=',contcoeff(ipg,ishell,ityp)
!!!        end do
!!!     end do
!!!  end do


  call f_free(contcoeff)
  call f_free(expo)


  mmax=2*lmax+1
  !now read the coefficients of the gaussian converged orbitals
  open(unit=36,file=trim(orbitalfile),action='read')
  !here there is the orbital label, for the moment it is assumed to vary between 1 and 4
  ctmp = f_malloc(10,id='ctmp')
  iorbtmp = f_malloc(10,id='iorbtmp')
  cimu = f_malloc((/ mmax, nbx, nat, orbs%norb /),id='cimu')

  read(36,*)
  read_line1: do
     read(36,'(a100)')line
     !analyse how many orbitals are contained in a given line
     read_orbitals1: do ipar=10,1,-1
        read(line,*,iostat=i_stat)(iorbtmp(i),i=1,ipar)
        if (i_stat==0) then
           read(line,*)nst
           exit read_line1
        end if
     end do read_orbitals1
  end do read_line1
  nend=nst+ipar-1

!!!  nst=1
!!!  nend=4
  jat=0
  ishell=1
  jbas=0
  iat=nat
  !now read the data to assign the coefficients
  store_coeff: do
     read(36,'(a100)')line
     !choose between different cases
     read(line,*,iostat=i_stat)ibas,iat,symbol,string,(ctmp(iorb),iorb=1,nend-nst+1)
     if (i_stat==0) then
        !print *,line,nst,nend
        if (jat==iat) then
           jbas=jbas+1
           if (jbas > 2*nam(ishell,iatype(iat))+1) then
              jbas=1
              ishell=ishell+1
              if (ishell > nshell(iatype(iat))) then
                 !if (iproc==0)
                 call yaml_warning('Problem in the gaucoeff.dat file, the number of shells of atom' // &
                      & trim(yaml_toa(iat)) // ' is incoherent')
                 !write(*,'(1x,a,i0,a)') 'Problem in the gaucoeff.dat file, the number of shells of atom ',iat ,&
                 !  ' is incoherent'
                 stop
              end if
           end if
        else
           jbas=1
           ishell=1
        end if
       symbol=trim(string)
       do iorb=nst,nend
          cimu(jbas+myshift(symbol),ishell,iat,iorb)=ctmp(iorb-nst+1)
       end do
       jat=iat
       if (jbas==2*nam(ishell,iatype(iat))+1 .and. ishell==nshell(iatype(iat))&
            .and. iat==nat .and. nend==orbs%norb) then
          exit store_coeff
       else
          cycle store_coeff
       end if
     end if

     read_orbitals: do ipar=10,1,-1
        read(line,*,iostat=i_stat)(iorbtmp(i),i=1,ipar)
        if (i_stat==0) then
           read(line,*)nst
           nend=nst+ipar-1
           if (jat/=nat) then
              !if (iproc==0)
              call yaml_warning('Problem in the gaucoeff.dat file, only ' // trim(yaml_toa(iat)) // &
                   & ' atoms processed')
              !write(*,'(1x,a,i0,a)') 'Problem in the gaucoeff.dat file, only ',iat ,' atoms processed'
              stop
           else
              cycle store_coeff
           end if
        end if
     end do read_orbitals

  end do store_coeff
  close(36)

!!!  !print the found values
!!!  do iat=1,nat
!!!     ityp=iatype(iat)
!!!     do ishell=1,nshell(ityp)
!!!        do jbas=1,2*nam(ishell,ityp)+1
!!!           print *,iat,ishell,nam(ishell,ityp),jbas,(cimu(jbas,ishell,iat,iorb),iorb=1,norb)
!!!        end do
!!!     end do
!!!  end do

  !allocate and assign the coefficients of each orbital
  wfn_cp2k = f_malloc_ptr((/ CP2K%ncoeff, orbs%norbp /),id='wfn_cp2k')
  do iorb=1,orbs%norbp
     jorb=iorb+orbs%isorb
     icoeff=0
     ishell=0
     do iat=1,CP2K%nat
        do isat=1,CP2K%nshell(iat)
           ishell=ishell+1
           do iam=1,2*CP2K%nam(ishell)-1
              icoeff=icoeff+1
              if (jorb <= orbs%norb) wfn_cp2k(icoeff,iorb)=cimu(iam,isat,iat,jorb)
           end do
        end do
     end do
     call gaudim_check(1,icoeff+1,ishell,0,CP2K%ncoeff,CP2K%nshltot)
  end do

  call f_free(ctmp)
  call f_free(iorbtmp)
  call f_free(nshell)
  call f_free(nam)
  call f_free(ndoc)
  call f_free(cimu)

  !if (iproc==0) write(*,'(1x,a)')'done.'

END SUBROUTINE parse_cp2k_files


subroutine gaussians_to_wavelets_new(iproc,nproc,Lzd,orbs,G,wfn_gau,psi)
  use module_precisions
  use module_types
  use module_bigdft_output
  use module_bigdft_mpi
  implicit none
  integer, intent(in) :: iproc,nproc
  type(local_zone_descriptors), intent(in) :: Lzd
  type(orbitals_data), intent(in) :: orbs
  type(gaussian_basis), intent(in) :: G
  real(wp), dimension(G%ncoeff,orbs%nspinor,orbs%norbp), intent(in) :: wfn_gau
  real(wp), dimension(orbs%npsidim_orbs), intent(out) :: psi

  !local variables
  integer :: iorb,ierr,ispinor,ncplx,ind,ind2,ilr
  real(dp) :: normdev,tt,scpr,totnorm
  real(gp) :: kx,ky,kz

  !if(iproc == 0 .and. verbose > 1) write(*,'(1x,a)',advance='no')&
  !     'Writing wavefunctions in wavelet form...'

  normdev=0.0_dp
  tt=0.0_dp
  ind = 1
  ind2 = 1
  do iorb=1,orbs%norbp
     ilr = orbs%inWhichLocreg(iorb+orbs%isorb)
    !features of the k-point ikpt
     kx=orbs%kpts(1,orbs%iokpt(iorb))
     ky=orbs%kpts(2,orbs%iokpt(iorb))
     kz=orbs%kpts(3,orbs%iokpt(iorb))

     !evaluate the complexity of the k-point
     if (kx**2 + ky**2 + kz**2 == 0.0_gp) then
        ncplx=1
     else
        ncplx=2
     end if
     totnorm=0.0_dp
     do ispinor=1,orbs%nspinor,ncplx
        !if (iproc == 0)print *,'start',ispinor,ncplx,iorb+orbs%isorb,orbs%nspinor
        !the Block wavefunctions are exp(-Ikr) psi(r) (with MINUS k)
        call gaussians_to_wavelets_orb(ncplx,Lzd%Llr(ilr),&
             Lzd%hgrids(1),Lzd%hgrids(2),Lzd%hgrids(3),kx,ky,kz,G,&
             wfn_gau(1,ispinor,iorb),psi(ind))

        !if (iproc == 0)print *,'end',ispinor,ncplx,iorb+orbs%isorb,orbs%nspinor
        call wnrm_wrap(ncplx,Lzd%Llr(ilr)%wfd%nvctr_c,Lzd%Llr(ilr)%wfd%nvctr_f,psi(ind),scpr)
        totnorm=totnorm+scpr
        ind = ind + (Lzd%Llr(ilr)%wfd%nvctr_c + 7*Lzd%Llr(ilr)%wfd%nvctr_f)*ncplx
     end do
     !write(*,'(1x,a,i5,1pe14.7,i3)')'norm of orbital ',iorb,totnorm,ncplx
     do ispinor=1,orbs%nspinor
        call wscal_wrap(Lzd%Llr(ilr)%wfd%nvctr_c,Lzd%Llr(ilr)%wfd%nvctr_f,real(1.0_dp/sqrt(totnorm),wp),&
             psi(ind2))
        ind2 = ind2 + (Lzd%Llr(ilr)%wfd%nvctr_c + 7*Lzd%Llr(ilr)%wfd%nvctr_f)
     end do
     tt=max(tt,abs(1.0_dp-totnorm))
     !print *,'iorb,norm',totnorm
  end do

!  if (iproc ==0  .and. verbose > 1) write(*,'(1x,a)')'done.'
  if (iproc ==0  .and. get_verbose_level() > 1) then
     call yaml_map('Wavelet conversion succeeded',.true.)
     !write(*,'(1x,a)')'done.'
  end if

  !renormalize the orbitals
  !calculate the deviation from 1 of the orbital norm
  if (nproc > 1) then
     call MPI_REDUCE(tt,normdev,1,mpidtypd,MPI_MAX,0,bigdft_mpi%mpi_comm,ierr)
     !call mpireduce(sendbuf=tt,recvbuf=normdev,count=1,op=MPI_MAX,comm=bigdft_mpi%mpi_comm)
  else
     normdev=tt
  end if
  if (iproc ==0) then
     !write(*,'(1x,a,1pe12.2)')&
     !  'Deviation from normalization of the imported orbitals',normdev
     call yaml_map('Deviation from normalization',normdev,fmt='(1pe12.2)')
  end if

END SUBROUTINE gaussians_to_wavelets_new

!> routine with lookup array on the Gaussians
subroutine gaussians_to_wavelets_mask(ob,hgrids,G,wfn_gau,mask)
  use module_precisions
  use module_types
  use orbitalbasis
  use yaml_output
  use f_ternary !to test
  use module_bigdft_mpi
  use module_bigdft_output
  implicit none
  real(gp), dimension(3), intent(in) :: hgrids
  type(orbital_basis), intent(in) :: ob
  type(gaussian_basis), intent(in) :: G
  real(wp), dimension(G%ncoeff,ob%orbs%nspinor,ob%orbs%norbp), intent(in) :: wfn_gau
  logical, dimension(ob%orbs%norbp), intent(in) :: mask !<mask array, only convert into gaussians the wfn for which the value is .true.
  !local variables
  integer :: ispinor,ncplx,ierr
  real(dp) :: normdev,tt,scpr,totnorm
  type(ket) :: it
  real(wp), dimension(:), pointer :: psi_ptr

  !if(iproc == 0 .and. verbose > 1) write(*,'(1x,a)',advance='no')&
  !     'Writing wavefunctions in wavelet form...'

  normdev=0.0_dp
  tt=0.0_dp
  it=orbital_basis_iterator(ob)
  do while (ket_next(it))
     if (.not. mask(it%iorbp)) cycle
     !evaluate the complexity of the k-point
     !new syntax to test
     ncplx = .if. all(it%kpoint==0.0_gp) .then. 1 .else. 2

!!$     if (all(it%kpoint==0.0_gp)) then
!!$        ncplx=1
!!$     else
!!$        ncplx=2
!!$     end if
     totnorm=0.0_dp
     do ispinor=1,it%nspinor,ncplx
        psi_ptr=> ob_subket_ptr(it,ispinor,ncplx=ncplx)
        call gaussians_to_wavelets_orb(ncplx,it%lr,&
             hgrids(1),hgrids(2),hgrids(3),&
             it%kpoint(1),it%kpoint(2),it%kpoint(3),G,&
             wfn_gau(1,ispinor,it%iorbp),psi_ptr)
        call wnrm_wrap(ncplx,it%lr%wfd%nvctr_c,it%lr%wfd%nvctr_f,psi_ptr,scpr)
        totnorm=totnorm+scpr
     end do
     do ispinor=1,it%nspinor
        psi_ptr=>ob_subket_ptr(it,ispinor)
        call wscal_wrap(it%lr%wfd%nvctr_c,it%lr%wfd%nvctr_f,real(1.0_dp/sqrt(totnorm),wp),psi_ptr)
     end do
     tt=max(tt,abs(1.0_dp-totnorm))
  end do

  if (bigdft_mpi%iproc ==0  .and. get_verbose_level() > 1) then
     call yaml_map('Wavelet conversion succeeded',.true.)
  end if

  !renormalize the orbitals
  !calculate the deviation from 1 of the orbital norm
  if (bigdft_mpi%nproc > 1) then
     call MPI_REDUCE(tt,normdev,1,mpidtypd,MPI_MAX,0,bigdft_mpi%mpi_comm,ierr)
  else
     normdev=tt
  end if
  if (bigdft_mpi%iproc ==0) then
     call yaml_map('Deviation from normalization',normdev,fmt='(1pe12.2)')
  end if

END SUBROUTINE gaussians_to_wavelets_mask


subroutine gaussians_to_wavelets_orb(ncplx,lr,hx,hy,hz,kx,ky,kz,G,wfn_gau,psi)
  use module_precisions
  use module_types
  use gaussians
  use locregs
  use f_arrays
  use at_domain, only: domain_periodic_dims
  use module_bigdft_arrays
  implicit none
  integer, intent(in) :: ncplx
  real(gp), intent(in) :: hx,hy,hz,kx,ky,kz
  type(locreg_descriptors), intent(in) :: lr
  type(gaussian_basis), intent(in) :: G
  real(wp), dimension(G%ncoeff), intent(in) :: wfn_gau
  real(wp), dimension((lr%wfd%nvctr_c+7*lr%wfd%nvctr_f)*ncplx), intent(out) :: psi
  !local variables
  character(len=*), parameter :: subname='gaussians_to_wavelets_orb'
  integer, parameter :: nterm_max=3,maxsizeKB=2048,nw=65536
!!  logical :: perx,pery,perz
  integer :: ishell,iexpo,icoeff,iat,isat,ng,l,m,i,nterm,ig
!! integer :: i_stat,i_all,
  integer :: nterms_max,nterms,iterm,n_gau,ml1,mu1,ml2,mu2,ml3,mu3 !n(c) iscoeff
  real(gp) :: rx,ry,rz,gau_cut
  type(f_scalar) :: gau_a, factor
  integer, dimension(nterm_max) :: lx,ly,lz
  real(gp), dimension(nterm_max) :: fac_arr
  real(wp), allocatable, dimension(:,:,:) :: work
  real(wp), allocatable, dimension(:,:,:,:) :: wx,wy,wz
  logical, dimension(3) :: peri

  !calculate nterms_max:
  !allows only maxsizeKB per one-dimensional array
  !(for a grid of dimension 100 nterms_max=655)
  !but with at least ngx*nterm_max ~= 100 elements
  nterms_max=max(maxsizeKB*1024/(2*ncplx*max(lr%d%n1,lr%d%n2,lr%d%n3)),100)

  work = f_malloc((/ 0.to.nw, 1.to.2, 1.to.2 /),id='work')
  wx = f_malloc((/ 1.to.ncplx, 0.to.lr%d%n1, 1.to.2, 1.to.nterms_max /),id='wx')
  wy = f_malloc((/ 1.to.ncplx, 0.to.lr%d%n2, 1.to.2, 1.to.nterms_max /),id='wy')
  wz = f_malloc((/ 1.to.ncplx, 0.to.lr%d%n3, 1.to.2, 1.to.nterms_max /),id='wz')

  !conditions for periodicity in the three directions
!!$  perx=(lr%geocode /= 'F')
!!$  pery=(lr%geocode == 'P')
!!$  perz=(lr%geocode /= 'F')
  peri=domain_periodic_dims(lr%mesh_coarse%dom)

  !initialize the wavefunction
  call f_zero(psi)

  gau_cut=1.0_gp !only meaningful for PAW
  !calculate the number of terms for this orbital
  nterms=0
  !loop over the atoms
  ishell=0
  iexpo=1
  icoeff=1
  !n(c) iscoeff=1
  iterm=1
  do iat=1,G%nat
     rx=G%rxyz(1,iat)
     ry=G%rxyz(2,iat)
     rz=G%rxyz(3,iat)
     !loop over the number of shells of the atom type
     do isat=1,G%nshell(iat)
        ishell=ishell+1
        !the degree of contraction of the basis function
        !is the same as the ng value of the createAtomicOrbitals routine
        ng=G%ndoc(ishell)
        !angular momentum of the basis set(shifted for compatibility with BigDFT routines
        l=G%nam(ishell)
        !print *,iproc,iat,ishell,G%nam(ishell),G%nshell(iat)
        !multiply the values of the gaussian contraction times the orbital coefficient

        do m=1,2*l-1
           call calc_coeff_inguess(l,m,nterm_max,nterm,lx,ly,lz,fac_arr)
           !control whether the basis element may be
           !contribute to some of the orbital of the processor
           if (wfn_gau(icoeff) /= 0.0_wp) then
              if (nterms + nterm*ng > nterms_max) then
                 !accumulate wavefuncton
                 call wfn_from_tensprod(lr,ncplx,nterms,wx,wy,wz,psi)
                 iterm=1
                 nterms=0
              end if
              !assign the arrays
              !make sure that the coefficients returned by
              !gauss_to_daub are zero outside [ml:mr]
              do ig=1,ng
                 do i=1,nterm
                    !print *,iat,ig,i,fac_arr(i),wfn_gau(icoeff),G%xp(1,iexpo+ig-1)
                    gau_a=G%xp(1,iexpo+ig-1)
                    factor=fac_arr(i)
                    n_gau=lx(i)
                    call gauss_to_daub_k(hx,kx*hx,ncplx,ncplx,factor,rx,gau_a,n_gau,&
                         lr%ns1,lr%d%n1,ml1,mu1,&
                         wx(1,0,1,iterm),work,nw,peri(1),gau_cut)
                    !write(*,'(a,2i7,f9.2,i7)') 'iat, m, rx, n1', iat, m, rx, lr%d%n1
                    !print *,'x',gau_a,nterm,ncplx,kx,ky,kz,ml1,mu1,lr%d%n1
                    factor=wfn_gau(icoeff)
                    n_gau=ly(i)
                    call gauss_to_daub_k(hy,ky*hy,ncplx,ncplx,factor,ry,gau_a,n_gau,&
                         lr%ns2,lr%d%n2,ml2,mu2,&
                         wy(1,0,1,iterm),work,nw,peri(2),gau_cut)
                    !print *,'y',ml2,mu2,lr%d%n2
                    factor=G%psiat(:,iexpo+ig-1)
                    n_gau=lz(i)
                    call gauss_to_daub_k(hz,kz*hz,ncplx,ncplx,factor,rz,gau_a,n_gau,&
                         lr%ns3,lr%d%n3,ml3,mu3,&
                         wz(1,0,1,iterm),work,nw,peri(3),gau_cut)
                    !print *,'z',ml3,mu3,lr%d%n3
                    iterm=iterm+1
                 end do
              end do
              nterms=nterms+nterm*ng
              !print *,'nterms',nterms,nterms_max
           end if
           icoeff=icoeff+1
        end do
        iexpo=iexpo+ng
     end do
  end do

  call gaudim_check(iexpo,icoeff,ishell,G%nexpo,G%ncoeff,G%nshltot)

  !accumulate wavefunction
  call wfn_from_tensprod(lr,ncplx,nterms,wx,wy,wz,psi)
!psi=1.d0

  call f_free(wx)
  call f_free(wy)
  call f_free(wz)
  call f_free(work)

END SUBROUTINE gaussians_to_wavelets_orb


subroutine gaussians_c_to_wavelets_orb(ncplx,lr,hx,hy,hz,kx,ky,kz,G,wfn_gau,psi, cutoff)
  use module_precisions
  use module_types
  use gaussians
  use locregs
  use at_domain, only: domain_periodic_dims
  use module_bigdft_arrays
  implicit none
  integer, intent(in) :: ncplx
  real(gp), intent(in) :: hx,hy,hz,kx,ky,kz
  type(locreg_descriptors), intent(in) :: lr
  type(gaussian_basis_c), intent(in) :: G
  real(wp), dimension(G%ncoeff), intent(in) :: wfn_gau
  real(wp), dimension((lr%wfd%nvctr_c+7*lr%wfd%nvctr_f)*ncplx), intent(out) :: psi
  real(gp) cutoff

  !local variables
  character(len=*), parameter :: subname='gaussians_to_wavelets_orb'
  integer, parameter :: nterm_max=3,maxsizeKB=2048,nw=65536
  logical :: perx,pery,perz
  integer :: ishell,iexpo,icoeff,iat,isat,ng,l,m,i,nterm,ig
!! integer :: i_stat,i_all,
  integer :: nterms_max,nterms,iscoeff,iterm,n_gau,ml1,mu1,ml2,mu2,ml3,mu3
  real(gp) :: rx,ry,rz,gau_a, gau_bf
  integer, dimension(nterm_max) :: lx,ly,lz
  real(gp), dimension(nterm_max) :: fac_arr
  real(wp), allocatable, dimension(:,:,:, :) :: work
  real(wp), allocatable, dimension(:,  :,:,:,:) :: wx,wy,wz
  real(wp), allocatable, dimension(:,:) :: cossinfacts
  integer :: ncplxC
  logical, dimension(3) :: peri

  ncplxC=2

  ! if ( ncplx.ne.1) then
  !    stop ' ncplx must be 1 in  actual version of  gaussians_c_to_wavelets_orb'
  ! end if

  !calculate nterms_max:
  !allows only maxsizeKB per one-dimensional array
  !(for a grid of dimension 100 nterms_max=655)
  !but with at least ngx*nterm_max ~= 100 elements
  nterms_max=max(maxsizeKB*1024/(2*ncplxC*max(lr%d%n1,lr%d%n2,lr%d%n3)),100)

  work = f_malloc((/ 0.to.nw, 1.to.2, 1.to.2, 1.to.ncplx /),id='work')
  wx = f_malloc((/ 1.to.ncplxC, 1.to.ncplx, 0.to.lr%d%n1, 1.to.2, 1.to.nterms_max /),id='wx')
  wy = f_malloc((/ 1.to.ncplxC, 1.to.ncplx, 0.to.lr%d%n2, 1.to.2, 1.to.nterms_max /),id='wy')
  wz = f_malloc((/ 1.to.ncplxC, 1.to.ncplx, 0.to.lr%d%n3, 1.to.2, 1.to.nterms_max /),id='wz')
  cossinfacts = f_malloc((/ 1.to.2, 1.to.nterms_max /),id='cossinfacts')


  !conditions for periodicity in the three directions
!!$  perx=(lr%geocode /= 'F')
!!$  pery=(lr%geocode == 'P')
!!$  perz=(lr%geocode /= 'F')
  peri=domain_periodic_dims(lr%mesh%dom)
  perx=peri(1)
  pery=peri(2)
  perz=peri(3)

  !initialize the wavefunction
  call f_zero(psi)

  !calculate the number of terms for this orbital
  nterms=0
  !loop over the atoms
  ishell=0
  iexpo=1
  icoeff=1
  iscoeff=1
  iterm=1
  do iat=1,G%nat

     rx=G%rxyz(1,iat)
     ry=G%rxyz(2,iat)
     rz=G%rxyz(3,iat)
     !loop over the number of shells of the atom type
     do isat=1,G%nshell(iat)

        ishell=ishell+1
        !the degree of contraction of the basis function
        !is the same as the ng value of the createAtomicOrbitals routine
        ng=G%ndoc(ishell)

        !angular momentum of the basis set(shifted for compatibility with BigDFT routines
        l=abs(G%nam(ishell)  )
        !print *,iproc,iat,ishell,G%nam(ishell),G%nshell(iat)
        !multiply the values of the gaussian contraction times the orbital coefficient

        do m=1,2*l-1
           call calc_coeff_inguess(l,m,nterm_max,nterm,lx,ly,lz,fac_arr)
           !control whether the basis element may be
           !contribute to some of the orbital of the processor

           if (wfn_gau(icoeff) /= 0.0_wp) then
              if (nterms + nterm*ng > nterms_max) then
                 call wfn_from_tensprod_cossin(lr, ncplx,cossinfacts , nterms,wx,wy,wz,psi)
                 iterm=1
                 nterms=0
              end if
              !assign the arrays
              !make sure that the coefficients returned by
              !gauss_to_daub are zero outside [ml:mr]
              do ig=1,ng

                 gau_a= sqrt( 1.0_gp/REAL(2.0_gp*G%expof(iexpo+ig-1))   )
                 gau_bf = AIMAG ( G%expof(iexpo+ig-1) )

                 do i=1,nterm

                    n_gau=lx(i)

                    call gauss_c_to_daub_k(hx,kx,ncplx,gau_bf ,ncplxC,fac_arr(i), &
                         rx,gau_a,  n_gau,&
                         lr%d%n1,ml1,mu1,&
                         wx(1,1,0,1,iterm),work,nw,perx, cutoff)

                    n_gau=ly(i)
                    !print *,'y',ml2,mu2,lr%d%n2
                    call gauss_c_to_daub_k(hy,ky,ncplx,gau_bf,ncplxC,wfn_gau(icoeff), &
                         ry,gau_a,n_gau,&
                         lr%d%n2,ml2,mu2,&
                         wy(1,1,0,1,iterm),work,nw,pery, cutoff)
                    n_gau=lz(i)
                    !print *,'z',ml3,mu3,lr%d%n3
                    call gauss_c_to_daub_k(hz,kz,ncplx,gau_bf,ncplxC,  1.0_wp,  &
                         rz,gau_a,n_gau,&
                         lr%d%n3,ml3,mu3,&
                         wz(1,1,0,1,iterm),work,nw,perz, cutoff)

                    cossinfacts(1,iterm)= REAL( G%psiat(iexpo+ig-1))
                    cossinfacts(2,iterm)= AIMAG(G%psiat(iexpo+ig-1))

                    iterm=iterm+1
                 end do
              end do


              nterms=nterms+nterm*ng
           end if
           icoeff=icoeff+1
        end do
        iexpo=iexpo+ng
     end do
  end do

  call gaudim_check(iexpo,icoeff,ishell,G%nexpo,G%ncoeff,G%nshltot)

  !accumulate wavefuncton

  call wfn_from_tensprod_cossin(lr, ncplx,  cossinfacts    ,nterms,wx,wy,wz,psi)

!psi=1.d0

  call f_free(wx)
  call f_free(wy)
  call f_free(wz)
  call f_free(cossinfacts)
  call f_free(work)

END SUBROUTINE gaussians_c_to_wavelets_orb


!> Accumulate 3d wavefunction in complex form from a tensor produc decomposition
!! universal routine which should be used for all gautowav operations
subroutine wfn_from_tensprod(lr,ncplx,nterm,wx,wy,wz,psi)
  use module_precisions
  use module_types
  use module_bigdft_output
  use locregs
  implicit none
  integer, intent(in) :: ncplx,nterm
  type(locreg_descriptors), intent(in) :: lr
  real(wp), dimension(ncplx,0:lr%d%n1,2,nterm), intent(in) :: wx
  real(wp), dimension(ncplx,0:lr%d%n2,2,nterm), intent(in) :: wy
  real(wp), dimension(ncplx,0:lr%d%n3,2,nterm), intent(in) :: wz
  real(wp), dimension((lr%wfd%nvctr_c+7*lr%wfd%nvctr_f)*ncplx), intent(inout) :: psi
  !local variables
  integer :: iseg,i,i0,i1,i2,i3,jj,ind_c,ind_f,iterm,nvctr
!  real(wp) :: re_cmplx_prod,im_cmplx_prod
  !!$  integer :: ithread,nthread,omp_get_thread_num,omp_get_num_threads

  !the filling of the wavefunction should be different if ncplx==1 or 2
  !split such as to avoid intensive call to if statements

  !!$omp parallel default(private) shared(lr%nseg_c,lr%wfd%keyv,lr%wfd%keyg,lr%d) &
  !!$omp shared(psi,wx,wy,wz,lr%wfd%nvctr_c) &
  !!$omp shared(nterm,lr%wfd%nvctr_f,lr%wfd%nseg_f)

  !!$	ithread=omp_get_thread_num()
  !!$	nthread=omp_get_num_threads()
  if (ncplx == 1) then

     !!$  if(ithread .eq. 0) then
     ! Other terms: coarse projector components
     ! coarse part
     nvctr=0
     do iseg=1,lr%wfd%nseg_c
        call segments_to_grid(lr%wfd%keyvloc(iseg),lr%wfd%keygloc(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_c=i-i0+jj
           do iterm=1,nterm
              psi(ind_c)=psi(ind_c)+&
                   wx(1,i,1,iterm)*wy(1,i2,1,iterm)*wz(1,i3,1,iterm)
           end do
           nvctr=nvctr+1
        end do
     end do

     if (nvctr /=  lr%wfd%nvctr_c) then
        call yaml_warning(' ERROR: nvctr /= nvctr_c ' // trim(yaml_toa(nvctr)) // trim(yaml_toa(lr%wfd%nvctr_c)))
        !write(*,'(1x,a,i0,1x,i0)')' ERROR: nvctr /= nvctr_c ',nvctr,lr%wfd%nvctr_c
        stop
     end if
     !!$  end if

     !!$  if(ithread .eq. 1 .or. nthread .eq. 1) then
     ! Other terms: fine projector components
     nvctr=0
     do iseg=lr%wfd%nseg_c+1,lr%wfd%nseg_c+lr%wfd%nseg_f
        call segments_to_grid(lr%wfd%keyvloc(iseg),lr%wfd%keygloc(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_f=lr%wfd%nvctr_c+7*(i-i0+jj-1)
           do iterm=1,nterm
              psi(ind_f+1)=psi(ind_f+1)+&
                   wx(1,i,2,iterm)*wy(1,i2,1,iterm)*wz(1,i3,1,iterm)
              psi(ind_f+2)=psi(ind_f+2)+&
                   wx(1,i,1,iterm)*wy(1,i2,2,iterm)*wz(1,i3,1,iterm)
              psi(ind_f+3)=psi(ind_f+3)+&
                   wx(1,i,2,iterm)*wy(1,i2,2,iterm)*wz(1,i3,1,iterm)
              psi(ind_f+4)=psi(ind_f+4)+&
                   wx(1,i,1,iterm)*wy(1,i2,1,iterm)*wz(1,i3,2,iterm)
              psi(ind_f+5)=psi(ind_f+5)+&
                   wx(1,i,2,iterm)*wy(1,i2,1,iterm)*wz(1,i3,2,iterm)
              psi(ind_f+6)=psi(ind_f+6)+&
                   wx(1,i,1,iterm)*wy(1,i2,2,iterm)*wz(1,i3,2,iterm)
              psi(ind_f+7)=psi(ind_f+7)+&
                   wx(1,i,2,iterm)*wy(1,i2,2,iterm)*wz(1,i3,2,iterm)
           end do
           nvctr=nvctr+1
        end do
     end do
     if (nvctr /= lr%wfd%nvctr_f) then
        call yaml_warning(' ERROR: nvctr /= nvctr_f ' // trim(yaml_toa(nvctr)) // trim(yaml_toa(lr%wfd%nvctr_f)))
        !write(*,'(1x,a,i0,1x,i0)')' ERROR: nvctr /= nvctr_f ',nvctr,lr%wfd%nvctr_f
        stop
     end if
     !!$  end if
  else if (ncplx ==2) then

     !part with real and imaginary part
     !modify the openMP statements such as to benefit from parallelisation

     !!$  if(ithread .eq. 0) then
     ! Other terms: coarse projector components
     ! coarse part
     nvctr=0
     do iseg=1,lr%wfd%nseg_c
        call segments_to_grid(lr%wfd%keyvloc(iseg),lr%wfd%keygloc(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_c=i-i0+jj
           do iterm=1,nterm
              psi(ind_c)=psi(ind_c)+re_cmplx_prod(&
                   wx(1,i,1,iterm),wy(1,i2,1,iterm),wz(1,i3,1,iterm))
           end do
           nvctr=nvctr+1
        end do
     end do
     if (nvctr /=  lr%wfd%nvctr_c) then
        call yaml_warning(' ERROR: nvctr /= nvctr_c ' // trim(yaml_toa(nvctr)) // trim(yaml_toa(lr%wfd%nvctr_c)))
        !write(*,'(1x,a,i0,1x,i0)')' ERROR: nvctr /= nvctr_c ',nvctr,lr%wfd%nvctr_c
        stop
     end if
     !!$  end if

     !!$  if(ithread .eq. 1 .or. nthread .eq. 1) then
     ! Other terms: fine projector components
     nvctr=0
     do iseg=lr%wfd%nseg_c+1,lr%wfd%nseg_c+lr%wfd%nseg_f
        call segments_to_grid(lr%wfd%keyvloc(iseg),lr%wfd%keygloc(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_f=lr%wfd%nvctr_c+7*(i-i0+jj-1)
           do iterm=1,nterm
              psi(ind_f+1)=psi(ind_f+1)+re_cmplx_prod(&
                   wx(1,i,2,iterm),wy(1,i2,1,iterm),wz(1,i3,1,iterm))
              psi(ind_f+2)=psi(ind_f+2)+re_cmplx_prod(&
                   wx(1,i,1,iterm),wy(1,i2,2,iterm),wz(1,i3,1,iterm))
              psi(ind_f+3)=psi(ind_f+3)+re_cmplx_prod(&
                   wx(1,i,2,iterm),wy(1,i2,2,iterm),wz(1,i3,1,iterm))
              psi(ind_f+4)=psi(ind_f+4)+re_cmplx_prod(&
                   wx(1,i,1,iterm),wy(1,i2,1,iterm),wz(1,i3,2,iterm))
              psi(ind_f+5)=psi(ind_f+5)+re_cmplx_prod(&
                   wx(1,i,2,iterm),wy(1,i2,1,iterm),wz(1,i3,2,iterm))
              psi(ind_f+6)=psi(ind_f+6)+re_cmplx_prod(&
                   wx(1,i,1,iterm),wy(1,i2,2,iterm),wz(1,i3,2,iterm))
              psi(ind_f+7)=psi(ind_f+7)+re_cmplx_prod(&
                   wx(1,i,2,iterm),wy(1,i2,2,iterm),wz(1,i3,2,iterm))
           end do
           nvctr=nvctr+1
        end do
     end do
     if (nvctr /= lr%wfd%nvctr_f) then
        call yaml_warning(' ERROR: nvctr /= nvctr_f ' // trim(yaml_toa(nvctr)) // trim(yaml_toa(lr%wfd%nvctr_f)))
        !write(*,'(1x,a,i0,1x,i0)')' ERROR: nvctr /= nvctr_f ',nvctr,lr%wfd%nvctr_f
        stop
     end if
     !!$  end if

     !now the imaginary part

     !!$  if((ithread == 0 .and. nthread <= 2) .or. ithread == 2) then
     ! Other terms: coarse projector components
     ! coarse part
     do iseg=1,lr%wfd%nseg_c
        call segments_to_grid(lr%wfd%keyvloc(iseg),lr%wfd%keygloc(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_c=lr%wfd%nvctr_c+7*lr%wfd%nvctr_f+i-i0+jj
           do iterm=1,nterm
              psi(ind_c)=psi(ind_c)+im_cmplx_prod(&
                   wx(1,i,1,iterm),wy(1,i2,1,iterm),wz(1,i3,1,iterm))
           end do
        end do
     end do

     !!$  end if

     !!$  if((ithread .eq. 1 .and. nthread <=3) .or. nthread .eq. 1 .or. ithread == 3) then
     ! Other terms: fine projector components
     do iseg=lr%wfd%nseg_c+1,lr%wfd%nseg_c+lr%wfd%nseg_f
        call segments_to_grid(lr%wfd%keyvloc(iseg),lr%wfd%keygloc(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_f=lr%wfd%nvctr_c+7*lr%wfd%nvctr_f+lr%wfd%nvctr_c+7*(i-i0+jj-1)
           do iterm=1,nterm
              psi(ind_f+1)=psi(ind_f+1)+im_cmplx_prod(&
                   wx(1,i,2,iterm),wy(1,i2,1,iterm),wz(1,i3,1,iterm))
              psi(ind_f+2)=psi(ind_f+2)+im_cmplx_prod(&
                   wx(1,i,1,iterm),wy(1,i2,2,iterm),wz(1,i3,1,iterm))
              psi(ind_f+3)=psi(ind_f+3)+im_cmplx_prod(&
                   wx(1,i,2,iterm),wy(1,i2,2,iterm),wz(1,i3,1,iterm))
              psi(ind_f+4)=psi(ind_f+4)+im_cmplx_prod(&
                   wx(1,i,1,iterm),wy(1,i2,1,iterm),wz(1,i3,2,iterm))
              psi(ind_f+5)=psi(ind_f+5)+im_cmplx_prod(&
                   wx(1,i,2,iterm),wy(1,i2,1,iterm),wz(1,i3,2,iterm))
              psi(ind_f+6)=psi(ind_f+6)+im_cmplx_prod(&
                   wx(1,i,1,iterm),wy(1,i2,2,iterm),wz(1,i3,2,iterm))
              psi(ind_f+7)=psi(ind_f+7)+im_cmplx_prod(&
                   wx(1,i,2,iterm),wy(1,i2,2,iterm),wz(1,i3,2,iterm))
           end do
        end do
     end do
     !!$  end if
  end if

  !!$omp end parallel

contains

  !> Real part of the complex product
  pure function re_cmplx_prod(a,b,c)
    use module_precisions
    implicit none
    real(wp), dimension(2), intent(in) :: a,b,c
    real(wp) :: re_cmplx_prod

    re_cmplx_prod=a(1)*b(1)*c(1) &
         -a(1)*b(2)*c(2) &
         -a(2)*b(1)*c(2) &
         -a(2)*b(2)*c(1)

  END FUNCTION re_cmplx_prod


  !> Imaginary part of the complex product
  pure function im_cmplx_prod(a,b,c)
    use module_precisions
    implicit none
    real(wp), dimension(2), intent(in) :: a,b,c
    real(wp) :: im_cmplx_prod

    im_cmplx_prod=-a(2)*b(2)*c(2) &
         +a(2)*b(1)*c(1) &
         +a(1)*b(2)*c(1) &
         +a(1)*b(1)*c(2)

  END FUNCTION im_cmplx_prod


END SUBROUTINE wfn_from_tensprod


!> Accumulate 3d projector in real form from a tensor produc decomposition
!! using complex gaussians
subroutine wfn_from_tensprod_cossin(lr,ncplx,  cossinfacts ,nterm,wx,wy,wz,psi)
  use module_precisions
  use module_types
  use module_bigdft_output
  use locregs
  implicit none
  integer, intent(in) :: nterm, ncplx
  type(locreg_descriptors), intent(in) :: lr
  real(wp), dimension(2,ncplx,0:lr%d%n1,2,nterm), intent(in) :: wx
  real(wp), dimension(2,ncplx,0:lr%d%n2,2,nterm), intent(in) :: wy
  real(wp), dimension(2,ncplx,0:lr%d%n3,2,nterm), intent(in) :: wz
  real(wp) :: cossinfacts(2,nterm)
  real(wp), dimension((lr%wfd%nvctr_c+7*lr%wfd%nvctr_f)*ncplx), intent(inout) :: psi
  !local variables
  integer :: iseg,i,i0,i1,i2,i3,jj,ind_c,ind_f,iterm,nvctr
  !real(wp) :: re_cmplx_prod,im_cmplx_prod
  !real(wp) :: re_re_cmplx_prod,re_im_cmplx_prod,im_re_cmplx_prod,im_im_cmplx_prod

  !!$omp parallel default(private) shared(lr%nseg_c,lr%wfd%keyv,lr%wfd%keyg,lr%d) &
  !!$omp shared(psi,wx,wy,wz,lr%wfd%nvctr_c) &
  !!$omp shared(nterm,lr%wfd%nvctr_f,lr%wfd%nseg_f)
  if (ncplx == 1) then
     nvctr=0
     do iseg=1,lr%wfd%nseg_c
        call segments_to_grid(lr%wfd%keyvglob(iseg),lr%wfd%keyglob(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_c=i-i0+jj
           do iterm=1,nterm
              psi(ind_c)=psi(ind_c)+re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
           end do
           nvctr=nvctr+1
        end do
     end do
     if (nvctr /=  lr%wfd%nvctr_c) then
        call yaml_warning(' ERROR: nvctr >< nvctr_c ' // trim(yaml_toa(nvctr)) // trim(yaml_toa(lr%wfd%nvctr_c)))
        !write(*,'(1x,a,i0,1x,i0)')' ERROR: nvctr >< nvctr_c ',nvctr,lr%wfd%nvctr_c
        stop
     end if
     !!$  end if

     !!$  if(ithread .eq. 1 .or. nthread .eq. 1) then
     ! Other terms: fine projector components
     nvctr=0
     do iseg=lr%wfd%nseg_c+1,lr%wfd%nseg_c+lr%wfd%nseg_f
        call segments_to_grid(lr%wfd%keyvglob(iseg),lr%wfd%keyglob(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_f=lr%wfd%nvctr_c+7*(i-i0+jj-1)
           do iterm=1,nterm
              psi(ind_f+1)=psi(ind_f+1)+re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
              psi(ind_f+2)=psi(ind_f+2)+re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
              psi(ind_f+3)=psi(ind_f+3)+re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
              psi(ind_f+4)=psi(ind_f+4)+re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
              psi(ind_f+5)=psi(ind_f+5)+re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
              psi(ind_f+6)=psi(ind_f+6)+re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
              psi(ind_f+7)=psi(ind_f+7)+re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
           end do
           nvctr=nvctr+1
        end do
     end do
     if (nvctr /= lr%wfd%nvctr_f) then
        call yaml_warning(' ERROR: nvctr >< nvctr_f ' // trim(yaml_toa(nvctr)) // trim(yaml_toa(lr%wfd%nvctr_f)))
        !write(*,'(1x,a,i0,1x,i0)')' ERROR: nvctr >< nvctr_f ',nvctr,lr%wfd%nvctr_f
        stop
     end if
     !!$  end if

     !now the imaginary part

     !!$  if((ithread == 0 .and. nthread <= 2) .or. ithread == 2) then
     ! Other terms: coarse projector components
     ! coarse part
     do iseg=1,lr%wfd%nseg_c
        call segments_to_grid(lr%wfd%keyvglob(iseg),lr%wfd%keyglob(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_c=i-i0+jj
           do iterm=1,nterm
              psi(ind_c)=psi(ind_c)+im_cmplx_prod(&
                   wx(1,1, i,1,iterm),wy(1,1, i2,1,iterm),wz(1,1, i3,1,iterm))*cossinfacts(2,iterm)
           end do
        end do
     end do

     !!$  end if

     !!$  if((ithread .eq. 1 .and. nthread <=3) .or. nthread .eq. 1 .or. ithread == 3) then
     ! Other terms: fine projector components
     do iseg=lr%wfd%nseg_c+1,lr%wfd%nseg_c+lr%wfd%nseg_f
        call segments_to_grid(lr%wfd%keyvglob(iseg),lr%wfd%keyglob(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_f=lr%wfd%nvctr_c+7*(i-i0+jj-1)
           do iterm=1,nterm
              psi(ind_f+1)=psi(ind_f+1)+im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,1,iterm))*cossinfacts(2,iterm)
              psi(ind_f+2)=psi(ind_f+2)+im_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(2,iterm)
              psi(ind_f+3)=psi(ind_f+3)+im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(2,iterm)
              psi(ind_f+4)=psi(ind_f+4)+im_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
              psi(ind_f+5)=psi(ind_f+5)+im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
              psi(ind_f+6)=psi(ind_f+6)+im_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
              psi(ind_f+7)=psi(ind_f+7)+im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
           end do
        end do
     end do
  else if (ncplx ==2) then

     nvctr=0
     do iseg=1,lr%wfd%nseg_c
        call segments_to_grid(lr%wfd%keyvglob(iseg),lr%wfd%keyglob(:,iseg),lr%d,i0,i1,i2,i3,jj)

        do i=i0,i1
           ind_c=i-i0+jj
           do iterm=1,nterm
              psi(ind_c)=psi(ind_c)+re_re_cmplx_prod(&
                   wx(1,1, i,1,iterm),wy(1,1, i2,1,iterm),wz(1,1, i3,1,iterm))*cossinfacts(1,iterm)
           end do
           nvctr=nvctr+1
        end do

        do i=i0,i1
           ind_c= lr%wfd%nvctr_c + 7*lr%wfd%nvctr_f + i-i0+jj
           do iterm=1,nterm
              psi(ind_c)=psi(ind_c)+im_re_cmplx_prod(&
                   wx(1,1, i,1,iterm),wy(1,1, i2,1,iterm),wz(1,1, i3,1,iterm))*cossinfacts(1,iterm)
           end do
        end do



     end do
     if (nvctr /=  lr%wfd%nvctr_c) then
        call yaml_warning(' ERROR: nvctr >< nvctr_c ' // trim(yaml_toa(nvctr)) // trim(yaml_toa(lr%wfd%nvctr_c)))
        !write(*,'(1x,a,i0,1x,i0)')' ERROR: nvctr >< nvctr_c ',nvctr,lr%wfd%nvctr_c
        stop
     end if
     !!$  end if

     !!$  if(ithread .eq. 1 .or. nthread .eq. 1) then
     ! Other terms: fine projector components
     nvctr=0
     do iseg=lr%wfd%nseg_c+1,lr%wfd%nseg_c+lr%wfd%nseg_f
        call segments_to_grid(lr%wfd%keyvglob(iseg),lr%wfd%keyglob(:,iseg),lr%d,i0,i1,i2,i3,jj)
        do i=i0,i1
           ind_f=lr%wfd%nvctr_c+7*(i-i0+jj-1)
           do iterm=1,nterm
              psi(ind_f+1)=psi(ind_f+1)+re_re_cmplx_prod(&
                   wx(1, 1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
              psi(ind_f+2)=psi(ind_f+2)+re_re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
              psi(ind_f+3)=psi(ind_f+3)+re_re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
              psi(ind_f+4)=psi(ind_f+4)+re_re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
              psi(ind_f+5)=psi(ind_f+5)+re_re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
              psi(ind_f+6)=psi(ind_f+6)+re_re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
              psi(ind_f+7)=psi(ind_f+7)+re_re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
           end do
           nvctr=nvctr+1
        end do

        do i=i0,i1
           ind_f=lr%wfd%nvctr_c + 7*lr%wfd%nvctr_f +  lr%wfd%nvctr_c+7*(i-i0+jj-1)
           do iterm=1,nterm
              psi(ind_f+1)=psi(ind_f+1)+im_re_cmplx_prod(&
                   wx(1, 1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
              psi(ind_f+2)=psi(ind_f+2)+im_re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
              psi(ind_f+3)=psi(ind_f+3)+im_re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(1,iterm)
              psi(ind_f+4)=psi(ind_f+4)+im_re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
              psi(ind_f+5)=psi(ind_f+5)+im_re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
              psi(ind_f+6)=psi(ind_f+6)+im_re_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
              psi(ind_f+7)=psi(ind_f+7)+im_re_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(1,iterm)
           end do
        end do


     end do
     if (nvctr /= lr%wfd%nvctr_f) then
        call yaml_warning(' ERROR: nvctr >< nvctr_f ' // trim(yaml_toa(nvctr)) // trim(yaml_toa(lr%wfd%nvctr_f)))
        !write(*,'(1x,a,i0,1x,i0)')' ERROR: nvctr >< nvctr_f ',nvctr,lr%wfd%nvctr_f
        stop
     end if
     !!$  end if

     !now the imaginary part

     !!$  if((ithread == 0 .and. nthread <= 2) .or. ithread == 2) then
     ! Other terms: coarse projector components
     ! coarse part
     do iseg=1,lr%wfd%nseg_c
        call segments_to_grid(lr%wfd%keyvglob(iseg),lr%wfd%keyglob(:,iseg),lr%d,i0,i1,i2,i3,jj)

        do i=i0,i1
           ind_c=i-i0+jj
           do iterm=1,nterm
              psi(ind_c)=psi(ind_c)+re_im_cmplx_prod(&
                   wx(1,1, i,1,iterm),wy(1,1, i2,1,iterm),wz(1,1, i3,1,iterm))*cossinfacts(2,iterm)
           end do
        end do

        do i=i0,i1
           ind_c=lr%wfd%nvctr_c + 7*lr%wfd%nvctr_f + i-i0+jj
           do iterm=1,nterm
              psi(ind_c)=psi(ind_c)+im_im_cmplx_prod(&
                   wx(1,1, i,1,iterm),wy(1,1, i2,1,iterm),wz(1,1, i3,1,iterm))*cossinfacts(2,iterm)
           end do
        end do

     end do

     !!$  end if

     !!$  if((ithread .eq. 1 .and. nthread <=3) .or. nthread .eq. 1 .or. ithread == 3) then
     ! Other terms: fine projector components
     do iseg=lr%wfd%nseg_c+1,lr%wfd%nseg_c+lr%wfd%nseg_f
        call segments_to_grid(lr%wfd%keyvglob(iseg),lr%wfd%keyglob(:,iseg),lr%d,i0,i1,i2,i3,jj)

        do i=i0,i1
           ind_f=lr%wfd%nvctr_c+7*(i-i0+jj-1)
           do iterm=1,nterm
              psi(ind_f+1)=psi(ind_f+1)+re_im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,1,iterm))*cossinfacts(2,iterm)
              psi(ind_f+2)=psi(ind_f+2)+re_im_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(2,iterm)
              psi(ind_f+3)=psi(ind_f+3)+re_im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(2,iterm)
              psi(ind_f+4)=psi(ind_f+4)+re_im_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
              psi(ind_f+5)=psi(ind_f+5)+re_im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
              psi(ind_f+6)=psi(ind_f+6)+re_im_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
              psi(ind_f+7)=psi(ind_f+7)+re_im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
           end do
        end do

        do i=i0,i1
           ind_f=lr%wfd%nvctr_c + 7*lr%wfd%nvctr_f +lr%wfd%nvctr_c+7*(i-i0+jj-1)
           do iterm=1,nterm
              psi(ind_f+1)=psi(ind_f+1)+im_im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,1,iterm))*cossinfacts(2,iterm)
              psi(ind_f+2)=psi(ind_f+2)+im_im_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(2,iterm)
              psi(ind_f+3)=psi(ind_f+3)+im_im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,1,iterm))*cossinfacts(2,iterm)
              psi(ind_f+4)=psi(ind_f+4)+im_im_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
              psi(ind_f+5)=psi(ind_f+5)+im_im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,1,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
              psi(ind_f+6)=psi(ind_f+6)+im_im_cmplx_prod(&
                   wx(1,1,i,1,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
              psi(ind_f+7)=psi(ind_f+7)+im_im_cmplx_prod(&
                   wx(1,1,i,2,iterm),wy(1,1,i2,2,iterm),wz(1,1,i3,2,iterm))*cossinfacts(2,iterm)
           end do
        end do

     end do

  end if

!!$omp end parallel

contains

  !> Real part of the complex product
  pure function re_cmplx_prod(a,b,c)
    use module_precisions
    implicit none
    real(wp), dimension(2), intent(in) :: a,b,c
    real(wp) :: re_cmplx_prod

    re_cmplx_prod=a(1)*b(1)*c(1) &
         -a(1)*b(2)*c(2) &
         -a(2)*b(1)*c(2) &
         -a(2)*b(2)*c(1)

  END FUNCTION re_cmplx_prod


  !> Imaginary part of the complex product
  pure function im_cmplx_prod(a,b,c)
    use module_precisions
    implicit none
    real(wp), dimension(2), intent(in) :: a,b,c
    real(wp) :: im_cmplx_prod

    im_cmplx_prod=-a(2)*b(2)*c(2) &
         +a(2)*b(1)*c(1) &
         +a(1)*b(2)*c(1) &
         +a(1)*b(1)*c(2)

  END FUNCTION im_cmplx_prod


  pure function re_re_cmplx_prod(a,b,c)
    use module_precisions
    implicit none
    real(wp), dimension(2,2), intent(in) :: a,b,c
    real(wp) :: re_re_cmplx_prod
    !  real(wp) :: re_cmplx_prod

    re_re_cmplx_prod=re_cmplx_prod( a(1,1),b(1,1),c(1,1)) &
         -re_cmplx_prod( a(1,1),b(1,2),c(1,2)) &
         -re_cmplx_prod( a(1,2),b(1,1),c(1,2)) &
         -re_cmplx_prod( a(1,2),b(1,2),c(1,1))
  END FUNCTION re_re_cmplx_prod


  pure function im_re_cmplx_prod(a,b,c)
    use module_precisions
    implicit none
    real(wp), dimension(2,2), intent(in) :: a,b,c
    real(wp) :: im_re_cmplx_prod
    !real(wp) :: re_cmplx_prod

    im_re_cmplx_prod=-re_cmplx_prod(a(1,2),b(1,2),c(1,2)) &
         +re_cmplx_prod(a(1,2),b(1,1),c(1,1)) &
         +re_cmplx_prod(a(1,1),b(1,2),c(1,1)) &
         +re_cmplx_prod(a(1,1),b(1,1),c(1,2))

  END FUNCTION im_re_cmplx_prod


  pure function re_im_cmplx_prod(a,b,c)
    use module_precisions
    implicit none
    real(wp), dimension(2,2), intent(in) :: a,b,c
    real(wp) :: re_im_cmplx_prod
    !real(wp) :: im_cmplx_prod

    re_im_cmplx_prod=im_cmplx_prod( a(1,1),b(1,1),c(1,1)) &
         -im_cmplx_prod( a(1,1),b(1,2),c(1,2)) &
         -im_cmplx_prod( a(1,2),b(1,1),c(1,2)) &
         -im_cmplx_prod( a(1,2),b(1,2),c(1,1))

  END FUNCTION re_im_cmplx_prod


  pure function im_im_cmplx_prod(a,b,c)
    use module_precisions
    implicit none
    real(wp), dimension(2,2), intent(in) :: a,b,c
    real(wp) :: im_im_cmplx_prod
    !real(wp) :: im_cmplx_prod

    im_im_cmplx_prod=-im_cmplx_prod(a(1,2),b(1,2),c(1,2)) &
         +im_cmplx_prod(a(1,2),b(1,1),c(1,1)) &
         +im_cmplx_prod(a(1,1),b(1,2),c(1,1)) &
         +im_cmplx_prod(a(1,1),b(1,1),c(1,2))
  END FUNCTION im_im_cmplx_prod


END SUBROUTINE wfn_from_tensprod_cossin


subroutine segments_to_grid(keyv,keyg,grid,i0,i1,i2,i3,jj)
  use module_types
  use locregs
  implicit none
  integer, intent(in) :: keyv
  integer, dimension(2), intent(in) :: keyg
  type(grid_dimensions), intent(in) :: grid
  integer, intent(out) :: i0,i1,i2,i3,jj
  !local variables
  integer :: j0,j1,ii

  jj=keyv
  j0=keyg(1)
  j1=keyg(2)
  ii=j0-1
  i3=ii/((grid%n1+1)*(grid%n2+1))
  ii=ii-i3*(grid%n1+1)*(grid%n2+1)
  i2=ii/(grid%n1+1)
  i0=ii-i2*(grid%n1+1)
  i1=i0+j1-j0
END SUBROUTINE segments_to_grid


!temporary creation, better to put in standby
!!!subroutine sumrho_gaussians(geocode,iproc,nproc,norb,norbp,nspin,nspinor,&
!!!     n1i,n2i,n3i,n3d,i3s,hxh,hyh,hzh,G,gaucoeff,occup,spinsgn,rho)
!!!  use module_base
!!!  use module_types
!!!  implicit none
!!!  character(len=1), intent(in) :: geocode !< @copydoc poisson_solver::doc::geocode
!!!  integer, intent(in) :: iproc,nproc,norb,norbp,n1i,n2i,n3i
!!!  real(gp), intent(in) :: hx,hy,hz
!!!  type(wavefunctions_descriptors), intent(in) :: wfd
!!!  type(gaussian_basis), intent(in) :: G
!!!  real(wp), dimension(G%ncoeff,norbp), intent(in) :: wfn_gau
!!!  real(wp), dimension(wfd%nvctr_c+7*wfd%nvctr_f,norbp), intent(out) :: psi
!!!
!!!  !local variables
!!!  character(len=*), parameter :: subname='gaussians_to_wavelets'
!!!  integer, parameter :: nterm_max=3
!!!  logical :: myorbital
!!!  integer :: i_stat,i_all,ishell,iexpo,icoeff,iat,isat,ng,l,m,iorb,jorb,i,nterm,ierr,ig
!!!  real(dp) :: normdev,tt,scpr
!!!  real(gp) :: rx,ry,rz
!!!  integer, dimension(nterm_max) :: lx,ly,lz
!!!  real(gp), dimension(nterm_max) :: fac_arr
!!!  real(wp), dimension(:), allocatable :: tpsi
!!!
!!!  if(iproc == 0) write(*,'(1x,a)',advance='no')'Writing wavefunctions in wavelet form '
!!!
!!!  allocate(tpsi(wfd%nvctr_c+7*wfd%nvctr_f+ndebug),stat=i_stat)
!!!  call memocc(i_stat,tpsi,'tpsi',subname)
!!!
!!!  !initialize the wavefunction
!!!  call to_zero((wfd%nvctr_c+7*wfd%nvctr_f)*norbp,psi)
!!!  !this can be changed to be passed only once to all the gaussian basis
!!!  !eks=0.d0
!!!  !loop over the atoms
!!!  ishell=0
!!!  iexpo=1
!!!  icoeff=1
!!!  do iat=1,G%nat
!!!     rx=G%rxyz(1,iat)
!!!     ry=G%rxyz(2,iat)
!!!     rz=G%rxyz(3,iat)
!!!     !loop over the number of shells of the atom type
!!!     do isat=1,G%nshell(iat)
!!!        ishell=ishell+1
!!!        !the degree of contraction of the basis function
!!!        !is the same as the ng value of the createAtomicOrbitals routine
!!!        ng=G%ndoc(ishell)
!!!        !angular momentum of the basis set(shifted for compatibility with BigDFT routines
!!!        l=G%nam(ishell)
!!!        !multiply the values of the gaussian contraction times the orbital coefficient
!!!        do m=1,2*l-1
!!!           call calc_coeff_inguess(l,m,nterm_max,nterm,lx,ly,lz,fac_arr)
           !this kinetic energy is not reliable
!!eks=eks+ek*occup(iorb)*cimu(m,ishell,iat,iorb)
!!!           call crtonewave(geocode,n1,n2,n3,ng,nterm,lx,ly,lz,fac_arr,G%xp(1,iexpo),G%psiat(1,iexpo),&
!!!                rx,ry,rz,hx,hy,hz,0,n1,0,n2,0,n3,nfl1,nfu1,nfl2,nfu2,nfl3,nfu3,  &
!!!                wfd%nseg_c,wfd%nvctr_c,wfd%keyg,wfd%keyv,wfd%nseg_f,wfd%nvctr_f,&
!!!                wfd%keyg(1,wfd%nseg_c+1),wfd%keyv(wfd%nseg_c+1),&
!!!                tpsi(1),tpsi(wfd%nvctr_c+1))
!!!           !sum the result inside the orbital wavefunction
!!!           !loop over the orbitals
!!!           do iorb=1,norb
!!!              if (myorbital(iorb,norb,iproc,nproc)) then
!!!                 jorb=iorb-iproc*norbp
!!!                 do i=1,wfd%nvctr_c+7*wfd%nvctr_f
!!!                    !for this also daxpy BLAS can be used
!!!                    psi(i,jorb)=psi(i,jorb)+wfn_gau(icoeff,jorb)*tpsi(i)
!!!                 end do
!!!              end if
!!!           end do
!!!           icoeff=icoeff+1
!!!        end do
!!!        iexpo=iexpo+ng
!!!     end do
!!!     if (iproc == 0) then
!!!        write(*,'(a)',advance='no') &
!!!             repeat('.',(iat*40)/G%nat-((iat-1)*40)/G%nat)
!!!     end if
!!!  end do
!!!
!!!  call gaudim_check(iexpo,icoeff,ishell,G%nexpo,G%ncoeff,G%nshltot)
!!!
!!!  if (iproc ==0 ) write(*,'(1x,a)')'done.'
!!!  !renormalize the orbitals
!!!  !calculate the deviation from 1 of the orbital norm
!!!  normdev=0.0_dp
!!!  tt=0.0_dp
!!!  do iorb=1,norb
!!!     if (myorbital(iorb,norb,iproc,nproc)) then
!!!        jorb=iorb-iproc*norbp
!!!        call wnrm(wfd%nvctr_c,wfd%nvctr_f,psi(1,jorb),psi(wfd%nvctr_c+1,jorb),scpr)
!!!        call wscal(wfd%nvctr_c,wfd%nvctr_f,real(1.0_dp/sqrt(scpr),wp),psi(1,jorb),psi(wfd%nvctr_c+1,jorb))
!!!        !print *,'norm of orbital ',iorb,scpr
!!!        tt=max(tt,abs(1.0_dp-scpr))
!!!     end if
!!!  end do
!!!  if (nproc > 1) then
!!!     call MPI_REDUCE(tt,normdev,1,mpidtypd,MPI_MAX,0,bigdft_mpi%mpi_comm,ierr)
!!!  else
!!!     normdev=tt
!!!  end if
!!!  if (iproc ==0 ) write(*,'(1x,a,1pe12.2)')&
!!!       'Deviation from normalization of the imported orbitals',normdev
!!!
!!!  i_all=-product(shape(tpsi))*kind(tpsi)
!!!  deallocate(tpsi,stat=i_stat)
!!!  call memocc(i_stat,i_all,'tpsi',subname)
!!!
!!!
!!!  !Creates charge density arising from the ionic PSP cores
!!!  if (n3pi >0 ) then
!!!
!!!     !conditions for periodicity in the three directions
!!!     perx=(geocode /= 'F')
!!!     pery=(geocode == 'P')
!!!     perz=(geocode /= 'F')
!!!
!!!     call ext_buffers(perx,nbl1,nbr1)
!!!     call ext_buffers(pery,nbl2,nbr2)
!!!     call ext_buffers(perz,nbl3,nbr3)
!!!
!!!     call to_zero(n1i*n2i*n3pi,pot_ion)
!!!
!!!     do iat=1,nat
!!!        ityp=iatype(iat)
!!!        rx=rxyz(1,iat)
!!!        ry=rxyz(2,iat)
!!!        rz=rxyz(3,iat)
!!!
!!!        rloc=psppar(0,0,ityp)
!!!        charge=real(nelpsp(ityp),kind=8)/(2.d0*pi*sqrt(2.d0*pi)*rloc**3)
!!!        cutoff=10.d0*rloc
!!!
!!!        isx=floor((rx-cutoff)/hxh)
!!!        isy=floor((ry-cutoff)/hyh)
!!!        isz=floor((rz-cutoff)/hzh)
!!!
!!!        iex=ceiling((rx+cutoff)/hxh)
!!!        iey=ceiling((ry+cutoff)/hyh)
!!!        iez=ceiling((rz+cutoff)/hzh)
!!!
!!!        !these nested loops will be used also for the actual ionic forces, to be recalculated
!!!        do i3=isz,iez
!!!           z=real(i3,kind=8)*hzh-rz
!!!           call ind_positions(perz,i3,n3,j3,goz)
!!!           j3=j3+nbl3+1
!!!           do i2=isy,iey
!!!              y=real(i2,kind=8)*hyh-ry
!!!              call ind_positions(pery,i2,n2,j2,goy)
!!!              do i1=isx,iex
!!!                 x=real(i1,kind=8)*hxh-rx
!!!                 call ind_positions(perx,i1,n1,j1,gox)
!!!                 r2=x**2+y**2+z**2
!!!                 arg=r2/rloc**2
!!!                 xp=exp(-.5d0*arg)
!!!                 if (j3 >= i3s .and. j3 <= i3s+n3pi-1  .and. goy  .and. gox ) then
!!!                    ind=j1+1+nbl1+(j2+nbl2)*n1i+(j3-i3s+1-1)*n1i*n2i
!!!                    pot_ion(ind)=pot_ion(ind)-xp*charge
!!!                 else if (.not. goz ) then
!!!                    rholeaked=rholeaked+xp*charge
!!!                 endif
!!!              enddo
!!!           enddo
!!!        enddo
!!!
!!!     enddo
!!!
!!!  end if
!!!
!!!  ! Check
!!!  tt=0.d0
!!!  do j3=1,n3pi
!!!     do i2= -nbl2,2*n2+1+nbr2
!!!        do i1= -nbl1,2*n1+1+nbr1
!!!           ind=i1+1+nbl1+(i2+nbl2)*n1i+(j3-1)*n1i*n2i
!!!           tt=tt+pot_ion(ind)
!!!        enddo
!!!     enddo
!!!  enddo
!!!
!!!  tt=tt*hxh*hyh*hzh
!!!  rholeaked=rholeaked*hxh*hyh*hzh
!!!
!!!  !print *,'test case input_rho_ion',iproc,i3start,i3end,n3pi,2*n3+16,tt
!!!
!!!  if (nproc > 1) then
!!!     charges_mpi(1)=tt
!!!     charges_mpi(2)=rholeaked
!!!     call MPI_ALLREDUCE(charges_mpi(1),charges_mpi(3),2,MPI_double_precision,  &
!!!          MPI_SUM,bigdft_mpi%mpi_comm,ierr)
!!!     tt_tot=charges_mpi(3)
!!!     rholeaked_tot=charges_mpi(4)
!!!  else
!!!     tt_tot=tt
!!!     rholeaked_tot=rholeaked
!!!  end if
!!!
!!!  if (iproc.eq.0) write(*,'(1x,a,f26.12,2x,1pe10.3)') &
!!!       'total ionic charge, leaked charge ',tt_tot,rholeaked_tot
!!!
!!!
!!!END SUBROUTINE sumrho_gaussians

!> Calculate the shift between the spherical harmonics of CP2K and the one of BigDFT
function myshift(symbol)
  implicit none
  character(len=5), intent(in) :: symbol
  integer :: myshift
  myshift=0
  if (symbol(2:2)=='s') then
     myshift=0
  else if (symbol(2:2)=='p') then
     if( symbol(3:3)=='y') then
        myshift=1
     else if( symbol(3:3)=='z') then
        myshift=1
     else if( symbol(3:3)=='x') then
        myshift=-2
     end if
  else if ( symbol(2:2)=='d') then
     if( symbol(3:4)=='-2') then
        myshift=2
     else if( symbol(3:4)=='-1') then
        myshift=-1
     else if( symbol(3:3)=='0') then
        myshift=2
     else if( symbol(3:4)=='+1') then
        myshift=-2
     else if( symbol(3:4)=='+2') then
        myshift=-1
     end if
  else if ( symbol(2:2)=='f') then
     if( symbol(3:4)=='-3') then
        myshift=4
     else if( symbol(3:4)=='-2') then
        myshift=5
     else if( symbol(3:4)=='-1') then
        myshift=-1
     else if( symbol(3:3)=='0') then
        myshift=-1
     else if( symbol(3:4)=='+1') then
        myshift=-4
     else if( symbol(3:4)=='+2') then
        myshift=0
     else if( symbol(3:4)=='+3') then
        myshift=-3
     end if
  else if ( symbol(2:2)=='g') then
     write(*,'(1x,a)')'the orbitals of type g are not yet implemented in BigDFT'
     stop
  end if

end function myshift


logical function myorbital(iorb,norbe,iproc,nproc)
  implicit none
  integer, intent(in) :: iorb,norbe,iproc,nproc
  !local variables
  real(kind=8), parameter :: eps_mach=1.d-12
  integer :: norbep
  real(kind=8) :: tt

  tt=dble(norbe)/dble(nproc)
  norbep=int((1.d0-eps_mach*tt) + tt)
  if (iorb >= iproc*norbep+1 .and. iorb <= min((iproc+1)*norbep,norbe)) then
     myorbital=.true.
  else
     myorbital=.false.
  endif

end function myorbital
