mirror of
https://github.com/LCPQ/quantum_package
synced 2024-06-26 07:02:14 +02:00
Fixed GPI2
This commit is contained in:
parent
c44a660a97
commit
631ef5b54c
|
|
@ -6,9 +6,9 @@ GPI_OPTIONS=--with-ethernet
|
|||
|
||||
function _install()
|
||||
{
|
||||
cd gpi2
|
||||
cd _build/gpi2
|
||||
./install.sh -p $QP_ROOT $GPI_OPTIONS
|
||||
cp src/GASPI.f90 $QP_ROOT/src/plugins/GPI2/
|
||||
cp src/GASPI.f90 $QP_ROOT/plugins/GPI2/
|
||||
return 0
|
||||
}
|
||||
|
||||
|
|
|
|||
254
plugins/GPI2/broadcast.irp.f
Normal file
254
plugins/GPI2/broadcast.irp.f
Normal file
|
|
@ -0,0 +1,254 @@
|
|||
subroutine broadcast_wf(energy)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Segment corresponding to the wave function. This is segment 0.
|
||||
END_DOC
|
||||
use bitmasks
|
||||
use GASPI
|
||||
use ISO_C_BINDING
|
||||
|
||||
double precision, intent(inout) :: energy(N_states)
|
||||
integer(gaspi_return_t) :: res
|
||||
|
||||
if (is_gaspi_master) then
|
||||
call broadcast_wf_put(energy)
|
||||
else
|
||||
call broadcast_wf_get(energy)
|
||||
endif
|
||||
|
||||
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_barrier failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
|
||||
integer(gaspi_segment_id_t) :: seg_id
|
||||
do seg_id=0,3
|
||||
res = gaspi_segment_delete(seg_id)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_segment_delete failed", seg_id
|
||||
stop -1
|
||||
end if
|
||||
end do
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine broadcast_wf_put(energy)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Segment corresponding to the wave function. This is segment 0.
|
||||
END_DOC
|
||||
use bitmasks
|
||||
use GASPI
|
||||
use ISO_C_BINDING
|
||||
|
||||
double precision, intent(in) :: energy(N_states)
|
||||
integer(gaspi_segment_id_t) :: seg_id
|
||||
integer(gaspi_alloc_t) :: seg_alloc_policy
|
||||
integer(gaspi_size_t) :: seg_size(0:3)
|
||||
type(c_ptr) :: seg_ptr(0:3)
|
||||
integer, pointer :: params_int(:) ! Segment 0
|
||||
double precision, pointer :: psi_coef_tmp(:,:) ! Segment 1
|
||||
integer(bit_kind), pointer :: psi_det_tmp(:,:,:) ! Segment 2
|
||||
double precision, pointer :: params_double(:) ! Segment 3
|
||||
|
||||
integer(gaspi_return_t) :: res
|
||||
|
||||
|
||||
seg_alloc_policy = GASPI_MEM_UNINITIALIZED
|
||||
|
||||
seg_size(0) = 4 * 5
|
||||
seg_id=0
|
||||
res = gaspi_segment_create(seg_id, seg_size(seg_id), GASPI_GROUP_ALL, &
|
||||
GASPI_BLOCK, seg_alloc_policy)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_create_segment failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
res = gaspi_segment_ptr(seg_id, seg_ptr(seg_id))
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_segment_ptr failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
call c_f_pointer(seg_ptr(0), params_int, shape=(/ 5 /))
|
||||
params_int(1) = N_states
|
||||
params_int(2) = N_det
|
||||
params_int(3) = psi_det_size
|
||||
|
||||
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_barrier failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
seg_size(1) = 8 * psi_det_size * N_states
|
||||
seg_size(2) = bit_kind * psi_det_size * 2 * N_int
|
||||
seg_size(3) = 8 * N_states
|
||||
|
||||
do seg_id=1, 3
|
||||
res = gaspi_segment_create(seg_id, seg_size(seg_id), GASPI_GROUP_ALL, &
|
||||
GASPI_BLOCK, seg_alloc_policy)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_create_segment failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
res = gaspi_segment_ptr(seg_id, seg_ptr(seg_id))
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_segment_ptr failed"
|
||||
stop -1
|
||||
end if
|
||||
end do
|
||||
|
||||
call c_f_pointer(seg_ptr(1), psi_coef_tmp, shape=shape(psi_coef))
|
||||
call c_f_pointer(seg_ptr(2), psi_det_tmp, shape=shape(psi_det))
|
||||
call c_f_pointer(seg_ptr(3), params_double, shape=(/ N_states /))
|
||||
|
||||
psi_coef_tmp = psi_coef
|
||||
psi_det_tmp = psi_det
|
||||
params_double = energy
|
||||
|
||||
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_barrier failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
subroutine broadcast_wf_get(energy)
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! Segment corresponding to the wave function. This is segment 0.
|
||||
END_DOC
|
||||
use bitmasks
|
||||
use GASPI
|
||||
use ISO_C_BINDING
|
||||
|
||||
double precision, intent(out) :: energy(N_states)
|
||||
integer(gaspi_segment_id_t) :: seg_id
|
||||
integer(gaspi_alloc_t) :: seg_alloc_policy
|
||||
integer(gaspi_size_t) :: seg_size(0:3)
|
||||
type(c_ptr) :: seg_ptr(0:3)
|
||||
integer, pointer :: params_int(:) ! Segment 0
|
||||
double precision, pointer :: psi_coef_tmp(:,:) ! Segment 1
|
||||
integer(bit_kind), pointer :: psi_det_tmp(:,:,:) ! Segment 2
|
||||
double precision, pointer :: params_double(:) ! Segment 3
|
||||
|
||||
integer(gaspi_return_t) :: res
|
||||
|
||||
|
||||
seg_alloc_policy = GASPI_MEM_UNINITIALIZED
|
||||
|
||||
seg_size(0) = 4 * 5
|
||||
seg_id=0
|
||||
res = gaspi_segment_create(seg_id, seg_size(seg_id), GASPI_GROUP_ALL,&
|
||||
GASPI_BLOCK, seg_alloc_policy)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_create_segment failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
res = gaspi_segment_ptr(seg_id, seg_ptr(seg_id))
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_segment_ptr failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_barrier failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
integer(gaspi_offset_t) :: localOff, remoteOff
|
||||
integer(gaspi_rank_t) :: remoteRank
|
||||
integer(gaspi_queue_id_t) :: queue
|
||||
localOff = 0
|
||||
remoteRank = 0
|
||||
queue = 0
|
||||
res = gaspi_read(seg_id, localOff, remoteRank, &
|
||||
seg_id, remoteOff, seg_size(seg_id), queue, GASPI_BLOCK)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_read failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
res = gaspi_wait(queue, GASPI_BLOCK)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_wait failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
call c_f_pointer(seg_ptr(0), params_int, shape=shape( (/ 5 /) ))
|
||||
|
||||
N_states = params_int(1)
|
||||
N_det = params_int(2)
|
||||
psi_det_size = params_int(3)
|
||||
TOUCH N_states N_det psi_det_size
|
||||
|
||||
seg_size(1) = 8 * psi_det_size * N_states
|
||||
seg_size(2) = bit_kind * psi_det_size * 2 * N_int
|
||||
seg_size(3) = 8 * N_states
|
||||
|
||||
do seg_id=1, 3
|
||||
res = gaspi_segment_create(seg_id, seg_size(seg_id), GASPI_GROUP_ALL, &
|
||||
GASPI_BLOCK, seg_alloc_policy)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_create_segment failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
res = gaspi_segment_ptr(seg_id, seg_ptr(seg_id))
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_segment_ptr failed"
|
||||
stop -1
|
||||
end if
|
||||
end do
|
||||
|
||||
res = gaspi_barrier(GASPI_GROUP_ALL, GASPI_BLOCK)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_barrier failed"
|
||||
stop -1
|
||||
end if
|
||||
|
||||
do seg_id=1, 3
|
||||
res = gaspi_read(seg_id, localOff, remoteRank, &
|
||||
seg_id, remoteOff, seg_size(seg_id), queue, GASPI_BLOCK)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_read failed"
|
||||
stop -1
|
||||
end if
|
||||
res = gaspi_wait(queue, GASPI_BLOCK)
|
||||
if(res .ne. GASPI_SUCCESS) then
|
||||
write(*,*) "gaspi_wait failed"
|
||||
stop -1
|
||||
end if
|
||||
end do
|
||||
|
||||
call c_f_pointer(seg_ptr(1), psi_coef_tmp, shape=shape(psi_coef))
|
||||
call c_f_pointer(seg_ptr(2), psi_det_tmp, shape=shape(psi_det))
|
||||
call c_f_pointer(seg_ptr(3), params_double, shape=shape(energy))
|
||||
|
||||
psi_coef = psi_coef_tmp
|
||||
psi_det = psi_det_tmp
|
||||
energy = params_double
|
||||
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -36,6 +36,7 @@ except ImportError:
|
|||
from qp_path import QP_ROOT, QP_SRC, QP_EZFIO
|
||||
|
||||
LIB = "" # join(QP_ROOT, "lib", "rdtsc.o")
|
||||
GPI_LIB = join(QP_ROOT, "lib64", "libGPI2.a")
|
||||
EZFIO_LIB = join(QP_ROOT, "lib", "libezfio_irp.a")
|
||||
ZMQ_LIB = join(QP_ROOT, "lib", "libf77zmq.a") + " " + join(QP_ROOT, "lib", "libzmq.a") + " -lstdc++ -lrt"
|
||||
ROOT_BUILD_NINJA = join(QP_ROOT, "config", "build.ninja")
|
||||
|
|
@ -96,8 +97,7 @@ def ninja_create_env_variable(pwd_config_file):
|
|||
l_string.append(str_)
|
||||
|
||||
lib_lapack = get_compilation_option(pwd_config_file, "LAPACK_LIB")
|
||||
lib_gpi2 = get_compilation_option(pwd_config_file, "GPI2_LIB")
|
||||
str_lib = " ".join([LIB, lib_lapack, lib_gpi2, EZFIO_LIB, ZMQ_LIB])
|
||||
str_lib = " ".join([LIB, lib_lapack, GPI_LIB, EZFIO_LIB, ZMQ_LIB])
|
||||
l_string.append("LIB = {0} ".format(str_lib))
|
||||
|
||||
l_string.append("")
|
||||
|
|
|
|||
|
|
@ -10,13 +10,10 @@ BEGIN_PROVIDER [ integer, ao_num_align ]
|
|||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ integer, ao_prim_num_max ]
|
||||
&BEGIN_PROVIDER [ integer, ao_prim_num_max_align ]
|
||||
implicit none
|
||||
ao_prim_num_max = 0
|
||||
PROVIDE ezfio_filename
|
||||
call ezfio_get_ao_basis_ao_prim_num_max(ao_prim_num_max)
|
||||
integer :: align_double
|
||||
ao_prim_num_max_align = align_double(ao_prim_num_max)
|
||||
END_PROVIDER
|
||||
|
||||
BEGIN_PROVIDER [ double precision, ao_coef_normalized, (ao_num_align,ao_prim_num_max) ]
|
||||
|
|
|
|||
|
|
@ -97,7 +97,7 @@ type: double precision
|
|||
size: (determinants.n_det)
|
||||
|
||||
[expected_s2]
|
||||
interface: ezfio,provider
|
||||
interface: ezfio
|
||||
doc: Expected value of S^2
|
||||
type: double precision
|
||||
|
||||
|
|
|
|||
|
|
@ -133,115 +133,6 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ]
|
|||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ integer(bit_kind), psi_occ_pattern, (N_int,2,psi_det_size) ]
|
||||
&BEGIN_PROVIDER [ integer, N_occ_pattern ]
|
||||
implicit none
|
||||
BEGIN_DOC
|
||||
! array of the occ_pattern present in the wf
|
||||
! psi_occ_pattern(:,1,j) = jth occ_pattern of the wave function : represent all the single occupation
|
||||
! psi_occ_pattern(:,2,j) = jth occ_pattern of the wave function : represent all the double occupation
|
||||
END_DOC
|
||||
integer :: i,j,k
|
||||
|
||||
! create
|
||||
do i = 1, N_det
|
||||
do k = 1, N_int
|
||||
psi_occ_pattern(k,1,i) = ieor(psi_det(k,1,i),psi_det(k,2,i))
|
||||
psi_occ_pattern(k,2,i) = iand(psi_det(k,1,i),psi_det(k,2,i))
|
||||
enddo
|
||||
enddo
|
||||
|
||||
! Sort
|
||||
integer, allocatable :: iorder(:)
|
||||
integer*8, allocatable :: bit_tmp(:)
|
||||
integer*8, external :: occ_pattern_search_key
|
||||
integer(bit_kind), allocatable :: tmp_array(:,:,:)
|
||||
logical,allocatable :: duplicate(:)
|
||||
|
||||
|
||||
allocate ( iorder(N_det), duplicate(N_det), bit_tmp(N_det), tmp_array(N_int,2,psi_det_size) )
|
||||
|
||||
do i=1,N_det
|
||||
iorder(i) = i
|
||||
!$DIR FORCEINLINE
|
||||
bit_tmp(i) = occ_pattern_search_key(psi_occ_pattern(1,1,i),N_int)
|
||||
enddo
|
||||
call i8sort(bit_tmp,iorder,N_det)
|
||||
!DIR$ IVDEP
|
||||
do i=1,N_det
|
||||
do k=1,N_int
|
||||
tmp_array(k,1,i) = psi_occ_pattern(k,1,iorder(i))
|
||||
tmp_array(k,2,i) = psi_occ_pattern(k,2,iorder(i))
|
||||
enddo
|
||||
duplicate(i) = .False.
|
||||
enddo
|
||||
|
||||
i=1
|
||||
integer (bit_kind) :: occ_pattern_tmp
|
||||
do i=1,N_det
|
||||
duplicate(i) = .False.
|
||||
enddo
|
||||
|
||||
do i=1,N_det-1
|
||||
if (duplicate(i)) then
|
||||
cycle
|
||||
endif
|
||||
j = i+1
|
||||
do while (bit_tmp(j)==bit_tmp(i))
|
||||
if (duplicate(j)) then
|
||||
j+=1
|
||||
cycle
|
||||
endif
|
||||
duplicate(j) = .True.
|
||||
do k=1,N_int
|
||||
if ( (tmp_array(k,1,i) /= tmp_array(k,1,j)) &
|
||||
.or. (tmp_array(k,2,i) /= tmp_array(k,2,j)) ) then
|
||||
duplicate(j) = .False.
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
j+=1
|
||||
if (j>N_det) then
|
||||
exit
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
|
||||
N_occ_pattern=0
|
||||
do i=1,N_det
|
||||
if (duplicate(i)) then
|
||||
cycle
|
||||
endif
|
||||
N_occ_pattern += 1
|
||||
do k=1,N_int
|
||||
psi_occ_pattern(k,1,N_occ_pattern) = tmp_array(k,1,i)
|
||||
psi_occ_pattern(k,2,N_occ_pattern) = tmp_array(k,2,i)
|
||||
enddo
|
||||
enddo
|
||||
|
||||
deallocate(iorder,duplicate,bit_tmp,tmp_array)
|
||||
! !TODO DEBUG
|
||||
! integer :: s
|
||||
! do i=1,N_occ_pattern
|
||||
! do j=i+1,N_occ_pattern
|
||||
! s = 0
|
||||
! do k=1,N_int
|
||||
! if((psi_occ_pattern(k,1,j) /= psi_occ_pattern(k,1,i)).or. &
|
||||
! (psi_occ_pattern(k,2,j) /= psi_occ_pattern(k,2,i))) then
|
||||
! s=1
|
||||
! exit
|
||||
! endif
|
||||
! enddo
|
||||
! if ( s == 0 ) then
|
||||
! print *, 'Error : occ ', j, 'already in wf'
|
||||
! call debug_det(psi_occ_pattern(1,1,j),N_int)
|
||||
! stop
|
||||
! endif
|
||||
! enddo
|
||||
! enddo
|
||||
! !TODO DEBUG
|
||||
END_PROVIDER
|
||||
|
||||
|
||||
BEGIN_PROVIDER [ double precision, psi_coef, (psi_det_size,N_states) ]
|
||||
implicit none
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user