mirror of
https://github.com/QuantumPackage/qp2.git
synced 2024-08-30 04:33:41 +02:00
Merge branch 'dev-stable' of https://github.com/QuantumPackage/qp2 into dev-stable
Some checks failed
continuous-integration/drone/push Build is failing
Some checks failed
continuous-integration/drone/push Build is failing
This commit is contained in:
commit
e68c2cbf4b
@ -8,6 +8,7 @@
|
|||||||
- Use OpamPack for OCaml
|
- Use OpamPack for OCaml
|
||||||
- Configure adapted for ARM
|
- Configure adapted for ARM
|
||||||
- Added many types of integrals
|
- Added many types of integrals
|
||||||
|
- Accelerated four-index transformation
|
||||||
|
|
||||||
*** TODO: take from dev
|
*** TODO: take from dev
|
||||||
- [ ] Added GTOs with complex exponent
|
- [ ] Added GTOs with complex exponent
|
||||||
|
2
external/qp2-dependencies
vendored
2
external/qp2-dependencies
vendored
@ -1 +1 @@
|
|||||||
Subproject commit f40bde0925808bbec0424b57bfcef1b26473a1c8
|
Subproject commit b8cd5815bce14c9b880e3c5ea3d5fc2652f5955c
|
@ -70,8 +70,8 @@ subroutine run_cipsi
|
|||||||
|
|
||||||
do while ( &
|
do while ( &
|
||||||
(N_det < N_det_max) .and. &
|
(N_det < N_det_max) .and. &
|
||||||
(sum(abs(pt2_data % pt2(1:N_states)) * state_average_weight(1:N_states)) > pt2_max) .and. &
|
(maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and. &
|
||||||
(sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and. &
|
(maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and. &
|
||||||
(correlation_energy_ratio <= correlation_energy_ratio_max) &
|
(correlation_energy_ratio <= correlation_energy_ratio_max) &
|
||||||
)
|
)
|
||||||
write(*,'(A)') '--------------------------------------------------------------------------------'
|
write(*,'(A)') '--------------------------------------------------------------------------------'
|
||||||
|
@ -31,11 +31,12 @@ subroutine run_pt2_slave(thread,iproc,energy)
|
|||||||
|
|
||||||
double precision, intent(in) :: energy(N_states_diag)
|
double precision, intent(in) :: energy(N_states_diag)
|
||||||
integer, intent(in) :: thread, iproc
|
integer, intent(in) :: thread, iproc
|
||||||
if (N_det > 100000 ) then
|
call run_pt2_slave_large(thread,iproc,energy)
|
||||||
call run_pt2_slave_large(thread,iproc,energy)
|
! if (N_det > 100000 ) then
|
||||||
else
|
! call run_pt2_slave_large(thread,iproc,energy)
|
||||||
call run_pt2_slave_small(thread,iproc,energy)
|
! else
|
||||||
endif
|
! call run_pt2_slave_small(thread,iproc,energy)
|
||||||
|
! endif
|
||||||
end
|
end
|
||||||
|
|
||||||
subroutine run_pt2_slave_small(thread,iproc,energy)
|
subroutine run_pt2_slave_small(thread,iproc,energy)
|
||||||
@ -66,6 +67,7 @@ subroutine run_pt2_slave_small(thread,iproc,energy)
|
|||||||
|
|
||||||
double precision, external :: memory_of_double, memory_of_int
|
double precision, external :: memory_of_double, memory_of_int
|
||||||
integer :: bsize ! Size of selection buffers
|
integer :: bsize ! Size of selection buffers
|
||||||
|
! logical :: sending
|
||||||
|
|
||||||
allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max))
|
allocate(task_id(pt2_n_tasks_max), task(pt2_n_tasks_max))
|
||||||
allocate(pt2_data(pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max))
|
allocate(pt2_data(pt2_n_tasks_max), i_generator(pt2_n_tasks_max), subset(pt2_n_tasks_max))
|
||||||
@ -162,11 +164,6 @@ end subroutine
|
|||||||
subroutine run_pt2_slave_large(thread,iproc,energy)
|
subroutine run_pt2_slave_large(thread,iproc,energy)
|
||||||
use selection_types
|
use selection_types
|
||||||
use f77_zmq
|
use f77_zmq
|
||||||
BEGIN_DOC
|
|
||||||
! This subroutine can miss important determinants when the PT2 is completely
|
|
||||||
! computed. It should be called only for large workloads where the PT2 is
|
|
||||||
! interrupted before the end
|
|
||||||
END_DOC
|
|
||||||
implicit none
|
implicit none
|
||||||
|
|
||||||
double precision, intent(in) :: energy(N_states_diag)
|
double precision, intent(in) :: energy(N_states_diag)
|
||||||
@ -192,12 +189,8 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
|
|||||||
|
|
||||||
integer :: bsize ! Size of selection buffers
|
integer :: bsize ! Size of selection buffers
|
||||||
logical :: sending
|
logical :: sending
|
||||||
double precision :: time_shift
|
|
||||||
|
|
||||||
PROVIDE global_selection_buffer global_selection_buffer_lock
|
PROVIDE global_selection_buffer global_selection_buffer_lock
|
||||||
|
|
||||||
call random_number(time_shift)
|
|
||||||
time_shift = time_shift*15.d0
|
|
||||||
|
|
||||||
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
|
||||||
|
|
||||||
@ -215,9 +208,6 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
|
|||||||
|
|
||||||
sending = .False.
|
sending = .False.
|
||||||
done = .False.
|
done = .False.
|
||||||
double precision :: time0, time1
|
|
||||||
call wall_time(time0)
|
|
||||||
time0 = time0+time_shift
|
|
||||||
do while (.not.done)
|
do while (.not.done)
|
||||||
|
|
||||||
integer, external :: get_tasks_from_taskserver
|
integer, external :: get_tasks_from_taskserver
|
||||||
@ -244,28 +234,25 @@ subroutine run_pt2_slave_large(thread,iproc,energy)
|
|||||||
ASSERT (b%N == bsize)
|
ASSERT (b%N == bsize)
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
double precision :: time0, time1
|
||||||
|
call wall_time(time0)
|
||||||
call pt2_alloc(pt2_data,N_states)
|
call pt2_alloc(pt2_data,N_states)
|
||||||
b%cur = 0
|
b%cur = 0
|
||||||
call select_connected(i_generator,energy,pt2_data,b,subset,pt2_F(i_generator))
|
call select_connected(i_generator,energy,pt2_data,b,subset,pt2_F(i_generator))
|
||||||
|
call wall_time(time1)
|
||||||
|
|
||||||
integer, external :: tasks_done_to_taskserver
|
integer, external :: tasks_done_to_taskserver
|
||||||
if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
|
if (tasks_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id,n_tasks) == -1) then
|
||||||
done = .true.
|
done = .true.
|
||||||
endif
|
endif
|
||||||
call sort_selection_buffer(b)
|
call sort_selection_buffer(b)
|
||||||
|
|
||||||
call wall_time(time1)
|
|
||||||
! if (time1-time0 > 15.d0) then
|
|
||||||
call omp_set_lock(global_selection_buffer_lock)
|
|
||||||
global_selection_buffer%mini = b%mini
|
|
||||||
call merge_selection_buffers(b,global_selection_buffer)
|
|
||||||
b%cur=0
|
|
||||||
call omp_unset_lock(global_selection_buffer_lock)
|
|
||||||
call wall_time(time0)
|
|
||||||
! endif
|
|
||||||
|
|
||||||
call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
|
call push_pt2_results_async_recv(zmq_socket_push,b%mini,sending)
|
||||||
if ( iproc == 1 .or. i_generator < 100 .or. done) then
|
call omp_set_lock(global_selection_buffer_lock)
|
||||||
|
global_selection_buffer%mini = b%mini
|
||||||
|
call merge_selection_buffers(b,global_selection_buffer)
|
||||||
|
b%cur=0
|
||||||
|
call omp_unset_lock(global_selection_buffer_lock)
|
||||||
|
if ( iproc == 1 ) then
|
||||||
call omp_set_lock(global_selection_buffer_lock)
|
call omp_set_lock(global_selection_buffer_lock)
|
||||||
call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), global_selection_buffer, (/task_id/), 1,sending)
|
call push_pt2_results_async_send(zmq_socket_push, (/i_generator/), (/pt2_data/), global_selection_buffer, (/task_id/), 1,sending)
|
||||||
global_selection_buffer%cur = 0
|
global_selection_buffer%cur = 0
|
||||||
|
@ -69,8 +69,8 @@ subroutine run_stochastic_cipsi
|
|||||||
|
|
||||||
do while ( &
|
do while ( &
|
||||||
(N_det < N_det_max) .and. &
|
(N_det < N_det_max) .and. &
|
||||||
(sum(abs(pt2_data % pt2(1:N_states)) * state_average_weight(1:N_states)) > pt2_max) .and. &
|
(maxval(abs(pt2_data % pt2(1:N_states))) > pt2_max) .and. &
|
||||||
(sum(abs(pt2_data % variance(1:N_states)) * state_average_weight(1:N_states)) > variance_max) .and. &
|
(maxval(abs(pt2_data % variance(1:N_states))) > variance_max) .and. &
|
||||||
(correlation_energy_ratio <= correlation_energy_ratio_max) &
|
(correlation_energy_ratio <= correlation_energy_ratio_max) &
|
||||||
)
|
)
|
||||||
write(*,'(A)') '--------------------------------------------------------------------------------'
|
write(*,'(A)') '--------------------------------------------------------------------------------'
|
||||||
|
@ -49,7 +49,6 @@ subroutine create_guess
|
|||||||
if (.not.exists) then
|
if (.not.exists) then
|
||||||
mo_label = 'Guess'
|
mo_label = 'Guess'
|
||||||
if (mo_guess_type == "HCore") then
|
if (mo_guess_type == "HCore") then
|
||||||
mo_coef = ao_ortho_lowdin_coef
|
|
||||||
call restore_symmetry(ao_num,mo_num,mo_coef,size(mo_coef,1),1.d-10)
|
call restore_symmetry(ao_num,mo_num,mo_coef,size(mo_coef,1),1.d-10)
|
||||||
TOUCH mo_coef
|
TOUCH mo_coef
|
||||||
call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals, &
|
call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals, &
|
||||||
|
@ -235,11 +235,11 @@ subroutine get_mo_two_e_integrals_erf_ij(k,l,sze,out_array,map)
|
|||||||
|
|
||||||
logical :: integral_is_in_map
|
logical :: integral_is_in_map
|
||||||
if (key_kind == 8) then
|
if (key_kind == 8) then
|
||||||
call i8radix_sort(hash,iorder,kk,-1)
|
call i8sort(hash,iorder,kk)
|
||||||
else if (key_kind == 4) then
|
else if (key_kind == 4) then
|
||||||
call iradix_sort(hash,iorder,kk,-1)
|
call isort(hash,iorder,kk)
|
||||||
else if (key_kind == 2) then
|
else if (key_kind == 2) then
|
||||||
call i2radix_sort(hash,iorder,kk,-1)
|
call i2sort(hash,iorder,kk)
|
||||||
endif
|
endif
|
||||||
|
|
||||||
call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk)
|
call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk)
|
||||||
@ -290,11 +290,11 @@ subroutine get_mo_two_e_integrals_erf_i1j1(k,l,sze,out_array,map)
|
|||||||
|
|
||||||
logical :: integral_is_in_map
|
logical :: integral_is_in_map
|
||||||
if (key_kind == 8) then
|
if (key_kind == 8) then
|
||||||
call i8radix_sort(hash,iorder,kk,-1)
|
call i8sort(hash,iorder,kk)
|
||||||
else if (key_kind == 4) then
|
else if (key_kind == 4) then
|
||||||
call iradix_sort(hash,iorder,kk,-1)
|
call isort(hash,iorder,kk)
|
||||||
else if (key_kind == 2) then
|
else if (key_kind == 2) then
|
||||||
call i2radix_sort(hash,iorder,kk,-1)
|
call i2sort(hash,iorder,kk)
|
||||||
endif
|
endif
|
||||||
|
|
||||||
call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk)
|
call map_get_many(mo_integrals_erf_map, hash, tmp_val, kk)
|
||||||
|
@ -53,7 +53,7 @@ BEGIN_PROVIDER [ double precision, h_core_ri, (mo_num, mo_num) ]
|
|||||||
enddo
|
enddo
|
||||||
do k=1,mo_num
|
do k=1,mo_num
|
||||||
do i=1,mo_num
|
do i=1,mo_num
|
||||||
h_core_ri(i,j) = h_core_ri(i,j) - 0.5 * big_array_exchange_integrals(k,i,j)
|
h_core_ri(i,j) = h_core_ri(i,j) - 0.5d0 * big_array_exchange_integrals(k,i,j)
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
enddo
|
enddo
|
||||||
|
@ -53,7 +53,11 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
|
|||||||
! call four_idx_novvvv
|
! call four_idx_novvvv
|
||||||
call four_idx_novvvv_old
|
call four_idx_novvvv_old
|
||||||
else
|
else
|
||||||
call add_integrals_to_map(full_ijkl_bitmask_4)
|
if (dble(ao_num)**4 * 32.d-9 < dble(qp_max_mem)) then
|
||||||
|
call four_idx_dgemm
|
||||||
|
else
|
||||||
|
call add_integrals_to_map(full_ijkl_bitmask_4)
|
||||||
|
endif
|
||||||
endif
|
endif
|
||||||
|
|
||||||
call wall_time(wall_2)
|
call wall_time(wall_2)
|
||||||
@ -77,6 +81,94 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ]
|
|||||||
|
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
subroutine four_idx_dgemm
|
||||||
|
implicit none
|
||||||
|
integer :: p,q,r,s,i,j,k,l
|
||||||
|
double precision, allocatable :: a1(:,:,:,:)
|
||||||
|
double precision, allocatable :: a2(:,:,:,:)
|
||||||
|
|
||||||
|
allocate (a1(ao_num,ao_num,ao_num,ao_num))
|
||||||
|
|
||||||
|
print *, 'Getting AOs'
|
||||||
|
!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(q,r,s)
|
||||||
|
do s=1,ao_num
|
||||||
|
do r=1,ao_num
|
||||||
|
do q=1,ao_num
|
||||||
|
call get_ao_two_e_integrals(q,r,s,ao_num,a1(1,q,r,s))
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END PARALLEL DO
|
||||||
|
|
||||||
|
print *, '1st transformation'
|
||||||
|
! 1st transformation
|
||||||
|
allocate (a2(ao_num,ao_num,ao_num,mo_num))
|
||||||
|
call dgemm('T','N', (ao_num*ao_num*ao_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*ao_num*ao_num))
|
||||||
|
|
||||||
|
! 2nd transformation
|
||||||
|
print *, '2nd transformation'
|
||||||
|
deallocate (a1)
|
||||||
|
allocate (a1(ao_num,ao_num,mo_num,mo_num))
|
||||||
|
call dgemm('T','N', (ao_num*ao_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (ao_num*ao_num*mo_num))
|
||||||
|
|
||||||
|
! 3rd transformation
|
||||||
|
print *, '3rd transformation'
|
||||||
|
deallocate (a2)
|
||||||
|
allocate (a2(ao_num,mo_num,mo_num,mo_num))
|
||||||
|
call dgemm('T','N', (ao_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a1, ao_num, mo_coef, ao_num, 0.d0, a2, (ao_num*mo_num*mo_num))
|
||||||
|
|
||||||
|
! 4th transformation
|
||||||
|
print *, '4th transformation'
|
||||||
|
deallocate (a1)
|
||||||
|
allocate (a1(mo_num,mo_num,mo_num,mo_num))
|
||||||
|
call dgemm('T','N', (mo_num*mo_num*mo_num), mo_num, ao_num, 1.d0, a2, ao_num, mo_coef, ao_num, 0.d0, a1, (mo_num*mo_num*mo_num))
|
||||||
|
|
||||||
|
deallocate (a2)
|
||||||
|
|
||||||
|
integer :: n_integrals, size_buffer
|
||||||
|
integer(key_kind) , allocatable :: buffer_i(:)
|
||||||
|
real(integral_kind), allocatable :: buffer_value(:)
|
||||||
|
size_buffer = min(ao_num*ao_num*ao_num,16000000)
|
||||||
|
|
||||||
|
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l,buffer_value,buffer_i,n_integrals)
|
||||||
|
allocate ( buffer_i(size_buffer), buffer_value(size_buffer) )
|
||||||
|
|
||||||
|
n_integrals = 0
|
||||||
|
!$OMP DO
|
||||||
|
do l=1,mo_num
|
||||||
|
do k=1,mo_num
|
||||||
|
do j=1,l
|
||||||
|
do i=1,k
|
||||||
|
if (abs(a1(i,j,k,l)) < mo_integrals_threshold) then
|
||||||
|
cycle
|
||||||
|
endif
|
||||||
|
n_integrals += 1
|
||||||
|
buffer_value(n_integrals) = a1(i,j,k,l)
|
||||||
|
!DIR$ FORCEINLINE
|
||||||
|
call mo_two_e_integrals_index(i,j,k,l,buffer_i(n_integrals))
|
||||||
|
if (n_integrals == size_buffer) then
|
||||||
|
call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals)
|
||||||
|
n_integrals = 0
|
||||||
|
endif
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
enddo
|
||||||
|
!$OMP END DO
|
||||||
|
|
||||||
|
call map_append(mo_integrals_map, buffer_i, buffer_value, n_integrals)
|
||||||
|
|
||||||
|
deallocate(buffer_i, buffer_value)
|
||||||
|
!$OMP END PARALLEL
|
||||||
|
|
||||||
|
deallocate (a1)
|
||||||
|
|
||||||
|
call map_unique(mo_integrals_map)
|
||||||
|
|
||||||
|
integer*8 :: get_mo_map_size, mo_map_size
|
||||||
|
mo_map_size = get_mo_map_size()
|
||||||
|
|
||||||
|
end subroutine
|
||||||
|
|
||||||
subroutine add_integrals_to_map(mask_ijkl)
|
subroutine add_integrals_to_map(mask_ijkl)
|
||||||
use bitmasks
|
use bitmasks
|
||||||
@ -153,24 +245,26 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
return
|
return
|
||||||
endif
|
endif
|
||||||
|
|
||||||
size_buffer = min(ao_num*ao_num*ao_num,16000000)
|
call wall_time(wall_1)
|
||||||
|
|
||||||
|
size_buffer = min(ao_num*ao_num*ao_num,8000000)
|
||||||
print*, 'Buffers : ', 8.*(mo_num*(n_j)*(n_k+1) + mo_num+&
|
print*, 'Buffers : ', 8.*(mo_num*(n_j)*(n_k+1) + mo_num+&
|
||||||
ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core'
|
ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core'
|
||||||
|
|
||||||
double precision :: accu_bis
|
|
||||||
accu_bis = 0.d0
|
|
||||||
call wall_time(wall_1)
|
|
||||||
|
|
||||||
!$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
|
!$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
|
||||||
!$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,&
|
!$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,&
|
||||||
!$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, &
|
!$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, &
|
||||||
!$OMP wall_0,thread_num,accu_bis) &
|
!$OMP wall_0,thread_num) &
|
||||||
!$OMP DEFAULT(NONE) &
|
!$OMP DEFAULT(NONE) &
|
||||||
!$OMP SHARED(size_buffer,ao_num,mo_num,n_i,n_j,n_k,n_l, &
|
!$OMP SHARED(size_buffer,ao_num,mo_num,n_i,n_j,n_k,n_l, &
|
||||||
!$OMP mo_coef_transp, &
|
!$OMP mo_coef_transp, &
|
||||||
!$OMP mo_coef_transp_is_built, list_ijkl, &
|
!$OMP mo_coef_transp_is_built, list_ijkl, &
|
||||||
!$OMP mo_coef_is_built, wall_1, &
|
!$OMP mo_coef_is_built, wall_1, &
|
||||||
!$OMP mo_coef,mo_integrals_threshold,mo_integrals_map)
|
!$OMP mo_coef,mo_integrals_threshold,mo_integrals_map)
|
||||||
|
|
||||||
|
thread_num = 0
|
||||||
|
!$ thread_num = omp_get_thread_num()
|
||||||
|
|
||||||
n_integrals = 0
|
n_integrals = 0
|
||||||
wall_0 = wall_1
|
wall_0 = wall_1
|
||||||
allocate(two_e_tmp_3(mo_num, n_j, n_k), &
|
allocate(two_e_tmp_3(mo_num, n_j, n_k), &
|
||||||
@ -181,8 +275,6 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
buffer_i(size_buffer), &
|
buffer_i(size_buffer), &
|
||||||
buffer_value(size_buffer) )
|
buffer_value(size_buffer) )
|
||||||
|
|
||||||
thread_num = 0
|
|
||||||
!$ thread_num = omp_get_thread_num()
|
|
||||||
!$OMP DO SCHEDULE(guided)
|
!$OMP DO SCHEDULE(guided)
|
||||||
do l1 = 1,ao_num
|
do l1 = 1,ao_num
|
||||||
two_e_tmp_3 = 0.d0
|
two_e_tmp_3 = 0.d0
|
||||||
@ -340,10 +432,10 @@ subroutine add_integrals_to_map(mask_ijkl)
|
|||||||
!$OMP END DO NOWAIT
|
!$OMP END DO NOWAIT
|
||||||
deallocate (two_e_tmp_1,two_e_tmp_2,two_e_tmp_3)
|
deallocate (two_e_tmp_1,two_e_tmp_2,two_e_tmp_3)
|
||||||
|
|
||||||
integer :: index_needed
|
if (n_integrals > 0) then
|
||||||
|
call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,&
|
||||||
call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,&
|
real(mo_integrals_threshold,integral_kind))
|
||||||
real(mo_integrals_threshold,integral_kind))
|
endif
|
||||||
deallocate(buffer_i, buffer_value)
|
deallocate(buffer_i, buffer_value)
|
||||||
!$OMP END PARALLEL
|
!$OMP END PARALLEL
|
||||||
call map_merge(mo_integrals_map)
|
call map_merge(mo_integrals_map)
|
||||||
@ -433,12 +525,10 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
|
|||||||
|
|
||||||
call wall_time(wall_1)
|
call wall_time(wall_1)
|
||||||
call cpu_time(cpu_1)
|
call cpu_time(cpu_1)
|
||||||
double precision :: accu_bis
|
|
||||||
accu_bis = 0.d0
|
|
||||||
!$OMP PARALLEL PRIVATE(m,l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
|
!$OMP PARALLEL PRIVATE(m,l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, &
|
||||||
!$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,&
|
!$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,&
|
||||||
!$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, &
|
!$OMP buffer_i,buffer_value,n_integrals,wall_2,i0,j0,k0,l0, &
|
||||||
!$OMP wall_0,thread_num,accu_bis) &
|
!$OMP wall_0,thread_num) &
|
||||||
!$OMP DEFAULT(NONE) &
|
!$OMP DEFAULT(NONE) &
|
||||||
!$OMP SHARED(size_buffer,ao_num,mo_num,n_i,n_j,n_k, &
|
!$OMP SHARED(size_buffer,ao_num,mo_num,n_i,n_j,n_k, &
|
||||||
!$OMP mo_coef_transp, &
|
!$OMP mo_coef_transp, &
|
||||||
@ -636,8 +726,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk)
|
|||||||
!$OMP END DO NOWAIT
|
!$OMP END DO NOWAIT
|
||||||
deallocate (two_e_tmp_1,two_e_tmp_2,two_e_tmp_3)
|
deallocate (two_e_tmp_1,two_e_tmp_2,two_e_tmp_3)
|
||||||
|
|
||||||
integer :: index_needed
|
|
||||||
|
|
||||||
call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,&
|
call insert_into_mo_integrals_map(n_integrals,buffer_i,buffer_value,&
|
||||||
real(mo_integrals_threshold,integral_kind))
|
real(mo_integrals_threshold,integral_kind))
|
||||||
deallocate(buffer_i, buffer_value)
|
deallocate(buffer_i, buffer_value)
|
||||||
|
@ -14,6 +14,7 @@ double precision, parameter :: thresh = 1.d-15
|
|||||||
double precision, parameter :: cx_lda = -0.73855876638202234d0
|
double precision, parameter :: cx_lda = -0.73855876638202234d0
|
||||||
double precision, parameter :: c_2_4_3 = 2.5198420997897464d0
|
double precision, parameter :: c_2_4_3 = 2.5198420997897464d0
|
||||||
double precision, parameter :: cst_lda = -0.93052573634909996d0
|
double precision, parameter :: cst_lda = -0.93052573634909996d0
|
||||||
double precision, parameter :: c_4_3 = 1.3333333333333333d0
|
double precision, parameter :: c_4_3 = 4.d0/3.d0
|
||||||
double precision, parameter :: c_1_3 = 0.3333333333333333d0
|
double precision, parameter :: c_1_3 = 1.d0/3.d0
|
||||||
|
double precision, parameter :: sq_op5 = dsqrt(0.5d0)
|
||||||
|
double precision, parameter :: dlog_2pi = dlog(2.d0*dacos(-1.d0))
|
||||||
|
@ -238,11 +238,11 @@ subroutine cache_map_sort(map)
|
|||||||
iorder(i) = i
|
iorder(i) = i
|
||||||
enddo
|
enddo
|
||||||
if (cache_key_kind == 2) then
|
if (cache_key_kind == 2) then
|
||||||
call i2radix_sort(map%key,iorder,map%n_elements,-1)
|
call i2sort(map%key,iorder,map%n_elements,-1)
|
||||||
else if (cache_key_kind == 4) then
|
else if (cache_key_kind == 4) then
|
||||||
call iradix_sort(map%key,iorder,map%n_elements,-1)
|
call isort(map%key,iorder,map%n_elements,-1)
|
||||||
else if (cache_key_kind == 8) then
|
else if (cache_key_kind == 8) then
|
||||||
call i8radix_sort(map%key,iorder,map%n_elements,-1)
|
call i8sort(map%key,iorder,map%n_elements,-1)
|
||||||
endif
|
endif
|
||||||
if (integral_kind == 4) then
|
if (integral_kind == 4) then
|
||||||
call set_order(map%value,iorder,map%n_elements)
|
call set_order(map%value,iorder,map%n_elements)
|
||||||
|
373
src/utils/qsort.c
Normal file
373
src/utils/qsort.c
Normal file
@ -0,0 +1,373 @@
|
|||||||
|
/* [[file:~/qp2/src/utils/qsort.org::*Generated%20C%20file][Generated C file:1]] */
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <stdint.h>
|
||||||
|
|
||||||
|
struct int16_t_comp {
|
||||||
|
int16_t x;
|
||||||
|
int32_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_int16_t( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const int16_t * restrict _l= l;
|
||||||
|
const int16_t * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int16_t(int16_t* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||||
|
struct int16_t_comp* A = malloc(isize * sizeof(struct int16_t_comp));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct int16_t_comp), compare_int16_t);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int16_t_noidx(int16_t* A, int32_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(int16_t), compare_int16_t);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
struct int16_t_comp_big {
|
||||||
|
int16_t x;
|
||||||
|
int64_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_int16_t_big( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const int16_t * restrict _l= l;
|
||||||
|
const int16_t * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int16_t_big(int16_t* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||||
|
struct int16_t_comp_big* A = malloc(isize * sizeof(struct int16_t_comp_big));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct int16_t_comp_big), compare_int16_t_big);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int16_t_noidx_big(int16_t* A, int64_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(int16_t), compare_int16_t_big);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
struct int32_t_comp {
|
||||||
|
int32_t x;
|
||||||
|
int32_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_int32_t( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const int32_t * restrict _l= l;
|
||||||
|
const int32_t * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int32_t(int32_t* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||||
|
struct int32_t_comp* A = malloc(isize * sizeof(struct int32_t_comp));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct int32_t_comp), compare_int32_t);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int32_t_noidx(int32_t* A, int32_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(int32_t), compare_int32_t);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
struct int32_t_comp_big {
|
||||||
|
int32_t x;
|
||||||
|
int64_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_int32_t_big( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const int32_t * restrict _l= l;
|
||||||
|
const int32_t * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int32_t_big(int32_t* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||||
|
struct int32_t_comp_big* A = malloc(isize * sizeof(struct int32_t_comp_big));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct int32_t_comp_big), compare_int32_t_big);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int32_t_noidx_big(int32_t* A, int64_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(int32_t), compare_int32_t_big);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
struct int64_t_comp {
|
||||||
|
int64_t x;
|
||||||
|
int32_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_int64_t( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const int64_t * restrict _l= l;
|
||||||
|
const int64_t * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int64_t(int64_t* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||||
|
struct int64_t_comp* A = malloc(isize * sizeof(struct int64_t_comp));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct int64_t_comp), compare_int64_t);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int64_t_noidx(int64_t* A, int32_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(int64_t), compare_int64_t);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
struct int64_t_comp_big {
|
||||||
|
int64_t x;
|
||||||
|
int64_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_int64_t_big( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const int64_t * restrict _l= l;
|
||||||
|
const int64_t * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int64_t_big(int64_t* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||||
|
struct int64_t_comp_big* A = malloc(isize * sizeof(struct int64_t_comp_big));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct int64_t_comp_big), compare_int64_t_big);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_int64_t_noidx_big(int64_t* A, int64_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(int64_t), compare_int64_t_big);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
struct double_comp {
|
||||||
|
double x;
|
||||||
|
int32_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_double( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const double * restrict _l= l;
|
||||||
|
const double * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_double(double* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||||
|
struct double_comp* A = malloc(isize * sizeof(struct double_comp));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct double_comp), compare_double);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_double_noidx(double* A, int32_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(double), compare_double);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
struct double_comp_big {
|
||||||
|
double x;
|
||||||
|
int64_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_double_big( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const double * restrict _l= l;
|
||||||
|
const double * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_double_big(double* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||||
|
struct double_comp_big* A = malloc(isize * sizeof(struct double_comp_big));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct double_comp_big), compare_double_big);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_double_noidx_big(double* A, int64_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(double), compare_double_big);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
struct float_comp {
|
||||||
|
float x;
|
||||||
|
int32_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_float( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const float * restrict _l= l;
|
||||||
|
const float * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_float(float* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||||
|
struct float_comp* A = malloc(isize * sizeof(struct float_comp));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct float_comp), compare_float);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_float_noidx(float* A, int32_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(float), compare_float);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
struct float_comp_big {
|
||||||
|
float x;
|
||||||
|
int64_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_float_big( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const float * restrict _l= l;
|
||||||
|
const float * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_float_big(float* restrict A_in, int64_t* restrict iorder, int64_t isize) {
|
||||||
|
struct float_comp_big* A = malloc(isize * sizeof(struct float_comp_big));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct float_comp_big), compare_float_big);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_float_noidx_big(float* A, int64_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(float), compare_float_big);
|
||||||
|
}
|
||||||
|
/* Generated C file:1 ends here */
|
169
src/utils/qsort.org
Normal file
169
src/utils/qsort.org
Normal file
@ -0,0 +1,169 @@
|
|||||||
|
#+TITLE: Quick sort binding for Fortran
|
||||||
|
|
||||||
|
* C template
|
||||||
|
|
||||||
|
#+NAME: c_template
|
||||||
|
#+BEGIN_SRC c
|
||||||
|
struct TYPE_comp_big {
|
||||||
|
TYPE x;
|
||||||
|
int32_t i;
|
||||||
|
};
|
||||||
|
|
||||||
|
int compare_TYPE_big( const void * l, const void * r )
|
||||||
|
{
|
||||||
|
const TYPE * restrict _l= l;
|
||||||
|
const TYPE * restrict _r= r;
|
||||||
|
if( *_l > *_r ) return 1;
|
||||||
|
if( *_l < *_r ) return -1;
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_TYPE_big(TYPE* restrict A_in, int32_t* restrict iorder, int32_t isize) {
|
||||||
|
struct TYPE_comp_big* A = malloc(isize * sizeof(struct TYPE_comp_big));
|
||||||
|
if (A == NULL) return;
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A[i].x = A_in[i];
|
||||||
|
A[i].i = iorder[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(struct TYPE_comp_big), compare_TYPE_big);
|
||||||
|
|
||||||
|
for (int i=0 ; i<isize ; ++i) {
|
||||||
|
A_in[i] = A[i].x;
|
||||||
|
iorder[i] = A[i].i;
|
||||||
|
}
|
||||||
|
free(A);
|
||||||
|
}
|
||||||
|
|
||||||
|
void qsort_TYPE_noidx_big(TYPE* A, int32_t isize) {
|
||||||
|
qsort( (void*) A, (size_t) isize, sizeof(TYPE), compare_TYPE_big);
|
||||||
|
}
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
* Fortran template
|
||||||
|
|
||||||
|
#+NAME:f_template
|
||||||
|
#+BEGIN_SRC f90
|
||||||
|
subroutine Lsort_big_c(A, iorder, isize) bind(C, name="qsort_TYPE_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
real (c_TYPE) :: A(isize)
|
||||||
|
end subroutine Lsort_big_c
|
||||||
|
|
||||||
|
subroutine Lsort_noidx_big_c(A, isize) bind(C, name="qsort_TYPE_noidx_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
real (c_TYPE) :: A(isize)
|
||||||
|
end subroutine Lsort_noidx_big_c
|
||||||
|
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+NAME:f_template2
|
||||||
|
#+BEGIN_SRC f90
|
||||||
|
subroutine Lsort_big(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
real (c_TYPE) :: A(isize)
|
||||||
|
call Lsort_big_c(A, iorder, isize)
|
||||||
|
end subroutine Lsort_big
|
||||||
|
|
||||||
|
subroutine Lsort_noidx_big(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
real (c_TYPE) :: A(isize)
|
||||||
|
call Lsort_noidx_big_c(A, isize)
|
||||||
|
end subroutine Lsort_noidx_big
|
||||||
|
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
* Python scripts for type replacements
|
||||||
|
|
||||||
|
#+NAME: replaced
|
||||||
|
#+begin_src python :results output :noweb yes
|
||||||
|
data = """
|
||||||
|
<<c_template>>
|
||||||
|
"""
|
||||||
|
for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]:
|
||||||
|
print( data.replace("TYPE", typ).replace("_big", "") )
|
||||||
|
print( data.replace("int32_t", "int64_t").replace("TYPE", typ) )
|
||||||
|
#+end_src
|
||||||
|
|
||||||
|
#+NAME: replaced_f
|
||||||
|
#+begin_src python :results output :noweb yes
|
||||||
|
data = """
|
||||||
|
<<f_template>>
|
||||||
|
"""
|
||||||
|
c1 = {
|
||||||
|
"int16_t": "i2",
|
||||||
|
"int32_t": "i",
|
||||||
|
"int64_t": "i8",
|
||||||
|
"double": "d",
|
||||||
|
"float": ""
|
||||||
|
}
|
||||||
|
c2 = {
|
||||||
|
"int16_t": "integer",
|
||||||
|
"int32_t": "integer",
|
||||||
|
"int64_t": "integer",
|
||||||
|
"double": "real",
|
||||||
|
"float": "real"
|
||||||
|
}
|
||||||
|
|
||||||
|
for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]:
|
||||||
|
print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") )
|
||||||
|
print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) )
|
||||||
|
#+end_src
|
||||||
|
|
||||||
|
#+NAME: replaced_f2
|
||||||
|
#+begin_src python :results output :noweb yes
|
||||||
|
data = """
|
||||||
|
<<f_template2>>
|
||||||
|
"""
|
||||||
|
c1 = {
|
||||||
|
"int16_t": "i2",
|
||||||
|
"int32_t": "i",
|
||||||
|
"int64_t": "i8",
|
||||||
|
"double": "d",
|
||||||
|
"float": ""
|
||||||
|
}
|
||||||
|
c2 = {
|
||||||
|
"int16_t": "integer",
|
||||||
|
"int32_t": "integer",
|
||||||
|
"int64_t": "integer",
|
||||||
|
"double": "real",
|
||||||
|
"float": "real"
|
||||||
|
}
|
||||||
|
|
||||||
|
for typ in ["int16_t", "int32_t", "int64_t", "double", "float"]:
|
||||||
|
print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("TYPE", typ).replace("_big", "") )
|
||||||
|
print( data.replace("real",c2[typ]).replace("L",c1[typ]).replace("int32_t", "int64_t").replace("TYPE", typ) )
|
||||||
|
#+end_src
|
||||||
|
|
||||||
|
* Generated C file
|
||||||
|
|
||||||
|
#+BEGIN_SRC c :comments link :tangle qsort.c :noweb yes
|
||||||
|
#include <stdlib.h>
|
||||||
|
#include <stdint.h>
|
||||||
|
<<replaced()>>
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
* Generated Fortran file
|
||||||
|
|
||||||
|
#+BEGIN_SRC f90 :tangle qsort_module.f90 :noweb yes
|
||||||
|
module qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
|
||||||
|
interface
|
||||||
|
<<replaced_f()>>
|
||||||
|
end interface
|
||||||
|
|
||||||
|
end module qsort_module
|
||||||
|
|
||||||
|
<<replaced_f2()>>
|
||||||
|
|
||||||
|
#+END_SRC
|
||||||
|
|
347
src/utils/qsort_module.f90
Normal file
347
src/utils/qsort_module.f90
Normal file
@ -0,0 +1,347 @@
|
|||||||
|
module qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
subroutine i2sort_c(A, iorder, isize) bind(C, name="qsort_int16_t")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
integer (c_int16_t) :: A(isize)
|
||||||
|
end subroutine i2sort_c
|
||||||
|
|
||||||
|
subroutine i2sort_noidx_c(A, isize) bind(C, name="qsort_int16_t_noidx")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
integer (c_int16_t) :: A(isize)
|
||||||
|
end subroutine i2sort_noidx_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine i2sort_big_c(A, iorder, isize) bind(C, name="qsort_int16_t_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
integer (c_int16_t) :: A(isize)
|
||||||
|
end subroutine i2sort_big_c
|
||||||
|
|
||||||
|
subroutine i2sort_noidx_big_c(A, isize) bind(C, name="qsort_int16_t_noidx_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
integer (c_int16_t) :: A(isize)
|
||||||
|
end subroutine i2sort_noidx_big_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine isort_c(A, iorder, isize) bind(C, name="qsort_int32_t")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
integer (c_int32_t) :: A(isize)
|
||||||
|
end subroutine isort_c
|
||||||
|
|
||||||
|
subroutine isort_noidx_c(A, isize) bind(C, name="qsort_int32_t_noidx")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
integer (c_int32_t) :: A(isize)
|
||||||
|
end subroutine isort_noidx_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine isort_big_c(A, iorder, isize) bind(C, name="qsort_int32_t_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
integer (c_int32_t) :: A(isize)
|
||||||
|
end subroutine isort_big_c
|
||||||
|
|
||||||
|
subroutine isort_noidx_big_c(A, isize) bind(C, name="qsort_int32_t_noidx_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
integer (c_int32_t) :: A(isize)
|
||||||
|
end subroutine isort_noidx_big_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine i8sort_c(A, iorder, isize) bind(C, name="qsort_int64_t")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
integer (c_int64_t) :: A(isize)
|
||||||
|
end subroutine i8sort_c
|
||||||
|
|
||||||
|
subroutine i8sort_noidx_c(A, isize) bind(C, name="qsort_int64_t_noidx")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
integer (c_int64_t) :: A(isize)
|
||||||
|
end subroutine i8sort_noidx_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine i8sort_big_c(A, iorder, isize) bind(C, name="qsort_int64_t_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
integer (c_int64_t) :: A(isize)
|
||||||
|
end subroutine i8sort_big_c
|
||||||
|
|
||||||
|
subroutine i8sort_noidx_big_c(A, isize) bind(C, name="qsort_int64_t_noidx_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
integer (c_int64_t) :: A(isize)
|
||||||
|
end subroutine i8sort_noidx_big_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine dsort_c(A, iorder, isize) bind(C, name="qsort_double")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
real (c_double) :: A(isize)
|
||||||
|
end subroutine dsort_c
|
||||||
|
|
||||||
|
subroutine dsort_noidx_c(A, isize) bind(C, name="qsort_double_noidx")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
real (c_double) :: A(isize)
|
||||||
|
end subroutine dsort_noidx_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine dsort_big_c(A, iorder, isize) bind(C, name="qsort_double_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
real (c_double) :: A(isize)
|
||||||
|
end subroutine dsort_big_c
|
||||||
|
|
||||||
|
subroutine dsort_noidx_big_c(A, isize) bind(C, name="qsort_double_noidx_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
real (c_double) :: A(isize)
|
||||||
|
end subroutine dsort_noidx_big_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine sort_c(A, iorder, isize) bind(C, name="qsort_float")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
real (c_float) :: A(isize)
|
||||||
|
end subroutine sort_c
|
||||||
|
|
||||||
|
subroutine sort_noidx_c(A, isize) bind(C, name="qsort_float_noidx")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t), value :: isize
|
||||||
|
real (c_float) :: A(isize)
|
||||||
|
end subroutine sort_noidx_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine sort_big_c(A, iorder, isize) bind(C, name="qsort_float_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
real (c_float) :: A(isize)
|
||||||
|
end subroutine sort_big_c
|
||||||
|
|
||||||
|
subroutine sort_noidx_big_c(A, isize) bind(C, name="qsort_float_noidx_big")
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t), value :: isize
|
||||||
|
real (c_float) :: A(isize)
|
||||||
|
end subroutine sort_noidx_big_c
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
end interface
|
||||||
|
|
||||||
|
end module qsort_module
|
||||||
|
|
||||||
|
|
||||||
|
subroutine i2sort(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
integer (c_int16_t) :: A(isize)
|
||||||
|
call i2sort_c(A, iorder, isize)
|
||||||
|
end subroutine i2sort
|
||||||
|
|
||||||
|
subroutine i2sort_noidx(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
integer (c_int16_t) :: A(isize)
|
||||||
|
call i2sort_noidx_c(A, isize)
|
||||||
|
end subroutine i2sort_noidx
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine i2sort_big(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
integer (c_int16_t) :: A(isize)
|
||||||
|
call i2sort_big_c(A, iorder, isize)
|
||||||
|
end subroutine i2sort_big
|
||||||
|
|
||||||
|
subroutine i2sort_noidx_big(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
integer (c_int16_t) :: A(isize)
|
||||||
|
call i2sort_noidx_big_c(A, isize)
|
||||||
|
end subroutine i2sort_noidx_big
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine isort(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
integer (c_int32_t) :: A(isize)
|
||||||
|
call isort_c(A, iorder, isize)
|
||||||
|
end subroutine isort
|
||||||
|
|
||||||
|
subroutine isort_noidx(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
integer (c_int32_t) :: A(isize)
|
||||||
|
call isort_noidx_c(A, isize)
|
||||||
|
end subroutine isort_noidx
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine isort_big(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
integer (c_int32_t) :: A(isize)
|
||||||
|
call isort_big_c(A, iorder, isize)
|
||||||
|
end subroutine isort_big
|
||||||
|
|
||||||
|
subroutine isort_noidx_big(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
integer (c_int32_t) :: A(isize)
|
||||||
|
call isort_noidx_big_c(A, isize)
|
||||||
|
end subroutine isort_noidx_big
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine i8sort(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
integer (c_int64_t) :: A(isize)
|
||||||
|
call i8sort_c(A, iorder, isize)
|
||||||
|
end subroutine i8sort
|
||||||
|
|
||||||
|
subroutine i8sort_noidx(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
integer (c_int64_t) :: A(isize)
|
||||||
|
call i8sort_noidx_c(A, isize)
|
||||||
|
end subroutine i8sort_noidx
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine i8sort_big(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
integer (c_int64_t) :: A(isize)
|
||||||
|
call i8sort_big_c(A, iorder, isize)
|
||||||
|
end subroutine i8sort_big
|
||||||
|
|
||||||
|
subroutine i8sort_noidx_big(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
integer (c_int64_t) :: A(isize)
|
||||||
|
call i8sort_noidx_big_c(A, isize)
|
||||||
|
end subroutine i8sort_noidx_big
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine dsort(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
real (c_double) :: A(isize)
|
||||||
|
call dsort_c(A, iorder, isize)
|
||||||
|
end subroutine dsort
|
||||||
|
|
||||||
|
subroutine dsort_noidx(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
real (c_double) :: A(isize)
|
||||||
|
call dsort_noidx_c(A, isize)
|
||||||
|
end subroutine dsort_noidx
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine dsort_big(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
real (c_double) :: A(isize)
|
||||||
|
call dsort_big_c(A, iorder, isize)
|
||||||
|
end subroutine dsort_big
|
||||||
|
|
||||||
|
subroutine dsort_noidx_big(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
real (c_double) :: A(isize)
|
||||||
|
call dsort_noidx_big_c(A, isize)
|
||||||
|
end subroutine dsort_noidx_big
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine sort(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
integer(c_int32_t) :: iorder(isize)
|
||||||
|
real (c_float) :: A(isize)
|
||||||
|
call sort_c(A, iorder, isize)
|
||||||
|
end subroutine sort
|
||||||
|
|
||||||
|
subroutine sort_noidx(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int32_t) :: isize
|
||||||
|
real (c_float) :: A(isize)
|
||||||
|
call sort_noidx_c(A, isize)
|
||||||
|
end subroutine sort_noidx
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
subroutine sort_big(A, iorder, isize)
|
||||||
|
use qsort_module
|
||||||
|
use iso_c_binding
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
integer(c_int64_t) :: iorder(isize)
|
||||||
|
real (c_float) :: A(isize)
|
||||||
|
call sort_big_c(A, iorder, isize)
|
||||||
|
end subroutine sort_big
|
||||||
|
|
||||||
|
subroutine sort_noidx_big(A, isize)
|
||||||
|
use iso_c_binding
|
||||||
|
use qsort_module
|
||||||
|
integer(c_int64_t) :: isize
|
||||||
|
real (c_float) :: A(isize)
|
||||||
|
call sort_noidx_big_c(A, isize)
|
||||||
|
end subroutine sort_noidx_big
|
@ -1,222 +1,4 @@
|
|||||||
BEGIN_TEMPLATE
|
BEGIN_TEMPLATE
|
||||||
subroutine insertion_$Xsort (x,iorder,isize)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Sort array x(isize) using the insertion sort algorithm.
|
|
||||||
! 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)
|
|
||||||
$type :: xtmp
|
|
||||||
integer :: i, i0, j, jmax
|
|
||||||
|
|
||||||
do i=2,isize
|
|
||||||
xtmp = x(i)
|
|
||||||
i0 = iorder(i)
|
|
||||||
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 quick_$Xsort(x, iorder, isize)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Sort array x(isize) using the quicksort algorithm.
|
|
||||||
! 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, external :: omp_get_num_threads
|
|
||||||
call rec_$X_quicksort(x,iorder,isize,1,isize,nproc)
|
|
||||||
end
|
|
||||||
|
|
||||||
recursive subroutine rec_$X_quicksort(x, iorder, isize, first, last, level)
|
|
||||||
implicit none
|
|
||||||
integer, intent(in) :: isize, first, last, level
|
|
||||||
integer,intent(inout) :: iorder(isize)
|
|
||||||
$type, intent(inout) :: x(isize)
|
|
||||||
$type :: c, tmp
|
|
||||||
integer :: itmp
|
|
||||||
integer :: i, j
|
|
||||||
|
|
||||||
if(isize<2)return
|
|
||||||
|
|
||||||
c = x( shiftr(first+last,1) )
|
|
||||||
i = first
|
|
||||||
j = last
|
|
||||||
do
|
|
||||||
do while (x(i) < c)
|
|
||||||
i=i+1
|
|
||||||
end do
|
|
||||||
do while (c < x(j))
|
|
||||||
j=j-1
|
|
||||||
end do
|
|
||||||
if (i >= j) exit
|
|
||||||
tmp = x(i)
|
|
||||||
x(i) = x(j)
|
|
||||||
x(j) = tmp
|
|
||||||
itmp = iorder(i)
|
|
||||||
iorder(i) = iorder(j)
|
|
||||||
iorder(j) = itmp
|
|
||||||
i=i+1
|
|
||||||
j=j-1
|
|
||||||
enddo
|
|
||||||
if ( ((i-first <= 10000).and.(last-j <= 10000)).or.(level<=0) ) then
|
|
||||||
if (first < i-1) then
|
|
||||||
call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2)
|
|
||||||
endif
|
|
||||||
if (j+1 < last) then
|
|
||||||
call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2)
|
|
||||||
endif
|
|
||||||
else
|
|
||||||
if (first < i-1) then
|
|
||||||
call rec_$X_quicksort(x, iorder, isize, first, i-1,level/2)
|
|
||||||
endif
|
|
||||||
if (j+1 < last) then
|
|
||||||
call rec_$X_quicksort(x, iorder, isize, j+1, last,level/2)
|
|
||||||
endif
|
|
||||||
endif
|
|
||||||
end
|
|
||||||
|
|
||||||
subroutine heap_$Xsort(x,iorder,isize)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Sort array x(isize) using the heap sort algorithm.
|
|
||||||
! 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 :: i, k, j, l, i0
|
|
||||||
$type :: xtemp
|
|
||||||
|
|
||||||
l = isize/2+1
|
|
||||||
k = isize
|
|
||||||
do while (.True.)
|
|
||||||
if (l>1) then
|
|
||||||
l=l-1
|
|
||||||
xtemp = x(l)
|
|
||||||
i0 = iorder(l)
|
|
||||||
else
|
|
||||||
xtemp = x(k)
|
|
||||||
i0 = iorder(k)
|
|
||||||
x(k) = x(1)
|
|
||||||
iorder(k) = iorder(1)
|
|
||||||
k = k-1
|
|
||||||
if (k == 1) then
|
|
||||||
x(1) = xtemp
|
|
||||||
iorder(1) = i0
|
|
||||||
exit
|
|
||||||
endif
|
|
||||||
endif
|
|
||||||
i=l
|
|
||||||
j = shiftl(l,1)
|
|
||||||
do while (j<k)
|
|
||||||
if ( x(j) < x(j+1) ) then
|
|
||||||
j=j+1
|
|
||||||
endif
|
|
||||||
if (xtemp < x(j)) then
|
|
||||||
x(i) = x(j)
|
|
||||||
iorder(i) = iorder(j)
|
|
||||||
i = j
|
|
||||||
j = shiftl(j,1)
|
|
||||||
else
|
|
||||||
j = k+1
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
if (j==k) then
|
|
||||||
if (xtemp < x(j)) then
|
|
||||||
x(i) = x(j)
|
|
||||||
iorder(i) = iorder(j)
|
|
||||||
i = j
|
|
||||||
j = shiftl(j,1)
|
|
||||||
else
|
|
||||||
j = k+1
|
|
||||||
endif
|
|
||||||
endif
|
|
||||||
x(i) = xtemp
|
|
||||||
iorder(i) = i0
|
|
||||||
enddo
|
|
||||||
end subroutine heap_$Xsort
|
|
||||||
|
|
||||||
subroutine heap_$Xsort_big(x,iorder,isize)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Sort array x(isize) using the heap sort algorithm.
|
|
||||||
! iorder in input should be (1,2,3,...,isize), and in output
|
|
||||||
! contains the new order of the elements.
|
|
||||||
! This is a version for very large arrays where the indices need
|
|
||||||
! to be in integer*8 format
|
|
||||||
END_DOC
|
|
||||||
integer*8,intent(in) :: isize
|
|
||||||
$type,intent(inout) :: x(isize)
|
|
||||||
integer*8,intent(inout) :: iorder(isize)
|
|
||||||
|
|
||||||
integer*8 :: i, k, j, l, i0
|
|
||||||
$type :: xtemp
|
|
||||||
|
|
||||||
l = isize/2+1
|
|
||||||
k = isize
|
|
||||||
do while (.True.)
|
|
||||||
if (l>1) then
|
|
||||||
l=l-1
|
|
||||||
xtemp = x(l)
|
|
||||||
i0 = iorder(l)
|
|
||||||
else
|
|
||||||
xtemp = x(k)
|
|
||||||
i0 = iorder(k)
|
|
||||||
x(k) = x(1)
|
|
||||||
iorder(k) = iorder(1)
|
|
||||||
k = k-1
|
|
||||||
if (k == 1) then
|
|
||||||
x(1) = xtemp
|
|
||||||
iorder(1) = i0
|
|
||||||
exit
|
|
||||||
endif
|
|
||||||
endif
|
|
||||||
i=l
|
|
||||||
j = shiftl(l,1)
|
|
||||||
do while (j<k)
|
|
||||||
if ( x(j) < x(j+1) ) then
|
|
||||||
j=j+1
|
|
||||||
endif
|
|
||||||
if (xtemp < x(j)) then
|
|
||||||
x(i) = x(j)
|
|
||||||
iorder(i) = iorder(j)
|
|
||||||
i = j
|
|
||||||
j = shiftl(j,1)
|
|
||||||
else
|
|
||||||
j = k+1
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
if (j==k) then
|
|
||||||
if (xtemp < x(j)) then
|
|
||||||
x(i) = x(j)
|
|
||||||
iorder(i) = iorder(j)
|
|
||||||
i = j
|
|
||||||
j = shiftl(j,1)
|
|
||||||
else
|
|
||||||
j = k+1
|
|
||||||
endif
|
|
||||||
endif
|
|
||||||
x(i) = xtemp
|
|
||||||
iorder(i) = i0
|
|
||||||
enddo
|
|
||||||
|
|
||||||
end subroutine heap_$Xsort_big
|
|
||||||
|
|
||||||
subroutine sorted_$Xnumber(x,isize,n)
|
subroutine sorted_$Xnumber(x,isize,n)
|
||||||
implicit none
|
implicit none
|
||||||
@ -250,222 +32,6 @@ SUBST [ X, type ]
|
|||||||
END_TEMPLATE
|
END_TEMPLATE
|
||||||
|
|
||||||
|
|
||||||
!---------------------- INTEL
|
|
||||||
IRP_IF INTEL
|
|
||||||
|
|
||||||
BEGIN_TEMPLATE
|
|
||||||
subroutine $Xsort(x,iorder,isize)
|
|
||||||
use intel
|
|
||||||
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
|
|
||||||
character, allocatable :: tmp(:)
|
|
||||||
if (isize < 2) return
|
|
||||||
call ippsSortRadixIndexGetBufferSize(isize, $ippsz, n)
|
|
||||||
allocate(tmp(n))
|
|
||||||
call ippsSortRadixIndexAscend_$ityp(x, $n, iorder, isize, tmp)
|
|
||||||
deallocate(tmp)
|
|
||||||
iorder(1:isize) = iorder(1:isize)+1
|
|
||||||
call $Xset_order(x,iorder,isize)
|
|
||||||
end
|
|
||||||
|
|
||||||
subroutine $Xsort_noidx(x,isize)
|
|
||||||
use intel
|
|
||||||
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 :: n
|
|
||||||
character, allocatable :: tmp(:)
|
|
||||||
if (isize < 2) return
|
|
||||||
call ippsSortRadixIndexGetBufferSize(isize, $ippsz, n)
|
|
||||||
allocate(tmp(n))
|
|
||||||
call ippsSortRadixAscend_$ityp_I(x, isize, tmp)
|
|
||||||
deallocate(tmp)
|
|
||||||
end
|
|
||||||
|
|
||||||
SUBST [ X, type, ityp, n, ippsz ]
|
|
||||||
; real ; 32f ; 4 ; 13 ;;
|
|
||||||
i ; integer ; 32s ; 4 ; 11 ;;
|
|
||||||
i2 ; integer*2 ; 16s ; 2 ; 7 ;;
|
|
||||||
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
|
|
||||||
if (isize < 2) then
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
! call sorted_$Xnumber(x,isize,n)
|
|
||||||
! if (isize == n) then
|
|
||||||
! return
|
|
||||||
! endif
|
|
||||||
if ( isize < 32) then
|
|
||||||
call insertion_$Xsort(x,iorder,isize)
|
|
||||||
else
|
|
||||||
! call heap_$Xsort(x,iorder,isize)
|
|
||||||
call quick_$Xsort(x,iorder,isize)
|
|
||||||
endif
|
|
||||||
end subroutine $Xsort
|
|
||||||
|
|
||||||
SUBST [ X, type ]
|
|
||||||
d ; double precision ;;
|
|
||||||
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
|
|
||||||
if (isize < 2) then
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
call sorted_$Xnumber(x,isize,n)
|
|
||||||
if (isize == n) then
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
if ( isize < 32) then
|
|
||||||
call insertion_$Xsort(x,iorder,isize)
|
|
||||||
else
|
|
||||||
! call $Xradix_sort(x,iorder,isize,-1)
|
|
||||||
call quick_$Xsort(x,iorder,isize)
|
|
||||||
endif
|
|
||||||
end subroutine $Xsort
|
|
||||||
|
|
||||||
SUBST [ X, type ]
|
|
||||||
i8 ; integer*8 ;;
|
|
||||||
END_TEMPLATE
|
|
||||||
|
|
||||||
!---------------------- END INTEL
|
|
||||||
IRP_ELSE
|
|
||||||
!---------------------- NON-INTEL
|
|
||||||
BEGIN_TEMPLATE
|
|
||||||
|
|
||||||
subroutine $Xsort_noidx(x,isize)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Sort array x(isize).
|
|
||||||
END_DOC
|
|
||||||
integer,intent(in) :: isize
|
|
||||||
$type,intent(inout) :: x(isize)
|
|
||||||
integer, allocatable :: iorder(:)
|
|
||||||
integer :: i
|
|
||||||
allocate(iorder(isize))
|
|
||||||
do i=1,isize
|
|
||||||
iorder(i)=i
|
|
||||||
enddo
|
|
||||||
call $Xsort(x,iorder,isize)
|
|
||||||
deallocate(iorder)
|
|
||||||
end subroutine $Xsort_noidx
|
|
||||||
|
|
||||||
SUBST [ X, type ]
|
|
||||||
; real ;;
|
|
||||||
d ; double precision ;;
|
|
||||||
i ; integer ;;
|
|
||||||
i8 ; integer*8 ;;
|
|
||||||
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
|
|
||||||
if (isize < 2) then
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
! call sorted_$Xnumber(x,isize,n)
|
|
||||||
! if (isize == n) then
|
|
||||||
! return
|
|
||||||
! endif
|
|
||||||
if ( isize < 32) then
|
|
||||||
call insertion_$Xsort(x,iorder,isize)
|
|
||||||
else
|
|
||||||
! call heap_$Xsort(x,iorder,isize)
|
|
||||||
call quick_$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
|
|
||||||
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
|
|
||||||
if (isize < 2) then
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
call sorted_$Xnumber(x,isize,n)
|
|
||||||
if (isize == n) then
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
if ( isize < 32) then
|
|
||||||
call insertion_$Xsort(x,iorder,isize)
|
|
||||||
else
|
|
||||||
! call $Xradix_sort(x,iorder,isize,-1)
|
|
||||||
call quick_$Xsort(x,iorder,isize)
|
|
||||||
endif
|
|
||||||
end subroutine $Xsort
|
|
||||||
|
|
||||||
SUBST [ X, type ]
|
|
||||||
i ; integer ;;
|
|
||||||
i8 ; integer*8 ;;
|
|
||||||
i2 ; integer*2 ;;
|
|
||||||
END_TEMPLATE
|
|
||||||
|
|
||||||
IRP_ENDIF
|
|
||||||
!---------------------- END NON-INTEL
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
BEGIN_TEMPLATE
|
BEGIN_TEMPLATE
|
||||||
subroutine $Xset_order(x,iorder,isize)
|
subroutine $Xset_order(x,iorder,isize)
|
||||||
@ -491,47 +57,6 @@ BEGIN_TEMPLATE
|
|||||||
deallocate(xtmp)
|
deallocate(xtmp)
|
||||||
end
|
end
|
||||||
|
|
||||||
SUBST [ X, type ]
|
|
||||||
; real ;;
|
|
||||||
d ; double precision ;;
|
|
||||||
i ; integer ;;
|
|
||||||
i8; integer*8 ;;
|
|
||||||
i2; integer*2 ;;
|
|
||||||
END_TEMPLATE
|
|
||||||
|
|
||||||
|
|
||||||
BEGIN_TEMPLATE
|
|
||||||
subroutine insertion_$Xsort_big (x,iorder,isize)
|
|
||||||
implicit none
|
|
||||||
BEGIN_DOC
|
|
||||||
! Sort array x(isize) using the insertion sort algorithm.
|
|
||||||
! iorder in input should be (1,2,3,...,isize), and in output
|
|
||||||
! contains the new order of the elements.
|
|
||||||
! This is a version for very large arrays where the indices need
|
|
||||||
! to be in integer*8 format
|
|
||||||
END_DOC
|
|
||||||
integer*8,intent(in) :: isize
|
|
||||||
$type,intent(inout) :: x(isize)
|
|
||||||
integer*8,intent(inout) :: iorder(isize)
|
|
||||||
$type :: xtmp
|
|
||||||
integer*8 :: i, i0, j, jmax
|
|
||||||
|
|
||||||
do i=2_8,isize
|
|
||||||
xtmp = x(i)
|
|
||||||
i0 = iorder(i)
|
|
||||||
j = i-1_8
|
|
||||||
do while (j>0_8)
|
|
||||||
if (x(j)<=xtmp) exit
|
|
||||||
x(j+1_8) = x(j)
|
|
||||||
iorder(j+1_8) = iorder(j)
|
|
||||||
j = j-1_8
|
|
||||||
enddo
|
|
||||||
x(j+1_8) = xtmp
|
|
||||||
iorder(j+1_8) = i0
|
|
||||||
enddo
|
|
||||||
|
|
||||||
end subroutine insertion_$Xsort_big
|
|
||||||
|
|
||||||
subroutine $Xset_order_big(x,iorder,isize)
|
subroutine $Xset_order_big(x,iorder,isize)
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
@ -565,223 +90,3 @@ SUBST [ X, type ]
|
|||||||
END_TEMPLATE
|
END_TEMPLATE
|
||||||
|
|
||||||
|
|
||||||
BEGIN_TEMPLATE
|
|
||||||
|
|
||||||
recursive subroutine $Xradix_sort$big(x,iorder,isize,iradix)
|
|
||||||
implicit none
|
|
||||||
|
|
||||||
BEGIN_DOC
|
|
||||||
! Sort integer array x(isize) using the radix sort algorithm.
|
|
||||||
! iorder in input should be (1,2,3,...,isize), and in output
|
|
||||||
! contains the new order of the elements.
|
|
||||||
! iradix should be -1 in input.
|
|
||||||
END_DOC
|
|
||||||
integer*$int_type, intent(in) :: isize
|
|
||||||
integer*$int_type, intent(inout) :: iorder(isize)
|
|
||||||
integer*$type, intent(inout) :: x(isize)
|
|
||||||
integer, intent(in) :: iradix
|
|
||||||
integer :: iradix_new
|
|
||||||
integer*$type, allocatable :: x2(:), x1(:)
|
|
||||||
integer*$type :: i4 ! data type
|
|
||||||
integer*$int_type, allocatable :: iorder1(:),iorder2(:)
|
|
||||||
integer*$int_type :: i0, i1, i2, i3, i ! index type
|
|
||||||
integer*$type :: mask
|
|
||||||
integer :: err
|
|
||||||
!DIR$ ATTRIBUTES ALIGN : 128 :: iorder1,iorder2, x2, x1
|
|
||||||
|
|
||||||
if (isize < 2) then
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
|
|
||||||
if (iradix == -1) then ! Sort Positive and negative
|
|
||||||
|
|
||||||
allocate(x1(isize),iorder1(isize), x2(isize),iorder2(isize),stat=err)
|
|
||||||
if (err /= 0) then
|
|
||||||
print *, irp_here, ': Unable to allocate arrays'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
|
|
||||||
i1=1_$int_type
|
|
||||||
i2=1_$int_type
|
|
||||||
do i=1_$int_type,isize
|
|
||||||
if (x(i) < 0_$type) then
|
|
||||||
iorder1(i1) = iorder(i)
|
|
||||||
x1(i1) = -x(i)
|
|
||||||
i1 = i1+1_$int_type
|
|
||||||
else
|
|
||||||
iorder2(i2) = iorder(i)
|
|
||||||
x2(i2) = x(i)
|
|
||||||
i2 = i2+1_$int_type
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
i1=i1-1_$int_type
|
|
||||||
i2=i2-1_$int_type
|
|
||||||
|
|
||||||
do i=1_$int_type,i2
|
|
||||||
iorder(i1+i) = iorder2(i)
|
|
||||||
x(i1+i) = x2(i)
|
|
||||||
enddo
|
|
||||||
deallocate(x2,iorder2,stat=err)
|
|
||||||
if (err /= 0) then
|
|
||||||
print *, irp_here, ': Unable to deallocate arrays x2, iorder2'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
if (i1 > 1_$int_type) then
|
|
||||||
call $Xradix_sort$big(x1,iorder1,i1,-2)
|
|
||||||
do i=1_$int_type,i1
|
|
||||||
x(i) = -x1(1_$int_type+i1-i)
|
|
||||||
iorder(i) = iorder1(1_$int_type+i1-i)
|
|
||||||
enddo
|
|
||||||
endif
|
|
||||||
|
|
||||||
if (i2>1_$int_type) then
|
|
||||||
call $Xradix_sort$big(x(i1+1_$int_type),iorder(i1+1_$int_type),i2,-2)
|
|
||||||
endif
|
|
||||||
|
|
||||||
deallocate(x1,iorder1,stat=err)
|
|
||||||
if (err /= 0) then
|
|
||||||
print *, irp_here, ': Unable to deallocate arrays x1, iorder1'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
return
|
|
||||||
|
|
||||||
else if (iradix == -2) then ! Positive
|
|
||||||
|
|
||||||
! Find most significant bit
|
|
||||||
|
|
||||||
i0 = 0_$int_type
|
|
||||||
i4 = maxval(x)
|
|
||||||
|
|
||||||
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)
|
|
||||||
if (err /= 0) then
|
|
||||||
print *, irp_here, ': Unable to allocate arrays'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
|
|
||||||
i1=1_$int_type
|
|
||||||
i2=1_$int_type
|
|
||||||
|
|
||||||
do i=1_$int_type,isize
|
|
||||||
if (iand(mask,x(i)) == 0_$type) then
|
|
||||||
iorder1(i1) = iorder(i)
|
|
||||||
x1(i1) = x(i)
|
|
||||||
i1 = i1+1_$int_type
|
|
||||||
else
|
|
||||||
iorder2(i2) = iorder(i)
|
|
||||||
x2(i2) = x(i)
|
|
||||||
i2 = i2+1_$int_type
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
i1=i1-1_$int_type
|
|
||||||
i2=i2-1_$int_type
|
|
||||||
|
|
||||||
do i=1_$int_type,i1
|
|
||||||
iorder(i0+i) = iorder1(i)
|
|
||||||
x(i0+i) = x1(i)
|
|
||||||
enddo
|
|
||||||
i0 = i0+i1
|
|
||||||
i3 = i0
|
|
||||||
deallocate(x1,iorder1,stat=err)
|
|
||||||
if (err /= 0) then
|
|
||||||
print *, irp_here, ': Unable to deallocate arrays x1, iorder1'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
do i=1_$int_type,i2
|
|
||||||
iorder(i0+i) = iorder2(i)
|
|
||||||
x(i0+i) = x2(i)
|
|
||||||
enddo
|
|
||||||
i0 = i0+i2
|
|
||||||
deallocate(x2,iorder2,stat=err)
|
|
||||||
if (err /= 0) then
|
|
||||||
print *, irp_here, ': Unable to deallocate arrays x2, iorder2'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
if (i3>1_$int_type) then
|
|
||||||
call $Xradix_sort$big(x,iorder,i3,iradix_new-1)
|
|
||||||
endif
|
|
||||||
|
|
||||||
if (isize-i3>1_$int_type) then
|
|
||||||
call $Xradix_sort$big(x(i3+1_$int_type),iorder(i3+1_$int_type),isize-i3,iradix_new-1)
|
|
||||||
endif
|
|
||||||
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
|
|
||||||
ASSERT (iradix >= 0)
|
|
||||||
|
|
||||||
if (isize < 48) then
|
|
||||||
call insertion_$Xsort$big(x,iorder,isize)
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
allocate(x2(isize),iorder2(isize),stat=err)
|
|
||||||
if (err /= 0) then
|
|
||||||
print *, irp_here, ': Unable to allocate arrays x1, iorder1'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
mask = ibset(0_$type,iradix)
|
|
||||||
i0=1_$int_type
|
|
||||||
i1=1_$int_type
|
|
||||||
|
|
||||||
do i=1_$int_type,isize
|
|
||||||
if (iand(mask,x(i)) == 0_$type) then
|
|
||||||
iorder(i0) = iorder(i)
|
|
||||||
x(i0) = x(i)
|
|
||||||
i0 = i0+1_$int_type
|
|
||||||
else
|
|
||||||
iorder2(i1) = iorder(i)
|
|
||||||
x2(i1) = x(i)
|
|
||||||
i1 = i1+1_$int_type
|
|
||||||
endif
|
|
||||||
enddo
|
|
||||||
i0=i0-1_$int_type
|
|
||||||
i1=i1-1_$int_type
|
|
||||||
|
|
||||||
do i=1_$int_type,i1
|
|
||||||
iorder(i0+i) = iorder2(i)
|
|
||||||
x(i0+i) = x2(i)
|
|
||||||
enddo
|
|
||||||
|
|
||||||
deallocate(x2,iorder2,stat=err)
|
|
||||||
if (err /= 0) then
|
|
||||||
print *, irp_here, ': Unable to allocate arrays x2, iorder2'
|
|
||||||
stop
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
if (iradix == 0) then
|
|
||||||
return
|
|
||||||
endif
|
|
||||||
|
|
||||||
|
|
||||||
if (i1>1_$int_type) then
|
|
||||||
call $Xradix_sort$big(x(i0+1_$int_type),iorder(i0+1_$int_type),i1,iradix-1)
|
|
||||||
endif
|
|
||||||
if (i0>1) then
|
|
||||||
call $Xradix_sort$big(x,iorder,i0,iradix-1)
|
|
||||||
endif
|
|
||||||
|
|
||||||
end
|
|
||||||
|
|
||||||
SUBST [ X, type, integer_size, is_big, big, int_type ]
|
|
||||||
i ; 4 ; 32 ; .False. ; ; 4 ;;
|
|
||||||
i8 ; 8 ; 64 ; .False. ; ; 4 ;;
|
|
||||||
i2 ; 2 ; 16 ; .False. ; ; 4 ;;
|
|
||||||
i ; 4 ; 32 ; .True. ; _big ; 8 ;;
|
|
||||||
i8 ; 8 ; 64 ; .True. ; _big ; 8 ;;
|
|
||||||
END_TEMPLATE
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
22
src/utils/units.irp.f
Normal file
22
src/utils/units.irp.f
Normal file
@ -0,0 +1,22 @@
|
|||||||
|
BEGIN_PROVIDER [double precision, ha_to_ev]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Converstion from Hartree to eV
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
ha_to_ev = 27.211396641308d0
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [double precision, au_to_D]
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
BEGIN_DOC
|
||||||
|
! Converstion from au to Debye
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
au_to_D = 2.5415802529d0
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
@ -37,6 +37,10 @@ double precision function binom_func(i,j)
|
|||||||
else
|
else
|
||||||
binom_func = dexp( logfact(i)-logfact(j)-logfact(i-j) )
|
binom_func = dexp( logfact(i)-logfact(j)-logfact(i-j) )
|
||||||
endif
|
endif
|
||||||
|
|
||||||
|
! To avoid .999999 numbers
|
||||||
|
binom_func = floor(binom_func + 0.5d0)
|
||||||
|
|
||||||
end
|
end
|
||||||
|
|
||||||
|
|
||||||
@ -132,7 +136,7 @@ double precision function logfact(n)
|
|||||||
enddo
|
enddo
|
||||||
end function
|
end function
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
BEGIN_PROVIDER [ double precision, fact_inv, (128) ]
|
BEGIN_PROVIDER [ double precision, fact_inv, (128) ]
|
||||||
implicit none
|
implicit none
|
||||||
@ -146,6 +150,29 @@ BEGIN_PROVIDER [ double precision, fact_inv, (128) ]
|
|||||||
enddo
|
enddo
|
||||||
END_PROVIDER
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
|
BEGIN_PROVIDER [ double precision, shiftfact_op5_inv, (128) ]
|
||||||
|
|
||||||
|
BEGIN_DOC
|
||||||
|
!
|
||||||
|
! 1 / Gamma(n + 0.5)
|
||||||
|
!
|
||||||
|
END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
integer :: i
|
||||||
|
double precision :: tmp
|
||||||
|
|
||||||
|
do i = 1, size(shiftfact_op5_inv)
|
||||||
|
!tmp = dgamma(dble(i) + 0.5d0)
|
||||||
|
tmp = gamma(dble(i) + 0.5d0)
|
||||||
|
shiftfact_op5_inv(i) = 1.d0 / tmp
|
||||||
|
enddo
|
||||||
|
|
||||||
|
END_PROVIDER
|
||||||
|
|
||||||
|
! ---
|
||||||
|
|
||||||
double precision function dble_fact(n)
|
double precision function dble_fact(n)
|
||||||
implicit none
|
implicit none
|
||||||
@ -300,12 +327,12 @@ subroutine wall_time(t)
|
|||||||
end
|
end
|
||||||
|
|
||||||
BEGIN_PROVIDER [ integer, nproc ]
|
BEGIN_PROVIDER [ integer, nproc ]
|
||||||
use omp_lib
|
|
||||||
implicit none
|
implicit none
|
||||||
BEGIN_DOC
|
BEGIN_DOC
|
||||||
! Number of current OpenMP threads
|
! Number of current OpenMP threads
|
||||||
END_DOC
|
END_DOC
|
||||||
|
|
||||||
|
integer, external :: omp_get_num_threads
|
||||||
nproc = 1
|
nproc = 1
|
||||||
!$OMP PARALLEL
|
!$OMP PARALLEL
|
||||||
!$OMP MASTER
|
!$OMP MASTER
|
||||||
@ -407,3 +434,28 @@ subroutine lowercase(txt,n)
|
|||||||
enddo
|
enddo
|
||||||
end
|
end
|
||||||
|
|
||||||
|
subroutine v2_over_x(v,x,res)
|
||||||
|
|
||||||
|
!BEGIN_DOC
|
||||||
|
! Two by two diagonalization to avoid the divergence in v^2/x when x goes to 0
|
||||||
|
!END_DOC
|
||||||
|
|
||||||
|
implicit none
|
||||||
|
|
||||||
|
double precision, intent(in) :: v, x
|
||||||
|
double precision, intent(out) :: res
|
||||||
|
|
||||||
|
double precision :: delta_E, tmp, val
|
||||||
|
|
||||||
|
res = 0d0
|
||||||
|
delta_E = x
|
||||||
|
if (v == 0.d0) return
|
||||||
|
|
||||||
|
val = 2d0 * v
|
||||||
|
tmp = dsqrt(delta_E * delta_E + val * val)
|
||||||
|
if (delta_E < 0.d0) then
|
||||||
|
tmp = -tmp
|
||||||
|
endif
|
||||||
|
res = 0.5d0 * (tmp - delta_E)
|
||||||
|
|
||||||
|
end
|
||||||
|
Loading…
Reference in New Issue
Block a user