- 01
- 02
- 03
- 04
- 05
- 06
- 07
- 08
- 09
- 10
- 11
- 12
- 13
- 14
- 15
- 16
- 17
- 18
- 19
- 20
- 21
- 22
- 23
- 24
- 25
- 26
- 27
- 28
- 29
- 30
- 31
- 32
- 33
- 34
- 35
- 36
- 37
- 38
- 39
- 40
- 41
- 42
- 43
- 44
- 45
- 46
- 47
- 48
- 49
- 50
* https://github.com/nwchemgit/nwchem/blob/8ac6bc6856d50954029cad01a751006851682398/src/nwpw/pspw/lib/psi/psi.F#L324
subroutine psi_sort_f_orb()
implicit none
#include "errquit.fh"
#include "bafdecls.fh"
#include "psi.fh"
logical value
integer i,j,ii,jj,ms
integer r1(2)
real*8 ei,ej
value = BA_push_get(mt_dcpl,npack1,'r1',r1(2),r1(1))
if (.not. value) call errquit(
> 'psi_sort_f_orb: out of stack memory',0,MA_ERR)
do ms=1,ispin
!*** Bubble sort ***
do ii=1,ne(ms)
do jj=ii+1,ne(ms)
i = ii + (ms-1)*ne(1)
j = jj + (ms-1)*ne(1)
ei = dbl_mb(eig(1)+i-1)
ej = dbl_mb(eig(1)+j-1)
!*** swap ***
if (ej.lt.ei) then
dbl_mb(eig(1)+i-1) = ej
dbl_mb(eig(1)+j-1) = ei
call Pack_c_Copy(1,dcpl_mb(psi1(1)+(i-1)*npack1),
> dcpl_mb(r1(1)))
call Pack_c_Copy(1,dcpl_mb(psi1(1)+(j-1)*npack1),
> dcpl_mb(psi1(1)+(i-1)*npack1))
call Pack_c_Copy(1,dcpl_mb(r1(1)),
> dcpl_mb(psi1(1)+(j-1)*npack1))
end if
end do
end do
end do
value = BA_pop_stack(r1(2))
if (.not. value) call errquit(
> 'psi_sort_f_orb: popping stack memory',1, MA_ERR)
return
end
Сортировка пузырьком на фортране из пакета квантовохимических вычислений "NWChem"
Follow us!