Fixed GPI2

install/scripts/install_gpi2.sh

@@ -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
 }
 

plugins/GPI2/broadcast.irp.f

@@ -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
+
+
+
+

scripts/compilation/qp_create_ninja.py

@@ -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, GPI_LIB, EZFIO_LIB, ZMQ_LIB])
-    str_lib = " ".join([LIB, lib_lapack, lib_gpi2, EZFIO_LIB, ZMQ_LIB])
     l_string.append("LIB = {0} ".format(str_lib))
 
     l_string.append("")

src/AO_Basis/aos.irp.f

@@ -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) ]

src/Determinants/EZFIO.cfg

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

src/Determinants/determinants.irp.f

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