From b12e898b116b930b6497edf003a4cfae9a1575e3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 19 Apr 2017 15:56:04 +0200 Subject: [PATCH] Fixed selection --- plugins/Full_CI_ZMQ/run_selection_slave.irp.f | 3 + plugins/Full_CI_ZMQ/selection_buffer.irp.f | 15 +++-- src/Utils/sort.irp.f | 59 +++++-------------- 3 files changed, 27 insertions(+), 50 deletions(-) diff --git a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f index 9ea942a5..bfc099e2 100644 --- a/plugins/Full_CI_ZMQ/run_selection_slave.irp.f +++ b/plugins/Full_CI_ZMQ/run_selection_slave.irp.f @@ -61,6 +61,9 @@ subroutine run_selection_slave(thread,iproc,energy) call push_selection_results(zmq_socket_push, pt2, buf, task_id(1), ctask) do i=1,buf%cur call add_to_selection_buffer(buf2, buf%det(1,1,i), buf%val(i)) + if (buf2%cur == buf2%N) then + call sort_selection_buffer(buf2) + endif enddo buf%mini = buf2%mini pt2 = 0d0 diff --git a/plugins/Full_CI_ZMQ/selection_buffer.irp.f b/plugins/Full_CI_ZMQ/selection_buffer.irp.f index 28ceaae3..8a067357 100644 --- a/plugins/Full_CI_ZMQ/selection_buffer.irp.f +++ b/plugins/Full_CI_ZMQ/selection_buffer.irp.f @@ -41,6 +41,7 @@ subroutine sort_selection_buffer(b) implicit none type(selection_buffer), intent(inout) :: b + double precision, allocatable:: absval(:) integer, allocatable :: iorder(:) double precision, pointer :: vals(:) integer(bit_kind), pointer :: detmp(:,:,:) @@ -48,23 +49,25 @@ subroutine sort_selection_buffer(b) logical, external :: detEq nmwen = min(b%N, b%cur) - allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), vals(size(b%val))) + + allocate(iorder(b%cur), detmp(N_int, 2, size(b%det,3)), absval(b%cur), vals(size(b%val))) + absval = -dabs(b%val(:b%cur)) do i=1,b%cur iorder(i) = i end do - call dsort(b%val, iorder, b%cur) + call dsort(absval, iorder, b%cur) do i=1, nmwen detmp(1:N_int,1,i) = b%det(1:N_int,1,iorder(i)) detmp(1:N_int,2,i) = b%det(1:N_int,2,iorder(i)) vals(i) = b%val(iorder(i)) end do - if (nmwen < b%N) then - vals(nmwen+1) = 0.d0 - endif + do i=nmwen+1, size(vals) + vals(i) = 0.d0 + enddo deallocate(b%det, b%val) b%det => detmp b%val => vals - b%mini = min(b%mini,b%val(1)) + b%mini = max(b%mini,dabs(b%val(b%N))) b%cur = nmwen end subroutine diff --git a/src/Utils/sort.irp.f b/src/Utils/sort.irp.f index f31627f0..e7b40a04 100644 --- a/src/Utils/sort.irp.f +++ b/src/Utils/sort.irp.f @@ -15,17 +15,18 @@ BEGIN_TEMPLATE do i=2,isize xtmp = x(i) i0 = iorder(i) - do j = i-1,1,-1 + j=i-1 + do while (j>0) if ((x(j) <= xtmp)) exit x(j+1) = x(j) iorder(j+1) = iorder(j) + j=j-1 enddo x(j+1) = xtmp iorder(j+1) = i0 enddo end subroutine insertion_$Xsort - subroutine heap_$Xsort(x,iorder,isize) implicit none BEGIN_DOC @@ -164,15 +165,10 @@ BEGIN_TEMPLATE $type, intent(in) :: x(isize) integer, intent(out) :: n integer :: i - if (isize < 2) then - n = 1 - return - endif + n=1 - if (x(1) >= x(2)) then - n=1 - else - n=0 + if (isize < 2) then + return endif do i=2,isize @@ -191,31 +187,6 @@ SUBST [ X, type ] i2 ; integer*2 ;; END_TEMPLATE -!BEGIN_TEMPLATE -! subroutine $Xsort(x,iorder,isize) -! implicit none -! BEGIN_DOC -! ! Sort array x(isize). -! ! iorder in input should be (1,2,3,...,isize), and in output -! ! contains the new order of the elements. -! END_DOC -! integer,intent(in) :: isize -! $type,intent(inout) :: x(isize) -! integer,intent(inout) :: iorder(isize) -! integer :: n -! call sorted_$Xnumber(x,isize,n) -! if ( isize-n < 1000) then -! call insertion_$Xsort(x,iorder,isize) -! else -! call heap_$Xsort(x,iorder,isize) -! endif -! end subroutine $Xsort -! -!SUBST [ X, type ] -! ; real ;; -! d ; double precision ;; -!END_TEMPLATE - BEGIN_TEMPLATE subroutine $Xsort(x,iorder,isize) implicit none @@ -228,14 +199,17 @@ BEGIN_TEMPLATE $type,intent(inout) :: x(isize) integer,intent(inout) :: iorder(isize) integer :: n + if (isize < 2) then + return + endif call sorted_$Xnumber(x,isize,n) if (isize == n) then return endif - if ( isize < 512+n) then + if ( isize < 64+n) then call insertion_$Xsort(x,iorder,isize) else - call $Yradix_sort(x,iorder,isize,-1) + call heap_$Xsort(x,iorder,isize) endif end subroutine $Xsort @@ -314,15 +288,15 @@ BEGIN_TEMPLATE $type :: xtmp integer*8 :: i, i0, j, jmax - do i=1_8,isize + do i=2_8,isize xtmp = x(i) i0 = iorder(i) j = i-1_8 - do while (x(j)0_8) + if (x(j)<=xtmp) exit x(j+1_8) = x(j) iorder(j+1_8) = iorder(j) j = j-1_8 - if (j<1_8) exit enddo x(j+1_8) = xtmp iorder(j+1_8) = i0 @@ -445,11 +419,8 @@ BEGIN_TEMPLATE i0 = 0_$int_type i4 = maxval(x) - if (i4 == 0_$type) then - return - endif - iradix_new = $integer_size-1-leadz(i4) + iradix_new = max($integer_size-1-leadz(i4),1) mask = ibset(0_$type,iradix_new) allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err)