QuantumPackage/src/tc_bi_ortho/psi_r_l_prov.irp.f

use bitmasks

BEGIN_PROVIDER [ double precision, psi_l_coef_bi_ortho, (psi_det_size,N_states) ]
  implicit none
  BEGIN_DOC
  ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
  ! is empty.
  END_DOC

  integer                        :: i,k, N_int2
  logical                        :: exists
  character*(64)                 :: label

  PROVIDE read_wf N_det mo_label ezfio_filename nproc
  psi_l_coef_bi_ortho = 0.d0
  do i=1,min(N_states,N_det)
    psi_l_coef_bi_ortho(i,i) = 1.d0
  enddo

  if (mpi_master) then
    if (read_wf) then
      call ezfio_has_tc_bi_ortho_psi_l_coef_bi_ortho(exists)
!      if (exists) then
!        call ezfio_has_tc_bi_ortho_mo_label(exists)
!        if (exists) then
!          call ezfio_get_tc_bi_ortho_mo_label(label)
!          exists = (label == mo_label)
!        endif
!      endif

      if (exists) then

        double precision, allocatable  :: psi_l_coef_bi_ortho_read(:,:)
        allocate (psi_l_coef_bi_ortho_read(N_det,N_states))
        print *,  'Read psi_l_coef_bi_ortho', N_det, N_states
        call ezfio_get_tc_bi_ortho_psi_l_coef_bi_ortho(psi_l_coef_bi_ortho_read)
        do k=1,N_states
          do i=1,N_det
            psi_l_coef_bi_ortho(i,k) = psi_l_coef_bi_ortho_read(i,k)
          enddo
        enddo
        deallocate(psi_l_coef_bi_ortho_read)

      else

        print*, 'psi_l_coef_bi_ortho are psi_coef'
        do k=1,N_states
          do i=1,N_det
            psi_l_coef_bi_ortho(i,k) = psi_coef(i,k)
          enddo
        enddo

      endif
    endif
  endif
  IRP_IF MPI_DEBUG
    print *,  irp_here, mpi_rank
    call MPI_BARRIER(MPI_COMM_WORLD, ierr)
  IRP_ENDIF
  IRP_IF MPI
    include 'mpif.h'
    integer                        :: ierr
    call     MPI_BCAST( psi_l_coef_bi_ortho, size(psi_l_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
    if (ierr /= MPI_SUCCESS) then
      stop 'Unable to read psi_l_coef_bi_ortho with MPI'
    endif
  IRP_ENDIF
END_PROVIDER


BEGIN_PROVIDER [ double precision, psi_r_coef_bi_ortho, (psi_det_size,N_states) ]
  implicit none
  BEGIN_DOC
  ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
  ! is empty.
  END_DOC

  integer                        :: i,k, N_int2
  logical                        :: exists
  character*(64)                 :: label

  PROVIDE read_wf N_det mo_label ezfio_filename nproc
  psi_r_coef_bi_ortho = 0.d0
  do i=1,min(N_states,N_det)
    psi_r_coef_bi_ortho(i,i) = 1.d0
  enddo

  if (mpi_master) then
    if (read_wf) then
      call ezfio_has_tc_bi_ortho_psi_r_coef_bi_ortho(exists)
!      if (exists) then
!        call ezfio_has_tc_bi_ortho_mo_label(exists)
!        if (exists) then
!          call ezfio_get_tc_bi_ortho_mo_label(label)
!          exists = (label == mo_label)
!        endif
!      endif

      if (exists) then

        double precision, allocatable  :: psi_r_coef_bi_ortho_read(:,:)
        allocate (psi_r_coef_bi_ortho_read(N_det,N_states))
        print *,  'Read psi_r_coef_bi_ortho', N_det, N_states
        call ezfio_get_tc_bi_ortho_psi_r_coef_bi_ortho(psi_r_coef_bi_ortho_read)
        do k=1,N_states
          do i=1,N_det
            psi_r_coef_bi_ortho(i,k) = psi_r_coef_bi_ortho_read(i,k)
          enddo
        enddo
        deallocate(psi_r_coef_bi_ortho_read)

      else

        print*, 'psi_r_coef_bi_ortho are psi_coef'
        do k=1,N_states
          do i=1,N_det
            psi_r_coef_bi_ortho(i,k) = psi_coef(i,k)
          enddo
        enddo

      endif
    endif
  endif
  IRP_IF MPI_DEBUG
    print *,  irp_here, mpi_rank
    call MPI_BARRIER(MPI_COMM_WORLD, ierr)
  IRP_ENDIF
  IRP_IF MPI
    include 'mpif.h'
    integer                        :: ierr
    call     MPI_BCAST( psi_r_coef_bi_ortho, size(psi_r_coef_bi_ortho), MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
    if (ierr /= MPI_SUCCESS) then
      stop 'Unable to read psi_r_coef_bi_ortho with MPI'
    endif
  IRP_ENDIF
END_PROVIDER


subroutine save_tc_wavefunction_general(ndet, nstates, psidet, sze, dim_psicoef, psilcoef, psircoef)
  implicit none
  BEGIN_DOC
  !  Save the wave function into the |EZFIO| file
  END_DOC
  use bitmasks
  include 'constants.include.F'
  integer, intent(in)            :: ndet,nstates,dim_psicoef,sze
  integer(bit_kind), intent(in)  :: psidet(N_int,2,sze)
  double precision, intent(in)   :: psilcoef(dim_psicoef,nstates)
  double precision, intent(in)   :: psircoef(dim_psicoef,nstates)
  integer*8, allocatable         :: psi_det_save(:,:,:)
  double precision, allocatable  :: psil_coef_save(:,:)
  double precision, allocatable  :: psir_coef_save(:,:)

  double precision               :: accu_norm
  integer                        :: i,j,k, ndet_qp_edit

  if (mpi_master) then
    ndet_qp_edit = min(ndet,N_det_qp_edit)

    call ezfio_set_determinants_N_int(N_int)
    call ezfio_set_determinants_bit_kind(bit_kind)
    call ezfio_set_determinants_N_det(ndet)
    call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
    call ezfio_set_determinants_n_states(nstates)
    call ezfio_set_determinants_mo_label(mo_label)

    allocate (psi_det_save(N_int,2,ndet))
    do i=1,ndet
      do j=1,2
        do k=1,N_int
          psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
        enddo
      enddo
    enddo
    call ezfio_set_determinants_psi_det(psi_det_save)
    call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
    deallocate (psi_det_save)

    allocate (psil_coef_save(ndet,nstates),psir_coef_save(ndet,nstates))
    do k=1,nstates
      do i=1,ndet
        psil_coef_save(i,k) = psilcoef(i,k)
        psir_coef_save(i,k) = psircoef(i,k)
      enddo
    enddo

    call ezfio_set_tc_bi_ortho_psi_l_coef_bi_ortho(psil_coef_save)
    call ezfio_set_tc_bi_ortho_psi_r_coef_bi_ortho(psir_coef_save)
    deallocate (psil_coef_save,psir_coef_save)

    call write_int(6,ndet,'Saved determinantsi and psi_r/psi_l coef')
  endif
end

! ---

subroutine save_tc_bi_ortho_wavefunction()

  implicit none

  if(save_sorted_tc_wf) then

    call save_tc_wavefunction_general( N_det, N_states, psi_det_sorted_tc, size(psi_det_sorted_tc, 3) &
                                     , size(psi_l_coef_sorted_bi_ortho, 1), psi_l_coef_sorted_bi_ortho, psi_r_coef_sorted_bi_ortho)
    call routine_save_right_sorted_bi_ortho()

  else

    call save_tc_wavefunction_general( N_det, N_states, psi_det, size(psi_det, 3) &
                                     , size(psi_l_coef_bi_ortho, 1), psi_l_coef_bi_ortho, psi_r_coef_bi_ortho )
    call routine_save_right_bi_ortho()

  endif

end

! ---

subroutine routine_save_right_sorted_bi_ortho()

  implicit none
  integer                       :: i
  double precision, allocatable :: coef_tmp(:,:)

  allocate(coef_tmp(N_det, N_states))
  do i = 1, N_det
    coef_tmp(i,1:N_states) = psi_r_coef_sorted_bi_ortho(i,1:N_states)
  enddo
  call save_wavefunction_general_unormalized(N_det, N_states, psi_det_sorted_tc, size(coef_tmp, 1), coef_tmp(1,1))
  deallocate(coef_tmp)

end

subroutine routine_save_left_right_sorted_bi_ortho()

  implicit none
  integer                       :: i, n_states_tmp
  double precision, allocatable :: coef_tmp(:,:)

  n_states_tmp = 2
  allocate(coef_tmp(N_det, n_states_tmp))
  do i = 1, N_det
    coef_tmp(i,1) = psi_r_coef_bi_ortho(i,1)
    coef_tmp(i,2) = psi_l_coef_bi_ortho(i,1)
  enddo
  call save_wavefunction_general_unormalized(N_det, n_states_tmp, psi_det, size(coef_tmp, 1), coef_tmp(1,1))
  deallocate(coef_tmp)
end

! ---

subroutine routine_save_right_bi_ortho()

  implicit none
  integer                       :: i
  double precision, allocatable :: coef_tmp(:,:)

  allocate(coef_tmp(N_det, N_states))
  do i = 1, N_det
    coef_tmp(i,1:N_states) = psi_r_coef_bi_ortho(i,1:N_states)
  enddo
  call save_wavefunction_general_unormalized(N_det, N_states, psi_det, size(coef_tmp, 1), coef_tmp(1,1))
  deallocate(coef_tmp)

end

! ---