!> Parse the output of CP2K to read the basis set information
subroutine gautowav(mesh,iproc,nproc,nat,ntypes,norb,norbp,n1,n2,n3,&
     nfl1,nfu1,nfl2,nfu2,nfl3,nfu3,&
     nvctr_c,nvctr_f,nseg_c,nseg_f,keyg,keyv,iatype,rxyz,hx,hy,hz,psi) !n(c) occup (arg:l-5)
  use module_base
  use module_types
  use gaussians
  use yaml_output
  use box, only: cell
  implicit none
!!$  character(len=1), intent(in) :: geocode !< @copydoc poisson_solver::doc::geocode
  type(cell), intent(in) :: mesh
  integer, intent(in) :: norb,norbp,iproc,nproc,nat,ntypes
  integer, intent(in) :: nvctr_c,nvctr_f,n1,n2,n3,nseg_c,nseg_f
  integer, intent(in) :: nfl1,nfu1,nfl2,nfu2,nfl3,nfu3
  integer, dimension(nseg_c+nseg_f), intent(in) :: keyv
  integer, dimension(2,nseg_c+nseg_f), intent(in) :: keyg
  integer, dimension(nat), intent(in) :: iatype
  real(gp), intent(in) :: hx,hy,hz
  real(gp), dimension(3,nat), intent(in) :: rxyz
  !n(c) real(gp), dimension(norb), intent(in) :: occup
  !real(gp), intent(out) :: eks
  real(wp), dimension(nvctr_c+7*nvctr_f,norbp), intent(out) :: psi
  !local variables
  character(len=*), parameter :: subname='gautowav'
  logical :: myorbital
  character(len=6) :: string,symbol
  character(len=100) :: line
  integer, parameter :: nterm_max=3
  integer :: ngx,nbx,nst,nend,ng,num,mmax,myshift,i,ipar,ipg,jat
  integer :: iorb,jorb,iat,ityp,l,m,nterm,i_stat,ibas,ig,iset,jbas,ishell,lmax
!! integer :: i_all,
  integer :: ierr
  real(dp) :: tt,normdev
  real(gp) :: rx,ry,rz
  real(gp) :: exponent,coefficient,scpr
  integer, dimension(nterm_max) :: lx,ly,lz
  real(gp), dimension(nterm_max) :: fac_arr
  integer, dimension(:), allocatable :: nshell,iorbtmp
  integer, dimension(:,:), allocatable :: nam,ndoc
  real(wp), dimension(:), allocatable :: tpsi,ctmp
  real(gp), dimension(:), allocatable :: psiatn,xp
  real(gp), dimension(:,:,:), allocatable :: contcoeff,expo
  real(wp), dimension(:,:,:,:), allocatable :: cimu


  !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='gaubasis.dat',action='read')

  !read the lines for analyzing the maximum number of primitive gaussian functions
  !and als for the maximum angular momentum
  ityp=0
  ngx=0
  nbx=0
  lmax=0
  ipg=0
  ishell=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

!!!  !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

!!!  !here we can start calculate the overlap matrix between the different basis functions
!!!  !as an example we can try to calculate the overlap in one shell
!!!  allocate(iw(18),stat=i_stat)
!!!  call memocc(i_stat,product(shape(iw))*kind(iw),'iw','gautowav')
!!!  allocate(rw(6),stat=i_stat)
!!!  call memocc(i_stat,product(shape(rw))*kind(rw),'rw','gautowav')
!!!
!!!  do ityp=1,ntypes
!!!     do ishell=1,nshell(ityp)
!!!        !perform the scalar product internally to the shell
!!!        do m1=1,2*nam(ishell,ityp)+1
!!!           do m2=1,2*nam(ishell,ityp)+1
!!!              call gbasovrlp(expo(1,ishell,ityp),contcoeff(1,ishell,ityp),&
!!!                   expo(1,ishell,ityp),contcoeff(1,ishell,ityp),&
!!!                   ndoc(ishell,ityp),ndoc(ishell,ityp),&
!!!                   nam(ishell,ityp)+1,m1,nam(ishell,ityp)+1,m2,&
!!!                   0.d0,0.d0,0.d0,&
!!!                   18,6,iw,rw,ovrlp)
!!!              if (iproc==0) then
!!!                 print *,ityp,ishell,nam(ishell,ityp),m1,m2,ovrlp!&
!!!                      !contcoeff(1:ndoc(ishell,ityp),ishell,ityp),ovrlp
!!!              end if
!!!           end do
!!!        end do
!!!     end do
!!!  end do
!!!
!!!  i_all=-product(shape(iw))*kind(iw)
!!!  deallocate(iw,stat=i_stat)
!!!  call memocc(i_stat,i_all,'iw','gautowav')
!!!  i_all=-product(shape(rw))*kind(rw)
!!!  deallocate(rw,stat=i_stat)
!!!  call memocc(i_stat,i_all,'rw','gautowav')

!!!subroutine basis_ovrlp(nat,norb,nbx,ngx,lmax,ntypes,nam,ndoc,contcoeff,expo,cimu)
!!!
!!!
!!!END SUBROUTINE basis_ovrlp

  mmax=2*lmax+1
  !now read the coefficients of the gaussian converged orbitals
  open(unit=36,file='gaucoeff.dat',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, 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==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

  call f_free(ctmp)
  call f_free(iorbtmp)


  !now apply this basis set information to construct the wavelets wavefunctions

  if (iproc==0) then
     call yaml_map('Reading Basis Set information and wavefunctions coefficients',.true.)
     !write(*,'(1x,a)')'done.'
     !write(*,'(1x,a)',advance='no')'Writing wavefunctions in wavelet form '
  end if

  psiatn = f_malloc(ngx,id='psiatn')
  xp = f_malloc(ngx,id='xp')
  tpsi = f_malloc(nvctr_c+7*nvctr_f,id='tpsi')

  !initialize the wavefunction
  call f_zero(psi)
  !this can be changed to be passed only once to all the gaussian basis
  !eks=0.d0
  !loop over the atoms
  do iat=1,nat
     ityp=iatype(iat)
     rx=rxyz(1,iat)
     ry=rxyz(2,iat)
     rz=rxyz(3,iat)
     !loop over the number of shells of the atom type
     do ishell=1,nshell(ityp)
        !the degree of contraction of the basis function
        !is the same as the ng value of the createAtomicOrbitals routine
        ng=ndoc(ishell,ityp)
        !angular momentum of the basis set(shifted for compatibility with BigDFT routines
        l=nam(ishell,ityp)+1
        !amplitude coefficients (contraction coefficients of the basis times
        !the amplitude of this basis in that orbital)
        !exponents for the gaussian expansion adapted following the convention
        !of the routine gauss_to_daub
        do ig=1,ng
           psiatn(ig)=contcoeff(ig,ishell,ityp)
           xp(ig)=sqrt(0.5_gp/expo(ig,ishell,ityp))
        end do
        !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(mesh,n1,n2,n3,ng,nterm,lx,ly,lz,fac_arr,xp,psiatn,&
                rx,ry,rz,hx,hy,hz,0,n1,0,n2,0,n3,nfl1,nfu1,nfl2,nfu2,nfl3,nfu3,  &
                nseg_c,nvctr_c,keyg,keyv,nseg_f,nvctr_f,&
                keyg(1,nseg_c+1),keyv(nseg_c+1),&
                tpsi(1),tpsi(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,nvctr_c+7*nvctr_f
                    !for this also daxpy BLAS can be used
                    psi(i,jorb)=psi(i,jorb)+cimu(m,ishell,iat,iorb)*tpsi(i)
                 end do
              end if
           end do
        end do
     end do
     !if (iproc == 0) then
     !   write(*,'(a)',advance='no') &
     !        repeat('.',(iat*40)/nat-((iat-1)*40)/nat)
     !end if
  end do
  call yaml_map('Writing wavefunctions in wavelet form ',.true.)
  !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(nvctr_c,nvctr_f,psi(1,jorb),psi(nvctr_c+1,jorb),scpr)
        call wscal(nvctr_c,nvctr_f,real(1.0_dp/sqrt(scpr),wp),psi(1,jorb),psi(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 ) call yaml_map('Deviation from normalization of the imported orbitals',normdev,fmt='(1pe12.2)')
  !if (iproc ==0 ) write(*,'(1x,a,1pe12.2)') 'Deviation from normalization of the imported orbitals',normdev

  !now we have to evaluate the eigenvalues of this hamiltonian

  call f_free(tpsi)
  call f_free(nshell)
  call f_free(nam)
  call f_free(ndoc)
  call f_free(contcoeff)
  call f_free(expo)
  call f_free(cimu)

  call f_free(xp)
  call f_free(psiatn)

END SUBROUTINE gautowav

!> Returns an input guess orbital that is a Gaussian centered at a Wannier center
!! @f$ exp (-1/(2*gau_a^2) *((x-cntrx)^2 + (y-cntry)^2 + (z-cntrz)^2 )) @f$
!! in the arrays psi_c, psi_f
subroutine crtonewave(mesh,n1,n2,n3,nterm,ntp,lx,ly,lz,fac_arr,xp,psiat,rx,ry,rz,hx,hy,hz, &
     nl1_c,nu1_c,nl2_c,nu2_c,nl3_c,nu3_c,nl1_f,nu1_f,nl2_f,nu2_f,nl3_f,nu3_f,  &
     nseg_c,mvctr_c,keyg_c,keyv_c,nseg_f,mvctr_f,keyg_f,keyv_f,psi_c,psi_f)
  use module_base
  use box, only: cell
  use at_domain, only: domain_periodic_dims
  implicit none
!!#  character(len=1), intent(in) :: geocode !< @copydoc poisson_solver::doc::geocode
  type(cell), intent(in) :: mesh
  integer, intent(in) :: n1,n2,n3,nterm,ntp,nseg_c,nseg_f,mvctr_c,mvctr_f
  integer, intent(in) :: nl1_c,nu1_c,nl2_c,nu2_c,nl3_c,nu3_c,nl1_f,nu1_f,nl2_f,nu2_f,nl3_f,nu3_f
  real(gp), intent(in) :: rx,ry,rz,hx,hy,hz
  integer, dimension(ntp), intent(in) :: lx,ly,lz
  integer, dimension(nseg_c), intent(in) :: keyv_c
  integer, dimension(nseg_f), intent(in) :: keyv_f
  integer, dimension(2,nseg_c), intent(in) :: keyg_c
  integer, dimension(2,nseg_f), intent(in) :: keyg_f
  real(gp), dimension(ntp), intent(in) :: fac_arr
  real(gp), dimension(nterm), intent(in) :: xp,psiat
  real(wp), dimension(mvctr_c), intent(out) :: psi_c
  real(wp), dimension(7,mvctr_f), intent(out) :: psi_f
  !local variables
  character(len=*), parameter :: subname='crtonewave'
  integer, parameter ::nw=32000
  logical :: perx,pery,perz
  integer:: iterm,itp,n_gau,ml1,mu1,ml2,mu2,ml3,mu3,i1,i2,i3,iseg,ii,jj,j0,j1,i0,i
!! integer :: i_stat,i_all,
  real(gp) :: gau_a,te
  real(wp), dimension(0:nw,2) :: work
  real(wp), dimension(:,:), allocatable :: wprojx,wprojy,wprojz
  real(wp), dimension(:,:,:), allocatable :: psig_c
  real(wp), dimension(:,:,:,:), allocatable :: psig_f
  logical, dimension(3) :: peri

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


  wprojx = f_malloc((/ 0.to.n1, 1.to.2 /),id='wprojx')
  wprojy = f_malloc((/ 0.to.n2, 1.to.2 /),id='wprojy')
  wprojz = f_malloc((/ 0.to.n3, 1.to.2 /),id='wprojz')
  psig_c = f_malloc((/ nl1_c.to.nu1_c, nl2_c.to.nu2_c, nl3_c.to.nu3_c /),id='psig_c')
  psig_f = f_malloc((/ 1.to.7, nl1_f.to.nu1_f, nl2_f.to.nu2_f, nl3_f.to.nu3_f /),id='psig_f')

  !print *,'limits',nl1_c,nu1_c,nl2_c,nu2_c,nl3_c,nu3_c,nl1_f,nu1_f,nl2_f,nu2_f,nl3_f,nu3_f

  iterm=1
  itp=1
  gau_a=xp(iterm)
  n_gau=lx(itp)
  call gauss_to_daub(hx,fac_arr(itp),rx,gau_a,n_gau,n1,ml1,mu1,wprojx(0,1),te,work,nw,perx)
  n_gau=ly(itp)
  call gauss_to_daub(hy,1.0_gp,ry,gau_a,n_gau,n2,ml2,mu2,wprojy(0,1),te,work,nw,pery)
  n_gau=lz(itp)
  call gauss_to_daub(hz,psiat(iterm),rz,gau_a,n_gau,n3,ml3,mu3,wprojz(0,1),te,work,nw,perz)
!$omp parallel default(private) shared(nl3_c,nu3_c,nl2_c,nu2_c,nl1_c,nu1_c,wprojx,wprojy,wprojz) &
!$omp shared(nl3_f,nu3_f,nl2_f,nu2_f,nl1_f,nu1_f,psig_c,psig_f)
  ! First term: coarse projector components
!$omp do
  do i3=nl3_c,nu3_c
     do i2=nl2_c,nu2_c
        do i1=nl1_c,nu1_c
           psig_c(i1,i2,i3)=wprojx(i1,1)*wprojy(i2,1)*wprojz(i3,1)
        enddo
     enddo
  enddo
!$omp enddo
  ! First term: fine projector components
!$omp do
  do i3=nl3_f,nu3_f
     do i2=nl2_f,nu2_f
        do i1=nl1_f,nu1_f
           psig_f(1,i1,i2,i3)=wprojx(i1,2)*wprojy(i2,1)*wprojz(i3,1)
           psig_f(2,i1,i2,i3)=wprojx(i1,1)*wprojy(i2,2)*wprojz(i3,1)
           psig_f(3,i1,i2,i3)=wprojx(i1,2)*wprojy(i2,2)*wprojz(i3,1)
           psig_f(4,i1,i2,i3)=wprojx(i1,1)*wprojy(i2,1)*wprojz(i3,2)
           psig_f(5,i1,i2,i3)=wprojx(i1,2)*wprojy(i2,1)*wprojz(i3,2)
           psig_f(6,i1,i2,i3)=wprojx(i1,1)*wprojy(i2,2)*wprojz(i3,2)
           psig_f(7,i1,i2,i3)=wprojx(i1,2)*wprojy(i2,2)*wprojz(i3,2)
        enddo
     enddo
  enddo
!$omp enddo
!$omp end parallel
  do iterm=2,nterm
     gau_a=xp(iterm)
     n_gau=lx(itp)
     call gauss_to_daub(hx,fac_arr(itp),rx,gau_a,n_gau,n1,ml1,mu1,wprojx(0,1),te,work,nw,perx)
     n_gau=ly(itp)
     call gauss_to_daub(hy,1.0_gp,ry,gau_a,n_gau,n2,ml2,mu2,wprojy(0,1),te,work,nw,pery)
     n_gau=lz(itp)
     call gauss_to_daub(hz,psiat(iterm),rz,gau_a,n_gau,n3,ml3,mu3,wprojz(0,1),te,work,nw,perz)

!$omp parallel default(private) shared(nl3_c,nu3_c,nl2_c,nu2_c,nl1_c,nu1_c,wprojx,wprojy,wprojz) &
!$omp shared(nl3_f,nu3_f,nl2_f,nu2_f,nl1_f,nu1_f,psig_c,psig_f)
  ! First term: coarse projector components
!$omp do
     do i3=nl3_c,nu3_c
        do i2=nl2_c,nu2_c
           do i1=nl1_c,nu1_c
              psig_c(i1,i2,i3)=psig_c(i1,i2,i3)+wprojx(i1,1)*wprojy(i2,1)*wprojz(i3,1)
           enddo
        enddo
     enddo
!$omp enddo

     ! First term: fine projector components
!$omp do
     do i3=nl3_f,nu3_f
        do i2=nl2_f,nu2_f
           do i1=nl1_f,nu1_f
              psig_f(1,i1,i2,i3)=psig_f(1,i1,i2,i3)+wprojx(i1,2)*wprojy(i2,1)*wprojz(i3,1)
              psig_f(2,i1,i2,i3)=psig_f(2,i1,i2,i3)+wprojx(i1,1)*wprojy(i2,2)*wprojz(i3,1)
              psig_f(3,i1,i2,i3)=psig_f(3,i1,i2,i3)+wprojx(i1,2)*wprojy(i2,2)*wprojz(i3,1)
              psig_f(4,i1,i2,i3)=psig_f(4,i1,i2,i3)+wprojx(i1,1)*wprojy(i2,1)*wprojz(i3,2)
              psig_f(5,i1,i2,i3)=psig_f(5,i1,i2,i3)+wprojx(i1,2)*wprojy(i2,1)*wprojz(i3,2)
              psig_f(6,i1,i2,i3)=psig_f(6,i1,i2,i3)+wprojx(i1,1)*wprojy(i2,2)*wprojz(i3,2)
              psig_f(7,i1,i2,i3)=psig_f(7,i1,i2,i3)+wprojx(i1,2)*wprojy(i2,2)*wprojz(i3,2)
           enddo
        enddo
     enddo
!$omp enddo
!$omp end parallel

  end do

  do itp=2,ntp

     do iterm=1,nterm
        gau_a=xp(iterm)
        n_gau=lx(itp)
        call gauss_to_daub(hx,fac_arr(itp),rx,gau_a,n_gau,n1,ml1,mu1,wprojx(0,1),te,work,nw,&
             perx)
        n_gau=ly(itp)
        call gauss_to_daub(hy,1.0_gp,ry,gau_a,n_gau,n2,ml2,mu2,wprojy(0,1),te,work,nw,pery)
        n_gau=lz(itp)
        call gauss_to_daub(hz,psiat(iterm),rz,gau_a,n_gau,n3,ml3,mu3,wprojz(0,1),te,work,nw,&
             perz)

!$omp parallel default(private) shared(nl3_c,nu3_c,nl2_c,nu2_c,nl1_c,nu1_c,wprojx,wprojy,wprojz) &
!$omp shared(nl3_f,nu3_f,nl2_f,nu2_f,nl1_f,nu1_f,psig_c,psig_f)
  ! First term: coarse projector components
!$omp do
        do i3=nl3_c,nu3_c
           do i2=nl2_c,nu2_c
              do i1=nl1_c,nu1_c
                 psig_c(i1,i2,i3)=psig_c(i1,i2,i3)+wprojx(i1,1)*wprojy(i2,1)*wprojz(i3,1)
              enddo
           enddo
        enddo
!$omp enddo
        ! First term: fine projector components
!$omp do
        do i3=nl3_f,nu3_f
           do i2=nl2_f,nu2_f
              do i1=nl1_f,nu1_f
                 psig_f(1,i1,i2,i3)=psig_f(1,i1,i2,i3)+wprojx(i1,2)*wprojy(i2,1)*wprojz(i3,1)
                 psig_f(2,i1,i2,i3)=psig_f(2,i1,i2,i3)+wprojx(i1,1)*wprojy(i2,2)*wprojz(i3,1)
                 psig_f(3,i1,i2,i3)=psig_f(3,i1,i2,i3)+wprojx(i1,2)*wprojy(i2,2)*wprojz(i3,1)
                 psig_f(4,i1,i2,i3)=psig_f(4,i1,i2,i3)+wprojx(i1,1)*wprojy(i2,1)*wprojz(i3,2)
                 psig_f(5,i1,i2,i3)=psig_f(5,i1,i2,i3)+wprojx(i1,2)*wprojy(i2,1)*wprojz(i3,2)
                 psig_f(6,i1,i2,i3)=psig_f(6,i1,i2,i3)+wprojx(i1,1)*wprojy(i2,2)*wprojz(i3,2)
                 psig_f(7,i1,i2,i3)=psig_f(7,i1,i2,i3)+wprojx(i1,2)*wprojy(i2,2)*wprojz(i3,2)
              enddo
           enddo
        enddo
!$omp enddo
!$omp end parallel
     end do


  end do


!$omp parallel default(private) shared(nseg_c,keyv_c,keyg_c,n1,n2,psi_c,nseg_f,keyv_f,keyg_f) &
!$omp shared(psi_f,psig_c,psig_f)

  !wavefunction compression

  !itp=0
  ! coarse part
!$omp do
  do iseg=1,nseg_c
     jj=keyv_c(iseg)
     j0=keyg_c(1,iseg)
     j1=keyg_c(2,iseg)
     ii=j0-1
     i3=ii/((n1+1)*(n2+1))
     ii=ii-i3*(n1+1)*(n2+1)
     i2=ii/(n1+1)
     i0=ii-i2*(n1+1)
     i1=i0+j1-j0
     do i=i0,i1
        !itp=itp+1
        psi_c(i-i0+jj)=psig_c(i,i2,i3)
     enddo
  enddo
!$omp enddo
  !print *,'nvctr_c',itp,mvctr_c

  !itp=0
  ! fine part
!$omp do
  do iseg=1,nseg_f
     jj=keyv_f(iseg)
     j0=keyg_f(1,iseg)
     j1=keyg_f(2,iseg)
     ii=j0-1
     i3=ii/((n1+1)*(n2+1))
     ii=ii-i3*(n1+1)*(n2+1)
     i2=ii/(n1+1)
     i0=ii-i2*(n1+1)
     i1=i0+j1-j0
     do i=i0,i1
        !itp=itp+1
        psi_f(1,i-i0+jj)=psig_f(1,i,i2,i3)
        psi_f(2,i-i0+jj)=psig_f(2,i,i2,i3)
        psi_f(3,i-i0+jj)=psig_f(3,i,i2,i3)
        psi_f(4,i-i0+jj)=psig_f(4,i,i2,i3)
        psi_f(5,i-i0+jj)=psig_f(5,i,i2,i3)
        psi_f(6,i-i0+jj)=psig_f(6,i,i2,i3)
        psi_f(7,i-i0+jj)=psig_f(7,i,i2,i3)
     enddo
  enddo
!$omp enddo
!$omp end parallel
  !print *,'nvctr_f',itp,mvctr_f

  call f_free(wprojx)
  call f_free(wprojy)
  call f_free(wprojz)
  call f_free(psig_c)
  call f_free(psig_f)

END SUBROUTINE crtonewave
