mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-16 19:02:09 +00:00
psblas3:
base/modules/Makefile base/modules/psb_c_sort_mod.f90 base/modules/psb_d_sort_mod.f90 base/modules/psb_i_sort_mod.f90 base/modules/psb_s_sort_mod.f90 base/modules/psb_sort_mod.f90 base/modules/psb_z_sort_mod.f90 base/serial/Makefile base/serial/aux/Makefile base/serial/impl/psb_c_coo_impl.f90 base/serial/impl/psb_c_csc_impl.f90 base/serial/impl/psb_c_csr_impl.f90 base/serial/impl/psb_d_coo_impl.f90 base/serial/impl/psb_d_csc_impl.f90 base/serial/impl/psb_d_csr_impl.f90 base/serial/impl/psb_s_coo_impl.f90 base/serial/impl/psb_s_csc_impl.f90 base/serial/impl/psb_s_csr_impl.f90 base/serial/impl/psb_z_coo_impl.f90 base/serial/impl/psb_z_csc_impl.f90 base/serial/impl/psb_z_csr_impl.f90 base/serial/sort/Makefile base/serial/sort/psb_c_hsort_impl.f90 base/serial/sort/psb_c_isort_impl.f90 base/serial/sort/psb_c_msort_impl.f90 base/serial/sort/psb_c_qsort_impl.f90 base/serial/sort/psb_d_hsort_impl.f90 base/serial/sort/psb_d_isort_impl.f90 base/serial/sort/psb_d_msort_impl.f90 base/serial/sort/psb_d_qsort_impl.f90 base/serial/sort/psb_i_hsort_impl.f90 base/serial/sort/psb_i_isort_impl.f90 base/serial/sort/psb_i_msort_impl.f90 base/serial/sort/psb_i_qsort_impl.f90 base/serial/sort/psb_s_isort_impl.f90 base/serial/sort/psb_s_msort_impl.f90 base/serial/sort/psb_s_qsort_impl.f90 base/serial/sort/psb_z_hsort_impl.f90 base/serial/sort/psb_z_isort_impl.f90 base/serial/sort/psb_z_msort_impl.f90 base/serial/sort/psb_z_qsort_impl.f90 base/serial/sort/psi_alcx_mod.f90 New sort implementations. Fix all methods calling them.
This commit is contained in:
Salvatore Filippone
@@ -138,6 +138,8 @@ psb_s_comm_mod.o: psb_s_vect_mod.o psb_desc_mod.o psb_mat_mod.o
|
||||
psb_d_comm_mod.o: psb_d_vect_mod.o psb_desc_mod.o psb_mat_mod.o
|
||||
psb_c_comm_mod.o: psb_c_vect_mod.o psb_desc_mod.o psb_mat_mod.o
|
||||
psb_z_comm_mod.o: psb_z_vect_mod.o psb_desc_mod.o psb_mat_mod.o
|
||||
psb_sort_mod.o: psb_i_sort_mod.o psb_s_sort_mod.o psb_d_sort_mod.o \
|
||||
psb_c_sort_mod.o psb_z_sort_mod.o psb_ip_reord_mod.o psi_serial_mod.o
|
||||
|
||||
psb_base_mod.o: $(MODULES)
|
||||
|
||||
|
||||
@@ -79,6 +79,54 @@ module psb_c_sort_mod
|
||||
end subroutine psb_cmsort
|
||||
end interface psb_msort
|
||||
|
||||
interface
|
||||
subroutine psi_c_lmsort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_c_lmsort_up
|
||||
subroutine psi_c_lmsort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_c_lmsort_dw
|
||||
subroutine psi_c_almsort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_c_almsort_up
|
||||
subroutine psi_c_almsort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_c_almsort_dw
|
||||
end interface
|
||||
interface
|
||||
subroutine psi_c_amsort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_c_amsort_up
|
||||
subroutine psi_c_amsort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_c_amsort_dw
|
||||
end interface
|
||||
|
||||
|
||||
interface psb_qsort
|
||||
subroutine psb_cqsort(x,ix,dir,flag)
|
||||
import
|
||||
|
||||
@@ -79,6 +79,40 @@ module psb_d_sort_mod
|
||||
end subroutine psb_dmsort
|
||||
end interface psb_msort
|
||||
|
||||
interface
|
||||
subroutine psi_d_msort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
real(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_d_msort_up
|
||||
subroutine psi_d_msort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
real(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_d_msort_dw
|
||||
end interface
|
||||
interface
|
||||
subroutine psi_d_amsort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
real(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_d_amsort_up
|
||||
subroutine psi_d_amsort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
real(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_d_amsort_dw
|
||||
end interface
|
||||
|
||||
|
||||
interface psb_qsort
|
||||
subroutine psb_dqsort(x,ix,dir,flag)
|
||||
import
|
||||
|
||||
@@ -120,6 +120,40 @@ module psb_i_sort_mod
|
||||
end subroutine psb_imsort
|
||||
end interface psb_msort
|
||||
|
||||
interface
|
||||
subroutine psi_i_msort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
integer(psb_ipk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_i_msort_up
|
||||
subroutine psi_i_msort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
integer(psb_ipk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_i_msort_dw
|
||||
end interface
|
||||
interface
|
||||
subroutine psi_i_amsort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
integer(psb_ipk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_i_amsort_up
|
||||
subroutine psi_i_amsort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
integer(psb_ipk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_i_amsort_dw
|
||||
end interface
|
||||
|
||||
|
||||
interface psb_qsort
|
||||
subroutine psb_iqsort(x,ix,dir,flag)
|
||||
import
|
||||
|
||||
@@ -79,6 +79,40 @@ module psb_s_sort_mod
|
||||
end subroutine psb_smsort
|
||||
end interface psb_msort
|
||||
|
||||
interface
|
||||
subroutine psi_s_msort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
real(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_s_msort_up
|
||||
subroutine psi_s_msort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
real(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_s_msort_dw
|
||||
end interface
|
||||
interface
|
||||
subroutine psi_s_amsort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
real(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_s_amsort_up
|
||||
subroutine psi_s_amsort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
real(psb_spk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_s_amsort_dw
|
||||
end interface
|
||||
|
||||
|
||||
interface psb_qsort
|
||||
subroutine psb_sqsort(x,ix,dir,flag)
|
||||
import
|
||||
|
||||
+704
-693
File diff suppressed because it is too large
Load Diff
@@ -79,6 +79,54 @@ module psb_z_sort_mod
|
||||
end subroutine psb_zmsort
|
||||
end interface psb_msort
|
||||
|
||||
interface
|
||||
subroutine psi_z_lmsort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_z_lmsort_up
|
||||
subroutine psi_z_lmsort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_z_lmsort_dw
|
||||
subroutine psi_z_almsort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_z_almsort_up
|
||||
subroutine psi_z_almsort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_z_almsort_dw
|
||||
end interface
|
||||
interface
|
||||
subroutine psi_z_amsort_up(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_z_amsort_up
|
||||
subroutine psi_z_amsort_dw(n,k,l,iret)
|
||||
import
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
complex(psb_dpk_) :: k(n)
|
||||
integer(psb_ipk_) :: l(0:n+1)
|
||||
end subroutine psi_z_amsort_dw
|
||||
end interface
|
||||
|
||||
|
||||
interface psb_qsort
|
||||
subroutine psb_zqsort(x,ix,dir,flag)
|
||||
import
|
||||
|
||||
@@ -1,7 +1,7 @@
|
||||
include ../../Make.inc
|
||||
|
||||
|
||||
FOBJS = psb_lsame.o psi_serial_impl.o psb_sort_impl.o \
|
||||
FOBJS = psb_lsame.o psi_serial_impl.o \
|
||||
psb_srwextd.o psb_drwextd.o psb_crwextd.o psb_zrwextd.o \
|
||||
psb_sspspmm.o psb_dspspmm.o psb_cspspmm.o psb_zspspmm.o \
|
||||
psb_ssymbmm.o psb_dsymbmm.o psb_csymbmm.o psb_zsymbmm.o \
|
||||
@@ -11,13 +11,14 @@ FOBJS = psb_lsame.o psi_serial_impl.o psb_sort_impl.o \
|
||||
psb_sgelp.o psb_dgelp.o psb_cgelp.o psb_zgelp.o \
|
||||
psb_samax_s.o psb_damax_s.o psb_camax_s.o psb_zamax_s.o \
|
||||
psb_sasum_s.o psb_dasum_s.o psb_casum_s.o psb_zasum_s.o
|
||||
# psb_sort_impl.o
|
||||
|
||||
LIBDIR=..
|
||||
INCDIR=..
|
||||
MODDIR=../modules
|
||||
FINCLUDES=$(FMFLAG). $(FMFLAG)$(MODDIR) $(FMFLAG)$(INCDIR)
|
||||
|
||||
lib: auxd f77d impld lib1 $(FOBJS)
|
||||
lib: auxd f77d impld sortd lib1 $(FOBJS)
|
||||
$(AR) $(LIBDIR)/$(LIBNAME) $(FOBJS)
|
||||
$(RANLIB) $(LIBDIR)/$(LIBNAME)
|
||||
|
||||
@@ -34,10 +35,14 @@ f77d:
|
||||
impld:
|
||||
cd impl && $(MAKE) lib
|
||||
|
||||
sortd:
|
||||
cd sort && $(MAKE) lib
|
||||
|
||||
clean:
|
||||
/bin/rm -f $(FOBJS) *$(.mod)
|
||||
(cd aux; $(MAKE) clean)
|
||||
(cd f77; $(MAKE) clean)
|
||||
(cd impl; $(MAKE) clean)
|
||||
(cd sort; $(MAKE) clean)
|
||||
|
||||
veryclean: clean
|
||||
|
||||
+13
-12
@@ -3,18 +3,19 @@ include ../../../Make.inc
|
||||
# The object files
|
||||
#
|
||||
|
||||
FOBJS = isr.o isrx.o iasr.o iasrx.o msort_up.o msort_dw.o\
|
||||
imsr.o imsrx.o imsru.o iamsort_up.o iamsort_dw.o idot.o inrm2.o\
|
||||
dsr.o dsrx.o dasr.o dasrx.o dmsr.o dmsrx.o \
|
||||
dmsort_up.o dmsort_dw.o damsort_up.o damsort_dw.o \
|
||||
ssr.o ssrx.o sasr.o sasrx.o smsr.o smsrx.o \
|
||||
smsort_up.o smsort_dw.o samsort_up.o samsort_dw.o \
|
||||
clcmp_mod.o clsr.o clsrx.o \
|
||||
calcmp_mod.o calsr.o calsrx.o \
|
||||
cacmp_mod.o casr.o casrx.o camsr.o camsrx.o camsort_up.o camsort_dw.o\
|
||||
zlcmp_mod.o zlsr.o zlsrx.o \
|
||||
zalcmp_mod.o zalsr.o zalsrx.o \
|
||||
zacmp_mod.o zasr.o zasrx.o zamsr.o zamsrx.o zamsort_up.o zamsort_dw.o
|
||||
FOBJS = idot.o inrm2.o
|
||||
# FOBJS = isr.o isrx.o iasr.o iasrx.o msort_up.o msort_dw.o\
|
||||
# imsr.o imsrx.o imsru.o iamsort_up.o iamsort_dw.o idot.o inrm2.o\
|
||||
# dsr.o dsrx.o dasr.o dasrx.o dmsr.o dmsrx.o \
|
||||
# dmsort_up.o dmsort_dw.o damsort_up.o damsort_dw.o \
|
||||
# ssr.o ssrx.o sasr.o sasrx.o smsr.o smsrx.o \
|
||||
# smsort_up.o smsort_dw.o samsort_up.o samsort_dw.o \
|
||||
# clcmp_mod.o clsr.o clsrx.o \
|
||||
# calcmp_mod.o calsr.o calsrx.o \
|
||||
# cacmp_mod.o casr.o casrx.o camsr.o camsrx.o camsort_up.o camsort_dw.o\
|
||||
# zlcmp_mod.o zlsr.o zlsrx.o \
|
||||
# zalcmp_mod.o zalsr.o zalsrx.o \
|
||||
# zacmp_mod.o zasr.o zasrx.o zamsr.o zamsrx.o zamsort_up.o zamsort_dw.o
|
||||
|
||||
|
||||
OBJS=$(FOBJS)
|
||||
|
||||
@@ -3382,7 +3382,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ja(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ja(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:imx),&
|
||||
& ia(i:imx),ja(i:imx),ix2)
|
||||
@@ -3493,7 +3493,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,jas(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,jas(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,vs(i:imx),&
|
||||
& ias(i:imx),jas(i:imx),ix2)
|
||||
@@ -3586,7 +3586,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
! If we did not have enough memory for buffers,
|
||||
! let's try in place.
|
||||
!
|
||||
call msort_up(nzin,ia(1:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzin,val,ia,ja,iaux)
|
||||
i = 1
|
||||
@@ -3598,7 +3598,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
if (j > nzin) exit
|
||||
enddo
|
||||
nzl = j - i
|
||||
call msort_up(nzl,ja(i:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:i+nzl-1),&
|
||||
& ia(i:i+nzl-1),ja(i:i+nzl-1),iaux)
|
||||
@@ -3704,7 +3704,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ia(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ia(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:imx),&
|
||||
& ia(i:imx),ja(i:imx),ix2)
|
||||
@@ -3813,7 +3813,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ias(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ias(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,vs(i:imx),&
|
||||
& ias(i:imx),jas(i:imx),ix2)
|
||||
@@ -3900,7 +3900,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
|
||||
else if (.not.use_buffers) then
|
||||
|
||||
call msort_up(nzin,ja(1:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzin,val,ia,ja,iaux)
|
||||
i = 1
|
||||
@@ -3911,7 +3911,7 @@ subroutine psb_c_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
if (j > nzin) exit
|
||||
enddo
|
||||
nzl = j - i
|
||||
call msort_up(nzl,ia(i:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:i+nzl-1),&
|
||||
& ia(i:i+nzl-1),ja(i:i+nzl-1),iaux)
|
||||
|
||||
@@ -2846,7 +2846,6 @@ contains
|
||||
integer(psb_ipk_) :: ma,na,mb,nb
|
||||
integer(psb_ipk_), allocatable :: icol(:), idxs(:), iaux(:)
|
||||
complex(psb_spk_), allocatable :: col(:)
|
||||
type(psb_int_heap) :: heap
|
||||
integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, &
|
||||
& nzc,nnzre, isz, ipb, irwsz, nrc, nze
|
||||
complex(psb_spk_) :: cfb
|
||||
|
||||
@@ -3085,7 +3085,6 @@ contains
|
||||
integer(psb_ipk_) :: ma,na,mb,nb
|
||||
integer(psb_ipk_), allocatable :: irow(:), idxs(:)
|
||||
complex(psb_spk_), allocatable :: row(:)
|
||||
type(psb_int_heap) :: heap
|
||||
integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, &
|
||||
& nzc,nnzre, isz, ipb, irwsz, nrc, nze
|
||||
complex(psb_spk_) :: cfb
|
||||
|
||||
@@ -3382,7 +3382,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ja(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ja(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:imx),&
|
||||
& ia(i:imx),ja(i:imx),ix2)
|
||||
@@ -3493,7 +3493,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,jas(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,jas(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,vs(i:imx),&
|
||||
& ias(i:imx),jas(i:imx),ix2)
|
||||
@@ -3586,7 +3586,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
! If we did not have enough memory for buffers,
|
||||
! let's try in place.
|
||||
!
|
||||
call msort_up(nzin,ia(1:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzin,val,ia,ja,iaux)
|
||||
i = 1
|
||||
@@ -3598,7 +3598,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
if (j > nzin) exit
|
||||
enddo
|
||||
nzl = j - i
|
||||
call msort_up(nzl,ja(i:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:i+nzl-1),&
|
||||
& ia(i:i+nzl-1),ja(i:i+nzl-1),iaux)
|
||||
@@ -3704,7 +3704,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ia(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ia(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:imx),&
|
||||
& ia(i:imx),ja(i:imx),ix2)
|
||||
@@ -3813,7 +3813,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ias(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ias(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,vs(i:imx),&
|
||||
& ias(i:imx),jas(i:imx),ix2)
|
||||
@@ -3900,7 +3900,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
|
||||
else if (.not.use_buffers) then
|
||||
|
||||
call msort_up(nzin,ja(1:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzin,val,ia,ja,iaux)
|
||||
i = 1
|
||||
@@ -3911,7 +3911,7 @@ subroutine psb_d_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
if (j > nzin) exit
|
||||
enddo
|
||||
nzl = j - i
|
||||
call msort_up(nzl,ia(i:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:i+nzl-1),&
|
||||
& ia(i:i+nzl-1),ja(i:i+nzl-1),iaux)
|
||||
|
||||
@@ -2846,7 +2846,6 @@ contains
|
||||
integer(psb_ipk_) :: ma,na,mb,nb
|
||||
integer(psb_ipk_), allocatable :: icol(:), idxs(:), iaux(:)
|
||||
real(psb_dpk_), allocatable :: col(:)
|
||||
type(psb_int_heap) :: heap
|
||||
integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, &
|
||||
& nzc,nnzre, isz, ipb, irwsz, nrc, nze
|
||||
real(psb_dpk_) :: cfb
|
||||
|
||||
@@ -3085,7 +3085,6 @@ contains
|
||||
integer(psb_ipk_) :: ma,na,mb,nb
|
||||
integer(psb_ipk_), allocatable :: irow(:), idxs(:)
|
||||
real(psb_dpk_), allocatable :: row(:)
|
||||
type(psb_int_heap) :: heap
|
||||
integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, &
|
||||
& nzc,nnzre, isz, ipb, irwsz, nrc, nze
|
||||
real(psb_dpk_) :: cfb
|
||||
|
||||
@@ -3382,7 +3382,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ja(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ja(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:imx),&
|
||||
& ia(i:imx),ja(i:imx),ix2)
|
||||
@@ -3493,7 +3493,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,jas(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,jas(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,vs(i:imx),&
|
||||
& ias(i:imx),jas(i:imx),ix2)
|
||||
@@ -3586,7 +3586,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
! If we did not have enough memory for buffers,
|
||||
! let's try in place.
|
||||
!
|
||||
call msort_up(nzin,ia(1:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzin,val,ia,ja,iaux)
|
||||
i = 1
|
||||
@@ -3598,7 +3598,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
if (j > nzin) exit
|
||||
enddo
|
||||
nzl = j - i
|
||||
call msort_up(nzl,ja(i:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:i+nzl-1),&
|
||||
& ia(i:i+nzl-1),ja(i:i+nzl-1),iaux)
|
||||
@@ -3704,7 +3704,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ia(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ia(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:imx),&
|
||||
& ia(i:imx),ja(i:imx),ix2)
|
||||
@@ -3813,7 +3813,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ias(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ias(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,vs(i:imx),&
|
||||
& ias(i:imx),jas(i:imx),ix2)
|
||||
@@ -3900,7 +3900,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
|
||||
else if (.not.use_buffers) then
|
||||
|
||||
call msort_up(nzin,ja(1:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzin,val,ia,ja,iaux)
|
||||
i = 1
|
||||
@@ -3911,7 +3911,7 @@ subroutine psb_s_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
if (j > nzin) exit
|
||||
enddo
|
||||
nzl = j - i
|
||||
call msort_up(nzl,ia(i:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:i+nzl-1),&
|
||||
& ia(i:i+nzl-1),ja(i:i+nzl-1),iaux)
|
||||
|
||||
@@ -2846,7 +2846,6 @@ contains
|
||||
integer(psb_ipk_) :: ma,na,mb,nb
|
||||
integer(psb_ipk_), allocatable :: icol(:), idxs(:), iaux(:)
|
||||
real(psb_spk_), allocatable :: col(:)
|
||||
type(psb_int_heap) :: heap
|
||||
integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, &
|
||||
& nzc,nnzre, isz, ipb, irwsz, nrc, nze
|
||||
real(psb_spk_) :: cfb
|
||||
|
||||
@@ -3085,7 +3085,6 @@ contains
|
||||
integer(psb_ipk_) :: ma,na,mb,nb
|
||||
integer(psb_ipk_), allocatable :: irow(:), idxs(:)
|
||||
real(psb_spk_), allocatable :: row(:)
|
||||
type(psb_int_heap) :: heap
|
||||
integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, &
|
||||
& nzc,nnzre, isz, ipb, irwsz, nrc, nze
|
||||
real(psb_spk_) :: cfb
|
||||
|
||||
@@ -3382,7 +3382,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ja(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ja(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:imx),&
|
||||
& ia(i:imx),ja(i:imx),ix2)
|
||||
@@ -3493,7 +3493,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,jas(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,jas(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,vs(i:imx),&
|
||||
& ias(i:imx),jas(i:imx),ix2)
|
||||
@@ -3586,7 +3586,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
! If we did not have enough memory for buffers,
|
||||
! let's try in place.
|
||||
!
|
||||
call msort_up(nzin,ia(1:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzin,ia(1:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzin,val,ia,ja,iaux)
|
||||
i = 1
|
||||
@@ -3598,7 +3598,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
if (j > nzin) exit
|
||||
enddo
|
||||
nzl = j - i
|
||||
call msort_up(nzl,ja(i:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzl,ja(i:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:i+nzl-1),&
|
||||
& ia(i:i+nzl-1),ja(i:i+nzl-1),iaux)
|
||||
@@ -3704,7 +3704,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ia(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ia(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:imx),&
|
||||
& ia(i:imx),ja(i:imx),ix2)
|
||||
@@ -3813,7 +3813,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
imx = i+nzl-1
|
||||
|
||||
if (nzl > 0) then
|
||||
call msort_up(nzl,ias(i:imx),ix2,iret)
|
||||
call psi_i_msort_up(nzl,ias(i:imx),ix2,iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,vs(i:imx),&
|
||||
& ias(i:imx),jas(i:imx),ix2)
|
||||
@@ -3900,7 +3900,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
|
||||
else if (.not.use_buffers) then
|
||||
|
||||
call msort_up(nzin,ja(1:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzin,ja(1:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzin,val,ia,ja,iaux)
|
||||
i = 1
|
||||
@@ -3911,7 +3911,7 @@ subroutine psb_z_fix_coo_inner(nr,nc,nzin,dupl,ia,ja,val,nzout,info,idir)
|
||||
if (j > nzin) exit
|
||||
enddo
|
||||
nzl = j - i
|
||||
call msort_up(nzl,ia(i:),iaux(1:),iret)
|
||||
call psi_i_msort_up(nzl,ia(i:),iaux(1:),iret)
|
||||
if (iret == 0) &
|
||||
& call psb_ip_reord(nzl,val(i:i+nzl-1),&
|
||||
& ia(i:i+nzl-1),ja(i:i+nzl-1),iaux)
|
||||
|
||||
@@ -2846,7 +2846,6 @@ contains
|
||||
integer(psb_ipk_) :: ma,na,mb,nb
|
||||
integer(psb_ipk_), allocatable :: icol(:), idxs(:), iaux(:)
|
||||
complex(psb_dpk_), allocatable :: col(:)
|
||||
type(psb_int_heap) :: heap
|
||||
integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, &
|
||||
& nzc,nnzre, isz, ipb, irwsz, nrc, nze
|
||||
complex(psb_dpk_) :: cfb
|
||||
|
||||
@@ -3085,7 +3085,6 @@ contains
|
||||
integer(psb_ipk_) :: ma,na,mb,nb
|
||||
integer(psb_ipk_), allocatable :: irow(:), idxs(:)
|
||||
complex(psb_dpk_), allocatable :: row(:)
|
||||
type(psb_int_heap) :: heap
|
||||
integer(psb_ipk_) :: i,j,k,irw,icl,icf, iret, &
|
||||
& nzc,nnzre, isz, ipb, irwsz, nrc, nze
|
||||
complex(psb_dpk_) :: cfb
|
||||
|
||||
@@ -4,12 +4,13 @@ include ../../../Make.inc
|
||||
# The object files
|
||||
#
|
||||
BOBJS=psi_lcx_mod.o psi_alcx_mod.o psi_acx_mod.o
|
||||
IOBJS=psb_i_hsort_impl.o psb_i_isort_impl.o psb_i_msort_impl.o psb_i_qsort_impl.o
|
||||
SOBJS=psb_s_hsort_impl.o psb_s_isort_impl.o psb_s_msort_impl.o psb_s_qsort_impl.o
|
||||
DOBJS=psb_d_hsort_impl.o psb_d_isort_impl.o psb_d_msort_impl.o psb_d_qsort_impl.o
|
||||
COBJS=psb_c_hsort_impl.o psb_c_isort_impl.o psb_c_msort_impl.o psb_c_qsort_impl.o
|
||||
ZOBJS=psb_z_hsort_impl.o psb_z_isort_impl.o psb_z_msort_impl.o psb_z_qsort_impl.o
|
||||
|
||||
OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS)
|
||||
OBJS=$(BOBJS) $(IOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS)
|
||||
|
||||
#
|
||||
# Where the library should go, and how it is called.
|
||||
|
||||
@@ -50,7 +50,7 @@ subroutine psb_chsort(x,ix,dir,flag)
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info
|
||||
real(psb_spk_) :: key
|
||||
complex(psb_spk_) :: key
|
||||
integer(psb_ipk_) :: index
|
||||
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
@@ -391,7 +391,7 @@ contains
|
||||
end subroutine psi_c_insert_heap
|
||||
|
||||
subroutine psi_c_heap_get_first(key,last,heap,dir,info)
|
||||
use psb_c_sort_mod, psb_protect_name => psi_c_insert_heap
|
||||
use psb_c_sort_mod, psb_protect_name => psi_c_heap_get_first
|
||||
implicit none
|
||||
|
||||
!
|
||||
@@ -633,7 +633,7 @@ contains
|
||||
end subroutine psi_c_heap_get_first
|
||||
|
||||
subroutine psi_c_idx_insert_heap(key,index,last,heap,idxs,dir,info)
|
||||
use psb_c_sort_mod, psb_protect_name => psi_c_idx_insert_idx_heap
|
||||
use psb_c_sort_mod, psb_protect_name => psi_c_idx_insert_heap
|
||||
|
||||
implicit none
|
||||
!
|
||||
@@ -869,7 +869,7 @@ end subroutine psi_c_idx_insert_heap
|
||||
|
||||
|
||||
subroutine psi_c_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
|
||||
use psb_c_sort_mod, psb_protect_name => psi_c_insert_heap
|
||||
use psb_c_sort_mod, psb_protect_name => psi_c_idx_heap_get_first
|
||||
implicit none
|
||||
|
||||
!
|
||||
@@ -905,22 +905,22 @@ subroutine psi_c_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
|
||||
info = -4
|
||||
|
||||
case (psb_asort_up_)
|
||||
call fix_aup(last,heap)
|
||||
call fix_aup(last,heap,idxs)
|
||||
|
||||
case (psb_asort_down_)
|
||||
call fix_adw(last,heap)
|
||||
call fix_adw(last,heap,idxs)
|
||||
|
||||
case (psb_alsort_up_)
|
||||
call fix_alup(last,heap)
|
||||
call fix_alup(last,heap,idxs)
|
||||
|
||||
case (psb_alsort_down_)
|
||||
call fix_aldw(last,heap)
|
||||
call fix_aldw(last,heap,idxs)
|
||||
|
||||
case (psb_lsort_up_)
|
||||
call fix_lup(last,heap)
|
||||
call fix_lup(last,heap,idxs)
|
||||
|
||||
case (psb_lsort_down_)
|
||||
call fix_ldw(last,heap)
|
||||
call fix_ldw(last,heap,idxs)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) 'Invalid direction in heap ',dir
|
||||
@@ -933,7 +933,7 @@ contains
|
||||
use psi_acx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_spk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_spk_) :: temp
|
||||
@@ -968,7 +968,7 @@ contains
|
||||
use psi_acx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_spk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_spk_) :: temp
|
||||
@@ -1002,7 +1002,7 @@ contains
|
||||
use psi_lcx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_spk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_spk_) :: temp
|
||||
@@ -1036,7 +1036,7 @@ contains
|
||||
use psi_lcx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_spk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_spk_) :: temp
|
||||
@@ -1070,7 +1070,7 @@ contains
|
||||
use psi_alcx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_spk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_spk_) :: temp
|
||||
@@ -1104,7 +1104,7 @@ contains
|
||||
use psi_alcx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_spk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_spk_) :: temp
|
||||
@@ -1134,7 +1134,7 @@ contains
|
||||
|
||||
end subroutine fix_aldw
|
||||
|
||||
end subroutine psi_c_heap_get_first
|
||||
end subroutine psi_c_idx_heap_get_first
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -137,13 +137,13 @@ subroutine psb_cisort(x,ix,dir,flag)
|
||||
return
|
||||
end subroutine psb_cisort
|
||||
|
||||
subroutine psi_clisrx_up(n,x,ix)
|
||||
subroutine psi_clisrx_up(n,x,idx)
|
||||
use psb_c_sort_mod, psb_protect_name => psi_clisrx_up
|
||||
use psb_error_mod
|
||||
use psi_lcx_mod
|
||||
implicit none
|
||||
complex(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_spk_) :: xx
|
||||
@@ -167,13 +167,13 @@ subroutine psi_clisrx_up(n,x,ix)
|
||||
|
||||
end subroutine psi_clisrx_up
|
||||
|
||||
subroutine psi_clisrx_dw(n,x,ix)
|
||||
subroutine psi_clisrx_dw(n,x,idx)
|
||||
use psb_c_sort_mod, psb_protect_name => psi_clisrx_dw
|
||||
use psb_error_mod
|
||||
use psi_lcx_mod
|
||||
implicit none
|
||||
complex(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_spk_) :: xx
|
||||
@@ -246,13 +246,13 @@ subroutine psi_clisr_dw(n,x)
|
||||
enddo
|
||||
end subroutine psi_clisr_dw
|
||||
|
||||
subroutine psi_calisrx_up(n,x,ix)
|
||||
subroutine psi_calisrx_up(n,x,idx)
|
||||
use psb_c_sort_mod, psb_protect_name => psi_calisrx_up
|
||||
use psb_error_mod
|
||||
use psi_alcx_mod
|
||||
implicit none
|
||||
complex(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_spk_) :: xx
|
||||
@@ -275,13 +275,13 @@ subroutine psi_calisrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_calisrx_up
|
||||
|
||||
subroutine psi_calisrx_dw(n,x,ix)
|
||||
subroutine psi_calisrx_dw(n,x,idx)
|
||||
use psb_c_sort_mod, psb_protect_name => psi_calisrx_dw
|
||||
use psb_error_mod
|
||||
use psi_alcx_mod
|
||||
implicit none
|
||||
complex(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_spk_) :: xx
|
||||
@@ -354,12 +354,12 @@ subroutine psi_calisr_dw(n,x)
|
||||
enddo
|
||||
end subroutine psi_calisr_dw
|
||||
|
||||
subroutine psi_caisrx_up(n,x,ix)
|
||||
subroutine psi_caisrx_up(n,x,idx)
|
||||
use psb_c_sort_mod, psb_protect_name => psi_caisrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
complex(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_spk_) :: xx
|
||||
@@ -382,12 +382,12 @@ subroutine psi_caisrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_caisrx_up
|
||||
|
||||
subroutine psi_caisrx_dw(n,x,ix)
|
||||
subroutine psi_caisrx_dw(n,x,idx)
|
||||
use psb_c_sort_mod, psb_protect_name => psi_caisrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
complex(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_spk_) :: xx
|
||||
|
||||
@@ -29,17 +29,17 @@
|
||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||
!!$
|
||||
!!$
|
||||
!
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
!
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
|
||||
|
||||
|
||||
@@ -48,108 +48,109 @@
|
||||
|
||||
|
||||
|
||||
subroutine psb_cmsort(x,ix,dir,flag)
|
||||
use psb_c_sort_mod, psb_protect_name => psb_cmsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
complex(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
subroutine psb_cmsort(x,ix,dir,flag)
|
||||
use psb_c_sort_mod, psb_protect_name => psb_cmsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
complex(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
|
||||
name='psb_cmsort'
|
||||
call psb_erractionsave(err_act)
|
||||
name='psb_cmsort'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_asort_up_
|
||||
end if
|
||||
select case(dir_)
|
||||
case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,&
|
||||
& psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
n = size(x)
|
||||
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_asort_up_
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
select case(dir_)
|
||||
case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,&
|
||||
& psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
end if
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_c_msort')
|
||||
goto 9999
|
||||
endif
|
||||
n = size(x)
|
||||
|
||||
select case(idir)
|
||||
case (psb_lsort_up_)
|
||||
call in_lmsort_up(n,x,iaux,iret)
|
||||
case (psb_lsort_down_)
|
||||
call in_lmsort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call in_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call in_amsort_dw(n,x,iaux,iret)
|
||||
case (psb_alsort_up_)
|
||||
call in_almsort_up(n,x,iaux,iret)
|
||||
case (psb_alsort_down_)
|
||||
call in_almsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,indx,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
end if
|
||||
end if
|
||||
|
||||
return
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_c_msort')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
select case(dir_)
|
||||
case (psb_lsort_up_)
|
||||
call psi_c_lmsort_up(n,x,iaux,iret)
|
||||
case (psb_lsort_down_)
|
||||
call psi_c_lmsort_dw(n,x,iaux,iret)
|
||||
case (psb_alsort_up_)
|
||||
call psi_c_almsort_up(n,x,iaux,iret)
|
||||
case (psb_alsort_down_)
|
||||
call psi_c_almsort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call psi_c_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call psi_c_amsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,ix,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
end if
|
||||
end if
|
||||
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine in_lmsort_up(n,k,l,iret)
|
||||
end subroutine psb_cmsort
|
||||
|
||||
subroutine psi_c_lmsort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_lcx_mod
|
||||
implicit none
|
||||
@@ -252,9 +253,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_lmsort_up
|
||||
end subroutine psi_c_lmsort_up
|
||||
|
||||
subroutine in_lmsort_dw(n,k,l,iret)
|
||||
subroutine psi_c_lmsort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_lcx_mod
|
||||
implicit none
|
||||
@@ -357,9 +358,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_lmsort_dw
|
||||
end subroutine psi_c_lmsort_dw
|
||||
|
||||
subroutine in_amsort_up(n,k,l,iret)
|
||||
subroutine psi_c_amsort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_acx_mod
|
||||
implicit none
|
||||
@@ -462,9 +463,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_up
|
||||
end subroutine psi_c_amsort_up
|
||||
|
||||
subroutine in_amsort_dw(n,k,l,iret)
|
||||
subroutine psi_c_amsort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_acx_mod
|
||||
implicit none
|
||||
@@ -567,9 +568,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_dw
|
||||
end subroutine psi_c_amsort_dw
|
||||
|
||||
subroutine in_almsort_up(n,k,l,iret)
|
||||
subroutine psi_c_almsort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_alcx_mod
|
||||
implicit none
|
||||
@@ -672,9 +673,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_almsort_up
|
||||
end subroutine psi_c_almsort_up
|
||||
|
||||
subroutine in_almsort_dw(n,k,l,iret)
|
||||
subroutine psi_c_almsort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_alcx_mod
|
||||
implicit none
|
||||
@@ -777,6 +778,5 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_almsort_dw
|
||||
end subroutine psi_c_almsort_dw
|
||||
|
||||
end subroutine psb_cmsort
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -50,7 +50,7 @@ subroutine psb_dhsort(x,ix,dir,flag)
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info
|
||||
real(psb_spk_) :: key
|
||||
real(psb_dpk_) :: key
|
||||
integer(psb_ipk_) :: index
|
||||
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
|
||||
@@ -129,12 +129,12 @@ subroutine psb_disort(x,ix,dir,flag)
|
||||
return
|
||||
end subroutine psb_disort
|
||||
|
||||
subroutine psi_disrx_up(n,x,ix)
|
||||
subroutine psi_disrx_up(n,x,idx)
|
||||
use psb_d_sort_mod, psb_protect_name => psi_disrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
real(psb_dpk_) :: xx
|
||||
@@ -157,12 +157,12 @@ subroutine psi_disrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_disrx_up
|
||||
|
||||
subroutine psi_disrx_dw(n,x,ix)
|
||||
subroutine psi_disrx_dw(n,x,idx)
|
||||
use psb_d_sort_mod, psb_protect_name => psi_disrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
real(psb_dpk_) :: xx
|
||||
@@ -234,12 +234,12 @@ subroutine psi_disr_dw(n,x)
|
||||
enddo
|
||||
end subroutine psi_disr_dw
|
||||
|
||||
subroutine psi_daisrx_up(n,x,ix)
|
||||
subroutine psi_daisrx_up(n,x,idx)
|
||||
use psb_d_sort_mod, psb_protect_name => psi_daisrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
real(psb_dpk_) :: xx
|
||||
@@ -262,12 +262,12 @@ subroutine psi_daisrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_daisrx_up
|
||||
|
||||
subroutine psi_daisrx_dw(n,x,ix)
|
||||
subroutine psi_daisrx_dw(n,x,idx)
|
||||
use psb_d_sort_mod, psb_protect_name => psi_daisrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
real(psb_dpk_) :: xx
|
||||
|
||||
@@ -29,117 +29,118 @@
|
||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||
!!$
|
||||
!!$
|
||||
!
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
!
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
|
||||
subroutine psb_dmsort(x,ix,dir,flag)
|
||||
use psb_d_sort_mod, psb_protect_name => psb_dmsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
subroutine psb_dmsort(x,ix,dir,flag)
|
||||
use psb_d_sort_mod, psb_protect_name => psb_dmsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
|
||||
name='psb_dmsort'
|
||||
call psb_erractionsave(err_act)
|
||||
name='psb_dmsort'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_sort_up_
|
||||
end if
|
||||
select case(dir_)
|
||||
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
n = size(x)
|
||||
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_sort_up_
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
select case(dir_)
|
||||
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
end if
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_d_msort')
|
||||
goto 9999
|
||||
endif
|
||||
n = size(x)
|
||||
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
select case(idir)
|
||||
case (psb_sort_up_)
|
||||
call in_msort_up(n,x,iaux,iret)
|
||||
case (psb_sort_down_)
|
||||
call in_msort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call in_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call in_amsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,indx,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
return
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_d_msort')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
select case(dir_)
|
||||
case (psb_sort_up_)
|
||||
call psi_d_msort_up(n,x,iaux,iret)
|
||||
case (psb_sort_down_)
|
||||
call psi_d_msort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call psi_d_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call psi_d_amsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,ix,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine in_msort_up(n,k,l,iret)
|
||||
end subroutine psb_dmsort
|
||||
|
||||
subroutine psi_d_msort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -241,9 +242,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_msort_up
|
||||
end subroutine psi_d_msort_up
|
||||
|
||||
subroutine in_msort_dw(n,k,l,iret)
|
||||
subroutine psi_d_msort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -345,9 +346,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_msort_dw
|
||||
end subroutine psi_d_msort_dw
|
||||
|
||||
subroutine in_amsort_up(n,k,l,iret)
|
||||
subroutine psi_d_amsort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -449,9 +450,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_up
|
||||
end subroutine psi_d_amsort_up
|
||||
|
||||
subroutine in_amsort_dw(n,k,l,iret)
|
||||
subroutine psi_d_amsort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -553,10 +554,8 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_dw
|
||||
|
||||
|
||||
end subroutine psb_dmsort
|
||||
end subroutine psi_d_amsort_dw
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -48,7 +48,7 @@ subroutine psb_dqsort(x,ix,dir,flag)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act, i
|
||||
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
@@ -129,15 +129,13 @@ subroutine psb_dqsort(x,ix,dir,flag)
|
||||
return
|
||||
end subroutine psb_dqsort
|
||||
|
||||
|
||||
|
||||
subroutine psi_dqsrx_up(n,x,ix)
|
||||
subroutine psi_dqsrx_up(n,x,idx)
|
||||
use psb_d_sort_mod, psb_protect_name => psi_dqsrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_dpk_) :: piv, xk, xt
|
||||
@@ -170,40 +168,40 @@ subroutine psi_dqsrx_up(n,x,ix)
|
||||
piv = x(lpiv)
|
||||
if (piv < x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv > x(j)) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv < x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -228,11 +226,11 @@ subroutine psi_dqsrx_up(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_up
|
||||
end if
|
||||
@@ -254,14 +252,14 @@ subroutine psi_dqsrx_up(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_disrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_disrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_disrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_disrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -269,29 +267,29 @@ subroutine psi_dqsrx_up(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_disrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_disrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_disrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_disrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_disrx_up(n,x,indx)
|
||||
call psi_disrx_up(n,x,idx)
|
||||
endif
|
||||
end subroutine psi_dqsrx_up
|
||||
|
||||
subroutine psi_dqsrx_dw(n,x,ix)
|
||||
subroutine psi_dqsrx_dw(n,x,idx)
|
||||
use psb_d_sort_mod, psb_protect_name => psi_dqsrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_dpk_) :: piv, xk, xt
|
||||
@@ -324,40 +322,40 @@ subroutine psi_dqsrx_dw(n,x,ix)
|
||||
piv = x(lpiv)
|
||||
if (piv > x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv < x(j)) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv > x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -382,11 +380,11 @@ subroutine psi_dqsrx_dw(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_dw
|
||||
end if
|
||||
@@ -408,14 +406,14 @@ subroutine psi_dqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_disrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_disrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_disrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_disrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -423,19 +421,19 @@ subroutine psi_dqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_disrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_disrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_disrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_disrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_disrx_dw(n,x,indx)
|
||||
call psi_disrx_dw(n,x,idx)
|
||||
endif
|
||||
|
||||
end subroutine psi_dqsrx_dw
|
||||
@@ -590,7 +588,7 @@ subroutine psi_dqsr_dw(n,x)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! ..
|
||||
! .. Local Scalars ..
|
||||
real(@FKIND) :: piv, xt, xk
|
||||
real(psb_dpk_) :: piv, xt, xk
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: n1, n2
|
||||
|
||||
@@ -722,16 +720,17 @@ subroutine psi_dqsr_dw(n,x)
|
||||
|
||||
end subroutine psi_dqsr_dw
|
||||
|
||||
subroutine psi_daqsrx_up(n,x,ix)
|
||||
subroutine psi_daqsrx_up(n,x,idx)
|
||||
use psb_d_sort_mod, psb_protect_name => psi_daqsrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_dpk_) :: piv, xk, xt
|
||||
real(psb_dpk_) :: piv, xk
|
||||
real(psb_dpk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
@@ -761,39 +760,39 @@ subroutine psi_daqsrx_up(n,x,ix)
|
||||
piv = abs(x(lpiv))
|
||||
if (piv < abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv > abs(x(j))) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv < abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -818,11 +817,11 @@ subroutine psi_daqsrx_up(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_up
|
||||
end if
|
||||
@@ -844,14 +843,14 @@ subroutine psi_daqsrx_up(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_daisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_daisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_daisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_daisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -859,34 +858,35 @@ subroutine psi_daqsrx_up(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_daisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_daisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_daisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_daisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_daisrx_up(n,x,indx)
|
||||
call psi_daisrx_up(n,x,idx)
|
||||
endif
|
||||
|
||||
|
||||
end subroutine psi_daqsrx_up
|
||||
|
||||
subroutine psi_daqsrx_dw(n,x,ix)
|
||||
subroutine psi_daqsrx_dw(n,x,idx)
|
||||
use psb_d_sort_mod, psb_protect_name => psi_daqsrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_dpk_) :: piv, xk, xt
|
||||
real(psb_dpk_) :: piv, xk
|
||||
real(psb_dpk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
@@ -915,39 +915,39 @@ subroutine psi_daqsrx_dw(n,x,ix)
|
||||
piv = abs(x(lpiv))
|
||||
if (piv > abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv < abs(x(j))) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv > abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -972,11 +972,11 @@ subroutine psi_daqsrx_dw(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_dw
|
||||
end if
|
||||
@@ -998,14 +998,14 @@ subroutine psi_daqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_daisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_daisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_daisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_daisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -1013,19 +1013,19 @@ subroutine psi_daqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_daisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_daisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_daisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_daisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_daisrx_dw(n,x,indx)
|
||||
call psi_daisrx_dw(n,x,idx)
|
||||
endif
|
||||
|
||||
end subroutine psi_daqsrx_dw
|
||||
@@ -1038,7 +1038,8 @@ subroutine psi_daqsr_up(n,x)
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_dpk_) :: piv, xk, xt
|
||||
real(psb_dpk_) :: piv, xk
|
||||
real(psb_dpk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
@@ -1177,7 +1178,8 @@ subroutine psi_daqsr_dw(n,x)
|
||||
real(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_dpk_) :: piv, xk, xt
|
||||
real(psb_dpk_) :: piv, xk
|
||||
real(psb_dpk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
|
||||
@@ -50,7 +50,7 @@ subroutine psb_ihsort(x,ix,dir,flag)
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info
|
||||
real(psb_spk_) :: key
|
||||
integer(psb_ipk_) :: key
|
||||
integer(psb_ipk_) :: index
|
||||
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
|
||||
@@ -129,12 +129,12 @@ subroutine psb_iisort(x,ix,dir,flag)
|
||||
return
|
||||
end subroutine psb_iisort
|
||||
|
||||
subroutine psi_iisrx_up(n,x,ix)
|
||||
subroutine psi_iisrx_up(n,x,idx)
|
||||
use psb_i_sort_mod, psb_protect_name => psi_iisrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
integer(psb_ipk_) :: xx
|
||||
@@ -157,12 +157,12 @@ subroutine psi_iisrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_iisrx_up
|
||||
|
||||
subroutine psi_iisrx_dw(n,x,ix)
|
||||
subroutine psi_iisrx_dw(n,x,idx)
|
||||
use psb_i_sort_mod, psb_protect_name => psi_iisrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
integer(psb_ipk_) :: xx
|
||||
@@ -234,12 +234,12 @@ subroutine psi_iisr_dw(n,x)
|
||||
enddo
|
||||
end subroutine psi_iisr_dw
|
||||
|
||||
subroutine psi_iaisrx_up(n,x,ix)
|
||||
subroutine psi_iaisrx_up(n,x,idx)
|
||||
use psb_i_sort_mod, psb_protect_name => psi_iaisrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
integer(psb_ipk_) :: xx
|
||||
@@ -262,12 +262,12 @@ subroutine psi_iaisrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_iaisrx_up
|
||||
|
||||
subroutine psi_iaisrx_dw(n,x,ix)
|
||||
subroutine psi_iaisrx_dw(n,x,idx)
|
||||
use psb_i_sort_mod, psb_protect_name => psi_iaisrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
integer(psb_ipk_) :: xx
|
||||
|
||||
@@ -29,308 +29,309 @@
|
||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||
!!$
|
||||
!!$
|
||||
!
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
logical function psb_isaperm(n,eip)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_isaperm
|
||||
implicit none
|
||||
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_), intent(in) :: eip(n)
|
||||
integer(psb_ipk_), allocatable :: ip(:)
|
||||
integer(psb_ipk_) :: i,j,m, info
|
||||
|
||||
|
||||
psb_isaperm = .true.
|
||||
if (n <= 0) return
|
||||
allocate(ip(n), stat=info)
|
||||
if (info /= psb_success_) return
|
||||
!
|
||||
! sanity check first
|
||||
!
|
||||
do i=1, n
|
||||
ip(i) = eip(i)
|
||||
if ((ip(i) < 1).or.(ip(i) > n)) then
|
||||
write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n
|
||||
psb_isaperm = .false.
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
logical function psb_isaperm(n,eip)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_isaperm
|
||||
implicit none
|
||||
|
||||
!
|
||||
! now work through the cycles, by marking each successive item as negative.
|
||||
! no cycle should intersect with any other, hence the >= 1 check.
|
||||
!
|
||||
do m = 1, n
|
||||
i = ip(m)
|
||||
if (i < 0) then
|
||||
ip(m) = -i
|
||||
else if (i /= m) then
|
||||
j = ip(i)
|
||||
ip(i) = -j
|
||||
i = j
|
||||
do while ((j >= 1).and.(j /= m))
|
||||
j = ip(i)
|
||||
ip(i) = -j
|
||||
i = j
|
||||
enddo
|
||||
ip(m) = abs(ip(m))
|
||||
if (j /= m) then
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_), intent(in) :: eip(n)
|
||||
integer(psb_ipk_), allocatable :: ip(:)
|
||||
integer(psb_ipk_) :: i,j,m, info
|
||||
|
||||
|
||||
psb_isaperm = .true.
|
||||
if (n <= 0) return
|
||||
allocate(ip(n), stat=info)
|
||||
if (info /= psb_success_) return
|
||||
!
|
||||
! sanity check first
|
||||
!
|
||||
do i=1, n
|
||||
ip(i) = eip(i)
|
||||
if ((ip(i) < 1).or.(ip(i) > n)) then
|
||||
write(psb_err_unit,*) 'Out of bounds in isaperm' ,ip(i), n
|
||||
psb_isaperm = .false.
|
||||
goto 9999
|
||||
return
|
||||
endif
|
||||
end if
|
||||
enddo
|
||||
enddo
|
||||
|
||||
!
|
||||
! now work through the cycles, by marking each successive item as negative.
|
||||
! no cycle should intersect with any other, hence the >= 1 check.
|
||||
!
|
||||
do m = 1, n
|
||||
i = ip(m)
|
||||
if (i < 0) then
|
||||
ip(m) = -i
|
||||
else if (i /= m) then
|
||||
j = ip(i)
|
||||
ip(i) = -j
|
||||
i = j
|
||||
do while ((j >= 1).and.(j /= m))
|
||||
j = ip(i)
|
||||
ip(i) = -j
|
||||
i = j
|
||||
enddo
|
||||
ip(m) = abs(ip(m))
|
||||
if (j /= m) then
|
||||
psb_isaperm = .false.
|
||||
goto 9999
|
||||
endif
|
||||
end if
|
||||
enddo
|
||||
9999 continue
|
||||
|
||||
return
|
||||
end function psb_isaperm
|
||||
return
|
||||
end function psb_isaperm
|
||||
|
||||
function psb_iblsrch(key,n,v) result(ipos)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_iblsrch
|
||||
implicit none
|
||||
integer(psb_ipk_) :: ipos, key, n
|
||||
integer(psb_ipk_) :: v(:)
|
||||
function psb_iblsrch(key,n,v) result(ipos)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_iblsrch
|
||||
implicit none
|
||||
integer(psb_ipk_) :: ipos, key, n
|
||||
integer(psb_ipk_) :: v(:)
|
||||
|
||||
integer(psb_ipk_) :: lb, ub, m
|
||||
integer(psb_ipk_) :: lb, ub, m
|
||||
|
||||
if (n < 5) then
|
||||
! don't bother with binary search for very
|
||||
! small vectors
|
||||
ipos = 0
|
||||
do
|
||||
if (ipos == n) return
|
||||
if (key < v(ipos+1)) return
|
||||
ipos = ipos + 1
|
||||
end do
|
||||
else
|
||||
lb = 1
|
||||
ub = n
|
||||
ipos = -1
|
||||
|
||||
do while (lb <= ub)
|
||||
m = (lb+ub)/2
|
||||
if (key==v(m)) then
|
||||
ipos = m
|
||||
return
|
||||
else if (key < v(m)) then
|
||||
ub = m-1
|
||||
else
|
||||
lb = m + 1
|
||||
end if
|
||||
enddo
|
||||
if (v(ub) > key) then
|
||||
!!$ write(0,*) 'Check: ',ub,v(ub),key
|
||||
ub = ub - 1
|
||||
end if
|
||||
ipos = ub
|
||||
endif
|
||||
return
|
||||
end function psb_iblsrch
|
||||
|
||||
function psb_ibsrch(key,n,v) result(ipos)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_ibsrch
|
||||
implicit none
|
||||
integer(psb_ipk_) :: ipos, key, n
|
||||
integer(psb_ipk_) :: v(:)
|
||||
|
||||
integer(psb_ipk_) :: lb, ub, m
|
||||
|
||||
if (n < 5) then
|
||||
! don't bother with binary search for very
|
||||
! small vectors
|
||||
ipos = 0
|
||||
do
|
||||
if (ipos == n) return
|
||||
if (key < v(ipos+1)) return
|
||||
ipos = ipos + 1
|
||||
end do
|
||||
else
|
||||
lb = 1
|
||||
ub = n
|
||||
ipos = -1
|
||||
|
||||
do while (lb <= ub)
|
||||
|
||||
do while (lb.le.ub)
|
||||
m = (lb+ub)/2
|
||||
if (key==v(m)) then
|
||||
if (key.eq.v(m)) then
|
||||
ipos = m
|
||||
return
|
||||
lb = ub + 1
|
||||
else if (key < v(m)) then
|
||||
ub = m-1
|
||||
else
|
||||
lb = m + 1
|
||||
end if
|
||||
enddo
|
||||
if (v(ub) > key) then
|
||||
!!$ write(0,*) 'Check: ',ub,v(ub),key
|
||||
ub = ub - 1
|
||||
return
|
||||
end function psb_ibsrch
|
||||
|
||||
function psb_issrch(key,n,v) result(ipos)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_issrch
|
||||
implicit none
|
||||
integer(psb_ipk_) :: ipos, key, n
|
||||
integer(psb_ipk_) :: v(:)
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
ipos = -1
|
||||
do i=1,n
|
||||
if (key.eq.v(i)) then
|
||||
ipos = i
|
||||
return
|
||||
end if
|
||||
enddo
|
||||
|
||||
return
|
||||
end function psb_issrch
|
||||
|
||||
|
||||
subroutine psb_imsort_u(x,nout,dir)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_imsort_u
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(out) :: nout
|
||||
integer(psb_ipk_), optional, intent(in) :: dir
|
||||
|
||||
integer(psb_ipk_) :: dir_, n, err_act, k
|
||||
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
|
||||
name='psb_msort_u'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_sort_up_
|
||||
end if
|
||||
ipos = ub
|
||||
endif
|
||||
return
|
||||
end function psb_iblsrch
|
||||
|
||||
function psb_ibsrch(key,n,v) result(ipos)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_ibsrch
|
||||
implicit none
|
||||
integer(psb_ipk_) :: ipos, key, n
|
||||
integer(psb_ipk_) :: v(:)
|
||||
|
||||
integer(psb_ipk_) :: lb, ub, m
|
||||
|
||||
lb = 1
|
||||
ub = n
|
||||
ipos = -1
|
||||
|
||||
do while (lb.le.ub)
|
||||
m = (lb+ub)/2
|
||||
if (key.eq.v(m)) then
|
||||
ipos = m
|
||||
lb = ub + 1
|
||||
else if (key < v(m)) then
|
||||
ub = m-1
|
||||
else
|
||||
lb = m + 1
|
||||
end if
|
||||
enddo
|
||||
return
|
||||
end function psb_ibsrch
|
||||
|
||||
function psb_issrch(key,n,v) result(ipos)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_issrch
|
||||
implicit none
|
||||
integer(psb_ipk_) :: ipos, key, n
|
||||
integer(psb_ipk_) :: v(:)
|
||||
|
||||
integer(psb_ipk_) :: i
|
||||
|
||||
ipos = -1
|
||||
do i=1,n
|
||||
if (key.eq.v(i)) then
|
||||
ipos = i
|
||||
return
|
||||
end if
|
||||
enddo
|
||||
|
||||
return
|
||||
end function psb_issrch
|
||||
|
||||
|
||||
subroutine psb_imsort_u(x,nout,dir)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_imsort_u
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(out) :: nout
|
||||
integer(psb_ipk_), optional, intent(in) :: dir
|
||||
|
||||
integer(psb_ipk_) :: dir_, n, err_act, k
|
||||
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
|
||||
name='psb_msort_u'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_sort_up_
|
||||
end if
|
||||
select case(dir_)
|
||||
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
n = size(x)
|
||||
|
||||
call psb_imsort(x,dir_)
|
||||
nout = min(1,n)
|
||||
do k=2,n
|
||||
if (x(k) /= x(nout)) then
|
||||
nout = nout + 1
|
||||
x(nout) = x(k)
|
||||
endif
|
||||
enddo
|
||||
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
end subroutine psb_imsort_u
|
||||
|
||||
|
||||
subroutine psb_imsort(x,ix,dir,flag)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_imsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
|
||||
name='psb_imsort'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_sort_up_
|
||||
end if
|
||||
select case(dir_)
|
||||
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
n = size(x)
|
||||
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
select case(dir_)
|
||||
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
end if
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_i_msort')
|
||||
goto 9999
|
||||
endif
|
||||
n = size(x)
|
||||
|
||||
select case(idir)
|
||||
case (psb_sort_up_)
|
||||
call in_msort_up(n,x,iaux,iret)
|
||||
case (psb_sort_down_)
|
||||
call in_msort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call in_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call in_amsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,indx,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
return
|
||||
call psb_imsort(x,dir=dir_)
|
||||
nout = min(1,n)
|
||||
do k=2,n
|
||||
if (x(k) /= x(nout)) then
|
||||
nout = nout + 1
|
||||
x(nout) = x(k)
|
||||
endif
|
||||
enddo
|
||||
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
return
|
||||
end subroutine psb_imsort_u
|
||||
|
||||
contains
|
||||
|
||||
subroutine in_msort_up(n,k,l,iret)
|
||||
subroutine psb_imsort(x,ix,dir,flag)
|
||||
use psb_i_sort_mod, psb_protect_name => psb_imsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
|
||||
name='psb_imsort'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_sort_up_
|
||||
end if
|
||||
select case(dir_)
|
||||
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
n = size(x)
|
||||
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
end if
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_i_msort')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
select case(dir_)
|
||||
case (psb_sort_up_)
|
||||
call psi_i_msort_up(n,x,iaux,iret)
|
||||
case (psb_sort_down_)
|
||||
call psi_i_msort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call psi_i_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call psi_i_amsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,ix,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
|
||||
|
||||
end subroutine psb_imsort
|
||||
|
||||
subroutine psi_i_msort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -432,9 +433,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_msort_up
|
||||
end subroutine psi_i_msort_up
|
||||
|
||||
subroutine in_msort_dw(n,k,l,iret)
|
||||
subroutine psi_i_msort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -536,9 +537,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_msort_dw
|
||||
end subroutine psi_i_msort_dw
|
||||
|
||||
subroutine in_amsort_up(n,k,l,iret)
|
||||
subroutine psi_i_amsort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -640,9 +641,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_up
|
||||
end subroutine psi_i_amsort_up
|
||||
|
||||
subroutine in_amsort_dw(n,k,l,iret)
|
||||
subroutine psi_i_amsort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -744,10 +745,8 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_dw
|
||||
|
||||
|
||||
end subroutine psb_imsort
|
||||
end subroutine psi_i_amsort_dw
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -48,7 +48,7 @@ subroutine psb_iqsort(x,ix,dir,flag)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act, i
|
||||
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
@@ -129,15 +129,13 @@ subroutine psb_iqsort(x,ix,dir,flag)
|
||||
return
|
||||
end subroutine psb_iqsort
|
||||
|
||||
|
||||
|
||||
subroutine psi_iqsrx_up(n,x,ix)
|
||||
subroutine psi_iqsrx_up(n,x,idx)
|
||||
use psb_i_sort_mod, psb_protect_name => psi_iqsrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
integer(psb_ipk_) :: piv, xk, xt
|
||||
@@ -170,40 +168,40 @@ subroutine psi_iqsrx_up(n,x,ix)
|
||||
piv = x(lpiv)
|
||||
if (piv < x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv > x(j)) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv < x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -228,11 +226,11 @@ subroutine psi_iqsrx_up(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_up
|
||||
end if
|
||||
@@ -254,14 +252,14 @@ subroutine psi_iqsrx_up(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_iisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_iisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_iisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_iisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -269,29 +267,29 @@ subroutine psi_iqsrx_up(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_iisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_iisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_iisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_iisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_iisrx_up(n,x,indx)
|
||||
call psi_iisrx_up(n,x,idx)
|
||||
endif
|
||||
end subroutine psi_iqsrx_up
|
||||
|
||||
subroutine psi_iqsrx_dw(n,x,ix)
|
||||
subroutine psi_iqsrx_dw(n,x,idx)
|
||||
use psb_i_sort_mod, psb_protect_name => psi_iqsrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
integer(psb_ipk_) :: piv, xk, xt
|
||||
@@ -324,40 +322,40 @@ subroutine psi_iqsrx_dw(n,x,ix)
|
||||
piv = x(lpiv)
|
||||
if (piv > x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv < x(j)) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv > x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -382,11 +380,11 @@ subroutine psi_iqsrx_dw(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_dw
|
||||
end if
|
||||
@@ -408,14 +406,14 @@ subroutine psi_iqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_iisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_iisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_iisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_iisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -423,19 +421,19 @@ subroutine psi_iqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_iisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_iisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_iisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_iisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_iisrx_dw(n,x,indx)
|
||||
call psi_iisrx_dw(n,x,idx)
|
||||
endif
|
||||
|
||||
end subroutine psi_iqsrx_dw
|
||||
@@ -590,7 +588,7 @@ subroutine psi_iqsr_dw(n,x)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! ..
|
||||
! .. Local Scalars ..
|
||||
integer(@FKIND) :: piv, xt, xk
|
||||
integer(psb_ipk_) :: piv, xt, xk
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: n1, n2
|
||||
|
||||
@@ -722,16 +720,17 @@ subroutine psi_iqsr_dw(n,x)
|
||||
|
||||
end subroutine psi_iqsr_dw
|
||||
|
||||
subroutine psi_iaqsrx_up(n,x,ix)
|
||||
subroutine psi_iaqsrx_up(n,x,idx)
|
||||
use psb_i_sort_mod, psb_protect_name => psi_iaqsrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
integer(psb_ipk_) :: piv, xk, xt
|
||||
integer(psb_ipk_) :: piv, xk
|
||||
integer(psb_ipk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
@@ -761,39 +760,39 @@ subroutine psi_iaqsrx_up(n,x,ix)
|
||||
piv = abs(x(lpiv))
|
||||
if (piv < abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv > abs(x(j))) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv < abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -818,11 +817,11 @@ subroutine psi_iaqsrx_up(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_up
|
||||
end if
|
||||
@@ -844,14 +843,14 @@ subroutine psi_iaqsrx_up(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_iaisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_iaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_iaisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_iaisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -859,34 +858,35 @@ subroutine psi_iaqsrx_up(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_iaisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_iaisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_iaisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_iaisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_iaisrx_up(n,x,indx)
|
||||
call psi_iaisrx_up(n,x,idx)
|
||||
endif
|
||||
|
||||
|
||||
end subroutine psi_iaqsrx_up
|
||||
|
||||
subroutine psi_iaqsrx_dw(n,x,ix)
|
||||
subroutine psi_iaqsrx_dw(n,x,idx)
|
||||
use psb_i_sort_mod, psb_protect_name => psi_iaqsrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
integer(psb_ipk_) :: piv, xk, xt
|
||||
integer(psb_ipk_) :: piv, xk
|
||||
integer(psb_ipk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
@@ -915,39 +915,39 @@ subroutine psi_iaqsrx_dw(n,x,ix)
|
||||
piv = abs(x(lpiv))
|
||||
if (piv > abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv < abs(x(j))) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv > abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -972,11 +972,11 @@ subroutine psi_iaqsrx_dw(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_dw
|
||||
end if
|
||||
@@ -998,14 +998,14 @@ subroutine psi_iaqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_iaisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_iaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_iaisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_iaisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -1013,19 +1013,19 @@ subroutine psi_iaqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_iaisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_iaisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_iaisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_iaisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_iaisrx_dw(n,x,indx)
|
||||
call psi_iaisrx_dw(n,x,idx)
|
||||
endif
|
||||
|
||||
end subroutine psi_iaqsrx_dw
|
||||
@@ -1038,7 +1038,8 @@ subroutine psi_iaqsr_up(n,x)
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
integer(psb_ipk_) :: piv, xk, xt
|
||||
integer(psb_ipk_) :: piv, xk
|
||||
integer(psb_ipk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
@@ -1177,7 +1178,8 @@ subroutine psi_iaqsr_dw(n,x)
|
||||
integer(psb_ipk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
integer(psb_ipk_) :: piv, xk, xt
|
||||
integer(psb_ipk_) :: piv, xk
|
||||
integer(psb_ipk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
|
||||
@@ -129,12 +129,12 @@ subroutine psb_sisort(x,ix,dir,flag)
|
||||
return
|
||||
end subroutine psb_sisort
|
||||
|
||||
subroutine psi_sisrx_up(n,x,ix)
|
||||
subroutine psi_sisrx_up(n,x,idx)
|
||||
use psb_s_sort_mod, psb_protect_name => psi_sisrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
real(psb_spk_) :: xx
|
||||
@@ -157,12 +157,12 @@ subroutine psi_sisrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_sisrx_up
|
||||
|
||||
subroutine psi_sisrx_dw(n,x,ix)
|
||||
subroutine psi_sisrx_dw(n,x,idx)
|
||||
use psb_s_sort_mod, psb_protect_name => psi_sisrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
real(psb_spk_) :: xx
|
||||
@@ -234,12 +234,12 @@ subroutine psi_sisr_dw(n,x)
|
||||
enddo
|
||||
end subroutine psi_sisr_dw
|
||||
|
||||
subroutine psi_saisrx_up(n,x,ix)
|
||||
subroutine psi_saisrx_up(n,x,idx)
|
||||
use psb_s_sort_mod, psb_protect_name => psi_saisrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
real(psb_spk_) :: xx
|
||||
@@ -262,12 +262,12 @@ subroutine psi_saisrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_saisrx_up
|
||||
|
||||
subroutine psi_saisrx_dw(n,x,ix)
|
||||
subroutine psi_saisrx_dw(n,x,idx)
|
||||
use psb_s_sort_mod, psb_protect_name => psi_saisrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
real(psb_spk_) :: xx
|
||||
|
||||
@@ -29,117 +29,118 @@
|
||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||
!!$
|
||||
!!$
|
||||
!
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
!
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
|
||||
subroutine psb_smsort(x,ix,dir,flag)
|
||||
use psb_s_sort_mod, psb_protect_name => psb_smsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
subroutine psb_smsort(x,ix,dir,flag)
|
||||
use psb_s_sort_mod, psb_protect_name => psb_smsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
|
||||
name='psb_smsort'
|
||||
call psb_erractionsave(err_act)
|
||||
name='psb_smsort'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_sort_up_
|
||||
end if
|
||||
select case(dir_)
|
||||
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
n = size(x)
|
||||
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_sort_up_
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
select case(dir_)
|
||||
case( psb_sort_up_, psb_sort_down_, psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
end if
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_s_msort')
|
||||
goto 9999
|
||||
endif
|
||||
n = size(x)
|
||||
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
select case(idir)
|
||||
case (psb_sort_up_)
|
||||
call in_msort_up(n,x,iaux,iret)
|
||||
case (psb_sort_down_)
|
||||
call in_msort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call in_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call in_amsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,indx,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
return
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_s_msort')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
select case(dir_)
|
||||
case (psb_sort_up_)
|
||||
call psi_s_msort_up(n,x,iaux,iret)
|
||||
case (psb_sort_down_)
|
||||
call psi_s_msort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call psi_s_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call psi_s_amsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,ix,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
end if
|
||||
end if
|
||||
|
||||
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine in_msort_up(n,k,l,iret)
|
||||
end subroutine psb_smsort
|
||||
|
||||
subroutine psi_s_msort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -241,9 +242,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_msort_up
|
||||
end subroutine psi_s_msort_up
|
||||
|
||||
subroutine in_msort_dw(n,k,l,iret)
|
||||
subroutine psi_s_msort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -345,9 +346,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_msort_dw
|
||||
end subroutine psi_s_msort_dw
|
||||
|
||||
subroutine in_amsort_up(n,k,l,iret)
|
||||
subroutine psi_s_amsort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -449,9 +450,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_up
|
||||
end subroutine psi_s_amsort_up
|
||||
|
||||
subroutine in_amsort_dw(n,k,l,iret)
|
||||
subroutine psi_s_amsort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
integer(psb_ipk_) :: n, iret
|
||||
@@ -553,10 +554,8 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_dw
|
||||
|
||||
|
||||
end subroutine psb_smsort
|
||||
end subroutine psi_s_amsort_dw
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -48,7 +48,7 @@ subroutine psb_sqsort(x,ix,dir,flag)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act, i
|
||||
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
@@ -129,15 +129,13 @@ subroutine psb_sqsort(x,ix,dir,flag)
|
||||
return
|
||||
end subroutine psb_sqsort
|
||||
|
||||
|
||||
|
||||
subroutine psi_sqsrx_up(n,x,ix)
|
||||
subroutine psi_sqsrx_up(n,x,idx)
|
||||
use psb_s_sort_mod, psb_protect_name => psi_sqsrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_spk_) :: piv, xk, xt
|
||||
@@ -170,40 +168,40 @@ subroutine psi_sqsrx_up(n,x,ix)
|
||||
piv = x(lpiv)
|
||||
if (piv < x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv > x(j)) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv < x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -228,11 +226,11 @@ subroutine psi_sqsrx_up(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_up
|
||||
end if
|
||||
@@ -254,14 +252,14 @@ subroutine psi_sqsrx_up(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_sisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_sisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_sisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_sisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -269,29 +267,29 @@ subroutine psi_sqsrx_up(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_sisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_sisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_sisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_sisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_sisrx_up(n,x,indx)
|
||||
call psi_sisrx_up(n,x,idx)
|
||||
endif
|
||||
end subroutine psi_sqsrx_up
|
||||
|
||||
subroutine psi_sqsrx_dw(n,x,ix)
|
||||
subroutine psi_sqsrx_dw(n,x,idx)
|
||||
use psb_s_sort_mod, psb_protect_name => psi_sqsrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_spk_) :: piv, xk, xt
|
||||
@@ -324,40 +322,40 @@ subroutine psi_sqsrx_dw(n,x,ix)
|
||||
piv = x(lpiv)
|
||||
if (piv > x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv < x(j)) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
if (piv > x(i)) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = x(lpiv)
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -382,11 +380,11 @@ subroutine psi_sqsrx_dw(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_dw
|
||||
end if
|
||||
@@ -408,14 +406,14 @@ subroutine psi_sqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_sisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_sisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_sisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_sisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -423,19 +421,19 @@ subroutine psi_sqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_sisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_sisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_sisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_sisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_sisrx_dw(n,x,indx)
|
||||
call psi_sisrx_dw(n,x,idx)
|
||||
endif
|
||||
|
||||
end subroutine psi_sqsrx_dw
|
||||
@@ -590,7 +588,7 @@ subroutine psi_sqsr_dw(n,x)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! ..
|
||||
! .. Local Scalars ..
|
||||
real(@FKIND) :: piv, xt, xk
|
||||
real(psb_spk_) :: piv, xt, xk
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: n1, n2
|
||||
|
||||
@@ -722,16 +720,17 @@ subroutine psi_sqsr_dw(n,x)
|
||||
|
||||
end subroutine psi_sqsr_dw
|
||||
|
||||
subroutine psi_saqsrx_up(n,x,ix)
|
||||
subroutine psi_saqsrx_up(n,x,idx)
|
||||
use psb_s_sort_mod, psb_protect_name => psi_saqsrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_spk_) :: piv, xk, xt
|
||||
real(psb_spk_) :: piv, xk
|
||||
real(psb_spk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
@@ -761,39 +760,39 @@ subroutine psi_saqsrx_up(n,x,ix)
|
||||
piv = abs(x(lpiv))
|
||||
if (piv < abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv > abs(x(j))) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv < abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -818,11 +817,11 @@ subroutine psi_saqsrx_up(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_up
|
||||
end if
|
||||
@@ -844,14 +843,14 @@ subroutine psi_saqsrx_up(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_saisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_saisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_saisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_saisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -859,34 +858,35 @@ subroutine psi_saqsrx_up(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_saisrx_up(n2,x(i:iux),indx(i:iux))
|
||||
call psi_saisrx_up(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_saisrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_saisrx_up(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_saisrx_up(n,x,indx)
|
||||
call psi_saisrx_up(n,x,idx)
|
||||
endif
|
||||
|
||||
|
||||
end subroutine psi_saqsrx_up
|
||||
|
||||
subroutine psi_saqsrx_dw(n,x,ix)
|
||||
subroutine psi_saqsrx_dw(n,x,idx)
|
||||
use psb_s_sort_mod, psb_protect_name => psi_saqsrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_spk_) :: piv, xk, xt
|
||||
real(psb_spk_) :: piv, xk
|
||||
real(psb_spk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
@@ -915,39 +915,39 @@ subroutine psi_saqsrx_dw(n,x,ix)
|
||||
piv = abs(x(lpiv))
|
||||
if (piv > abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv < abs(x(j))) then
|
||||
xt = x(j)
|
||||
ixt = indx(j)
|
||||
x(j) = x(lpiv)
|
||||
indx(j) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(j)
|
||||
x(j) = x(lpiv)
|
||||
idx(j) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
if (piv > abs(x(i))) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
piv = abs(x(lpiv))
|
||||
endif
|
||||
!
|
||||
! now piv is correct; place it into first location
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(lpiv)
|
||||
indx(i) = indx(lpiv)
|
||||
x(lpiv) = xt
|
||||
indx(lpiv) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(lpiv)
|
||||
idx(i) = idx(lpiv)
|
||||
x(lpiv) = xt
|
||||
idx(lpiv) = ixt
|
||||
|
||||
i = ilx - 1
|
||||
j = iux + 1
|
||||
@@ -972,11 +972,11 @@ subroutine psi_saqsrx_dw(n,x,ix)
|
||||
|
||||
if (j > i) then
|
||||
xt = x(i)
|
||||
ixt = indx(i)
|
||||
x(i) = x(j)
|
||||
indx(i) = indx(j)
|
||||
x(j) = xt
|
||||
indx(j) = ixt
|
||||
ixt = idx(i)
|
||||
x(i) = x(j)
|
||||
idx(i) = idx(j)
|
||||
x(j) = xt
|
||||
idx(j) = ixt
|
||||
else
|
||||
exit outer_dw
|
||||
end if
|
||||
@@ -998,14 +998,14 @@ subroutine psi_saqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_saisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_saisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
if (n2 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_saisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_saisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
else
|
||||
if (n2 > ithrs) then
|
||||
@@ -1013,19 +1013,19 @@ subroutine psi_saqsrx_dw(n,x,ix)
|
||||
istack(1,istp) = i
|
||||
istack(2,istp) = iux
|
||||
else
|
||||
call psi_saisrx_dw(n2,x(i:iux),indx(i:iux))
|
||||
call psi_saisrx_dw(n2,x(i:iux),idx(i:iux))
|
||||
endif
|
||||
if (n1 > ithrs) then
|
||||
istp = istp + 1
|
||||
istack(1,istp) = ilx
|
||||
istack(2,istp) = i-1
|
||||
else
|
||||
call psi_saisrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
|
||||
call psi_saisrx_dw(n1,x(ilx:i-1),idx(ilx:i-1))
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
else
|
||||
call psi_saisrx_dw(n,x,indx)
|
||||
call psi_saisrx_dw(n,x,idx)
|
||||
endif
|
||||
|
||||
end subroutine psi_saqsrx_dw
|
||||
@@ -1038,7 +1038,8 @@ subroutine psi_saqsr_up(n,x)
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_spk_) :: piv, xk, xt
|
||||
real(psb_spk_) :: piv, xk
|
||||
real(psb_spk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
@@ -1177,7 +1178,8 @@ subroutine psi_saqsr_dw(n,x)
|
||||
real(psb_spk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
! .. Local Scalars ..
|
||||
real(psb_spk_) :: piv, xk, xt
|
||||
real(psb_spk_) :: piv, xk
|
||||
real(psb_spk_) :: xt
|
||||
integer(psb_ipk_) :: i, j, ilx, iux, istp, lpiv
|
||||
integer(psb_ipk_) :: ixt, n1, n2
|
||||
|
||||
|
||||
@@ -50,7 +50,7 @@ subroutine psb_zhsort(x,ix,dir,flag)
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, i, l, err_act,info
|
||||
real(psb_spk_) :: key
|
||||
complex(psb_dpk_) :: key
|
||||
integer(psb_ipk_) :: index
|
||||
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
@@ -391,7 +391,7 @@ contains
|
||||
end subroutine psi_z_insert_heap
|
||||
|
||||
subroutine psi_z_heap_get_first(key,last,heap,dir,info)
|
||||
use psb_z_sort_mod, psb_protect_name => psi_z_insert_heap
|
||||
use psb_z_sort_mod, psb_protect_name => psi_z_heap_get_first
|
||||
implicit none
|
||||
|
||||
!
|
||||
@@ -633,7 +633,7 @@ contains
|
||||
end subroutine psi_z_heap_get_first
|
||||
|
||||
subroutine psi_z_idx_insert_heap(key,index,last,heap,idxs,dir,info)
|
||||
use psb_z_sort_mod, psb_protect_name => psi_z_idx_insert_idx_heap
|
||||
use psb_z_sort_mod, psb_protect_name => psi_z_idx_insert_heap
|
||||
|
||||
implicit none
|
||||
!
|
||||
@@ -869,7 +869,7 @@ end subroutine psi_z_idx_insert_heap
|
||||
|
||||
|
||||
subroutine psi_z_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
|
||||
use psb_z_sort_mod, psb_protect_name => psi_z_insert_heap
|
||||
use psb_z_sort_mod, psb_protect_name => psi_z_idx_heap_get_first
|
||||
implicit none
|
||||
|
||||
!
|
||||
@@ -905,22 +905,22 @@ subroutine psi_z_idx_heap_get_first(key,index,last,heap,idxs,dir,info)
|
||||
info = -4
|
||||
|
||||
case (psb_asort_up_)
|
||||
call fix_aup(last,heap)
|
||||
call fix_aup(last,heap,idxs)
|
||||
|
||||
case (psb_asort_down_)
|
||||
call fix_adw(last,heap)
|
||||
call fix_adw(last,heap,idxs)
|
||||
|
||||
case (psb_alsort_up_)
|
||||
call fix_alup(last,heap)
|
||||
call fix_alup(last,heap,idxs)
|
||||
|
||||
case (psb_alsort_down_)
|
||||
call fix_aldw(last,heap)
|
||||
call fix_aldw(last,heap,idxs)
|
||||
|
||||
case (psb_lsort_up_)
|
||||
call fix_lup(last,heap)
|
||||
call fix_lup(last,heap,idxs)
|
||||
|
||||
case (psb_lsort_down_)
|
||||
call fix_ldw(last,heap)
|
||||
call fix_ldw(last,heap,idxs)
|
||||
|
||||
case default
|
||||
write(psb_err_unit,*) 'Invalid direction in heap ',dir
|
||||
@@ -933,7 +933,7 @@ contains
|
||||
use psi_acx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_dpk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_dpk_) :: temp
|
||||
@@ -968,7 +968,7 @@ contains
|
||||
use psi_acx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_dpk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_dpk_) :: temp
|
||||
@@ -1002,7 +1002,7 @@ contains
|
||||
use psi_lcx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_dpk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_dpk_) :: temp
|
||||
@@ -1036,7 +1036,7 @@ contains
|
||||
use psi_lcx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_dpk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_dpk_) :: temp
|
||||
@@ -1070,7 +1070,7 @@ contains
|
||||
use psi_alcx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_dpk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_dpk_) :: temp
|
||||
@@ -1104,7 +1104,7 @@ contains
|
||||
use psi_alcx_mod
|
||||
integer(psb_ipk_), intent(in) :: last
|
||||
complex(psb_dpk_), intent(inout) :: heap(:)
|
||||
integer(psb_ipk) :: idxs(:)
|
||||
integer(psb_ipk_) :: idxs(:)
|
||||
|
||||
integer(psb_ipk_) :: i,j, itemp
|
||||
complex(psb_dpk_) :: temp
|
||||
@@ -1134,7 +1134,7 @@ contains
|
||||
|
||||
end subroutine fix_aldw
|
||||
|
||||
end subroutine psi_z_heap_get_first
|
||||
end subroutine psi_z_idx_heap_get_first
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -137,13 +137,13 @@ subroutine psb_zisort(x,ix,dir,flag)
|
||||
return
|
||||
end subroutine psb_zisort
|
||||
|
||||
subroutine psi_zlisrx_up(n,x,ix)
|
||||
subroutine psi_zlisrx_up(n,x,idx)
|
||||
use psb_z_sort_mod, psb_protect_name => psi_zlisrx_up
|
||||
use psb_error_mod
|
||||
use psi_lcx_mod
|
||||
implicit none
|
||||
complex(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_dpk_) :: xx
|
||||
@@ -167,13 +167,13 @@ subroutine psi_zlisrx_up(n,x,ix)
|
||||
|
||||
end subroutine psi_zlisrx_up
|
||||
|
||||
subroutine psi_zlisrx_dw(n,x,ix)
|
||||
subroutine psi_zlisrx_dw(n,x,idx)
|
||||
use psb_z_sort_mod, psb_protect_name => psi_zlisrx_dw
|
||||
use psb_error_mod
|
||||
use psi_lcx_mod
|
||||
implicit none
|
||||
complex(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_dpk_) :: xx
|
||||
@@ -246,13 +246,13 @@ subroutine psi_zlisr_dw(n,x)
|
||||
enddo
|
||||
end subroutine psi_zlisr_dw
|
||||
|
||||
subroutine psi_zalisrx_up(n,x,ix)
|
||||
subroutine psi_zalisrx_up(n,x,idx)
|
||||
use psb_z_sort_mod, psb_protect_name => psi_zalisrx_up
|
||||
use psb_error_mod
|
||||
use psi_alcx_mod
|
||||
implicit none
|
||||
complex(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_dpk_) :: xx
|
||||
@@ -275,13 +275,13 @@ subroutine psi_zalisrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_zalisrx_up
|
||||
|
||||
subroutine psi_zalisrx_dw(n,x,ix)
|
||||
subroutine psi_zalisrx_dw(n,x,idx)
|
||||
use psb_z_sort_mod, psb_protect_name => psi_zalisrx_dw
|
||||
use psb_error_mod
|
||||
use psi_alcx_mod
|
||||
implicit none
|
||||
complex(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_dpk_) :: xx
|
||||
@@ -354,12 +354,12 @@ subroutine psi_zalisr_dw(n,x)
|
||||
enddo
|
||||
end subroutine psi_zalisr_dw
|
||||
|
||||
subroutine psi_zaisrx_up(n,x,ix)
|
||||
subroutine psi_zaisrx_up(n,x,idx)
|
||||
use psb_z_sort_mod, psb_protect_name => psi_zaisrx_up
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
complex(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_dpk_) :: xx
|
||||
@@ -382,12 +382,12 @@ subroutine psi_zaisrx_up(n,x,ix)
|
||||
enddo
|
||||
end subroutine psi_zaisrx_up
|
||||
|
||||
subroutine psi_zaisrx_dw(n,x,ix)
|
||||
subroutine psi_zaisrx_dw(n,x,idx)
|
||||
use psb_z_sort_mod, psb_protect_name => psi_zaisrx_dw
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
complex(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), intent(inout) :: ix(:)
|
||||
integer(psb_ipk_), intent(inout) :: idx(:)
|
||||
integer(psb_ipk_), intent(in) :: n
|
||||
integer(psb_ipk_) :: i,j,ix
|
||||
complex(psb_dpk_) :: xx
|
||||
|
||||
@@ -29,17 +29,17 @@
|
||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||
!!$
|
||||
!!$
|
||||
!
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
!
|
||||
! The merge-sort routines
|
||||
! References:
|
||||
! D. Knuth
|
||||
! The Art of Computer Programming, vol. 3
|
||||
! Addison-Wesley
|
||||
!
|
||||
! Aho, Hopcroft, Ullman
|
||||
! Data Structures and Algorithms
|
||||
! Addison-Wesley
|
||||
!
|
||||
|
||||
|
||||
|
||||
@@ -48,108 +48,109 @@
|
||||
|
||||
|
||||
|
||||
subroutine psb_zmsort(x,ix,dir,flag)
|
||||
use psb_z_sort_mod, psb_protect_name => psb_zmsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
complex(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
subroutine psb_zmsort(x,ix,dir,flag)
|
||||
use psb_z_sort_mod, psb_protect_name => psb_zmsort
|
||||
use psb_error_mod
|
||||
use psb_ip_reord_mod
|
||||
implicit none
|
||||
complex(psb_dpk_), intent(inout) :: x(:)
|
||||
integer(psb_ipk_), optional, intent(in) :: dir, flag
|
||||
integer(psb_ipk_), optional, intent(inout) :: ix(:)
|
||||
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
integer(psb_ipk_) :: dir_, flag_, n, err_act
|
||||
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
integer(psb_ipk_), allocatable :: iaux(:)
|
||||
integer(psb_ipk_) :: iret, info, i
|
||||
integer(psb_ipk_) :: ierr(5)
|
||||
character(len=20) :: name
|
||||
|
||||
name='psb_zmsort'
|
||||
call psb_erractionsave(err_act)
|
||||
name='psb_zmsort'
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_asort_up_
|
||||
end if
|
||||
select case(dir_)
|
||||
case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,&
|
||||
& psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
|
||||
n = size(x)
|
||||
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
if (present(dir)) then
|
||||
dir_ = dir
|
||||
else
|
||||
dir_= psb_asort_up_
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
select case(dir_)
|
||||
case( psb_lsort_up_, psb_lsort_down_, psb_alsort_up_, psb_alsort_down_,&
|
||||
& psb_asort_up_, psb_asort_down_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
ierr(1) = 3; ierr(2) = dir_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
end if
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_z_msort')
|
||||
goto 9999
|
||||
endif
|
||||
n = size(x)
|
||||
|
||||
select case(idir)
|
||||
case (psb_lsort_up_)
|
||||
call in_lmsort_up(n,x,iaux,iret)
|
||||
case (psb_lsort_down_)
|
||||
call in_lmsort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call in_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call in_amsort_dw(n,x,iaux,iret)
|
||||
case (psb_alsort_up_)
|
||||
call in_almsort_up(n,x,iaux,iret)
|
||||
case (psb_alsort_down_)
|
||||
call in_almsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,indx,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
if (present(ix)) then
|
||||
if (size(ix) < n) then
|
||||
ierr(1) = 2; ierr(2) = size(ix);
|
||||
call psb_errpush(psb_err_input_asize_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end if
|
||||
if (present(flag)) then
|
||||
flag_ = flag
|
||||
else
|
||||
flag_ = psb_sort_ovw_idx_
|
||||
end if
|
||||
select case(flag_)
|
||||
case(psb_sort_ovw_idx_)
|
||||
do i=1,n
|
||||
ix(i) = i
|
||||
end do
|
||||
case (psb_sort_keep_idx_)
|
||||
! OK keep going
|
||||
case default
|
||||
ierr(1) = 4; ierr(2) = flag_;
|
||||
call psb_errpush(psb_err_input_value_invalid_i_,name,i_err=ierr)
|
||||
goto 9999
|
||||
end select
|
||||
end if
|
||||
end if
|
||||
|
||||
return
|
||||
|
||||
allocate(iaux(0:n+1),stat=info)
|
||||
if (info /= psb_success_) then
|
||||
call psb_errpush(psb_err_alloc_dealloc_,r_name='psb_z_msort')
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
select case(dir_)
|
||||
case (psb_lsort_up_)
|
||||
call psi_z_lmsort_up(n,x,iaux,iret)
|
||||
case (psb_lsort_down_)
|
||||
call psi_z_lmsort_dw(n,x,iaux,iret)
|
||||
case (psb_alsort_up_)
|
||||
call psi_z_almsort_up(n,x,iaux,iret)
|
||||
case (psb_alsort_down_)
|
||||
call psi_z_almsort_dw(n,x,iaux,iret)
|
||||
case (psb_asort_up_)
|
||||
call psi_z_amsort_up(n,x,iaux,iret)
|
||||
case (psb_asort_down_)
|
||||
call psi_z_amsort_dw(n,x,iaux,iret)
|
||||
end select
|
||||
!
|
||||
! Do the actual reordering, since the inner routines
|
||||
! only provide linked pointers.
|
||||
!
|
||||
if (iret == 0 ) then
|
||||
if (present(ix)) then
|
||||
call psb_ip_reord(n,x,ix,iaux)
|
||||
else
|
||||
call psb_ip_reord(n,x,iaux)
|
||||
end if
|
||||
end if
|
||||
|
||||
return
|
||||
|
||||
9999 call psb_error_handler(err_act)
|
||||
|
||||
return
|
||||
return
|
||||
|
||||
contains
|
||||
|
||||
subroutine in_lmsort_up(n,k,l,iret)
|
||||
end subroutine psb_zmsort
|
||||
|
||||
subroutine psi_z_lmsort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_lcx_mod
|
||||
implicit none
|
||||
@@ -252,9 +253,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_lmsort_up
|
||||
end subroutine psi_z_lmsort_up
|
||||
|
||||
subroutine in_lmsort_dw(n,k,l,iret)
|
||||
subroutine psi_z_lmsort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_lcx_mod
|
||||
implicit none
|
||||
@@ -357,9 +358,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_lmsort_dw
|
||||
end subroutine psi_z_lmsort_dw
|
||||
|
||||
subroutine in_amsort_up(n,k,l,iret)
|
||||
subroutine psi_z_amsort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_acx_mod
|
||||
implicit none
|
||||
@@ -462,9 +463,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_up
|
||||
end subroutine psi_z_amsort_up
|
||||
|
||||
subroutine in_amsort_dw(n,k,l,iret)
|
||||
subroutine psi_z_amsort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_acx_mod
|
||||
implicit none
|
||||
@@ -567,9 +568,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_amsort_dw
|
||||
end subroutine psi_z_amsort_dw
|
||||
|
||||
subroutine in_almsort_up(n,k,l,iret)
|
||||
subroutine psi_z_almsort_up(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_alcx_mod
|
||||
implicit none
|
||||
@@ -672,9 +673,9 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_almsort_up
|
||||
end subroutine psi_z_almsort_up
|
||||
|
||||
subroutine in_almsort_dw(n,k,l,iret)
|
||||
subroutine psi_z_almsort_dw(n,k,l,iret)
|
||||
use psb_const_mod
|
||||
use psi_alcx_mod
|
||||
implicit none
|
||||
@@ -777,6 +778,5 @@ contains
|
||||
end do outer
|
||||
end do mergepass
|
||||
|
||||
end subroutine in_almsort_dw
|
||||
end subroutine psi_z_almsort_dw
|
||||
|
||||
end subroutine psb_zmsort
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -29,7 +29,7 @@
|
||||
!!$ POSSIBILITY OF SUCH DAMAGE.
|
||||
!!$
|
||||
!!$
|
||||
module psi_lcx_mod
|
||||
module psi_alcx_mod
|
||||
use psb_const_mod
|
||||
interface operator(<)
|
||||
module procedure psi_callt, psi_zallt
|
||||
@@ -126,5 +126,5 @@ contains
|
||||
& (abs(aimag(a))>=abs(aimag(b))))
|
||||
end function psi_zalge
|
||||
|
||||
end module psi_lcx_mod
|
||||
end module psi_alcx_mod
|
||||
|
||||
|
||||
Reference in New Issue
Block a user