fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Merged new serial code.

Browse Source
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent 2875be5e2d
commit 7cbb943e6c
73 changed files with 9441 additions and 3798 deletions
Show Stats Download Patch File Download Diff File

6
Changelog
Unescape Escape View File

@ -1,6 +1,12 @@
Changelog. A lot less detailed than usual, at least for past
history.
2007/09/14: Second round of serial changes: merged into trunk, fixed
JAD regeneration and srch_upd now works.
2007/09/10: First round of serial changes: implemented serial
psb_spcnv unifying multiple functionalities.
2007/09/04: Implemented RGMRES for complex data.
2007/06/04: Fixed implementation of fctint and coins: assume size

265
base/modules/psb_serial_mod.f90
Unescape Escape View File

@ -140,10 +140,45 @@ module psb_serial_mod
subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info)
integer, intent(in) :: m,n,nnz,iup
integer, intent(out) :: lia1, lia2, lar, info
character, intent(inout) :: afmt*5
character(len=*), intent(inout) :: afmt
end subroutine psb_cest
end interface
interface psb_spcnv
subroutine psb_dspcnv2(ain, a, info, afmt, upd, dupl)
use psb_spmat_type
type(psb_dspmat_type), intent (in) :: ain
type(psb_dspmat_type), intent (out) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
end subroutine psb_dspcnv2
subroutine psb_dspcnv1(a, info, afmt, upd, dupl)
use psb_spmat_type
type(psb_dspmat_type), intent (inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
end subroutine psb_dspcnv1
subroutine psb_zspcnv2(ain, a, info, afmt, upd, dupl)
use psb_spmat_type
type(psb_zspmat_type), intent (in) :: ain
type(psb_zspmat_type), intent (out) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
end subroutine psb_zspcnv2
subroutine psb_zspcnv1(a, info, afmt, upd, dupl)
use psb_spmat_type
type(psb_zspmat_type), intent (inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
end subroutine psb_zspcnv1
end interface
interface psb_fixcoo
subroutine psb_dfixcoo(a,info,idir)
use psb_spmat_type
@ -466,10 +501,13 @@ module psb_serial_mod
module procedure imsort_u
end interface
interface psb_qsort
module procedure iqsort
module procedure iqsort, dqsort, zqsort
end interface
integer, parameter :: psb_sort_up_=1, psb_sort_down_=-1
integer, parameter :: psb_sort_up_=1, psb_sort_down_=-1
integer, parameter :: psb_lsort_up_=2, psb_lsort_down_=-2
integer, parameter :: psb_asort_up_=3, psb_asort_down_=-3
integer, parameter :: psb_alsort_up_=4, psb_alsort_down_=-4
integer, parameter :: psb_sort_ovw_idx_=0, psb_sort_keep_idx_=1
contains
@ -587,52 +625,231 @@ contains
name='psb_qsort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/))
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
n = size(x)
select case(dir_)
case( psb_sort_up_, psb_sort_down_)
if (present(ix)) then
if (size(ix) < n) then
call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
goto 9999
end if
call isrx(n,x,ix,dir_,flag_)
else
call isr(n,x,dir_)
end if
case( psb_asort_up_, psb_asort_down_)
! OK keep going
if (present(ix)) then
if (size(ix) < n) then
call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
goto 9999
end if
call iasrx(n,x,ix,dir_,flag_)
else
call iasr(n,x,dir_)
end if
case default
call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/))
goto 9999
end select
9999 continue
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
end subroutine iqsort
subroutine dqsort(x,ix,dir,flag)
use psb_error_mod
implicit none
real(kind(1.d0)), intent(inout) :: x(:)
integer, optional, intent(in) :: dir, flag
integer, optional, intent(inout) :: ix(:)
integer :: dir_, flag_, n, err_act
character(len=20) :: name
name='psb_qsort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/))
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
dir_= psb_sort_up_
end if
n = size(x)
if (present(ix)) then
if (size(ix) < n) then
call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
goto 9999
select case(dir_)
case( psb_sort_up_, psb_sort_down_)
if (present(ix)) then
if (size(ix) < n) then
call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
goto 9999
end if
call dsrx(n,x,ix,dir_,flag_)
else
call dsr(n,x,dir_)
end if
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
case( psb_asort_up_, psb_asort_down_)
! OK keep going
if (present(ix)) then
if (size(ix) < n) then
call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
goto 9999
end if
call dasrx(n,x,ix,dir_,flag_)
else
call dasr(n,x,dir_)
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/))
goto 9999
end select
case default
call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/))
goto 9999
end select
9999 continue
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
end subroutine dqsort
subroutine zqsort(x,ix,dir,flag)
use psb_error_mod
implicit none
complex(kind(1.d0)), intent(inout) :: x(:)
integer, optional, intent(in) :: dir, flag
integer, optional, intent(inout) :: ix(:)
integer :: dir_, flag_, n, err_act
character(len=20) :: name
call isrx(n,x,ix,dir_,flag_)
name='psb_qsort'
call psb_erractionsave(err_act)
if (present(flag)) then
flag_ = flag
else
flag_ = psb_sort_ovw_idx_
end if
select case(flag_)
case( psb_sort_ovw_idx_, psb_sort_keep_idx_)
! OK keep going
case default
call psb_errpush(30,name,i_err=(/4,flag_,0,0,0/))
goto 9999
end select
if (present(dir)) then
dir_ = dir
else
call isr(n,x,dir_)
dir_= psb_lsort_up_
end if
n = size(x)
select case(dir_)
case( psb_lsort_up_, psb_lsort_down_)
if (present(ix)) then
if (size(ix) < n) then
call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
goto 9999
end if
call zlsrx(n,x,ix,dir_,flag_)
else
call zlsr(n,x,dir_)
end if
case( psb_alsort_up_, psb_alsort_down_)
! OK keep going
if (present(ix)) then
if (size(ix) < n) then
call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
goto 9999
end if
call zalsrx(n,x,ix,dir_,flag_)
else
call zalsr(n,x,dir_)
end if
case( psb_asort_up_, psb_asort_down_)
! OK keep going
if (present(ix)) then
if (size(ix) < n) then
call psb_errpush(35,name,i_err=(/2,size(ix),0,0,0/))
goto 9999
end if
call zasrx(n,x,ix,dir_,flag_)
else
call zasr(n,x,dir_)
end if
case default
call psb_errpush(30,name,i_err=(/3,dir_,0,0,0/))
goto 9999
end select
9999 continue
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
end subroutine iqsort
end subroutine zqsort
end module psb_serial_mod

62
base/modules/psb_spmat_type.f90
Unescape Escape View File

@ -48,25 +48,55 @@ module psb_spmat_type
!
! Entries and values for spmat%info
!
integer, parameter :: psb_nnz_=1
integer, parameter :: psb_del_bnd_=7, psb_srtd_=8
integer, parameter :: psb_state_=9
integer, parameter :: psb_upd_pnt_=10
integer, parameter :: psb_dupl_=11, psb_upd_=12
integer, parameter :: psb_ifasize_=16
!
!
! Possible matrix states.
!
! A sparse matrix can move between states according to the
! following state transition table.
! In Out Routine
! ----------------------------------
! Null Build psb_sp_all
! Build Build psb_coins
! Build Assembeld psb_spcnv
! Assembled Assembled psb_spcnv
! Assembled Update psb_sp_reinit
! Update Update psb_coins
! Update Assembled psb_spcnv
! * unchanged psb_sp_reall
! Assembled Null psb_sp_free
!
! Note that psb_spcnv is overloaded in two flavours,
! psb_spcnv(a,info)
! psb_spcnv(a,b,info)
! in the second variant, the IN state applies to A and
! the OUT state applies to B.
!
!
integer, parameter :: psb_spmat_null_=0, psb_spmat_bld_=1
integer, parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4
integer, parameter :: psb_ireg_flgs_=10, psb_ip2_=0
integer, parameter :: psb_iflag_=2, psb_ichk_=3
integer, parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6
! Duplicate coefficients handling
! These are usually set while calling spcnv as one of its
! optional arugments.
integer, parameter :: psb_dupl_ovwrt_ = 0
integer, parameter :: psb_dupl_add_ = 1
integer, parameter :: psb_dupl_err_ = 2
integer, parameter :: psb_dupl_def_ = psb_dupl_ovwrt_
integer, parameter :: psb_upd_dflt_ = 0
! Matrix update mode
integer, parameter :: psb_upd_srch_ = 98764
integer, parameter :: psb_upd_perm_ = 98765
integer, parameter :: psb_upd_dflt_ = psb_upd_srch_
! Mark a COO matrix with sorted entries.
integer, parameter :: psb_isrtdcoo_ = 98761
integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4
integer, parameter :: psb_dbleint_=2
@ -379,8 +409,9 @@ contains
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(:) = 0
a%m = 0
a%k = 0
a%infoa(psb_state_) = psb_spmat_bld_
a%m = 0
a%k = 0
if (debug) write(0,*) 'SPALL : end'
Return
@ -412,6 +443,7 @@ contains
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(:) = 0
a%infoa(psb_state_) = psb_spmat_bld_
if (debug) write(0,*) 'SPALL : end'
Return
@ -445,6 +477,7 @@ contains
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(:) = 0
a%infoa(psb_state_) = psb_spmat_bld_
if (debug) write(0,*) 'spall : end'
return
@ -471,6 +504,7 @@ contains
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(:) = 0
a%infoa(psb_state_) = psb_spmat_bld_
a%m = 0
a%k = 0
if (debug) write(0,*) 'SPALL : end'
@ -718,18 +752,18 @@ contains
ia = size(a%aspk)
return
endif
select case(toupper(a%fida))
case('CSR')
select case(tolower(a%fida))
case('csr')
nza = a%ia2(a%m+1)-1
ia = nza
i1 = nza
i2 = a%m + 1
case('COO')
case('coo','coi')
nza = a%infoa(psb_nnz_)
i1 = nza
i2 = nza
ia = nza
case('JAD')
case('jad')
! Feeling lazy today
i1 = size(a%ia1)
i2 = size(a%ia2)
@ -936,6 +970,7 @@ contains
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(:) = 0
a%infoa(psb_state_) = psb_spmat_bld_
a%m = 0
a%k = 0
if (debug) write(0,*) 'SPALL : end'
@ -969,6 +1004,7 @@ contains
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(:) = 0
a%infoa(psb_state_) = psb_spmat_bld_
if (debug) write(0,*) 'SPALL : end'
Return
@ -1002,6 +1038,7 @@ contains
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(:) = 0
a%infoa(psb_state_) = psb_spmat_bld_
if (debug) write(0,*) 'spall : end'
return
@ -1029,6 +1066,7 @@ contains
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(:) = 0
a%infoa(psb_state_) = psb_spmat_bld_
a%m = 0
a%k = 0
if (debug) write(0,*) 'SPALL : end'
@ -1222,18 +1260,18 @@ contains
ia = size(a%aspk)
return
endif
select case(toupper(a%fida))
case('CSR')
select case(tolower(a%fida))
case('csr')
nza = a%ia2(a%m+1)-1
ia = nza
i1 = nza
i2 = a%m + 1
case('COO')
case('coo','coi')
nza = a%infoa(psb_nnz_)
i1 = nza
i2 = nza
ia = nza
case('JAD')
case('jad')
! Feeling lazy today
i1 = size(a%ia1)
i2 = size(a%ia2)

42
base/modules/psb_tools_mod.f90
Unescape Escape View File

@ -31,6 +31,7 @@
Module psb_tools_mod
use psb_const_mod
use psb_gps_mod
use psb_spmat_type
interface psb_geall
! 2-D double precision version
@ -447,7 +448,7 @@ Module psb_tools_mod
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5
character(len=*), optional, intent(in) :: afmt
end subroutine psb_dspasb
subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
use psb_descriptor_type
@ -456,32 +457,33 @@ Module psb_tools_mod
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5
character(len=*), optional, intent(in) :: afmt
end subroutine psb_zspasb
end interface
interface psb_spcnv
subroutine psb_dspcnv(a,b,desc_a,info)
use psb_descriptor_type
use psb_spmat_type
type(psb_dspmat_type), intent(in) :: a
type(psb_dspmat_type), intent(out) :: b
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
end subroutine psb_dspcnv
subroutine psb_zspcnv(a,b,desc_a,info)
use psb_descriptor_type
use psb_spmat_type
type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(out) :: b
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
end subroutine psb_zspcnv
end interface
!!$ interface psb_spcnv
!!$ subroutine psb_dspcnv(a,b,desc_a,info)
!!$ use psb_descriptor_type
!!$ use psb_spmat_type
!!$ type(psb_dspmat_type), intent(in) :: a
!!$ type(psb_dspmat_type), intent(out) :: b
!!$ type(psb_desc_type), intent(in) :: desc_a
!!$ integer, intent(out) :: info
!!$ end subroutine psb_dspcnv
!!$ subroutine psb_zspcnv(a,b,desc_a,info)
!!$ use psb_descriptor_type
!!$ use psb_spmat_type
!!$ type(psb_zspmat_type), intent(in) :: a
!!$ type(psb_zspmat_type), intent(out) :: b
!!$ type(psb_desc_type), intent(in) :: desc_a
!!$ integer, intent(out) :: info
!!$ end subroutine psb_zspcnv
!!$ end interface
interface psb_spfree
module procedure psb_dsp_free, psb_zsp_free
subroutine psb_dspfree(a, desc_a,info)
use psb_descriptor_type
use psb_spmat_type

11
base/serial/Makefile
Unescape Escape View File

@ -1,14 +1,14 @@
include ../../Make.inc
FOBJS = psb_cest.o psb_dcoins.o psb_dcsdp.o psb_dcsmm.o psb_dcsmv.o \
FOBJS = psb_cest.o psb_dcoins.o psb_dcsmm.o psb_dcsmv.o \
psb_dcsnmi.o psb_dcsprt.o psb_dcsrws.o psb_dcssm.o psb_dcssv.o \
psb_dfixcoo.o psb_dipcoo2csr.o psb_dipcsr2coo.o psb_dneigh.o \
psb_dnumbmm.o psb_drwextd.o psb_dspgtdiag.o psb_dspgtblk.o \
psb_dspscal.o psb_dsymbmm.o psb_dtransp.o psb_dspclip.o\
psb_dipcoo2csc.o psb_dspgetrow.o lsame.o psb_zspgetrow.o\
psb_dspscal.o psb_dsymbmm.o psb_dtransp.o psb_dspclip.o psb_dspcnv.o\
psb_regen_mod.o psb_dipcoo2csc.o psb_dspgetrow.o lsame.o psb_zspgetrow.o\
psb_zcsmm.o psb_zcsmv.o psb_zspgtdiag.o psb_zspgtblk.o\
psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zcsdp.o\
psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zspcnv.o\
psb_zfixcoo.o psb_zipcoo2csr.o psb_zipcsr2coo.o psb_zipcoo2csc.o \
psb_zcoins.o psb_zcsprt.o psb_zneigh.o psb_ztransp.o psb_ztransc.o\
psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspscal.o psb_zspclip.o\
@ -26,7 +26,8 @@ lib: auxd cood csrd jadd f77d dpd lib1
lib1: $(FOBJS)
psb_dcoins.o psb_zcoins.o: psb_update_mod.o
psb_dspgetrow.o: psb_getrow_mod.o
psb_dspgetrow.o psb_zspgetrow.o: psb_getrow_mod.o
psb_dspcnv.o pzb_zspcnv.o: psb_regen_mod.o
auxd:
(cd aux; make lib)

13
base/serial/aux/Makefile
Unescape Escape View File

@ -3,8 +3,12 @@ include ../../../Make.inc
# The object files
#
FOBJS = isr.o isrx.o msort_up.o msort_dw.o\
isaperm.o ibsrch.o issrch.o imsr.o imsrx.o imsru.o
FOBJS = isr.o isrx.o iasr.o iasrx.o msort_up.o msort_dw.o\
isaperm.o ibsrch.o issrch.o imsr.o imsrx.o imsru.o\
dsr.o dsrx.o dasr.o dasrx.o \
zlcmp_mod.o zlsr.o zlsrx.o \
zalcmp_mod.o zalsr.o zalsrx.o \
zacmp_mod.o zasr.o zasrx.o
OBJS=$(FOBJS)
@ -26,9 +30,12 @@ default: lib
lib: $(OBJS)
$(AR) $(LIBDIR)/$(LIBNAME) $(OBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME)
zlsr.o zlsrx.o: zlcmp_mod.o
zalsr.o zalsrx.o: zalcmp_mod.o
zasr.o zasrx.o: zacmp_mod.o
clean:
/bin/rm -f $(OBJS)
/bin/rm -f $(OBJS) *$(.mod)
veryclean: clean

361
base/serial/aux/dasr.f90
Unescape Escape View File

@ -0,0 +1,361 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine dasr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir
real(kind(1.d0)) :: x(n)
! ..
! .. Local Scalars ..
real(kind(1.d0)) :: xx, piv, xt, xk
integer i, j, ilx, iux, istp, lpiv
integer n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call disr_up(n,x)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call disr_dw(n,x)
endif
case default
write(0,*) 'isr error !',dir
end select
return
contains
subroutine disr_up(n,x)
implicit none
integer :: n
real(kind(1.d0)) :: x(n)
integer :: i,j
real(kind(1.d0)) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine disr_up
subroutine disr_dw(n,x)
implicit none
integer :: n
real(kind(1.d0)) :: x(n)
integer :: i,j
real(kind(1.d0)) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine disr_dw
end subroutine dasr

409
base/serial/aux/dasrx.f90
Unescape Escape View File

@ -0,0 +1,409 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine dasrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir, flag
real(kind(1.d0)) :: x(n)
integer :: indx(n)
! ..
! .. Local Scalars ..
real(kind(1.d0)) :: xx, piv, xt, xk
integer i, j, ii, ilx, iux, istp, lpiv
integer ixt, n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
write(0,*) 'Error in isrx: invalid flag',flag
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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
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
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
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
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idasrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idasrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call idasrx_up(n,x,indx)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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
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
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
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
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idasrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idasrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call idasrx_dw(n,x,indx)
endif
case default
write(0,*) 'isrx error dir ',dir
end select
return
contains
subroutine idasrx_up(n,x,indx)
implicit none
integer :: n
real(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
real(kind(1.d0)) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine idasrx_up
subroutine idasrx_dw(n,x,indx)
implicit none
integer :: n
real(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
real(kind(1.d0)) :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine idasrx_dw
end subroutine dasrx

359
base/serial/aux/dsr.f90
Unescape Escape View File

@ -0,0 +1,359 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine dsr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir
real(kind(1.d0)) :: x(n)
! ..
! .. Local Scalars ..
real(kind(1.d0)) :: xx, piv, xt, xk
integer i, j, ilx, iux, istp, lpiv
integer n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_sort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call disr_up(n,x)
endif
case(psb_sort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call disr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call disr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call disr_dw(n,x)
endif
case default
write(0,*) 'isr error !',dir
end select
return
contains
subroutine disr_up(n,x)
implicit none
integer :: n
real(kind(1.d0)) :: x(n)
integer :: i,j
real(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine disr_up
subroutine disr_dw(n,x)
implicit none
integer :: n
real(kind(1.d0)) :: x(n)
integer :: i,j
real(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine disr_dw
end subroutine dsr

409
base/serial/aux/dsrx.f90
Unescape Escape View File

@ -0,0 +1,409 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine dsrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir, flag
real(kind(1.d0)) :: x(n)
integer :: indx(n)
! ..
! .. Local Scalars ..
real(kind(1.d0)) :: xx, piv, xk, xt
integer i, j, ii, ilx, iux, istp, lpiv
integer ixt, n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
write(0,*) 'Error in isrx: invalid flag',flag
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_sort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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)
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)
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)
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)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idsrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idsrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call idsrx_up(n,x,indx)
endif
case(psb_sort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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)
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)
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)
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)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idsrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call idsrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call idsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call idsrx_dw(n,x,indx)
endif
case default
write(0,*) 'isrx error dir ',dir
end select
return
contains
subroutine idsrx_up(n,x,indx)
implicit none
integer :: n
real(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
real(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine idsrx_up
subroutine idsrx_dw(n,x,indx)
implicit none
integer :: n
real(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
real(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine idsrx_dw
end subroutine dsrx

361
base/serial/aux/iasr.f90
Unescape Escape View File

@ -0,0 +1,361 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine iasr(n,x,dir)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir
integer :: x(n)
! ..
! .. Local Scalars ..
integer :: xx, piv, xt, xk
integer i, j, ilx, iux, istp, lpiv
integer n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iaisr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iaisr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iaisr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iaisr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call iaisr_up(n,x)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = abs(x(lpiv))
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv < abs(x(j))) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
if (piv > abs(x(i))) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = abs(x(lpiv))
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iaisr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iaisr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iaisr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iaisr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call iaisr_dw(n,x)
endif
case default
write(0,*) 'isr error !',dir
end select
return
contains
subroutine iaisr_up(n,x)
implicit none
integer :: n
integer :: x(n)
integer :: i,j
integer :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine iaisr_up
subroutine iaisr_dw(n,x)
implicit none
integer :: n
integer :: x(n)
integer :: i,j
integer :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
endif
enddo
end subroutine iaisr_dw
end subroutine iasr

409
base/serial/aux/iasrx.f90
Unescape Escape View File

@ -0,0 +1,409 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine iasrx(n,x,indx,dir,flag)
use psb_serial_mod
implicit none
!
! Quicksort on absolute value with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir, flag
integer :: x(n)
integer :: indx(n)
! ..
! .. Local Scalars ..
integer :: xx, piv, xt, xk
integer i, j, ii, ilx, iux, istp, lpiv
integer ixt, n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
write(0,*) 'Error in isrx: invalid flag',flag
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_asort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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
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
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
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
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = abs(x(i))
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_up2:do
j = j - 1
xk = abs(x(j))
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iiasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iiasrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iiasrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iiasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call iiasrx_up(n,x,indx)
endif
case(psb_asort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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
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
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
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
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = abs(x(i))
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = x(i)
x(i) = piv
in_dw2:do
j = j - 1
xk = abs(x(j))
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iiasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iiasrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call iiasrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call iiasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call iiasrx_dw(n,x,indx)
endif
case default
write(0,*) 'isrx error dir ',dir
end select
return
contains
subroutine iiasrx_up(n,x,indx)
implicit none
integer :: n
integer :: x(n)
integer :: indx(n)
integer :: i,j,ix
integer :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) < abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) >= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine iiasrx_up
subroutine iiasrx_dw(n,x,indx)
implicit none
integer :: n
integer :: x(n)
integer :: indx(n)
integer :: i,j,ix
integer :: xx,xax
do j=n-1,1,-1
if (abs(x(j+1)) > abs(x(j))) then
xx = x(j)
ix = indx(j)
xax = abs(xx)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (abs(x(i)) <= xax) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine iiasrx_dw
end subroutine iasrx

44
base/serial/aux/zacmp_mod.f90
Unescape Escape View File

@ -0,0 +1,44 @@
module zacmp_mod
interface operator(<)
module procedure zalt
end interface
interface operator(<=)
module procedure zale
end interface
interface operator(>)
module procedure zagt
end interface
interface operator(>=)
module procedure zage
end interface
contains
function zalt(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zalt
zalt = ((abs(real(a))+abs(aimag(a))) < (abs(real(b))+abs(aimag(b))))
end function zalt
function zale(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zale
zale = ((abs(real(a))+abs(aimag(a))) <= (abs(real(b))+abs(aimag(b))))
end function zale
function zagt(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zagt
zagt = ((abs(real(a))+abs(aimag(a))) > (abs(real(b))+abs(aimag(b))))
end function zagt
function zage(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zage
zage = ((abs(real(a))+abs(aimag(a))) >= (abs(real(b))+abs(aimag(b))))
end function zage
end module zacmp_mod

48
base/serial/aux/zalcmp_mod.f90
Unescape Escape View File

@ -0,0 +1,48 @@
module zalcmp_mod
interface operator(<)
module procedure zallt
end interface
interface operator(<=)
module procedure zalle
end interface
interface operator(>)
module procedure zalgt
end interface
interface operator(>=)
module procedure zalge
end interface
contains
function zallt(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zallt
zallt = (abs(real(a))<abs(real(b))).or. &
& ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))<abs(aimag(b))))
end function zallt
function zalle(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zalle
zalle = (abs(real(a))<abs(real(b))).or. &
& ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))<=abs(aimag(b))))
end function zalle
function zalgt(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zalgt
zalgt = (abs(real(a))>abs(real(b))).or. &
& ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>abs(aimag(b))))
end function zalgt
function zalge(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zalge
zalge = (abs(real(a))>abs(real(b))).or. &
& ((abs(real(a))==abs(real(b))).and.(abs(aimag(a))>=abs(aimag(b))))
end function zalge
end module zalcmp_mod

362
base/serial/aux/zalsr.f90
Unescape Escape View File

@ -0,0 +1,362 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zalsr(n,x,dir)
use psb_serial_mod
use zalcmp_mod
implicit none
!
! Quicksort on lexicographic comparison of complex numbers.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir
complex(kind(1.d0)) :: x(n)
! ..
! .. Local Scalars ..
complex(kind(1.d0)) :: xx, xk, piv, xt
integer i, j, ilx, iux, istp, lpiv
integer n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call izalsr_up(n,x)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call izalsr_dw(n,x)
endif
case default
write(0,*) 'isr error !',dir
end select
return
contains
subroutine izalsr_up(n,x)
use zalcmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: i,j
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izalsr_up
subroutine izalsr_dw(n,x)
use zalcmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: i,j
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izalsr_dw
end subroutine zalsr

413
base/serial/aux/zalsrx.f90
Unescape Escape View File

@ -0,0 +1,413 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zalsrx(n,x,indx,dir,flag)
use psb_serial_mod
use zalcmp_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir, flag
complex(kind(1.d0)) :: x(n)
integer :: indx(n)
! ..
! .. Local Scalars ..
complex(kind(1.d0)) :: xx, piv, xk, xt
integer i, j, ii, ilx, iux, istp, lpiv
integer ixt, n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
write(0,*) 'Error in isrx: invalid flag',flag
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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)
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)
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)
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)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izalsrx_up(n,x,indx)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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)
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)
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)
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)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izalsrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izalsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izalsrx_dw(n,x,indx)
endif
case default
write(0,*) 'isrx error dir ',dir
end select
return
contains
subroutine izalsrx_up(n,x,indx)
use zalcmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izalsrx_up
subroutine izalsrx_dw(n,x,indx)
use zalcmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izalsrx_dw
end subroutine zalsrx

362
base/serial/aux/zasr.f90
Unescape Escape View File

@ -0,0 +1,362 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zasr(n,x,dir)
use psb_serial_mod
use zacmp_mod
implicit none
!
! Quicksort on lexicographic comparison of complex numbers.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir
complex(kind(1.d0)) :: x(n)
! ..
! .. Local Scalars ..
complex(kind(1.d0)) :: xx, xk, piv, xt
integer i, j, ilx, iux, istp, lpiv
integer n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call izasr_up(n,x)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call izasr_dw(n,x)
endif
case default
write(0,*) 'isr error !',dir
end select
return
contains
subroutine izasr_up(n,x)
use zacmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: i,j
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izasr_up
subroutine izasr_dw(n,x)
use zacmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: i,j
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izasr_dw
end subroutine zasr

413
base/serial/aux/zasrx.f90
Unescape Escape View File

@ -0,0 +1,413 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zasrx(n,x,indx,dir,flag)
use psb_serial_mod
use zacmp_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir, flag
complex(kind(1.d0)) :: x(n)
integer :: indx(n)
! ..
! .. Local Scalars ..
complex(kind(1.d0)) :: xx, piv, xk, xt
integer i, j, ii, ilx, iux, istp, lpiv
integer ixt, n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
write(0,*) 'Error in isrx: invalid flag',flag
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_alsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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)
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)
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)
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)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izasrx_up(n,x,indx)
endif
case(psb_alsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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)
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)
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)
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)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izasrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izasrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izasrx_dw(n,x,indx)
endif
case default
write(0,*) 'isrx error dir ',dir
end select
return
contains
subroutine izasrx_up(n,x,indx)
use zacmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izasrx_up
subroutine izasrx_dw(n,x,indx)
use zacmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izasrx_dw
end subroutine zasrx

44
base/serial/aux/zlcmp_mod.f90
Unescape Escape View File

@ -0,0 +1,44 @@
module zlcmp_mod
interface operator(<)
module procedure zllt
end interface
interface operator(<=)
module procedure zlle
end interface
interface operator(>)
module procedure zlgt
end interface
interface operator(>=)
module procedure zlge
end interface
contains
function zllt(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zllt
zllt = (real(a)<real(b)).or.((real(a)==real(b)).and.(aimag(a)<aimag(b)))
end function zllt
function zlle(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zlle
zlle = (real(a)<real(b)).or.((real(a)==real(b)).and.(aimag(a)<=aimag(b)))
end function zlle
function zlgt(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zlgt
zlgt = (real(a)>real(b)).or.((real(a)==real(b)).and.(aimag(a)>aimag(b)))
end function zlgt
function zlge(a,b)
complex(kind(1.d0)), intent(in) :: a,b
logical :: zlge
zlge = (real(a)>real(b)).or.((real(a)==real(b)).and.(aimag(a)>=aimag(b)))
end function zlge
end module zlcmp_mod

362
base/serial/aux/zlsr.f90
Unescape Escape View File

@ -0,0 +1,362 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zlsr(n,x,dir)
use psb_serial_mod
use zlcmp_mod
implicit none
!
! Quicksort on lexicographic comparison of complex numbers.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir
complex(kind(1.d0)) :: x(n)
! ..
! .. Local Scalars ..
complex(kind(1.d0)) :: xx, xk, piv, xt
integer i, j, ilx, iux, istp, lpiv
integer n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_lsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsr_up(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsr_up(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsr_up(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsr_up(n1,x(ilx:i-1))
endif
endif
enddo
else
call izlsr_up(n,x)
endif
case(psb_lsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
piv = x(lpiv)
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv < x(j)) then
xt = x(j)
x(j) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
if (piv > x(i)) then
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
piv = x(lpiv)
endif
!
! now piv is correct; place it into first location
xt = x(i)
x(i) = x(lpiv)
x(lpiv) = xt
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
x(i) = x(j)
x(j) = xt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsr_dw(n1,x(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsr_dw(n2,x(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsr_dw(n2,x(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsr_dw(n1,x(ilx:i-1))
endif
endif
enddo
else
call izlsr_dw(n,x)
endif
case default
write(0,*) 'isr error !',dir
end select
return
contains
subroutine izlsr_up(n,x)
use zlcmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: i,j
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izlsr_up
subroutine izlsr_dw(n,x)
use zlcmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: i,j
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
i=j+1
do
x(i-1) = x(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
endif
enddo
end subroutine izlsr_dw
end subroutine zlsr

413
base/serial/aux/zlsrx.f90
Unescape Escape View File

@ -0,0 +1,413 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine zlsrx(n,x,indx,dir,flag)
use psb_serial_mod
use zlcmp_mod
implicit none
!
! Quicksort with indices into original positions.
! Adapted from a number of sources, including Don Knuth's TAOCP.
!
! .. Scalar Arguments ..
integer, intent(in) :: n, dir, flag
complex(kind(1.d0)) :: x(n)
integer :: indx(n)
! ..
! .. Local Scalars ..
complex(kind(1.d0)) :: xx, piv, xk, xt
integer i, j, ii, ilx, iux, istp, lpiv
integer ixt, n1, n2
integer, parameter :: maxstack=64,nparms=3,ithrs=16
integer :: istack(nparms,maxstack)
! ..
select case(flag)
case(psb_sort_ovw_idx_)
do i=1, n
indx(i) = i
enddo
case(psb_sort_keep_idx_)
! do nothing
case default
write(0,*) 'Error in isrx: invalid flag',flag
end select
!
!
! small inputs will only get through insertion sort.
!
select case(dir)
case(psb_lsort_up_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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)
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)
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)
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)
i = ilx - 1
j = iux + 1
outer_up: do
in_up1: do
i = i + 1
xk = x(i)
if (xk >= piv) exit in_up1
end do in_up1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_up2:do
j = j - 1
xk = x(j)
if (xk <= piv) exit in_up2
end do in_up2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_up
end if
end do outer_up
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsrx_up(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsrx_up(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsrx_up(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izlsrx_up(n,x,indx)
endif
case(psb_lsort_down_)
if (n > ithrs) then
!
! Init stack pointer
!
istp = 1
istack(1,istp) = 1
istack(2,istp) = n
do
if (istp <= 0) exit
ilx = istack(1,istp)
iux = istack(2,istp)
istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
!
! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location
!
i = ilx
j = iux
lpiv = (i+j)/2
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)
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)
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)
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)
i = ilx - 1
j = iux + 1
outer_dw: do
in_dw1: do
i = i + 1
xk = x(i)
if (xk <= piv) exit in_dw1
end do in_dw1
!
! Ensure finite termination for next loop
!
xt = xk
x(i) = piv
in_dw2:do
j = j - 1
xk = x(j)
if (xk >= piv) exit in_dw2
end do in_dw2
x(i) = xt
if (j > i) then
xt = x(i)
ixt = indx(i)
x(i) = x(j)
indx(i) = indx(j)
x(j) = xt
indx(j) = ixt
else
exit outer_dw
end if
end do outer_dw
if (i == ilx) then
if (x(i) /= piv) then
write(0,*) 'Should never ever get here????!!!!'
stop
endif
i = i + 1
endif
n1 = (i-1)-ilx+1
n2 = iux-(i)+1
if (n1 > n2) then
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsrx_dw(n2,x(i:iux),indx(i:iux))
endif
else
if (n2 > ithrs) then
istp = istp + 1
istack(1,istp) = i
istack(2,istp) = iux
else
call izlsrx_dw(n2,x(i:iux),indx(i:iux))
endif
if (n1 > ithrs) then
istp = istp + 1
istack(1,istp) = ilx
istack(2,istp) = i-1
else
call izlsrx_dw(n1,x(ilx:i-1),indx(ilx:i-1))
endif
endif
enddo
else
call izlsrx_dw(n,x,indx)
endif
case default
write(0,*) 'isrx error dir ',dir
end select
return
contains
subroutine izlsrx_up(n,x,indx)
use zlcmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) < x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) >= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izlsrx_up
subroutine izlsrx_dw(n,x,indx)
use zlcmp_mod
implicit none
integer :: n
complex(kind(1.d0)) :: x(n)
integer :: indx(n)
integer :: i,j,ix
complex(kind(1.d0)) :: xx
do j=n-1,1,-1
if (x(j+1) > x(j)) then
xx = x(j)
ix = indx(j)
i=j+1
do
x(i-1) = x(i)
indx(i-1) = indx(i)
i = i+1
if (i>n) exit
if (x(i) <= xx) exit
end do
x(i-1) = xx
indx(i-1) = ix
endif
enddo
end subroutine izlsrx_dw
end subroutine zlsrx

18
base/serial/dp/dcoco.f
Unescape Escape View File

@ -36,6 +36,7 @@ c
use psb_const_mod
use psb_spmat_type
use psb_string_mod
implicit none
c .. scalar arguments ..
@ -74,8 +75,8 @@ c
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
if (trans.eq.'N') then
scale = (unitd.eq.'L') ! meaningless
if (toupper(trans).eq.'N') then
scale = (toupper(unitd).eq.'L') ! meaningless
p1(1) = 0
p2(1) = 0
@ -114,7 +115,7 @@ c
goto 9999
end if
if (descra(1:1).eq.'G') then
if (toupper(descra(1:1)).eq.'G') then
c
c sort COO data structure
c
@ -245,26 +246,29 @@ c ... add the duplicated element ...
if (debug) write(*,*)'done rebuild COO',infon(1)
else if (descra(1:1).eq.'S' .and. descra(2:2).eq.'U') then
else if (toupper(descra(1:1)).eq.'S' .and.
+ toupper(descra(2:2)).eq.'U') then
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then
else if (toupper(descra(1:1)).eq.'T' .and.
+ toupper(descra(2:2)).eq.'U') then
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then
else if (toupper(descra(1:1)).eq.'T' .and.
+ toupper(descra(2:2)).eq.'L') then
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
end if
c
else if (trans.ne.'N') then
else if (toupper(trans).ne.'N') then
c
c to do
c

674
base/serial/dp/dcocr.f
Unescape Escape View File

@ -37,6 +37,7 @@ C
use psb_const_mod
use psb_spmat_type
use psb_string_mod
IMPLICIT NONE
C
@ -51,18 +52,19 @@ C .. Array Arguments ..
* INFON(*), P1(*), P2(*)
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER NNZ, K, ROW, I, J, NZL, IRET
integer ipx, ip1, ip2, CHECK_FLAG, err_act
INTEGER ELEM, ELEM_CSR
LOGICAL SCALE
INTEGER MAX_NNZERO
integer nnz, k, row, i, j, nzl, iret
integer ipx, ip1, ip2, check_flag, err_act
integer elem, elem_csr,regen_flag
logical scale
integer max_nnzero
logical debug
parameter (debug=.false.)
c .. Local Arrays ..
CHARACTER*20 NAME
INTEGER INT_VAL(5)
integer, allocatable :: itmp(:)
c .. local arrays ..
character*20 name
integer int_val(5)
C
c
C ...Common variables...
C .. External Subroutines ..
@ -75,14 +77,15 @@ C
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN
IF (toupper(TRANS).EQ.'N') THEN
SCALE = (UNITD.EQ.'L') ! meaningless
SCALE = (toupper(UNITD).EQ.'L') ! meaningless
P1(1) = 0
P2(1) = 0
NNZ = INFO(1)
nnz = info(1)
if (debug) then
write(0,*) 'On entry to DCOCR: NNZ LAUX ',
+ nnz,laux,larn,lian1,lian2
@ -117,25 +120,35 @@ C
GOTO 9999
END IF
IF (DESCRA(1:1).EQ.'G') THEN
allocate(itmp(nnz),stat=iret)
if (iret /= 0) then
call fcpsb_errpush(4010,name,int_val)
goto 9999
end if
do k=1, nnz
arn(k) = ar(k)
ian1(k) = ja(k)
itmp(k) = ia(k)
enddo
! Mark as unavailable by default.
infon(psb_upd_pnt_) = 0
IF (toupper(descra(1:1)).EQ.'G') THEN
C
C Sort COO data structure
C
if (debug) write(0,*)'First sort',nnz
c$$$ if (debug) then
c$$$ do k=1,nnz
c$$$ write(*,*) k,ia(k),ja(k),ar(k)
c$$$ enddo
c$$$ endif
c$$$ write(0,*) 'DCOCR Sizes ',lian2,((m+1)+nnz+psb_ireg_flgs_+1),
c$$$ + m+1,nnz,psb_ireg_flgs_,
c$$$ + laux,2*(2+nnz)
if ((lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
if ((regen_flag==psb_upd_perm_).and.
+ (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
+ .and.(laux.ge.2*(2+nnz))) then
C
C Prepare for smart regeneration
c
ipx = nnz+3
do i=1, nnz
aux(ipx+i-1) = i
@ -149,182 +162,167 @@ c
ian2(ip1+psb_nnz_) = 0
ian2(ip1+psb_ichk_) = nnz+check_flag
c$$$ write(0,*)'DCOCR Check: ',ip2,ian2(ip1+psb_iflag_),
c$$$ + ian2(ip1+psb_nnzt_), ian2(ip1+psb_nnz_),
c$$$ + ian2(ip1+psb_ichk_)
c$$$ + ip1,ip2,nnz,ian2(ip1+nnzt_)
if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_)
C .... Order with key IA ...
CALL MSORT_UP(NNZ,IA,AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN3(NNZ,AR,IA,JA,AUX(IPX),AUX)
call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call reordvn3(nnz,arn,itmp,ian1,aux(ipx),aux)
if (debug) then
do i=1, nnz-1
if (ia(i).gt.ia(i+1)) then
write(0,*) 'Sorting error:',i,ia(i),ia(i+1)
if (itmp(i).gt.itmp(i+1)) then
write(0,*) 'Sorting error:',i,itmp(i),itmp(i+1)
endif
enddo
write(0,*) 'nnz :',m,nnz,ia(nnz),ja(nnz)
write(0,*) 'nnz :',m,nnz,itmp(nnz),ian1(nnz)
endif
C .... Order with key IA2N ...
C .... Order with key JA ...
I = 1
J = I
c$$$ DO WHILE (I.LE.NNZ)
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
c$$$ + (J.LE.NNZ))
DO
if (I>NNZ) exit
DO
do
if (i>nnz) exit
do
if (j>nnz) exit
if (ia(j) /= ia(i)) exit
J = J+1
ENDDO
NZL = J - I
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN3(NZL,AR(I),IA(I),JA(I),
+ AUX(IPX+I-1),AUX)
I = J
ENDDO
if (itmp(j) /= itmp(i)) exit
j = j+1
enddo
nzl = j - i
call msort_up(nzl,ian1(i),aux,iret)
if (iret.eq.0) call reordvn3(nzl,arn(i),itmp(i),ian1(i),
+ aux(ipx+i-1),aux)
i = j
enddo
C ... Construct CSR Representation...
ELEM = 1
ELEM_CSR = 1
C ... Insert first element ...
DO ROW = 1, IA(1)
IAN2(ROW) = 1
ENDDO
c ... Construct CSR Representation...
elem = 1
elem_csr = 1
c ... Insert first element ...
do row = 1, itmp(1)
ian2(row) = 1
enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
ELEM = ELEM+1
ELEM_CSR = ELEM_CSR+1
C ... Insert remaining element ...
DO ROW = IA(1), M
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
DO
elem = elem+1
elem_csr = elem_csr+1
c ... insert remaining element ...
do row = itmp(1), m
do
if (elem > nnz) exit
if (ia(elem) /= row) exit
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
C ... Insert first element of a row ...
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
if (itmp(elem) /= row) exit
if (itmp(elem).ne.itmp(elem-1)) then
c ... insert first element of a row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
ELEM_CSR = ELEM_CSR+1
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
C ... Insert other element of row ...
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
elem_csr = elem_csr+1
else if (ian1(elem).ne.ian1(elem-1)) then
c ... insert other element of row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
ELEM_CSR = ELEM_CSR+1
ELSE
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ...
ARN(ELEM_CSR-1) = AR(ELEM)
elem_csr = elem_csr+1
else
if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
if (debug) write(0,*) 'Duplicated overwrite perm ',
if (debug) write(0,*) 'duplicated overwrite perm ',
+ elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
if (debug) write(0,*) 'Duplicated add perm ',
if (debug) write(0,*) 'duplicated add perm ',
+ elem_csr-1,elem
END IF
ENDIF
ELEM = ELEM + 1
ENDDO
IAN2(ROW+1) = ELEM_CSR
ENDDO
end if
endif
elem = elem + 1
enddo
ian2(row+1) = elem_csr
enddo
ELSE
c$$$ write(0,*) 'Going for ELSE !!!?'
else
C .... Order with key IA ...
CALL MSORT_UP(NNZ,IA,AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NNZ,AR,IA,JA,AUX)
C .... Order with key IA2N ...
I = 1
J = I
c$$$ DO WHILE (I.LE.NNZ)
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
c$$$ + (J.LE.NNZ))
DO
if (I>NNZ) exit
DO
call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux)
C .... Order with key JA ...
i = 1
j = i
do
if (i>nnz) exit
do
if (j>nnz) exit
if (ia(j) /= ia(i)) exit
J = J+1
ENDDO
NZL = J - I
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NZL,AR(I),IA(I),JA(I),AUX)
I = J
ENDDO
if (itmp(j) /= itmp(i)) exit
j = j+1
enddo
nzl = j - i
call msort_up(nzl,ian1(i),aux,iret)
if (iret.eq.0)
+ call reordvn(nzl,arn(i),itmp(i),ian1(i),aux)
i = j
enddo
C ... Construct CSR Representation...
ELEM = 1
ELEM_CSR = 1
elem = 1
elem_csr = 1
C ... Insert first element ...
DO ROW = 1, IA(1)
IAN2(ROW) = 1
ENDDO
do row = 1, itmp(1)
ian2(row) = 1
enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM = ELEM+1
ELEM_CSR = ELEM_CSR+1
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem = elem+1
elem_csr = elem_csr+1
C ... Insert remaining element ...
DO ROW = IA(1), M
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
DO
do row = itmp(1), m
do
if (elem > nnz) exit
if (ia(elem) /= row) exit
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
C ... Insert first element of a row ...
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
if (itmp(elem) /= row) exit
if (itmp(elem).ne.itmp(elem-1)) then
c ... insert first element of a row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else if (ian1(elem).ne.ian1(elem-1)) then
C ... Insert other element of row ...
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ELSE
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ...
ARN(ELEM_CSR-1) = AR(ELEM)
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else
if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
END IF
ENDIF
ELEM = ELEM + 1
ENDDO
IAN2(ROW+1) = ELEM_CSR
ENDDO
ENDIF
end if
endif
elem = elem + 1
enddo
ian2(row+1) = elem_csr
enddo
endif
if (debug) write(0,*)'Done Rebuild CSR',
+ ian2(m+1),ia(elem)
@ -334,200 +332,162 @@ c$$$ write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
c$$$ enddo
c$$$ endif
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
DO 20 K = 1, M
P2(K) = K
20 CONTINUE
do 20 k = 1, m
p2(k) = k
20 continue
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
else if (toupper(DESCRA(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux)
C .... Order with key JA ...
i = 1
j = i
do
if (i>nnz) exit
do
if (j>nnz) exit
if (itmp(j) /= itmp(i)) exit
j = j+1
enddo
nzl = j - i
call msort_up(nzl,ian1(i),aux,iret)
if (iret.eq.0)
+ call reordvn(nzl,arn(i),itmp(i),ian1(i),aux)
i = j
enddo
C .... Order with key IA ...
CALL MSORT_UP(NNZ,IA,AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NNZ,AR,IA,JA,AUX)
C .... Order with key IA2N ...
I = 1
J = I
c$$$ DO WHILE (I.LE.NNZ)
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
c$$$ + (J.LE.NNZ))
DO
if (I>NNZ) exit
DO
if (j>nnz) exit
if (ia(j) /= ia(i)) exit
J = J+1
ENDDO
NZL = J - I
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NZL,AR(I),IA(I),JA(I),AUX)
I = J
ENDDO
C ... Construct CSR Representation...
ELEM = 1
ELEM_CSR = 1
elem = 1
elem_csr = 1
C ... Insert first element ...
DO ROW = 1, IA(1)
IAN2(ROW) = 1
ENDDO
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
IF(JA(ELEM).GT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELEM = ELEM+1
do row = 1, itmp(1)
ian2(row) = 1
enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem = elem+1
elem_csr = elem_csr+1
C ... Insert remaining element ...
DO ROW = IA(1), M
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
DO
if (elem > nnz) exit
if (ia(elem) /= row) exit
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
C ... Insert first element of a row ...
IF(JA(ELEM).GT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
C ... Insert other element of row ...
IF(JA(ELEM).GT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELSE
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ...
IF(JA(ELEM).GT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = AR(ELEM)
ENDIF
if (debug) write(0,*) 'Duplicated overwrite',
+ elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ...
IF(JA(ELEM).GT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
ENDIF
if (debug) write(0,*) 'Duplicated add',
+ elem_csr-1,elem
END IF
ENDIF
ELEM = ELEM + 1
ENDDO
IAN2(ROW+1) = ELEM_CSR
ENDDO
if (debug) write(0,*)'Done Rebuild CSR',
+ ian2(m+1),ia(elem)
if (debug) then
do i=ian2(m+1), nnz
write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
do row = itmp(1), m
do
if (elem > nnz) exit
if (itmp(elem) /= row) exit
if (itmp(elem).ne.itmp(elem-1)) then
c ... insert first element of a row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else if (ian1(elem).ne.ian1(elem-1)) then
C ... Insert other element of row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else
if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if
endif
elem = elem + 1
enddo
ian2(row+1) = elem_csr
enddo
endif
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
else if (toupper(descra(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'L') THEN
call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux)
C .... Order with key JA ...
i = 1
j = i
do
if (i>nnz) exit
do
if (j>nnz) exit
if (itmp(j) /= itmp(i)) exit
j = j+1
enddo
nzl = j - i
call msort_up(nzl,ian1(i),aux,iret)
if (iret.eq.0)
+ call reordvn(nzl,arn(i),itmp(i),ian1(i),aux)
i = j
enddo
C .... Order with key IA ...
CALL MSORT_UP(NNZ,IA,AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NNZ,AR,IA,JA,AUX)
C .... Order with key IA2N ...
I = 1
J = I
c$$$ DO WHILE (I.LE.NNZ)
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
c$$$ + (J.LE.NNZ))
DO
if (I>NNZ) exit
DO
if (j>nnz) exit
if (ia(j) /= ia(i)) exit
J = J+1
ENDDO
NZL = J - I
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NZL,AR(I),IA(I),JA(I),AUX)
I = J
ENDDO
C ... Construct CSR Representation...
ELEM = 1
ELEM_CSR = 1
elem = 1
elem_csr = 1
C ... Insert first element ...
DO ROW = 1, IA(1)
IAN2(ROW) = 1
ENDDO
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
IF(JA(ELEM).LT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELEM = ELEM+1
do row = 1, itmp(1)
ian2(row) = 1
enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem = elem+1
elem_csr = elem_csr+1
C ... Insert remaining element ...
do row = itmp(1), m
do
if (elem > nnz) exit
if (itmp(elem) /= row) exit
if (itmp(elem).ne.itmp(elem-1)) then
c ... insert first element of a row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else if (ian1(elem).ne.ian1(elem-1)) then
C ... Insert other element of row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else
if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if
endif
elem = elem + 1
enddo
ian2(row+1) = elem_csr
enddo
C ... Insert remaining element ...
DO ROW = IA(1), M
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
DO
if (elem > nnz) exit
if (ia(elem) /= row) exit
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
C ... Insert first element of a row ...
IF(JA(ELEM).LT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
C ... Insert other element of row ...
IF(JA(ELEM).LT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELSE
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ...
IF(JA(ELEM).LT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = AR(ELEM)
ENDIF
if (debug) write(0,*) 'Duplicated overwrite',
+ elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ...
IF(JA(ELEM).LT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
ENDIF
if (debug) write(0,*) 'Duplicated add',
+ elem_csr-1,elem
END IF
ENDIF
ELEM = ELEM + 1
ENDDO
IAN2(ROW+1) = ELEM_CSR
ENDDO
if (debug) write(0,*)'Done Rebuild CSR',
+ ian2(m+1),ia(elem)
if (debug) then
@ -537,29 +497,29 @@ C ... Sum the duplicated element ...
endif
END IF
C
ELSE IF (TRANS.NE.'N') THEN
C
C TO DO
C
IERROR = 3021
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
end if
c
else if (toupper(TRANS).NE.'N') then
c
c to do
c
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
END IF
INFON(1)=ELEM_CSR-1
end if
infon(1)=elem_csr-1
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
RETURN
call fcpsb_erractionrestore(err_act)
return
9999 CONTINUE
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
9999 continue
call fcpsb_erractionrestore(err_act)
IF ( ERR_ACT .NE. 0 ) THEN
CALL FCPSB_SERROR()
RETURN
ENDIF
if ( err_act .ne. 0 ) then
call fcpsb_serror()
return
endif
RETURN
END
return
end

36
base/serial/dp/dcrco.f
Unescape Escape View File

@ -34,6 +34,7 @@ C
use psb_const_mod
use psb_spmat_type
use psb_string_mod
IMPLICIT NONE
C
@ -63,8 +64,8 @@ C
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
IF (TRANS.EQ.'N') THEN
SCALE = (UNITD.EQ.'L') ! meaningless
IF (toupper(TRANS).EQ.'N') THEN
SCALE = (toupper(UNITD).EQ.'L') ! meaningless
IP1(1) = 0
IP2(1) = 0
NNZ = IA2(M+1)-1
@ -92,7 +93,7 @@ C
GOTO 9999
END IF
IF (DESCRA(1:1).EQ.'G') THEN
IF (toupper(DESCRA(1:1)).EQ.'G') THEN
C ... Construct COO Representation...
ELEM = 0
@ -106,19 +107,27 @@ C ... Construct COO Representation...
ENDDO
INFON(psb_nnz_) = elem
if (debug) write(0,*) 'CRCO endloop',m,elem
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
DO 20 K = 1, M
IP2(K) = K
20 CONTINUE
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
c$$$ CALL DVSSG(M,IA1,IA2,IP2,IAN2(PNG),IP1,IP2,AUX(IWLEN),
c$$$ * AUX(IWORK1))
c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2,
c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1),
c$$$ * AUX(IWORK2),NJA,IER,SCALE)
C
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
c$$$ CALL DVTFG('U',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN),
c$$$c * AUX(IWORK1),AUX(IWORK2),IAN1(M+1))
@ -127,23 +136,36 @@ c$$$ CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2,
c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE)
C
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'L') THEN
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
c$$$ CALL DVTFG('L',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN),
c$$$c * AUX(IWORK1),AUX(IWORK2),IAN1(M+1))
c$$$ * AUX(IWORK1),IAN1(1),IAN1(M+5))
c$$$ CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2,
c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE)
else
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
END IF
C
ELSE IF (TRANS.NE.'N') THEN
ELSE IF (toupper(TRANS).NE.'N') THEN
C
C TO DO
C
IERROR = 3021
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
else
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
END IF

29
base/serial/dp/dcrcr.f
Unescape Escape View File

@ -163,6 +163,7 @@ C
SUBROUTINE DCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1,
* DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2,
* WORK,LWORK,IERROR)
use psb_string_mod
IMPLICIT NONE
C
C .. Scalar Arguments ..
@ -177,6 +178,7 @@ C .. Local Scalars ..
INTEGER I, J, ERR_ACT
LOGICAL EXIT
c .. Local Arrays ..
character idescra*11
CHARACTER*20 NAME
INTEGER INT_VAL(5)
@ -192,11 +194,12 @@ C
C
C Check for argument errors
C
IF(((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
& DESCRA(1:1) .EQ. 'A') .AND. (UNITD .NE. 'B')) .OR.
& (.NOT.((DESCRA(3:3).EQ.'N').OR.(DESCRA(3:3).EQ.'L').OR.
+ (DESCRA(3:3).EQ.'U'))) .OR.
+ TRANS.NE.'N') THEN
idescra=toupper(descra)
IF(((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR.
& idescra(1:1) .EQ. 'A') .AND. (toupper(unitd) .NE. 'B')) .OR.
& (.NOT.((idescra(3:3).EQ.'N').OR.(idescra(3:3).EQ.'L').OR.
+ (idescra(3:3).EQ.'U'))) .OR.
+ toupper(TRANS).NE.'N') THEN
IERROR = 20
ENDIF
IF(LAN.LT.(IA2(M+1)-1)) THEN
@ -223,8 +226,8 @@ C
IERROR = 23
ENDIF
ENDIF
IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
& DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN
IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR.
& idescra(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN
IF (LWORK.LT.M) THEN
IF (LWORK.LE.0) THEN
EXIT=.TRUE.
@ -250,7 +253,7 @@ C
C
C Set DESCRN, IP1, IP2
C
DESCRN(1:3) = DESCRA(1:3)
DESCRN(1:3) = idescra(1:3)
IP1(1)=0
IP2(1)=0
@ -260,8 +263,8 @@ C
DO 20 I = 1, M+1
IAN2(I) = IA2(I)
20 CONTINUE
IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
& DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN
IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR.
& idescra(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN
DO 30 I = 1, M
WORK(I) = DSQRT(D(I))
30 CONTINUE
@ -271,21 +274,21 @@ C
IAN1(J) = IA1(J)
50 CONTINUE
40 CONTINUE
ELSE IF (UNITD .EQ. 'L') THEN
ELSE IF (toupper(UNITD) .EQ. 'L') THEN
DO 60 I = 1, M
DO 70 J = IA2(I), IA2(I+1)-1
AN(J) = D(I) * A(J)
IAN1(J) = IA1(J)
70 CONTINUE
60 CONTINUE
ELSE IF (UNITD .EQ. 'R') THEN
ELSE IF (toupper(UNITD) .EQ. 'R') THEN
DO 80 I = 1, M
DO 90 J = IA2(I), IA2(I+1)-1
AN(J) = A(J) * D(IA1(J))
IAN1(J) = IA1(J)
90 CONTINUE
80 CONTINUE
ELSE IF (UNITD .EQ. 'U') THEN
ELSE IF (toupper(UNITD) .EQ. 'U') THEN
DO 100 J = 1, IA2(M+1)-1
AN(J) = A(J)
IAN1(J) = IA1(J)

34
base/serial/dp/dcrjd.f
Unescape Escape View File

@ -61,6 +61,7 @@ C IAN2,INFON, IP1, IP2
C
use psb_const_mod
use psb_spmat_type
use psb_string_mod
IMPLICIT NONE
C
@ -69,9 +70,9 @@ C .. Scalar Arguments ..
* SIZE_REQ, IERROR
CHARACTER TRANS,UNITD
C .. Array Arguments ..
DOUBLE PRECISION AR(*), ARN(*), D(*), AUX(LAUX)
INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*),
* INFON(*), IP1(*), IP2(*)
DOUBLE PRECISION AR(*), ARN(LARN), D(*), AUX(LAUX)
INTEGER IA1(*), IA2(*), INFO(*), IAN1(LIAN1),
+ IAN2(LIAN2), INFON(*), IP1(*), IP2(*)
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER IOFF, ISTROW, NJA, NZ, PIA,
@ -103,10 +104,10 @@ C
GOTO 9999
ENDIF
IF (TRANS.EQ.'N') THEN
IF (toupper(TRANS).EQ.'N') THEN
C
NJA = 3*M
SCALE = (UNITD.EQ.'L') ! meaningless
SCALE = (toupper(UNITD).EQ.'L') ! meaningless
IOFF = 5
C
C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX
@ -115,7 +116,7 @@ C
PIA = PNG + 1
PJA = PIA + 3*(M+2)
IF (DESCRA(1:1).EQ.'G') THEN
IF (toupper(DESCRA(1:1)).EQ.'G') THEN
C
C CHECK ON DIMENSION OF IAN2 AND AUX
@ -169,10 +170,11 @@ C
ENDIF
LJA = LIAN2-PJA
CALL DGINDEX(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA),
+ IAN2(PJA), INFON, LARN,LIAN1,
+ LJA,IP1, AUX, LAUX*2, SIZE_REQ,IERROR)
CALL DGINDEX(M,IAN2(PNG),AR,IA1,IA2,info,
+ ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON,
+ LARN,LIAN1, LJA,IP1,
+ AUX, LAUX*2, SIZE_REQ,IERROR)
IF (IERROR.NE.0) THEN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
@ -182,7 +184,8 @@ C
DESCRN(2:2) = 'U'
DESCRN(3:3) = 'N'
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
C
ISTROW = 1
NZ = 2*(IA2(M+1)-1) - M
@ -218,13 +221,13 @@ c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2,
c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1),
c$$$ * AUX(IWORK2),NJA,IER,SCALE)
C
ELSE IF (DESCRA(1:1).EQ.'T') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'T') THEN
C
C Only unit diagonal so far for triangular matrices.
C
IF (DESCRA(3:3).NE.'U') THEN
IF (toupper(DESCRA(3:3)).NE.'U') THEN
IERROR=3022
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
@ -273,8 +276,7 @@ c$$$ write(0,*) "error 2",ierrv(1)
ENDIF
DESCRN(1:1) = 'T'
DESCRN(2:2) = DESCRA(2:2)
DESCRN(3:3) = DESCRA(3:3)
DESCRN(2:3) = toupper(DESCRA(2:3))
END IF
C
@ -288,7 +290,7 @@ C
LIAN2 = 3*M + 10
LAUX2 = 4*M + 2
C
ELSE IF (TRANS.NE.'N') THEN
ELSE IF (toupper(TRANS).NE.'N') THEN
C
C TO BE DONE
C

5
base/serial/dp/dcsrp1.f
Unescape Escape View File

@ -118,6 +118,7 @@ C
+ P,WORK,IWORK,LWORK,IERROR)
use psb_const_mod
use psb_spmat_type
use psb_string_mod
IMPLICIT NONE
C .. Scalar Arguments ..
INTEGER LWORK,M, N, IERROR
@ -140,14 +141,14 @@ C
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
IF(TRANS.EQ.'N') THEN
IF(toupper(TRANS).EQ.'N') THEN
DO 30 I=1,M
DO 10 J=IA(I),IA(I+1)-1
JA(J) = P(JA(J))
10 CONTINUE
30 CONTINUE
WORK(1) = 0.D0
ELSE IF(TRANS.EQ.'T') THEN
ELSE IF(toupper(TRANS).EQ.'T') THEN
C
C LWORK refers here to INTEGER IWORK (alias for WORK)
C

4
base/serial/dp/dcsrrp.f
Unescape Escape View File

@ -121,6 +121,7 @@ C
C
SUBROUTINE DCSRRP(TRANS,M,N,DESCRA,JA,IA,
+ P,WORK,LWORK,IERROR)
use psb_string_mod
IMPLICIT NONE
C .. Scalar Arguments ..
INTEGER LWORK, M, N, IERROR
@ -143,7 +144,8 @@ C
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
IF (DESCRA(1:1).EQ.'S' .OR. DESCRA(1:1).EQ.'T') THEN
IF (toupper(DESCRA(1:1)).EQ.'S' .OR.
+ toupper(DESCRA(1:1)).EQ.'T') THEN
IERROR=3023
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999

262
base/serial/dp/dgind_tri.f
Unescape Escape View File

@ -29,7 +29,7 @@ C POSSIBILITY OF SUCH DAMAGE.
C
C
SUBROUTINE DGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA,
+ LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR)
+ LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR)
use psb_const_mod
IMPLICIT NONE
@ -42,11 +42,11 @@ C ... Array arguments ...
DOUBLE PRECISION A(*), ARN(*), WORK(*)
INTEGER IA1(*), IA2(*), KA(*),
+ IA(3,*), IPERM(M), JA(*)
+ IA(3,*), IPERM(M), JA(*)
C .... Local scalars ...
INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA,
+ DIM_BLOCK, LIMIT, ERR_ACT
+ DIM_BLOCK, LIMIT, ERR_ACT
LOGICAL CSR
c .. Local Arrays ..
CHARACTER*20 NAME
@ -61,161 +61,161 @@ c .. Local Arrays ..
IERROR = 0
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 10
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
IERROR = 60
INT_VAL(1) = 10
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
C .... Invert Permutation Matrix...
IF (IPERM(1).NE.0) THEN
DO I = 1, M
WORK(IPERM(I)) = I
ENDDO
DO I = 1, M
WORK(IPERM(I)) = I
ENDDO
ENDIF
DO BLOCK = 1, N_BLOCKS
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 12
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(2,BLOCK) = POINT_JA
JA(POINT_JA) = POINT_AR
CSR = .FALSE.
IF (DIM_BLOCK.NE.0) THEN
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 12
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(2,BLOCK) = POINT_JA
JA(POINT_JA) = POINT_AR
CSR = .FALSE.
IF (DIM_BLOCK.NE.0) THEN
C ... If current block is not empty ...
C ... For each Column belonging to Block ...
DO WHILE(.TRUE.)
DO WHILE(.TRUE.)
C ... For each row belonging to the block BLOCK ...
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
C ... If the current row is too short ...
IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN
IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN
C ... Switch to CSR representation ...
IF (I.LE.IA(1,BLOCK)+LIMIT) THEN
CSR=.TRUE.
POINT_AR = POINT_AR - I + IA(1,BLOCK)
GOTO 998
ELSE
ARN(POINT_AR) = 0.D0
IF (I.LE.IA(1,BLOCK)+LIMIT) THEN
CSR=.TRUE.
POINT_AR = POINT_AR - I + IA(1,BLOCK)
GOTO 998
ELSE
ARN(POINT_AR) = 0.D0
C
C The following statement assumes that we never get here with POINT_AR=1
C
KA (POINT_AR) = KA(POINT_AR-1)
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 10
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDIF
ELSE
ARN(POINT_AR) = A(IA2(ROW)+COL-1)
KA (POINT_AR) = IPERM(IA1(IA2(ROW)+COL-1))
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 10
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
KA (POINT_AR) = KA(POINT_AR-1)
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 10
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDDO
ENDIF
ELSE
ARN(POINT_AR) = A(IA2(ROW)+COL-1)
KA (POINT_AR) = IPERM(IA1(IA2(ROW)+COL-1))
IF (CSR) GOTO 998
IF (LJA.LT.POINT_JA+COL) THEN
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 12
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
INT_VAL(1) = 10
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
JA(POINT_JA+COL) = POINT_AR
COL = COL+1
ENDIF
ENDIF
ENDDO
998 CONTINUE
ENDIF
IF (CSR) GOTO 998
POINT_JA = POINT_JA+COL-1
IF (LJA.LT.POINT_JA) THEN
IF (LJA.LT.POINT_JA+COL) THEN
IERROR = 60
INT_VAL(1) = 12
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
JA(POINT_JA+COL) = POINT_AR
COL = COL+1
ENDDO
998 CONTINUE
ENDIF
POINT_JA = POINT_JA+COL-1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 12
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(3,BLOCK) = POINT_JA
C ... Start CSR Format ...
C ... For each row belonging to the block BLOCK ...
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
C ... For each nnzero elements belonging to current row ...
DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1
ARN(POINT_AR) = A(J)
KA (POINT_AR) = IPERM(IA1(J))
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 10
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDDO
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 12
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(3,BLOCK) = POINT_JA
C ... Start CSR Format ...
C ... For each row belonging to the block BLOCK ...
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
C ... For each nnzero elements belonging to current row ...
DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1
ARN(POINT_AR) = A(J)
KA (POINT_AR) = IPERM(IA1(J))
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 10
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDDO
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 12
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
JA(POINT_JA) = POINT_AR
ENDDO
ENDIF
JA(POINT_JA) = POINT_AR
ENDDO
ENDDO
IA(2,N_BLOCKS+1) = POINT_JA
@ -227,8 +227,8 @@ C ... For each nnzero elements belonging to current row ...
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
IF ( ERR_ACT .NE. 0 ) THEN
CALL FCPSB_SERROR()
RETURN
CALL FCPSB_SERROR()
RETURN
ENDIF
RETURN

655
base/serial/dp/dgindex.f
Unescape Escape View File

@ -28,8 +28,8 @@ C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
SUBROUTINE DGINDEX(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, INFON,
+ LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR)
SUBROUTINE DGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON,
+ LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR)
use psb_const_mod
use psb_spmat_type
@ -37,18 +37,18 @@ C
C ... Scalar arguments ...
INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA,
+ SIZE_REQ,IERROR
+ SIZE_REQ,IERROR
C ... Array arguments ...
DOUBLE PRECISION A(*), ARN(*)
INTEGER IA1(*), IA2(*), KA(*),
+ IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*)
DOUBLE PRECISION A(*), ARN(LARN)
INTEGER IA1(*), IA2(*), KA(LKA),
+ IA(3,*), IPERM(*), JA(LJA), WORK(*),INFON(*), infoa(*)
C .... Local scalars ...
INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1,
+ IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG,
+ ERR_ACT
+ IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG,
+ ERR_ACT, ix, regen_flag
LOGICAL CSR
c .. Local Arrays ..
CHARACTER*20 NAME
@ -60,373 +60,390 @@ c .. Local Arrays ..
POINT_AR = 1
POINT_JA = 0
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
NNZ = IA2(M + 1) - 1
COUNT = 0
NNZ = IA2(M + 1) - 1
COUNT = 0
C .... Invert Permutation Matrix...
IF (IPERM(1).NE.0) THEN
DO I = 1, M
WORK(IPERM(I)) = I
ENDDO
DO I = 1, M
WORK(IPERM(I)) = I
ENDDO
ENDIF
IF ( (LKA .GE.( SIZE_REQ ))
+ .AND. (LWORK .GE. (M + NNZ+2))) THEN
size_Req=0
IF ( (regen_flag == psb_upd_perm_)
+ .AND. (LWORK .GE. (M + NNZ+2))) THEN
C
C Prepare for smart regeneration
C
IPW = M + 2
IP1 = (LKA-PSB_IREG_FLGS_-2)/2
IP2 = IP1+PSB_IREG_FLGS_
IPC = IP2 + NNZ + 1
KA(IP1 + PSB_IPC_) = IPC
KA(IP1+PSB_IP2_) = IP2
INFON(PSB_UPD_PNT_) = IP1
KA(IP1+PSB_IFLAG_) = CHECK_FLAG
KA(IP1+PSB_NNZT_) = NNZ
KA(IP1+PSB_NNZ_) = 0
KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG
I = M+2
IPX = IA2(I+PSB_IP2_)
IPW = M + 2
IP1 = (LKA-PSB_IREG_FLGS_-2)/2
IP2 = IP1+PSB_IREG_FLGS_
IPC = IP2 + NNZ + 1
KA(IP1 + PSB_IPC_) = IPC
KA(IP1+PSB_IP2_) = IP2
INFON(PSB_UPD_PNT_) = IP1
KA(IP1+PSB_IFLAG_) = CHECK_FLAG
KA(IP1+PSB_NNZT_) = NNZ
KA(IP1+PSB_NNZ_) = 0
KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG
if (infoa(psb_upd_pnt_) > 0) then
I = infoa(psb_upd_pnt_)
IPX = IA2(I+PSB_IP2_)
C Invert permutation for smart regeneration
DO I = 1, NNZ
DO I = 1, NNZ
WORK(IPW + IA2(IPX + I -1) - 1) = I
ENDDO
ENDDO
else
! No permutation available before, set identity.
DO I = 1, NNZ
WORK(IPW + I - 1) = I
ENDDO
endif
C Construct JAD matrix...
DO BLOCK = 1, N_BLOCKS
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
DO BLOCK = 1, N_BLOCKS
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
c$$$ write(0,*) 'DGINDEX: BLOCK LOOP ',block,n_blocks,dim_block
if (dim_block .gt. PSB_MAXJDROWS_) then
write(0,*) 'Wrong value for dim_block',block,
+ IA(1,BLOCK+1),IA(1,BLOCK)
return
endif
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(2,BLOCK) = POINT_JA
JA(POINT_JA) = POINT_AR
CSR = .FALSE.
IF (DIM_BLOCK.NE.0) THEN
if (dim_block .gt. PSB_MAXJDROWS_) then
write(0,*) 'Wrong value for dim_block',block,
+ IA(1,BLOCK+1),IA(1,BLOCK)
return
endif
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(2,BLOCK) = POINT_JA
JA(POINT_JA) = POINT_AR
CSR = .FALSE.
IF (DIM_BLOCK.NE.0) THEN
C ... If current block is not empty ...
C ... For each Column belonging to Block ...
DO WHILE(.TRUE.)
DO WHILE(.TRUE.)
C ... For each row belonging to the block BLOCK ...
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
C ... If the current row is too short ...
IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN
IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN
C ... Switch to CSR representation ...
IF (I.LE.IA(1,BLOCK)+LIMIT) THEN
CSR=.TRUE.
POINT_AR = POINT_AR - I + IA(1,BLOCK)
GOTO 998
ELSE
IF (I.LE.IA(1,BLOCK)+LIMIT) THEN
CSR=.TRUE.
POINT_AR = POINT_AR - I + IA(1,BLOCK)
GOTO 998
ELSE
COUNT = COUNT + 1
ARN(POINT_AR) = 0.D0
KA(POINT_AR) = KA(POINT_AR-1)
IF(POINT_AR.LT.IP1) THEN
KA(IPC + COUNT -1) = POINT_AR
ENDIF
COUNT = COUNT + 1
ARN(POINT_AR) = 0.D0
KA(POINT_AR) = KA(POINT_AR-1)
IF(POINT_AR.LT.IP1) THEN
KA(IPC + COUNT -1) = POINT_AR
ENDIF
C
C The following statement assumes that we never get here with POINT_AR=1
C
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDIF
ELSE
ARN(POINT_AR) = A(IA2(ROW)+COL-1)
KA(POINT_AR) = IA1(IA2(ROW)+COL-1)
IF(POINT_AR.LT.IP1) THEN
KA(IP2 + WORK(IPW +
+ IA2(ROW) +COL -1-1)-1) = POINT_AR
ENDIF
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDIF
ENDDO
IF (CSR) GOTO 998
IF (LJA.LT.POINT_JA+COL) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDIF
IF(IERROR.EQ.0) THEN
JA(POINT_JA+COL) = POINT_AR
ELSE
ARN(POINT_AR) = A(IA2(ROW)+COL-1)
KA(POINT_AR) = IA1(IA2(ROW)+COL-1)
IF(POINT_AR.LT.IP1) THEN
KA(IP2 + WORK(IPW +
+ IA2(ROW) +COL -1-1)-1) = POINT_AR
ENDIF
COL = COL+1
ENDDO
ENDIF
998 CONTINUE
POINT_JA = POINT_JA+COL-1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(3,BLOCK) = POINT_JA
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDIF
ENDDO
IF (CSR) GOTO 998
IF (LJA.LT.POINT_JA+COL) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IF(IERROR.EQ.0) THEN
JA(POINT_JA+COL) = POINT_AR
ENDIF
COL = COL+1
ENDDO
ENDIF
998 CONTINUE
POINT_JA = POINT_JA+COL-1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(3,BLOCK) = POINT_JA
C ... Start CSR Format ...
C ... For each row belonging to the block BLOCK ...
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
C ... For each nnzero elements belonging to current row ...
DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1
ARN(POINT_AR) = A(J)
KA (POINT_AR) = IA1(J)
IF (POINT_AR.LT.IP1) THEN
KA(IP2 + WORK(IPW + J-1)-1) = POINT_AR
ENDIF
DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1
ARN(POINT_AR) = A(J)
KA (POINT_AR) = IA1(J)
IF (POINT_AR.LT.IP1) THEN
KA(IP2 + WORK(IPW + J-1)-1) = POINT_AR
ENDIF
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDDO
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
JA(POINT_JA) = POINT_AR
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDDO
ENDDO
ELSE
c$$$ c write(*,*)'inizio a ciclare sui blocchi'
DO BLOCK = 1, N_BLOCKS
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(2,BLOCK) = POINT_JA
JA(POINT_JA) = POINT_AR
CSR = .FALSE.
IF (DIM_BLOCK.NE.0) THEN
ENDDO
ENDDO
IA(2,N_BLOCKS+1) = POINT_JA
KA(IP1 + PSB_ZERO_) = COUNT
IF (POINT_AR.GE.IP1) THEN
SIZE_REQ=NNZ+COUNT
ELSE
SIZE_REQ=0
ENDIF
ELSE
c$$$ c write(*,*)'inizio a ciclare sui blocchi'
IP1 = LKA - PSB_ZERO_
DO BLOCK = 1, N_BLOCKS
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
LIMIT = INT(DIM_BLOCK*PSB_PERCENT_)
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(2,BLOCK) = POINT_JA
JA(POINT_JA) = POINT_AR
CSR = .FALSE.
IF (DIM_BLOCK.NE.0) THEN
C ... If current block is not empty ...
C ... For each Column belonging to Block ...
DO WHILE(.TRUE.)
DO WHILE(.TRUE.)
C ... For each row belonging to the block BLOCK ...
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
C ... If the current row is too short ...
IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN
IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN
C ... Switch to CSR representation ...
IF (I.LE.IA(1,BLOCK)+LIMIT) THEN
CSR=.TRUE.
POINT_AR = POINT_AR - I + IA(1,BLOCK)
GOTO 999
ELSE
COUNT= COUNT+1
ARN(POINT_AR) = 0.D0
KA (POINT_AR) = KA(POINT_AR-1)
IF (I.LE.IA(1,BLOCK)+LIMIT) THEN
CSR=.TRUE.
POINT_AR = POINT_AR - I + IA(1,BLOCK)
GOTO 999
ELSE
COUNT= COUNT+1
ARN(POINT_AR) = 0.D0
KA (POINT_AR) = KA(POINT_AR-1)
C
C The following statement assumes that we never get here with POINT_AR=1
C
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDIF
ELSE
ARN(POINT_AR) = A(IA2(ROW)+COL-1)
KA (POINT_AR) = IA1(IA2(ROW)+COL-1)
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDIF
ENDDO
IF (CSR) GOTO 999
IF (LJA.LT.POINT_JA+COL) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDIF
JA(POINT_JA+COL) = POINT_AR
COL = COL+1
ENDDO
ENDIF
999 CONTINUE
POINT_JA = POINT_JA+COL-1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(3,BLOCK) = POINT_JA
ELSE
ARN(POINT_AR) = A(IA2(ROW)+COL-1)
KA (POINT_AR) = IA1(IA2(ROW)+COL-1)
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR))
+ THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDIF
ENDDO
IF (CSR) GOTO 999
IF (LJA.LT.POINT_JA+COL) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
JA(POINT_JA+COL) = POINT_AR
COL = COL+1
ENDDO
ENDIF
999 CONTINUE
POINT_JA = POINT_JA+COL-1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
IA(3,BLOCK) = POINT_JA
C ... Start CSR Format ...
C ... For each row belonging to the block BLOCK ...
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1
IF (IPERM(1).EQ.0) THEN
ROW = I
ELSE
ROW = WORK(I)
ENDIF
C ... For each nnzero elements belonging to current row ...
DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1
ARN(POINT_AR) = A(J)
KA (POINT_AR) = IA1(J)
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDDO
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
JA(POINT_JA) = POINT_AR
DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1
ARN(POINT_AR) = A(J)
KA (POINT_AR) = IA1(J)
POINT_AR = POINT_AR+1
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
INT_VAL(1) = 11
INT_VAL(2) = POINT_AR
INT_VAL(3) = LARN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
ENDDO
ENDDO
POINT_JA = POINT_JA+1
IF (LJA.LT.POINT_JA) THEN
IERROR = 60
INT_VAL(1) = 13
INT_VAL(2) = POINT_JA
INT_VAL(3) = LJA
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF
JA(POINT_JA) = POINT_AR
ENDDO
ENDDO
IA(2,N_BLOCKS+1) = POINT_JA
IF (POINT_AR.GE.lka) THEN
SIZE_REQ=NNZ+COUNT
ELSE
SIZE_REQ=0
ENDIF
ENDIF
IA(2,N_BLOCKS+1) = POINT_JA
KA(IP1 + PSB_ZERO_) = COUNT
IF(POINT_AR.GE.IP1) THEN
SIZE_REQ=NNZ+COUNT
ELSE
SIZE_REQ=0
ENDIF
infon(1)=point_ar-1
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
@ -436,8 +453,8 @@ C ... For each nnzero elements belonging to current row ...
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
IF ( ERR_ACT .NE. 0 ) THEN
CALL FCPSB_SERROR()
RETURN
CALL FCPSB_SERROR()
RETURN
ENDIF
RETURN

3
base/serial/dp/djadrp.f
Unescape Escape View File

@ -116,6 +116,7 @@ C
C
SUBROUTINE DJADRP(TRANS,M,N,DESCRA,JA,IA,
+ P,WORK,LWORK,IERROR)
use psb_string_mod
IMPLICIT NONE
C .. Scalar Arguments ..
INTEGER LWORK, M, N, IERROR
@ -146,7 +147,7 @@ C
PIA = PNG + 1
PJA = PIA + 3*(IA(PNG)+1)
IF (DESCRA(1:1).EQ.'G') THEN
IF (toupper(DESCRA(1:1)).EQ.'G') THEN
CALL DJADRP1(TRANS,M,N,DESCRA,IA(PNG),
+ JA,IA(PIA),IA(PJA),P,WORK,LWORK*2)
ELSE

5
base/serial/dp/djadrp1.f
Unescape Escape View File

@ -102,6 +102,7 @@ C
C
SUBROUTINE DJADRP1(TRANS,M,N,DESCRA,NG,KA,IA,JA,
+ P,IWORK,LWORK,IERROR)
use psb_string_mod
IMPLICIT NONE
C .. Scalar Arguments ..
INTEGER LWORK,M, N, NG, IERROR
@ -125,7 +126,7 @@ C
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
IF(TRANS.EQ.'N') THEN
IF(toupper(TRANS).EQ.'N') THEN
IF (DEBUG) WRITE(0,*)'DJADRP1:',NG
DO IPG = 1, NG
DO K = IA(2,IPG), IA(3,IPG)-1
@ -143,7 +144,7 @@ C Permute CSR
ENDDO
IWORK(1) = 0
ELSE IF(TRANS.EQ.'T') THEN
ELSE IF(toupper(TRANS).EQ.'T') THEN
C
C LWORK refers here to INTEGER IWORK (alias for WORK)
C

208
base/serial/dp/djdcox.f
Unescape Escape View File

@ -33,10 +33,11 @@ C
C Covert matrix from JAD format to COO Format
C
SUBROUTINE DJDCOX(TRANS,M,N,DESCRA,AR,IA,JA,KA,NG,IPERM,INFO,
* IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N,
* LIA2N,AUX,LAUX,IERROR)
* IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N,
* LIA2N,AUX,LAUX,IERROR)
use psb_const_mod
use psb_string_mod
IMPLICIT NONE
C
@ -47,11 +48,11 @@ C .. Array Arguments ..
DOUBLE PRECISION AR(*), ARN(*)
INTEGER AUX(0:LAUX/2-1),IPERM(*)
INTEGER IA(3,*), JA(*), KA(*), INFO(*), IA1N(*),
* IA2N(*), INFON(*), IP1(*), IP2(*)
* IA2N(*), INFON(*), IP1(*), IP2(*)
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER IPX, IPG, NNZ, K, ROW,
* I, J, NZL, IRET, ERR_ACT
* I, J, NZL, IRET, ERR_ACT
LOGICAL SCALE
logical debug
parameter (debug=.false.)
@ -66,110 +67,115 @@ C
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
IF (TRANS.EQ.'N') THEN
IF (toupper(TRANS).EQ.'N') THEN
C SCALE = (UNITD.EQ.'L') ! meaningless
IP1(1) = 0
IP2(1) = 0
IF (IPERM(1).NE.0) THEN
DO I = 1, M
AUX(IPERM(I)) = I
ENDDO
ENDIF
NNZ = JA(IA(2,NG+1)-1 +1)-1
if (debug) then
write(0,*) 'On entry to DJDCOX: NNZ LAUX ',
+ nnz,laux,larn,lia1n,lia2n
endif
IF (LAUX.LT.NNZ+2) THEN
IERROR = 60
INT_VAL(1) = 23
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LARN.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 19
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LIA1N.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 20
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LIA2N.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 21
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ENDIF
IF (DESCRA(1:1).EQ.'G') THEN
DO 200 IPG = 1, NG
DO 50 K = IA(2,IPG), IA(3,IPG)-1
IPX = IA(1,IPG)
DO 40 I = JA(K), JA(K+1) - 1
ARN(I) = AR(I)
IA1N(I) = AUX(IPX)
IA2N(I) = KA(I)
IPX = IPX + 1
40 CONTINUE
50 CONTINUE
IPX = IA(1,IPG)
DO 70 K = IA(3,IPG), IA(2,IPG+1)-1
DO 60 I = JA(K), JA(K+1) - 1
ARN(I) = AR(I)
IA1N(I) = AUX(IPX)
IA2N(I) = KA(I)
60 CONTINUE
IPX = IPX + 1
70 CONTINUE
200 CONTINUE
IP1(1) = 0
IP2(1) = 0
IF (IPERM(1).NE.0) THEN
DO I = 1, M
AUX(IPERM(I)) = I
ENDDO
ENDIF
NNZ = JA(IA(2,NG+1)-1 +1)-1
if (debug) then
write(0,*) 'On entry to DJDCOX: NNZ LAUX ',
+ nnz,laux,larn,lia1n,lia2n
endif
IF (LAUX.LT.NNZ+2) THEN
IERROR = 60
INT_VAL(1) = 23
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LARN.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 19
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LIA1N.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 20
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ELSE IF (LIA2N.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 21
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
ENDIF
IF (toupper(DESCRA(1:1)).EQ.'G') THEN
DO 200 IPG = 1, NG
DO 50 K = IA(2,IPG), IA(3,IPG)-1
IPX = IA(1,IPG)
DO 40 I = JA(K), JA(K+1) - 1
ARN(I) = AR(I)
IA1N(I) = AUX(IPX)
IA2N(I) = KA(I)
IPX = IPX + 1
40 CONTINUE
50 CONTINUE
IPX = IA(1,IPG)
DO 70 K = IA(3,IPG), IA(2,IPG+1)-1
DO 60 I = JA(K), JA(K+1) - 1
ARN(I) = AR(I)
IA1N(I) = AUX(IPX)
IA2N(I) = KA(I)
60 CONTINUE
IPX = IPX + 1
70 CONTINUE
200 CONTINUE
C .... Order with key IA1N....
CALL MSORT_UP(NNZ,IA1N,AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NNZ,ARN,IA1N,IA2N,AUX)
CALL MSORT_UP(NNZ,IA1N,AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NNZ,ARN,IA1N,IA2N,AUX)
C .... Order with key IA2N ...
I = 1
J = I
DO WHILE (I.LE.NNZ)
DO WHILE ((IA1N(J).EQ.IA1N(I)).AND.
+ (J.LE.NNZ))
J = J+1
ENDDO
NZL = J - I
CALL MSORT_UP(NZL,IA2N(I),AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NZL,ARN(I),IA1N(I),IA2N(I),
+ AUX)
I = J
I = 1
J = I
DO WHILE (I.LE.NNZ)
DO WHILE ((IA1N(J).EQ.IA1N(I)).AND.
+ (J.LE.NNZ))
J = J+1
ENDDO
INFON(1)=nnz
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
DO 20 K = 1, M
IP2(K) = K
20 CONTINUE
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
END IF
NZL = J - I
CALL MSORT_UP(NZL,IA2N(I),AUX,IRET)
IF (IRET.EQ.0) CALL REORDVN(NZL,ARN(I),IA1N(I),IA2N(I),
+ AUX)
I = J
ENDDO
INFON(1)=nnz
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
DO 20 K = 1, M
IP2(K) = K
20 CONTINUE
c$$$ ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
c$$$
c$$$ ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
else
IERROR = 3021
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
END IF
C
ELSE IF (TRANS.NE.'N') THEN
ELSE IF (toupper(TRANS).NE.'N') THEN
C
C TO DO
C
IERROR = 3021
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
IERROR = 3021
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
END IF
@ -181,8 +187,8 @@ C
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
IF ( ERR_ACT .NE. 0 ) THEN
CALL FCPSB_SERROR()
RETURN
CALL FCPSB_SERROR()
RETURN
ENDIF
RETURN

158
base/serial/dp/dvtfg.f
Unescape Escape View File

@ -32,13 +32,15 @@ C
C Compute level numbers for the triangular matrix.
C
SUBROUTINE DVTFG (UPLO,M,JA,IA,NG,IPA,IPAT,KLEN,IWORK1,IWORK2,
* IWORK3)
* IWORK3)
use psb_string_mod
implicit none
C .. Scalar Arguments ..
INTEGER M, NG
CHARACTER UPLO
C .. Array Arguments ..
INTEGER IA(*), IPA(*), IPAT(*), IWORK3(*), JA(*),
* KLEN(*), IWORK2(*), IWORK1(*)
* KLEN(*), IWORK2(*), IWORK1(*)
C .. Local Scalars ..
INTEGER I, J, L, L0, L1, LEV, NP, iret
C .. Intrinsic Functions ..
@ -56,11 +58,11 @@ C
C THE MATRIX HASN'T ELEMENTS
C THE OUTPUT PERMUTATIONS ARE POSED TO THE IDENTITY MATRIX
C
DO 20 I = 1, M
IPA(I) = I
IPAT(I) = I
KLEN(I) = 0
20 CONTINUE
DO 20 I = 1, M
IPA(I) = I
IPAT(I) = I
KLEN(I) = 0
20 CONTINUE
ELSE
C
C COMPUTE LEVEL NUMBER FOR EACH ROWS
@ -68,31 +70,31 @@ C
C IWORK1: AUXILIARY VECTOR WHICH CONTAINS
C LEVEL NUMBERS OF EACH ROW
C
DO 40 I = 1, M
IWORK1(I) = 0
IWORK3(I) = 0
40 CONTINUE
IF (UPLO.EQ.'L') THEN
DO 40 I = 1, M
IWORK1(I) = 0
IWORK3(I) = 0
40 CONTINUE
IF (toupper(UPLO).EQ.'L') THEN
C
C LOWER TRIANGULAR SPARSE MATRIX
C
DO 80 I = 1, M
IWORK1(I) = 1
DO 60 J = IA(I), IA(I+1) - 1
IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1)
60 CONTINUE
80 CONTINUE
ELSE IF (UPLO.EQ.'U') THEN
DO 80 I = 1, M
IWORK1(I) = 1
DO 60 J = IA(I), IA(I+1) - 1
IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1)
60 CONTINUE
80 CONTINUE
ELSE IF (toupper(UPLO).EQ.'U') THEN
C
C UPPER TRIANGULAR SPARSE MATRIX
C
DO 120 I = M, 1, -1
IWORK1(I) = 1
DO 100 J = IA(I), IA(I+1) - 1
IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1)
100 CONTINUE
120 CONTINUE
END IF
DO 120 I = M, 1, -1
IWORK1(I) = 1
DO 100 J = IA(I), IA(I+1) - 1
IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1)
100 CONTINUE
120 CONTINUE
END IF
C
C COUNT NUMBER OF ROWS IN EACH EQUIVALENCE GROUPS
C
@ -101,44 +103,44 @@ C
C IWORK3: AUXILIARY VECTOR WHICH CONTAINS
C THE NUMBER OF ROWS FOR EACH GROUPS
C
DO 140 I = 1, M
IWORK3(IWORK1(I)) = IWORK3(IWORK1(I)) + 1
140 CONTINUE
DO 140 I = 1, M
IWORK3(IWORK1(I)) = IWORK3(IWORK1(I)) + 1
140 CONTINUE
C
C SET UP IWORK2:
C IWORK2(I) POINTS TO THE BEGINNING OF I-TH GROUP
C
IWORK2(1) = 1
DO 160 I = 2, M + 1
IWORK2(I) = IWORK3(I-1) + IWORK2(I-1)
IF (IWORK2(I).EQ.M+1) THEN
NG = I - 1
GO TO 180
END IF
160 CONTINUE
180 CONTINUE
IWORK2(1) = 1
DO 160 I = 2, M + 1
IWORK2(I) = IWORK3(I-1) + IWORK2(I-1)
IF (IWORK2(I).EQ.M+1) THEN
NG = I - 1
GO TO 180
END IF
160 CONTINUE
180 CONTINUE
C
C NG : TOTAL NUMBER OF LEVELS
C IWORK3: VECTOR CONTAINING THE NUMBER OF THE ROWS SORTED BY
C EQUIVALENCE GROUPS.
C
DO 200 I = 1, M
IWORK3(IWORK2(IWORK1(I))) = I
IWORK2(IWORK1(I)) = IWORK2(IWORK1(I)) + 1
200 CONTINUE
DO 200 I = 1, M
IWORK3(IWORK2(IWORK1(I))) = I
IWORK2(IWORK1(I)) = IWORK2(IWORK1(I)) + 1
200 CONTINUE
C
C REGENERATE IWORK2: POINTER INTO IWORK3 FOR EQUIVALENCE GROUPS
C
DO 220 I = NG + 1, 2, -1
IWORK2(I) = IWORK2(I-1)
220 CONTINUE
IWORK2(1) = 1
DO 220 I = NG + 1, 2, -1
IWORK2(I) = IWORK2(I-1)
220 CONTINUE
IWORK2(1) = 1
C
C IWORK1: ROWS LENGTH IN NEW ORDERING
C
DO 240 L = 1, M
IWORK1(L) = IA(IWORK3(L)) - IA(IWORK3(L)+1)
240 CONTINUE
DO 240 L = 1, M
IWORK1(L) = IA(IWORK3(L)) - IA(IWORK3(L)+1)
240 CONTINUE
C
C SORT ROWS BY DECREASING NUMBER OF NONZERO ELEMENTS.
C
@ -146,49 +148,49 @@ C IPA: VECTOR OF NUMBER OF ROWS SORTED BY EQUIVALENCE
C GROUPS AND BY ROW LENGTH
C IPAT: AUXILIARY VECTOR NEED TO THE SORTER ROUTINES
C
L1 = IWORK2(2) - IWORK2(1)
DO 260 L = 1, L1
IPA(L) = IWORK3(L)
260 CONTINUE
if (debug) write(0,*) 'DVTFG: Group ',1,':',(ipa(l),l=1,l1)
DO 360 LEV = 2, NG
L1 = IWORK2(2) - IWORK2(1)
DO 260 L = 1, L1
IPA(L) = IWORK3(L)
260 CONTINUE
if (debug) write(0,*) 'DVTFG: Group ',1,':',(ipa(l),l=1,l1)
DO 360 LEV = 2, NG
C
C LOOP ON GROUPS
C L1: LENGTH OF CURRENT GROUP
C L0: POINTER TO IPA TO THE FIRST LOCATIONS RESERVED
C FOR CURRENT GROUP
C
L1 = IWORK2(LEV+1) - IWORK2(LEV)
L0 = IWORK2(LEV) - 1
CALL MSORT_UP(L1,IWORK1(IWORK2(LEV)),IPAT,IRET)
IF (IRET.EQ.0) THEN
NP = IPAT(1)
DO 280 L = 1, L1
IPA(L0+L) = IWORK3(L0+NP)
NP = IPAT(1+NP)
280 CONTINUE
ELSE
L1 = IWORK2(LEV+1) - IWORK2(LEV)
L0 = IWORK2(LEV) - 1
CALL MSORT_UP(L1,IWORK1(IWORK2(LEV)),IPAT,IRET)
IF (IRET.EQ.0) THEN
NP = IPAT(1)
DO 280 L = 1, L1
IPA(L0+L) = IWORK3(L0+NP)
NP = IPAT(1+NP)
280 CONTINUE
ELSE
C
C VECTOR ALREADY SORTED. NO CHANGE IS NEED
C
DO 320 L = 1, L1
IPA(L0+L) = IWORK3(L0+L)
320 CONTINUE
ENDIF
if (debug) write(0,*) 'DVTFG: Group ',lev,
+ ':',(ipa(l0+l),l=1,l1)
360 CONTINUE
DO 320 L = 1, L1
IPA(L0+L) = IWORK3(L0+L)
320 CONTINUE
ENDIF
if (debug) write(0,*) 'DVTFG: Group ',lev,
+ ':',(ipa(l0+l),l=1,l1)
360 CONTINUE
C
C IPAT = IPA-1
C
DO 380 I = 1, M
IPAT(IPA(I)) = I
380 CONTINUE
DO 380 I = 1, M
IPAT(IPA(I)) = I
380 CONTINUE
C DO 400 I = 1, NG
C KLEN(I) = IWORK2(I+1) - IWORK2(I)
DO 400 I = 1, NG+1
KLEN(I) = IWORK2(I)
400 CONTINUE
DO 400 I = 1, NG+1
KLEN(I) = IWORK2(I)
400 CONTINUE
END IF
RETURN
END

18
base/serial/dp/zcoco.f
Unescape Escape View File

@ -36,6 +36,7 @@ c
use psb_const_mod
use psb_spmat_type
use psb_string_mod
implicit none
c .. scalar arguments ..
@ -73,8 +74,8 @@ c
call fcpsb_erractionsave(err_act)
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
if (trans.eq.'N') then
scale = (unitd.eq.'L') ! meaningless
if (toupper(trans).eq.'N') then
scale = (toupper(unitd).eq.'L') ! meaningless
p1(1) = 0
p2(1) = 0
@ -113,7 +114,7 @@ c
goto 9999
end if
if (descra(1:1).eq.'G') then
if (toupper(descra(1:1)).eq.'G') then
c
c sort COO data structure
c
@ -245,26 +246,29 @@ c ... sum the duplicated element ...
if (debug) write(*,*)'done rebuild COO',infon(1)
else if (descra(1:1).eq.'S' .and. descra(2:2).eq.'U') then
else if (toupper(descra(1:1)).eq.'S' .and.
+ toupper(descra(2:2)).eq.'U') then
do 20 k = 1, m
p2(k) = k
20 continue
else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'U') then
else if (toupper(descra(1:1)).eq.'T' .and.
+ toupper(descra(2:2)).eq.'U') then
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (descra(1:1).eq.'T' .and. descra(2:2).eq.'L') then
else if (toupper(descra(1:1)).eq.'T' .and.
+ toupper(descra(2:2)).eq.'L') then
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
end if
c
else if (trans.ne.'N') then
else if (toupper(trans).ne.'N') then
c
c to do
c

692
base/serial/dp/zcocr.f
Unescape Escape View File

@ -37,6 +37,7 @@ C
use psb_const_mod
use psb_spmat_type
use psb_string_mod
IMPLICIT NONE
C
@ -51,16 +52,17 @@ C .. Array Arguments ..
* INFON(*), P1(*), P2(*)
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER NNZ, K, ROW, I, J, NZL, IRET
integer ipx, ip1, ip2, CHECK_FLAG, err_act
INTEGER ELEM, ELEM_CSR
LOGICAL SCALE
INTEGER MAX_NNZERO
integer nnz, k, row, i, j, nzl, iret
integer ipx, ip1, ip2, check_flag, err_act
integer elem, elem_csr,regen_flag
logical scale
integer max_nnzero
logical debug
parameter (debug=.false.)
c .. Local Arrays ..
CHARACTER*20 NAME
INTEGER INT_VAL(5)
integer, allocatable :: itmp(:)
c .. local arrays ..
character*20 name
integer int_val(5)
C
C ...Common variables...
@ -75,14 +77,15 @@ C
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
IF ((TRANS.EQ.'N').or.(TRANS.EQ.'n')) THEN
IF (toupper(TRANS).EQ.'N') THEN
SCALE = (UNITD.EQ.'L') ! meaningless
SCALE = (toupper(UNITD).EQ.'L') ! meaningless
P1(1) = 0
P2(1) = 0
NNZ = INFO(1)
nnz = info(1)
if (debug) then
write(0,*) 'On entry to ZCOCR: NNZ LAUX ',
+ nnz,laux,larn,lian1,lian2
@ -95,18 +98,18 @@ C
ELSE IF (LARN.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 18
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
INT_VAL(2) = NNZ
INT_VAL(3) = LARN
ELSE IF (LIAN1.LT.NNZ) THEN
IERROR = 60
INT_VAL(1) = 19
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
INT_VAL(2) = NNZ
INT_VAL(3) = LIAN1
ELSE IF (LIAN2.LT.M+1) THEN
IERROR = 60
INT_VAL(1) = 20
INT_VAL(2) = NNZ+2
INT_VAL(3) = LAUX
INT_VAL(2) = M+1
INT_VAL(3) = LIAN2
ENDIF
C
@ -117,25 +120,32 @@ C
GOTO 9999
END IF
IF (DESCRA(1:1).EQ.'G') THEN
allocate(itmp(nnz),stat=iret)
if (iret /= 0) then
call fcpsb_errpush(4010,name,int_val)
goto 9999
end if
do k=1, nnz
arn(k) = ar(k)
ian1(k) = ja(k)
itmp(k) = ia(k)
enddo
IF (toupper(descra(1:1)).EQ.'G') THEN
C
C Sort COO data structure
C
if (debug) write(0,*)'First sort',nnz
c$$$ if (debug) then
c$$$ do k=1,nnz
c$$$ write(*,*) k,ia(k),ja(k),ar(k)
c$$$ enddo
c$$$ endif
c$$$ write(0,*) 'ZCOCR Sizes ',lian2,((m+1)+nnz+psb_ireg_flgs_+1),
c$$$ + m+1,nnz,psb_ireg_flgs_,
c$$$ + laux,2*(2+nnz)
if ((lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
if ((regen_flag==psb_upd_perm_).and.
+ (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
+ .and.(laux.ge.2*(2+nnz))) then
C
C Prepare for smart regeneration
c
ipx = nnz+3
do i=1, nnz
aux(ipx+i-1) = i
@ -157,371 +167,331 @@ c$$$ + ip1,ip2,nnz,ian2(ip1+nnzt_)
if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_)
C .... Order with key IA ...
CALL MSORT_UP(NNZ,IA,AUX,IRET)
IF (IRET.EQ.0) CALL ZREORDVN3(NNZ,AR,IA,JA,AUX(IPX),AUX)
call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0)
+ call zreordvn3(nnz,arn,itmp,ian1,aux(ipx),aux)
if (debug) then
do i=1, nnz-1
if (ia(i).gt.ia(i+1)) then
write(0,*) 'Sorting error:',i,ia(i),ia(i+1)
if (itmp(i).gt.itmp(i+1)) then
write(0,*) 'Sorting error:',i,itmp(i),itmp(i+1)
endif
enddo
write(0,*) 'nnz :',m,nnz,ia(nnz),ja(nnz)
write(0,*) 'nnz :',m,nnz,itmp(nnz),ian1(nnz)
endif
C .... Order with key IA2N ...
C .... Order with key JA ...
I = 1
J = I
c$$$ DO WHILE (I.LE.NNZ)
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
c$$$ + (J.LE.NNZ))
DO
if (I>NNZ) exit
DO
do
if (i>nnz) exit
do
if (j>nnz) exit
if (ia(j) /= ia(i)) exit
J = J+1
ENDDO
NZL = J - I
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
IF (IRET.EQ.0) CALL ZREORDVN3(NZL,AR(I),IA(I),JA(I),
+ AUX(IPX+I-1),AUX)
I = J
ENDDO
if (itmp(j) /= itmp(i)) exit
j = j+1
enddo
nzl = j - i
call msort_up(nzl,ian1(i),aux,iret)
if (iret.eq.0) call zreordvn3(nzl,arn(i),itmp(i),ian1(i),
+ aux(ipx+i-1),aux)
i = j
enddo
C ... Construct CSR Representation...
ELEM = 1
ELEM_CSR = 1
C ... Insert first element ...
DO ROW = 1, IA(1)
IAN2(ROW) = 1
ENDDO
c ... Construct CSR Representation...
elem = 1
elem_csr = 1
c ... Insert first element ...
do row = 1, itmp(1)
ian2(row) = 1
enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
ELEM = ELEM+1
ELEM_CSR = ELEM_CSR+1
C ... Insert remaining element ...
DO ROW = IA(1), M
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
DO
elem = elem+1
elem_csr = elem_csr+1
c ... insert remaining element ...
do row = itmp(1), m
do
if (elem > nnz) exit
if (ia(elem) /= row) exit
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
C ... Insert first element of a row ...
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
if (itmp(elem) /= row) exit
if (itmp(elem).ne.itmp(elem-1)) then
c ... insert first element of a row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
ELEM_CSR = ELEM_CSR+1
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
C ... Insert other element of row ...
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
elem_csr = elem_csr+1
else if (ian1(elem).ne.ian1(elem-1)) then
c ... insert other element of row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
ELEM_CSR = ELEM_CSR+1
ELSE
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ...
ARN(ELEM_CSR-1) = AR(ELEM)
elem_csr = elem_csr+1
else
if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
if (debug) write(0,*) 'duplicated overwrite perm ',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
END IF
ENDIF
ELEM = ELEM + 1
ENDDO
IAN2(ROW+1) = ELEM_CSR
ENDDO
ELSE
c$$$ write(0,*) 'Going for ELSE !!!?'
if (debug) write(0,*) 'duplicated add perm ',
+ elem_csr-1,elem
end if
endif
elem = elem + 1
enddo
ian2(row+1) = elem_csr
enddo
else
C .... Order with key IA ...
CALL MSORT_UP(NNZ,IA,AUX,IRET)
IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX)
C .... Order with key IA2N ...
I = 1
J = I
c$$$ DO WHILE (I.LE.NNZ)
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
c$$$ + (J.LE.NNZ))
DO
if (I>NNZ) exit
DO
call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux)
C .... Order with key JA ...
i = 1
j = i
do
if (i>nnz) exit
do
if (j>nnz) exit
if (ia(j) /= ia(i)) exit
J = J+1
ENDDO
NZL = J - I
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX)
I = J
ENDDO
if (itmp(j) /= itmp(i)) exit
j = j+1
enddo
nzl = j - i
call msort_up(nzl,ian1(i),aux,iret)
if (iret.eq.0)
+ call zreordvn(nzl,arn(i),itmp(i),ian1(i),aux)
i = j
enddo
C ... Construct CSR Representation...
ELEM = 1
ELEM_CSR = 1
elem = 1
elem_csr = 1
C ... Insert first element ...
DO ROW = 1, IA(1)
IAN2(ROW) = 1
ENDDO
do row = 1, itmp(1)
ian2(row) = 1
enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM = ELEM+1
ELEM_CSR = ELEM_CSR+1
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem = elem+1
elem_csr = elem_csr+1
C ... Insert remaining element ...
DO ROW = IA(1), M
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
DO
do row = itmp(1), m
do
if (elem > nnz) exit
if (ia(elem) /= row) exit
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
C ... Insert first element of a row ...
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
if (itmp(elem) /= row) exit
if (itmp(elem).ne.itmp(elem-1)) then
c ... insert first element of a row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else if (ian1(elem).ne.ian1(elem-1)) then
C ... Insert other element of row ...
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ELSE
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ...
ARN(ELEM_CSR-1) = AR(ELEM)
if (debug) write(0,*) 'Duplicated overwrite',
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else
if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ...
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
if (debug) write(0,*) 'Duplicated add',
else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
END IF
ENDIF
ELEM = ELEM + 1
ENDDO
IAN2(ROW+1) = ELEM_CSR
ENDDO
ENDIF
end if
endif
elem = elem + 1
enddo
ian2(row+1) = elem_csr
enddo
endif
if (debug) write(0,*)'Done Rebuild CSR',
+ ian2(m+1),ia(elem)
if (debug) then
do i=ian2(m+1), nnz
write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
enddo
endif
c$$$ if (debug) then
c$$$ do i=ian2(m+1), nnz
c$$$ write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
c$$$ enddo
c$$$ endif
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
DO 20 K = 1, M
P2(K) = K
20 CONTINUE
do 20 k = 1, m
p2(k) = k
20 continue
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
else if (toupper(DESCRA(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux)
C .... Order with key JA ...
i = 1
j = i
do
if (i>nnz) exit
do
if (j>nnz) exit
if (itmp(j) /= itmp(i)) exit
j = j+1
enddo
nzl = j - i
call msort_up(nzl,ian1(i),aux,iret)
if (iret.eq.0)
+ call zreordvn(nzl,arn(i),itmp(i),ian1(i),aux)
i = j
enddo
C .... Order with key IA ...
CALL MSORT_UP(NNZ,IA,AUX,IRET)
IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX)
C .... Order with key IA2N ...
I = 1
J = I
c$$$ DO WHILE (I.LE.NNZ)
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
c$$$ + (J.LE.NNZ))
DO
if (I>NNZ) exit
DO
if (j>nnz) exit
if (ia(j) /= ia(i)) exit
J = J+1
ENDDO
NZL = J - I
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX)
I = J
ENDDO
C ... Construct CSR Representation...
ELEM = 1
ELEM_CSR = 1
elem = 1
elem_csr = 1
C ... Insert first element ...
DO ROW = 1, IA(1)
IAN2(ROW) = 1
ENDDO
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
IF(JA(ELEM).GT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELEM = ELEM+1
do row = 1, itmp(1)
ian2(row) = 1
enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem = elem+1
elem_csr = elem_csr+1
C ... Insert remaining element ...
DO ROW = IA(1), M
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
DO
if (elem > nnz) exit
if (ia(elem) /= row) exit
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
C ... Insert first element of a row ...
IF(JA(ELEM).GT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
C ... Insert other element of row ...
IF(JA(ELEM).GT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELSE
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ...
IF(JA(ELEM).GT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = AR(ELEM)
ENDIF
if (debug) write(0,*) 'Duplicated overwrite',
+ elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ...
IF(JA(ELEM).GT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
ENDIF
if (debug) write(0,*) 'Duplicated add',
+ elem_csr-1,elem
END IF
ENDIF
ELEM = ELEM + 1
ENDDO
IAN2(ROW+1) = ELEM_CSR
ENDDO
if (debug) write(0,*)'Done Rebuild CSR',
+ ian2(m+1),ia(elem)
if (debug) then
do i=ian2(m+1), nnz
write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
do row = itmp(1), m
do
if (elem > nnz) exit
if (itmp(elem) /= row) exit
if (itmp(elem).ne.itmp(elem-1)) then
c ... insert first element of a row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else if (ian1(elem).ne.ian1(elem-1)) then
C ... Insert other element of row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else
if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if
endif
elem = elem + 1
enddo
ian2(row+1) = elem_csr
enddo
endif
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
else if (toupper(descra(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'L') THEN
call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux)
C .... Order with key JA ...
i = 1
j = i
do
if (i>nnz) exit
do
if (j>nnz) exit
if (itmp(j) /= itmp(i)) exit
j = j+1
enddo
nzl = j - i
call msort_up(nzl,ian1(i),aux,iret)
if (iret.eq.0)
+ call zreordvn(nzl,arn(i),itmp(i),ian1(i),aux)
i = j
enddo
C .... Order with key IA ...
CALL MSORT_UP(NNZ,IA,AUX,IRET)
IF (IRET.EQ.0) CALL ZREORDVN(NNZ,AR,IA,JA,AUX)
C .... Order with key IA2N ...
I = 1
J = I
c$$$ DO WHILE (I.LE.NNZ)
c$$$ DO WHILE ((IA(J).EQ.IA(I)).AND.
c$$$ + (J.LE.NNZ))
DO
if (I>NNZ) exit
DO
if (j>nnz) exit
if (ia(j) /= ia(i)) exit
J = J+1
ENDDO
NZL = J - I
CALL MSORT_UP(NZL,JA(I),AUX,IRET)
IF (IRET.EQ.0) CALL ZREORDVN(NZL,AR(I),IA(I),JA(I),AUX)
I = J
ENDDO
C ... Construct CSR Representation...
ELEM = 1
ELEM_CSR = 1
elem = 1
elem_csr = 1
C ... Insert first element ...
DO ROW = 1, IA(1)
IAN2(ROW) = 1
ENDDO
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
IF(JA(ELEM).LT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELEM = ELEM+1
do row = 1, itmp(1)
ian2(row) = 1
enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem = elem+1
elem_csr = elem_csr+1
C ... Insert remaining element ...
do row = itmp(1), m
do
if (elem > nnz) exit
if (itmp(elem) /= row) exit
if (itmp(elem).ne.itmp(elem-1)) then
c ... insert first element of a row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else if (ian1(elem).ne.ian1(elem-1)) then
C ... Insert other element of row ...
ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem)
elem_csr = elem_csr+1
else
if (check_flag.eq.psb_dupl_err_) then
c ... error, there are duplicated elements ...
ierror = 130
call fcpsb_errpush(ierror,name,int_val)
goto 9999
else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if
endif
elem = elem + 1
enddo
ian2(row+1) = elem_csr
enddo
C ... Insert remaining element ...
DO ROW = IA(1), M
c$$$ if (debug) write(*,*)'CSR Loop:',row,m,elem_csr
c$$$ DO WHILE ((IA(ELEM).EQ.ROW).AND.(ELEM.LE.NNZ))
DO
if (elem > nnz) exit
if (ia(elem) /= row) exit
IF (IA(ELEM).NE.IA(ELEM-1)) THEN
C ... Insert first element of a row ...
IF(JA(ELEM).LT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELSE IF (JA(ELEM).NE.JA(ELEM-1)) THEN
C ... Insert other element of row ...
IF(JA(ELEM).LT.IA(ELEM)) THEN
IAN1(ELEM_CSR) = JA(ELEM)
ARN(ELEM_CSR) = AR(ELEM)
ELEM_CSR = ELEM_CSR+1
ENDIF
ELSE
IF (CHECK_FLAG.EQ.psb_dupl_err_) THEN
C ... Error, there are duplicated elements ...
IERROR = 130
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ELSE IF (CHECK_FLAG.EQ.psb_dupl_ovwrt_) THEN
C ... Insert only the last duplicated element ...
IF(JA(ELEM).LT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = AR(ELEM)
ENDIF
if (debug) write(0,*) 'Duplicated overwrite',
+ elem_csr-1,elem
ELSE IF (CHECK_FLAG.EQ.psb_dupl_add_) THEN
C ... Sum the duplicated element ...
IF(JA(ELEM).LT.IA(ELEM)) THEN
ARN(ELEM_CSR-1) = ARN(ELEM_CSR-1) + AR(ELEM)
ENDIF
if (debug) write(0,*) 'Duplicated add',
+ elem_csr-1,elem
END IF
ENDIF
ELEM = ELEM + 1
ENDDO
IAN2(ROW+1) = ELEM_CSR
ENDDO
if (debug) write(0,*)'Done Rebuild CSR',
+ ian2(m+1),ia(elem)
if (debug) then
@ -531,29 +501,29 @@ C ... Sum the duplicated element ...
endif
END IF
C
ELSE IF (TRANS.NE.'N') THEN
C
C TO DO
C
IERROR = 3021
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
end if
c
else if (toupper(TRANS).NE.'N') then
c
c to do
c
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
END IF
INFON(1)=ELEM_CSR-1
end if
infon(1)=elem_csr-1
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
RETURN
call fcpsb_erractionrestore(err_act)
return
9999 CONTINUE
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
9999 continue
call fcpsb_erractionrestore(err_act)
IF ( ERR_ACT .NE. 0 ) THEN
CALL FCPSB_SERROR()
RETURN
ENDIF
if ( err_act .ne. 0 ) then
call fcpsb_serror()
return
endif
RETURN
END
return
end

18
base/serial/dp/zcrco.f
Unescape Escape View File

@ -34,6 +34,7 @@ C
use psb_const_mod
use psb_spmat_type
use psb_string_mod
IMPLICIT NONE
C
@ -63,8 +64,8 @@ C
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
IF (TRANS.EQ.'N') THEN
SCALE = (UNITD.EQ.'L') ! meaningless
IF (toupper(TRANS).EQ.'N') THEN
SCALE = (toupper(UNITD).EQ.'L') ! meaningless
IP1(1) = 0
IP2(1) = 0
NNZ = IA2(M+1)-1
@ -90,7 +91,7 @@ C
GOTO 9999
END IF
IF (DESCRA(1:1).EQ.'G') THEN
IF (toupper(DESCRA(1:1)).EQ.'G') THEN
C ... Construct COO Representation...
ELEM = 1
@ -103,7 +104,8 @@ C ... Construct COO Representation...
ENDDO
ENDDO
INFON(psb_nnz_) = IA2(M+1)-1
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
DO 20 K = 1, M
IP2(K) = K
@ -113,14 +115,16 @@ C ... Construct COO Representation...
call fcpsb_errpush(ierror,name,int_val)
goto 9999
C
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
C
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
goto 9999
ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'L') THEN
ierror = 3021
call fcpsb_errpush(ierror,name,int_val)
@ -128,7 +132,7 @@ C
END IF
C
ELSE IF (TRANS.NE.'N') THEN
ELSE IF (toupper(TRANS).NE.'N') THEN
C
C TO DO
C

157
base/serial/dp/zcrcr.f
Unescape Escape View File

@ -161,8 +161,9 @@ C IERROR > 0 error
C
C
SUBROUTINE ZCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1,
* DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2,
* WORK,LWORK,IERROR)
* DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2,
* WORK,LWORK,IERROR)
use psb_string_mod
IMPLICIT NONE
C
C .. Scalar Arguments ..
@ -171,12 +172,13 @@ C .. Scalar Arguments ..
C .. Array Arguments ..
complex(kind(1.d0)) A(*), AN(*), D(*), WORK(LWORK)
INTEGER IA1(*), IA2(*), IAN1(*), IAN2(*), IP1(*), IP2(*),
* INFOA(*), INFON(*)
* INFOA(*), INFON(*)
CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars ..
INTEGER I, J, ERR_ACT
LOGICAL EXIT
c .. Local Arrays ..
character idescra*11
CHARACTER*20 NAME
INTEGER INT_VAL(5)
@ -192,65 +194,66 @@ C
C
C Check for argument errors
C
IF(((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
& DESCRA(1:1) .EQ. 'A') .AND. (UNITD .NE. 'B')) .OR.
& (.NOT.((DESCRA(3:3).EQ.'N').OR.(DESCRA(3:3).EQ.'L').OR.
+ (DESCRA(3:3).EQ.'U'))) .OR.
+ TRANS.NE.'N') THEN
IERROR = 20
idescra=toupper(descra)
IF(((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR.
& IDESCRA(1:1) .EQ. 'A') .AND. (toupper(UNITD) .NE. 'B')) .OR.
& (.NOT.((IDESCRA(3:3).EQ.'N').OR.(IDESCRA(3:3).EQ.'L').OR.
+ (IDESCRA(3:3).EQ.'U'))) .OR.
+ toupper(TRANS).NE.'N') THEN
IERROR = 20
ENDIF
IF(LAN.LT.(IA2(M+1)-1)) THEN
IF (LAN.LE.0) THEN
EXIT=.TRUE.
AN(1) = DBLE(IA2(M+1)-1)
ELSE
IERROR = 21
ENDIF
IF (LAN.LE.0) THEN
EXIT=.TRUE.
AN(1) = DBLE(IA2(M+1)-1)
ELSE
IERROR = 21
ENDIF
ENDIF
IF(LIAN1.LT.(IA2(M+1)-1)) THEN
IF (LAN.LE.0) THEN
EXIT=.TRUE.
IAN1(1) = IA2(M+1)-1
ELSE
IERROR = 22
ENDIF
IF (LAN.LE.0) THEN
EXIT=.TRUE.
IAN1(1) = IA2(M+1)-1
ELSE
IERROR = 22
ENDIF
ENDIF
IF(LIAN2.LT.(M+1)) THEN
IF (LAN.LE.0) THEN
EXIT=.TRUE.
IAN2(1) = M+1
ELSE
IERROR = 23
ENDIF
IF (LAN.LE.0) THEN
EXIT=.TRUE.
IAN2(1) = M+1
ELSE
IERROR = 23
ENDIF
ENDIF
IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
& DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN
IF (LWORK.LT.M) THEN
IF (LWORK.LE.0) THEN
EXIT=.TRUE.
ELSE
IERROR = 25
ENDIF
WORK(1) = DBLE(M)
ENDIF
IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR.
& IDESCRA(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN
IF (LWORK.LT.M) THEN
IF (LWORK.LE.0) THEN
EXIT=.TRUE.
ELSE
IERROR = 25
ENDIF
WORK(1) = DBLE(M)
ENDIF
ELSE
IF (LWORK.LT.0) THEN
WORK(1) = 0.D0
ENDIF
IF (LWORK.LT.0) THEN
WORK(1) = 0.D0
ENDIF
ENDIF
C
C Error handling
C
IF(IERROR.NE.0) THEN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
END IF
IF(IERROR.NE.0) THEN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
END IF
IF (EXIT) goto 9998
C
C Set DESCRN, IP1, IP2
C
DESCRN(1:3) = DESCRA(1:3)
DESCRN(1:3) = IDESCRA(1:3)
IP1(1)=0
IP2(1)=0
@ -258,38 +261,38 @@ C
C Compute output matrix
C
DO 20 I = 1, M+1
IAN2(I) = IA2(I)
IAN2(I) = IA2(I)
20 CONTINUE
IF ((DESCRA(1:1) .EQ. 'S' .OR. DESCRA(1:1) .EQ. 'H' .OR.
& DESCRA(1:1) .EQ. 'A') .AND. (UNITD .EQ. 'B')) THEN
DO 30 I = 1, M
WORK(I) = DBLE(DSQRT(ABS(D(I))))
30 CONTINUE
DO 40 I = 1, M
DO 50 J = IA2(I), IA2(I+1)-1
AN(J) = WORK(I) * A(J) * WORK(IA1(J))
IAN1(J) = IA1(J)
50 CONTINUE
40 CONTINUE
ELSE IF (UNITD .EQ. 'L') THEN
DO 60 I = 1, M
DO 70 J = IA2(I), IA2(I+1)-1
AN(J) = D(I) * A(J)
IAN1(J) = IA1(J)
70 CONTINUE
60 CONTINUE
ELSE IF (UNITD .EQ. 'R') THEN
DO 80 I = 1, M
DO 90 J = IA2(I), IA2(I+1)-1
AN(J) = A(J) * D(IA1(J))
IAN1(J) = IA1(J)
90 CONTINUE
80 CONTINUE
ELSE IF (UNITD .EQ. 'U') THEN
DO 100 J = 1, IA2(M+1)-1
AN(J) = A(J)
IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR.
& IDESCRA(1:1) .EQ. 'A') .AND. (toupper(UNITD) .EQ. 'B')) THEN
DO 30 I = 1, M
WORK(I) = DBLE(DSQRT(ABS(D(I))))
30 CONTINUE
DO 40 I = 1, M
DO 50 J = IA2(I), IA2(I+1)-1
AN(J) = WORK(I) * A(J) * WORK(IA1(J))
IAN1(J) = IA1(J)
50 CONTINUE
40 CONTINUE
ELSE IF (toupper(UNITD) .EQ. 'L') THEN
DO 60 I = 1, M
DO 70 J = IA2(I), IA2(I+1)-1
AN(J) = D(I) * A(J)
IAN1(J) = IA1(J)
70 CONTINUE
60 CONTINUE
ELSE IF (toupper(UNITD) .EQ. 'R') THEN
DO 80 I = 1, M
DO 90 J = IA2(I), IA2(I+1)-1
AN(J) = A(J) * D(IA1(J))
IAN1(J) = IA1(J)
100 CONTINUE
90 CONTINUE
80 CONTINUE
ELSE IF (toupper(UNITD) .EQ. 'U') THEN
DO 100 J = 1, IA2(M+1)-1
AN(J) = A(J)
IAN1(J) = IA1(J)
100 CONTINUE
ENDIF
9998 CONTINUE
@ -300,8 +303,8 @@ C
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
IF ( ERR_ACT .NE. 0 ) THEN
CALL FCPSB_SERROR()
RETURN
CALL FCPSB_SERROR()
RETURN
ENDIF
RETURN

28
base/serial/dp/zcrjd.f
Unescape Escape View File

@ -61,6 +61,7 @@ C IAN2,INFON, IP1, IP2
C
use psb_const_mod
use psb_spmat_type
use psb_string_mod
IMPLICIT NONE
C
@ -103,10 +104,10 @@ C
GOTO 9999
ENDIF
IF (TRANS.EQ.'N') THEN
IF (toupper(TRANS).EQ.'N') THEN
C
NJA = 3*M
SCALE = (UNITD.EQ.'L') ! meaningless
SCALE = (toupper(UNITD).EQ.'L') ! meaningless
IOFF = 5
C
C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX
@ -115,7 +116,7 @@ C
PIA = PNG + 1
PJA = PIA + 3*(M+2)
IF (DESCRA(1:1).EQ.'G') THEN
IF (toupper(DESCRA(1:1)).EQ.'G') THEN
C
C CHECK ON DIMENSION OF IAN2 AND AUX
@ -169,10 +170,11 @@ C
ENDIF
LJA = LIAN2-PJA
CALL ZGINDEX(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA),
+ IAN2(PJA), INFON, LARN,LIAN1,
+ LJA,IP1, AUX, LAUX*2, SIZE_REQ,IERROR)
CALL ZGINDEX(M,IAN2(PNG),AR,IA1,IA2,info,
+ ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON,
+ LARN,LIAN1, LJA,IP1,
+ AUX, LAUX*2, SIZE_REQ,IERROR)
IF (IERROR.NE.0) THEN
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
@ -182,7 +184,8 @@ C
DESCRN(2:2) = 'U'
DESCRN(3:3) = 'N'
ELSE IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN
C
ISTROW = 1
NZ = 2*(IA2(M+1)-1) - M
@ -218,13 +221,13 @@ c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2,
c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1),
c$$$ * AUX(IWORK2),NJA,IER,SCALE)
C
ELSE IF (DESCRA(1:1).EQ.'T') THEN
ELSE IF (toupper(DESCRA(1:1)).EQ.'T') THEN
C
C Only unit diagonal so far for triangular matrices.
C
IF (DESCRA(3:3).NE.'U') THEN
IF (toupper(DESCRA(3:3)).NE.'U') THEN
IERROR=3022
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
@ -273,8 +276,7 @@ c$$$ write(0,*) "error 2",ierrv(1)
ENDIF
DESCRN(1:1) = 'T'
DESCRN(2:2) = DESCRA(2:2)
DESCRN(3:3) = DESCRA(3:3)
DESCRN(2:3) = toupper(DESCRA(2:3))
END IF
C
@ -288,7 +290,7 @@ C
LIAN2 = 3*M + 10
LAUX2 = 4*M + 2
C
ELSE IF (TRANS.NE.'N') THEN
ELSE IF (toupper(TRANS).NE.'N') THEN
C
C TO BE DONE
C

61
base/serial/dp/zgindex.f
Unescape Escape View File

@ -28,7 +28,7 @@ C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
SUBROUTINE ZGINDEX(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, INFON,
SUBROUTINE ZGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON,
+ LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR)
use psb_const_mod
@ -43,12 +43,12 @@ C ... Array arguments ...
complex(kind(1.d0)) A(*), ARN(*)
INTEGER IA1(*), IA2(*), KA(*),
+ IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*)
+ IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*), infoa(*)
C .... Local scalars ...
INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1,
+ IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG,
+ ERR_ACT
+ ERR_ACT, ix, regen_flag
LOGICAL CSR
c .. Local Arrays ..
CHARACTER*20 NAME
@ -61,6 +61,8 @@ c .. Local Arrays ..
POINT_AR = 1
POINT_JA = 0
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN
IERROR = 60
@ -71,8 +73,8 @@ c .. Local Arrays ..
GOTO 9999
ENDIF
NNZ = IA2(M + 1) - 1
COUNT = 0
NNZ = IA2(M + 1) - 1
COUNT = 0
C .... Invert Permutation Matrix...
IF (IPERM(1).NE.0) THEN
@ -81,7 +83,9 @@ C .... Invert Permutation Matrix...
ENDDO
ENDIF
IF ( (LKA .GE.( SIZE_REQ ))
size_Req=0
IF ( (regen_flag == psb_upd_perm_)
+ .AND. (LWORK .GE. (M + NNZ+2))) THEN
C
C Prepare for smart regeneration
@ -98,19 +102,25 @@ C
KA(IP1+PSB_NNZT_) = NNZ
KA(IP1+PSB_NNZ_) = 0
KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG
I = M+2
IPX = IA2(I+PSB_IP2_)
if (infoa(psb_upd_pnt_) > 0) then
I = infoa(psb_upd_pnt_)
IPX = IA2(I+PSB_IP2_)
C Invert permutation for smart regeneration
DO I = 1, NNZ
WORK(IPW + IA2(IPX + I -1) - 1) = I
ENDDO
DO I = 1, NNZ
WORK(IPW + IA2(IPX + I -1) - 1) = I
ENDDO
else
! No permutation available before, set identity.
DO I = 1, NNZ
WORK(IPW + I - 1) = I
ENDDO
endif
C Construct JAD matrix...
DO BLOCK = 1, N_BLOCKS
COL = 1
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
c$$$ write(0,*) 'ZGINDEX: BLOCK LOOP ',block,n_blocks,dim_block
if (dim_block .gt. PSB_MAXJDROWS_) then
@ -270,9 +280,19 @@ C ... For each nnzero elements belonging to current row ...
ENDDO
ENDDO
IA(2,N_BLOCKS+1) = POINT_JA
KA(IP1 + PSB_ZERO_) = COUNT
IF (POINT_AR.GE.IP1) THEN
SIZE_REQ=NNZ+COUNT
ELSE
SIZE_REQ=0
ENDIF
ELSE
c$$$ c write(*,*)'inizio a ciclare sui blocchi'
IP1 = LKA - PSB_ZERO_
DO BLOCK = 1, N_BLOCKS
COL = 1
DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK)
@ -415,16 +435,15 @@ C ... For each nnzero elements belonging to current row ...
IA(2,N_BLOCKS+1) = POINT_JA
IF (POINT_AR.GE.lka) THEN
SIZE_REQ=NNZ+COUNT
ELSE
SIZE_REQ=0
ENDIF
ENDIF
IA(2,N_BLOCKS+1) = POINT_JA
KA(IP1 + PSB_ZERO_) = COUNT
IF(POINT_AR.GE.IP1) THEN
SIZE_REQ=NNZ+COUNT
ELSE
SIZE_REQ=0
ENDIF
infon(1)=point_ar-1
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)

33
base/serial/psb_cest.f90
Unescape Escape View File

@ -28,19 +28,20 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info)
subroutine psb_cest(afmt,m,n,nnz, lia1, lia2, lar, iup,info)
use psb_error_mod
use psb_const_mod
use psb_string_mod
use psb_spmat_type
implicit none
! .. scalar arguments ..
integer, intent(in) :: m,n,nnz,iup
integer, intent(out) :: lia1, lia2, lar, info
character(len=*), intent(inout) :: afmt
! .. array arguments..
character(len=5) :: afmt
integer :: int_val(5), err_act
character(len=20) :: name
@ -50,18 +51,20 @@ subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info)
if (afmt == '???') then
afmt = psb_fidef_
endif
afmt = toupper(afmt)
select case(iup)
case (psb_upd_perm_)
if (toupper(afmt) == 'JAD') then
lia1 = 2*(nnz + nnz/5) +1000
lia2 = 2*(nnz + nnz/5) +1000 +m
lar = nnz + nnz/5
else if (toupper(afmt) == 'COO') then
if (afmt == 'JAD') then
lia1 = 2*(nnz) + 1000
lia2 = (3*nnz)/2 + 1000 + m
lar = (3*nnz)/2
else if (afmt == 'COO') then
lia1 = nnz
lia2 = 2*nnz + 1000
lar = nnz
else if(toupper(afmt) == 'CSR') then
else if(afmt == 'CSR') then
lia1 = nnz
lia2 = 2*nnz + 1000 + m + 1
lar = nnz
@ -71,17 +74,17 @@ subroutine psb_cest(afmt, m,n,nnz, lia1, lia2, lar, iup, info)
goto 9999
endif
case (psb_upd_dflt_, psb_upd_srch_)
case (psb_upd_srch_)
if (toupper(afmt) == 'JAD') then
lia1 = nnz + nnz/5
lia2 = nnz + nnz/5
lar = nnz + nnz/5
else if (toupper(afmt) == 'COO') then
if (afmt == 'JAD') then
lia1 = (3*nnz)/2
lia2 = (3*nnz)/2
lar = (3*nnz)/2
else if (afmt == 'COO') then
lia1 = nnz
lia2 = nnz
lar = nnz
else if(toupper(afmt) == 'CSR') then
else if(afmt == 'CSR') then
lia1 = nnz
lia2 = max(nnz,m+1)
lar = nnz

29
base/serial/psb_dcoins.f90
Unescape Escape View File

@ -38,7 +38,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_realloc_mod
use psb_string_mod
use psb_error_mod
use psb_serial_mod, only : psb_csdp
use psb_serial_mod, psb_protect_name => psb_dcoins
use psb_update_mod
implicit none
@ -156,8 +156,12 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
select case(ufida)
case ('JAD')
nza = a%ia1(ip1+psb_nnz_)
case default
nza = a%ia2(ip1+psb_nnz_)
end select
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
@ -172,11 +176,17 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
write(0,*) 'PSB_COINS: update discarded items '
end if
end if
a%ia2(ip1+psb_nnz_) = nza
select case(ufida)
case ('JAD')
a%ia1(ip1+psb_nnz_) = nza
case default
a%ia2(ip1+psb_nnz_) = nza
end select
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
case (psb_upd_dflt_, psb_upd_srch_)
case (psb_upd_srch_)
call psb_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
@ -187,8 +197,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
& 'COINS: Going through rebuild_ fingers crossed!'
irst = info
call psb_nullify_sp(tmp)
tmp%fida='COO'
call psb_csdp(a,tmp,info)
call psb_spcnv(a,tmp,info,afmt='coo')
if(info /= izero) then
info=4010
ch_err='psb_csdp'
@ -349,7 +358,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
case (psb_upd_dflt_, psb_upd_srch_)
case (psb_upd_srch_)
call psb_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info)
@ -360,8 +369,7 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
& 'COINS: Going through rebuild_ fingers crossed!'
irst = info
call psb_nullify_sp(tmp)
tmp%fida='COO'
call psb_csdp(a,tmp,info)
call psb_spcnv(a,tmp,info,afmt='coo')
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
if (debug) then
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
@ -429,7 +437,6 @@ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif
return
call psb_erractionrestore(err_act)
return

515
base/serial/psb_dcsdp.f90
Unescape Escape View File

@ -1,515 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psb_dcsdp.f90
!
! Subroutine: psb_dcsdp
! This subroutine performs the assembly of
! the local part of a sparse distributed matrix
!
! Parameters:
! a - type(<psb_spmat_type>). The input matrix to be assembled.
! b - type(<psb_spmat_type>). The assembled output matrix.
! info - integer. Eventually returns an error code.
! ifc - integer(optional). ???
! check - character(optional). ???
! trans - character(optional). ???
! unitd - character(optional). ???
!
subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl)
use psb_const_mod
use psb_error_mod
use psb_spmat_type
use psb_string_mod
use psb_serial_mod, psb_protect_name => psb_dcsdp
implicit none
!....Parameters...
Type(psb_dspmat_type), intent(in) :: A
Type(psb_dspmat_type), intent(inout) :: B
Integer, intent(out) :: info
Integer, intent(in), optional :: ifc,upd,dupl
character, intent(in), optional :: check,trans,unitd
!...Locals...
real(kind(1.d0)) :: d(1)
real(kind(1.d0)), allocatable :: work(:)
type(psb_dspmat_type) :: temp_a
Integer :: nzr, ntry, ifc_, ia1_size,&
& ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_
integer :: ip1, ip2, nnz, iflag, ichk, nnzt,&
& ipc, i, count, err_act, i1, i2, ia
character :: check_,trans_,unitd_
Integer, Parameter :: maxtry=8
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
name='psb_csdp'
info = 0
call psb_erractionsave(err_act)
ntry=0
if (present(ifc)) then
ifc_ = max(1,ifc)
else
ifc_ = 1
endif
if (present(check)) then
check_ = toupper(check)
else
check_ = 'N'
endif
if (present(trans)) then
trans_ = toupper(trans)
else
trans_ = 'N'
endif
if (present(unitd)) then
unitd_ = toupper(unitd)
else
unitd_ = 'U'
endif
if (check_=='R') then
allocate(work(max(size(a%aspk),size(b%aspk))+1000),stat=info)
else
allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info)
endif
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (ifc_<1) then
write(0,*) 'csdp90 Error: invalid ifc ',ifc_
info = -4
call psb_errpush(info,name)
goto 9999
endif
if((check_=='Y').or.(check_=='C')) then
if(toupper(a%fida(1:3))=='CSR') then
call dcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info)
if(info /= 0) then
info=4010
ch_err='dcsrck'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
write(0,'("Check not yet suported for the ",a3," storage format")')a%fida(1:3)
end if
end if
if (check_/='R') then
if (present(upd)) then
call psb_sp_setifld(upd,psb_upd_,b,info)
end if
if (present(dupl)) then
call psb_sp_setifld(dupl,psb_dupl_,b,info)
end if
upd_ = psb_sp_getifld(psb_upd_,b,info)
select case(upd_)
case(psb_upd_dflt_,psb_upd_srch_,psb_upd_perm_)
! Legal value, do nothing
case default
! Fix bad value
upd_ = psb_upd_dflt_
call psb_sp_setifld(upd_,psb_upd_,b,info)
end select
dupl_ = psb_sp_getifld(psb_dupl_,b,info)
select case(dupl_)
case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
! Legal value, do nothing
case default
! Fix bad value
dupl_ = psb_dupl_def_
call psb_sp_setifld(dupl_,psb_dupl_,b,info)
end select
! ...matrix conversion...
b%m=a%m
b%k=a%k
size_req = psb_sp_get_nnzeros(a)
if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!
n_row=b%m
n_col=b%k
call psb_cest(b%fida, n_row,n_col,size_req,&
& ia1_size, ia2_size, aspk_size, upd_,info)
if (info /= psb_no_err_) then
info=4010
ch_err='psb_cest'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (.not.allocated(b%aspk).or.&
&.not.allocated(b%ia1).or.&
&.not.allocated(b%ia2).or.&
&.not.allocated(b%pl).or.&
&.not.allocated(b%pr)) then
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
else if ((size(b%aspk) < aspk_size) .or.&
&(size(b%ia1) < ia1_size) .or.&
&(size(b%ia2) < ia2_size) .or.&
&(size(b%pl) < b%m) .or.&
&(size(b%pr) < b%k )) then
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
endif
if (info /= psb_no_err_) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
b%pl(:) = 0
b%pr(:) = 0
b%descra = a%descra
select case (toupper(a%fida(1:3)))
case ('CSR')
select case (toupper(b%fida(1:3)))
case ('CSR')
call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), info)
if (info/=0) then
info=4010
ch_err='dcrcr'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case ('JAD')
!...converting to JAD
!...output matrix may not be big enough
do
call dcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), nzr, info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
endif
ntry = ntry + 1
if (debug) then
write(0,*) 'On out from dcrjad ',nzr,info
end if
if (nzr == 0) exit
if (ntry > maxtry ) then
write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.'
info=2040
call psb_errpush(info,name)
goto 9999
endif
call psb_sp_reall(b,nzr,info,ifc=ifc_)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
end do
if (info/=0) then
call psb_errpush(info,name)
goto 9999
end if
case ('COO')
if (debug) write(0,*) 'Calling CRCO ',a%descra
call dcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrco')
goto 9999
end if
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
case ('COO','COI')
select case (toupper(b%fida(1:3)))
case ('CSR')
call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
case ('JAD')
call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
temp_a%m = a%m
temp_a%k = a%k
!...Dirty trick: converting to CSR and then to JAD
call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, &
& temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, &
& size(temp_a%aspk), size(temp_a%ia1),&
& size(temp_a%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
do
call dcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, &
& temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, &
& b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, &
& size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), nzr, info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
end if
ntry = ntry + 1
if (debug) then
write(0,*) 'On out from dcrjad ',nzr,info
end if
if (nzr == 0) exit
if (ntry > maxtry ) then
write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,&
& ': giving up now.'
info=2040
call psb_errpush(info,name)
goto 9999
endif
call psb_sp_reall(b,nzr,info,ifc=ifc_)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
end do
case ('COO')
call dcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcoco')
goto 9999
end if
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) &
& call psb_sp_trim(b,info)
else if (check_=='R') then
!...Regenerating matrix
if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then
info = 8888
call psb_errpush(info,name)
goto 9999
endif
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,b,info))
case(psb_upd_perm_)
if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
if (toupper(b%fida(1:3))/='JAD') then
ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
ip2 = b%ia2(ip1+psb_ip2_)
nnz = b%ia2(ip1+psb_nnz_)
iflag = b%ia2(ip1+psb_iflag_)
ichk = b%ia2(ip1+psb_ichk_)
nnzt = b%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = 0.d0
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
b%aspk(i) = work(i)
enddo
else if (toupper(b%fida(1:3)) == 'JAD') then
ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
ip2 = b%ia1(ip1+psb_ip2_)
count = b%ia1(ip1+psb_zero_)
ipc = b%ia1(ip1+psb_ipc_)
nnz = b%ia1(ip1+psb_nnz_)
iflag = b%ia1(ip1+psb_iflag_)
ichk = b%ia1(ip1+psb_ichk_)
nnzt = b%ia1(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt,count, &
& iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 10
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz+count
work(i) = 0.d0
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz+count
b%aspk(i) = work(i)
enddo
do i=1, count
b%aspk(b%ia1(ipc+i-1)) = 0.d0
end do
endif
case(psb_upd_dflt_,psb_upd_srch_)
! Nothing to be done here.
if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
end if
call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_dcsdp

171
base/serial/psb_dfixcoo.f90
Unescape Escape View File

@ -32,10 +32,12 @@
! Subroutine:
! Parameters:
Subroutine psb_dfixcoo(A,INFO,idir)
subroutine psb_dfixcoo(a,info,idir)
use psb_spmat_type
use psb_const_mod
use psb_string_mod
use psb_serial_mod, psb_protect_name => psb_dfixcoo
use psb_error_mod
implicit none
!....Parameters...
@ -45,11 +47,14 @@ Subroutine psb_dfixcoo(A,INFO,idir)
integer, allocatable :: iaux(:)
!locals
Integer :: nza, nzl,iret,idir_
integer :: i,j, irw, icl
Integer :: nza, nzl,iret,idir_, dupl_
integer :: i,j, irw, icl, err_act
logical, parameter :: debug=.false.
character(len=20) :: name = 'psb_fixcoo'
info = 0
call psb_erractionsave(err_act)
if(debug) write(0,*)'fixcoo: ',size(a%ia1),size(a%ia2)
if (toupper(a%fida) /= 'COO') then
write(0,*) 'Fixcoo Invalid input ',a%fida
@ -62,9 +67,11 @@ Subroutine psb_dfixcoo(A,INFO,idir)
idir_ = 0
endif
nza = a%infoa(psb_nnz_)
nza = psb_sp_getifld(psb_nnz_,a,info)
if (nza < 2) return
dupl_ = psb_sp_getifld(psb_dupl_,a,info)
allocate(iaux(nza+2),stat=info)
if (info /= 0) return
@ -92,22 +99,61 @@ Subroutine psb_dfixcoo(A,INFO,idir)
irw = a%ia1(i)
icl = a%ia2(i)
j = 1
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(i) + a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
a%infoa(psb_nnz_) = i
a%infoa(psb_srtd_) = psb_isrtdcoo_
select case(dupl_)
case(psb_dupl_ovwrt_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
case(psb_dupl_add_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(i) + a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
case(psb_dupl_err_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
call psb_errpush(130,name)
goto 9999
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
end select
if(debug) write(0,*)'FIXCOO: end second loop'
@ -133,28 +179,79 @@ Subroutine psb_dfixcoo(A,INFO,idir)
irw = a%ia1(i)
icl = a%ia2(i)
j = 1
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(i) + a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
a%infoa(psb_nnz_) = i
a%infoa(psb_srtd_) = psb_isrtdcoo_
select case(dupl_)
case(psb_dupl_ovwrt_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
case(psb_dupl_add_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(i) + a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
case(psb_dupl_err_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
call psb_errpush(130,name)
goto 9999
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
end select
if(debug) write(0,*)'FIXCOO: end second loop'
case default
write(0,*) 'Fixcoo: unknown direction ',idir_
end select
a%infoa(psb_upd_) = psb_upd_srch_
call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info)
call psb_sp_setifld(i,psb_nnz_,a,info)
call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info)
call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info)
deallocate(iaux)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end Subroutine psb_dfixcoo

2
base/serial/psb_dipcoo2csc.f90
Unescape Escape View File

@ -35,7 +35,7 @@
subroutine psb_dipcoo2csc(a,info,clshr)
use psb_spmat_type
use psb_const_mod
use psb_serial_mod, only : psb_fixcoo
use psb_serial_mod, psb_protect_name => psb_dipcoo2csc
use psb_error_mod
use psb_string_mod
use psb_realloc_mod

2
base/serial/psb_dipcoo2csr.f90
Unescape Escape View File

@ -36,7 +36,7 @@ subroutine psb_dipcoo2csr(a,info,rwshr)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_serial_mod, only : psb_fixcoo
use psb_serial_mod, psb_protect_name => psb_dipcoo2csr
use psb_error_mod
use psb_string_mod
implicit none

2
base/serial/psb_dipcsr2coo.f90
Unescape Escape View File

@ -38,6 +38,7 @@ Subroutine psb_dipcsr2coo(a,info)
use psb_error_mod
use psb_string_mod
use psb_realloc_mod
use psb_serial_mod, psb_protect_name => psb_dipcsr2coo
implicit none
!....Parameters...
@ -86,6 +87,7 @@ Subroutine psb_dipcsr2coo(a,info)
a%infoa(psb_upd_) = psb_upd_srch_
deallocate(itemp)
call psb_fixcoo(a,info)
call psb_erractionrestore(err_act)
return

1
base/serial/psb_dnumbmm.f90
Unescape Escape View File

@ -71,6 +71,7 @@ subroutine psb_dnumbmm(a,b,c)
write(0,*) 'Error ',info,' from inner numbmm'
end if
end if
call psb_sp_setifld(psb_spmat_asb_,psb_state_,c,info)
deallocate(temp)
return

7
base/serial/psb_drwextd.f90
Unescape Escape View File

@ -41,6 +41,7 @@ subroutine psb_drwextd(nr,a,info,b,rowscale)
use psb_spmat_type
use psb_error_mod
use psb_string_mod
use psb_serial_mod, psb_protect_name => psb_drwextd
implicit none
! Extend matrix A up to NR rows with empty ones (i.e.: all zeroes)
@ -66,11 +67,11 @@ subroutine psb_drwextd(nr,a,info,b,rowscale)
if (nr > a%m) then
if (toupper(a%fida) == 'CSR') then
call psb_realloc(nr+1,a%ia2,info)
call psb_ensure_size(nr+1,a%ia2,info)
if (present(b)) then
nzb = psb_sp_get_nnzeros(b)
call psb_realloc(size(a%ia1)+nzb,a%ia1,info)
call psb_realloc(size(a%aspk)+nzb,a%aspk,info)
call psb_ensure_size(size(a%ia1)+nzb,a%ia1,info)
call psb_ensure_size(size(a%aspk)+nzb,a%aspk,info)
if (toupper(b%fida)=='CSR') then
do i=1, min(nr-a%m,b%m)

2
base/serial/psb_dspclip.f90
Unescape Escape View File

@ -109,7 +109,7 @@ subroutine psb_dspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale)
call psb_sp_all(mb,kb,b,sizeb,info)
b%fida = 'COO'
b%descra = a%descra
nzb = 0
nzb = 0
do i=imin_, imax_, irbk
nrt = min(irbk,imax_-i+1)
ifst = i

553
base/serial/psb_dspcnv.f90
Unescape Escape View File

@ -0,0 +1,553 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psb_dcsdp.f90
!
! Subroutine: psb_dcsdp
! This subroutine performs the assembly of
! the local part of a sparse distributed matrix
!
! Parameters:
! a - type(<psb_spmat_type>). The input matrix to be assembled.
! b - type(<psb_spmat_type>). The assembled output matrix.
! info - integer. Eventually returns an error code.
! ifc - integer(optional). ???
! check - character(optional). ???
! trans - character(optional). ???
! unitd - character(optional). ???
!
subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl)
use psb_const_mod
use psb_error_mod
use psb_spmat_type
use psb_string_mod
use psb_serial_mod, psb_protect_name => psb_dspcnv2
implicit none
!....Parameters...
Type(psb_dspmat_type), intent(in) :: A
Type(psb_dspmat_type), intent(out) :: B
Integer, intent(out) :: info
Integer, intent(in), optional :: upd,dupl
character(len=*), optional, intent(in) :: afmt
!...Locals...
real(kind(1.d0)) :: d(1)
real(kind(1.d0)), allocatable :: work(:)
type(psb_dspmat_type) :: temp_a
Integer :: nzr, ntry, ifc_, ia1_size,&
& ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_
integer :: ip1, ip2, nnz, iflag, ichk, nnzt,&
& ipc, i, count, err_act, i1, i2, ia
character :: check_,trans_,unitd_
character(len=5) :: afmt_
Integer, Parameter :: maxtry=8
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
ntry=0
ifc_ = 2
check_ = 'N'
trans_ = 'N'
unitd_ = 'U'
allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (present(upd)) then
call psb_sp_setifld(upd,psb_upd_,b,info)
end if
if (present(dupl)) then
call psb_sp_setifld(dupl,psb_dupl_,b,info)
end if
if (present(afmt)) then
afmt_ = afmt
else
afmt_ = psb_fidef_
end if
upd_ = psb_sp_getifld(psb_upd_,b,info)
select case(upd_)
case(psb_upd_srch_,psb_upd_perm_)
! Legal value, do nothing
case default
! Fix bad value
upd_ = psb_upd_dflt_
call psb_sp_setifld(upd_,psb_upd_,b,info)
end select
dupl_ = psb_sp_getifld(psb_dupl_,b,info)
select case(dupl_)
case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
! Legal value, do nothing
case default
! Fix bad value
dupl_ = psb_dupl_def_
call psb_sp_setifld(dupl_,psb_dupl_,b,info)
end select
! ...matrix conversion...
b%m=a%m
b%k=a%k
b%fida=afmt_
size_req = psb_sp_get_nnzeros(a)
if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!
n_row=b%m
n_col=b%k
call psb_cest(afmt_,n_row,n_col,size_req,&
& ia1_size, ia2_size, aspk_size, upd_,info)
b%fida=afmt_
if (info /= psb_no_err_) then
info=4010
ch_err='psb_cest'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (.not.allocated(b%aspk).or.&
&.not.allocated(b%ia1).or.&
&.not.allocated(b%ia2).or.&
&.not.allocated(b%pl).or.&
&.not.allocated(b%pr)) then
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
else if ((size(b%aspk) < aspk_size) .or.&
&(size(b%ia1) < ia1_size) .or.&
&(size(b%ia2) < ia2_size) .or.&
&(size(b%pl) < b%m) .or.&
&(size(b%pr) < b%k )) then
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
endif
if (info /= psb_no_err_) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
b%pl(:) = 0
b%pr(:) = 0
b%descra = a%descra
select case (tolower(a%fida))
case ('csr')
select case (tolower(b%fida))
case ('csr')
call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), info)
if (info/=0) then
info=4010
ch_err='dcrcr'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case ('jad')
!...converting to JAD
!...output matrix may not be big enough
do
call dcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), nzr, info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
endif
ntry = ntry + 1
if (debug) then
write(0,*) 'On out from dcrjad ',nzr,info
end if
if (nzr == 0) exit
if (ntry > maxtry ) then
write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.'
info=2040
call psb_errpush(info,name)
goto 9999
endif
call psb_cest(afmt_,n_row,n_col,nzr,&
& ia1_size, ia2_size, aspk_size, upd_,info)
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
end do
if (info/=0) then
call psb_errpush(info,name)
goto 9999
end if
case ('coo')
if (debug) write(0,*) 'Calling CRCO ',a%descra
call dcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrco')
goto 9999
end if
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
case ('coo','coi')
select case (tolower(b%fida))
case ('csr')
call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
case ('jad')
call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
temp_a%m = a%m
temp_a%k = a%k
temp_a%infoa=b%infoa
!...Dirty trick: converting to CSR and then to JAD
call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, &
& temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, &
& size(temp_a%aspk), size(temp_a%ia1),&
& size(temp_a%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
do
call dcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, &
& temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, &
& b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, &
& size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), nzr, info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
end if
ntry = ntry + 1
if (debug) then
write(0,*) 'On out from dcrjad ',nzr,info
end if
if (nzr == 0) exit
if (ntry > maxtry ) then
write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,&
& ': giving up now.'
info=2040
call psb_errpush(info,name)
goto 9999
endif
call psb_sp_reall(b,nzr,info,ifc=ifc_)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
end do
case ('coo')
call dcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcoco')
goto 9999
end if
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) &
& call psb_sp_trim(b,info)
call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_dspcnv2
subroutine psb_dspcnv1(a, info, afmt, upd, dupl)
use psb_spmat_type
use psb_regen_mod
use psb_serial_mod, psb_protect_name => psb_dspcnv1
use psb_const_mod
use psi_mod
use psb_error_mod
use psb_string_mod
!use psb_penv_mod
implicit none
!...Parameters....
type(psb_dspmat_type), intent (inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
integer :: int_err(5)
type(psb_dspmat_type) :: atemp
integer :: np,me,n_col,iout, err_act
integer :: spstate
integer :: upd_, dupl_
integer :: ictxt,n_row
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err
info = 0
int_err(1)=0
name = 'psb_spcnv'
call psb_erractionsave(err_act)
if (present(upd)) then
call psb_sp_setifld(upd,psb_upd_,a,info)
end if
if (present(dupl)) then
call psb_sp_setifld(dupl,psb_dupl_,a,info)
end if
upd_ = psb_sp_getifld(psb_upd_,a,info)
select case(upd_)
case(psb_upd_srch_,psb_upd_perm_)
! Legal value, do nothing
case default
! Fix bad value
upd_ = psb_upd_dflt_
call psb_sp_setifld(upd_,psb_upd_,a,info)
end select
dupl_ = psb_sp_getifld(psb_dupl_,a,info)
select case(dupl_)
case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
! Legal value, do nothing
case default
! Fix bad value
dupl_ = psb_dupl_def_
call psb_sp_setifld(dupl_,psb_dupl_,a,info)
end select
spstate = psb_sp_getifld(psb_state_,a,info)
if (info /= 0) then
goto 9999
endif
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
if (spstate /= psb_spmat_upd_) then
! Should we first figure out if we can do it in place?
if (debug) write(0,*) 'Update:',upd_,psb_upd_srch_,psb_upd_perm_
if (upd_ == psb_upd_srch_) then
if (present(afmt)) then
select case (tolower(a%fida))
case('coo')
select case(tolower(afmt))
case('coo')
call psb_fixcoo(a,info)
goto 9998
case('csr')
call psb_ipcoo2csr(a,info)
goto 9998
case('csc')
call psb_ipcoo2csc(a,info)
goto 9998
end select
case('csr')
select case(tolower(afmt))
case('coo')
call psb_ipcsr2coo(a,info)
goto 9998
end select
end select
end if
end if
call psb_sp_clone(a,atemp,info)
if(info /= psb_no_err_) then
info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
! convert to user requested format after the temp copy
end if
if (debugwrt) then
iout = 30+me
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
! Do the real conversion into the requested storage format
! result is put in A
call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl)
IF (debug) WRITE (*, *) me,' ASB: From SPCNV',info,' ',A%FIDA
if (info /= psb_no_err_) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debugwrt) then
iout = 60+me
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
call psb_sp_free(atemp,info)
else if (spstate == psb_spmat_upd_) then
!
! Second case: we come from an update loop.
!
select case(tolower(a%fida))
case('csr')
call csr_regen(a,info)
case ('coo','coi')
call coo_regen(a,info)
case('jad')
call jad_regen(a,info)
case default
info=136
ch_err=a%fida
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
! check on error retuned by dcsdp
if (info /= psb_no_err_) then
info = 4010
ch_err='xx_regen'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
info = 600
call psb_errpush(info,name)
goto 9999
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
endif
9998 continue
call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_dspcnv1

28
base/serial/psb_dspgetrow.f90
Unescape Escape View File

@ -87,21 +87,19 @@ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
nzin_ = 0
endif
if (toupper(a%fida) == 'CSR') then
call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
else if (toupper(a%fida) == 'COO') then
call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
else if (toupper(a%fida) == 'JAD') then
call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
else
info=136
ch_err=a%fida(1:3)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
select case (tolower(a%fida))
case ('csr')
call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
case ('coo')
call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
case ('jad')
call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
case default
info=136
ch_err=a%fida(1:3)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
if (info /= 0) goto 9999
!!$ call psb_erractionrestore(err_act)

1
base/serial/psb_dsymbmm.f90
Unescape Escape View File

@ -93,6 +93,7 @@ subroutine psb_dsymbmm(a,b,c,info)
c%k=b%k
c%fida='CSR'
c%descra='GUN'
deallocate(itemp)
call psb_erractionrestore(err_act)
return

57
base/serial/psb_dtransp.f90
Unescape Escape View File

@ -36,10 +36,11 @@ subroutine psb_dtransp(a,b,c,fmt)
use psb_spmat_type
use psb_tools_mod
use psb_string_mod
use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo, psb_csdp
use psb_serial_mod, psb_protect_name => psb_dtransp
implicit none
type(psb_dspmat_type) :: a,b
type(psb_dspmat_type), intent(inout) :: a
type(psb_dspmat_type), intent(out) :: b
integer, optional :: c
character(len=*), optional :: fmt
@ -59,55 +60,21 @@ subroutine psb_dtransp(a,b,c,fmt)
fmt_='CSR'
endif
if (.true.) then
if (allocated(b%aspk)) call psb_sp_free(b,info)
b%fida = 'COO'
b%descra = 'GUN'
call psb_csdp(a,b,info)
!!$ write(0,*) 'Check from CSDP',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_)
if (info /= 0) then
write(0,*) 'transp: info from CSDP ',info
return
end if
else
if (allocated(b%aspk)) call psb_sp_free(b,info)
call psb_sp_clone(a,b,info)
if (b%fida=='CSR') then
call psb_ipcsr2coo(b,info)
else if (b%fida=='COO') then
! do nothing
else
write(0,*) 'Unimplemented case in TRANSP '
endif
!!$ write(0,*) 'Check from CLONE',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_)
endif
!!$ nz = b%infoa(nnz_)
!!$ write(0,*) 'TRANSP CHECKS:',a%m,a%k,&
!!$ &minval(b%ia1(1:nz)),maxval(b%ia1(1:nz)),&
!!$ &minval(b%ia2(1:nz)),maxval(b%ia2(1:nz))
call psb_nullify_sp(b)
call psb_spcnv(a,b,info,afmt='coo')
if (info /= 0) then
write(0,*) 'transp: info from CSDP ',info
return
end if
call psb_transfer(b%ia1,itmp,info)
call psb_transfer(b%ia2,b%ia1,info)
call psb_transfer(itmp,b%ia2,info)
b%m = a%k
b%k = a%m
!!$ write(0,*) 'Calling IPCOO2CSR from transp90 ',b%m,b%k
if (fmt_=='CSR') then
call psb_ipcoo2csr(b,info)
b%fida='CSR'
else if (fmt_=='COO') then
call psb_fixcoo(b,info)
b%fida='COO'
else
call psb_nullify_sp(tmp)
call psb_sp_clone(b,tmp,info)
b%fida=fmt_
call psb_csdp(tmp,b,info)
!!!!!! ADD HERE ERRPUSH!!!
call psb_sp_free(tmp,info)
endif
call psb_spcnv(b,info,afmt=fmt_)
return
end subroutine psb_dtransp

613
base/serial/psb_regen_mod.f90
Unescape Escape View File

@ -0,0 +1,613 @@
module psb_regen_mod
interface csr_regen
module procedure csr_dsp_regen, csr_zsp_regen
end interface
interface coo_regen
module procedure coo_dsp_regen, coo_zsp_regen
end interface
interface jad_regen
module procedure jad_dsp_regen, jad_zsp_regen
end interface
contains
subroutine csr_dsp_regen(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_dspmat_type), intent(inout) :: a
integer :: info
integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
real(kind(1.d0)), allocatable :: work(:)
integer :: err_act
character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,a,info))
case(psb_upd_perm_)
allocate(work(size(a%aspk)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
ip2 = a%ia2(ip1+psb_ip2_)
nnz = a%ia2(ip1+psb_nnz_)
iflag = a%ia2(ip1+psb_iflag_)
ichk = a%ia2(ip1+psb_ichk_)
nnzt = a%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = dzero
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
a%aspk(i) = work(i)
enddo
case(psb_upd_srch_)
! Nothing to be done here.
if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine csr_dsp_regen
subroutine coo_dsp_regen(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_dspmat_type), intent(inout) :: a
integer :: info
integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
real(kind(1.d0)), allocatable :: work(:)
integer :: err_act
character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,a,info))
case(psb_upd_perm_)
allocate(work(size(a%aspk)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
ip2 = a%ia2(ip1+psb_ip2_)
nnz = a%ia2(ip1+psb_nnz_)
iflag = a%ia2(ip1+psb_iflag_)
ichk = a%ia2(ip1+psb_ichk_)
nnzt = a%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = dzero
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
a%aspk(i) = work(i)
enddo
case(psb_upd_srch_)
! Nothing to be done here.
if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine coo_dsp_regen
subroutine jad_dsp_regen(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_dspmat_type), intent(inout) :: a
integer :: info
integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
real(kind(1.d0)), allocatable :: work(:)
integer :: err_act
character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,a,info))
case(psb_upd_perm_)
allocate(work(size(a%aspk)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
ip2 = a%ia1(ip1+psb_ip2_)
nnz = a%ia1(ip1+psb_nnz_)
iflag = a%ia1(ip1+psb_iflag_)
ichk = a%ia1(ip1+psb_ichk_)
nnzt = a%ia1(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = dzero
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(a%ia1(ip2+i-1)) = a%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
a%aspk(i) = work(i)
enddo
case(psb_upd_srch_)
! Nothing to be done here.
if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine jad_dsp_regen
subroutine csr_zsp_regen(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_zspmat_type), intent(inout) :: a
integer :: info
integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
complex(kind(1.d0)), allocatable :: work(:)
integer :: err_act
character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,a,info))
case(psb_upd_perm_)
allocate(work(size(a%aspk)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
ip2 = a%ia2(ip1+psb_ip2_)
nnz = a%ia2(ip1+psb_nnz_)
iflag = a%ia2(ip1+psb_iflag_)
ichk = a%ia2(ip1+psb_ichk_)
nnzt = a%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = zzero
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
a%aspk(i) = work(i)
enddo
case(psb_upd_srch_)
! Nothing to be done here.
if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine csr_zsp_regen
subroutine coo_zsp_regen(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_zspmat_type), intent(inout) :: a
integer :: info
integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
complex(kind(1.d0)), allocatable :: work(:)
integer :: err_act
character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,a,info))
case(psb_upd_perm_)
allocate(work(size(a%aspk)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
ip2 = a%ia2(ip1+psb_ip2_)
nnz = a%ia2(ip1+psb_nnz_)
iflag = a%ia2(ip1+psb_iflag_)
ichk = a%ia2(ip1+psb_ichk_)
nnzt = a%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = zzero
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
a%aspk(i) = work(i)
enddo
case(psb_upd_srch_)
! Nothing to be done here.
if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine coo_zsp_regen
subroutine jad_zsp_regen(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_zspmat_type), intent(inout) :: a
integer :: info
integer :: i,j, k, ip1,ip2,nnz,iflag,ichk,nnzt
complex(kind(1.d0)), allocatable :: work(:)
integer :: err_act
character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,a,info))
case(psb_upd_perm_)
allocate(work(size(a%aspk)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
ip2 = a%ia1(ip1+psb_ip2_)
nnz = a%ia1(ip1+psb_nnz_)
iflag = a%ia1(ip1+psb_iflag_)
ichk = a%ia1(ip1+psb_ichk_)
nnzt = a%ia1(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = zzero
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(a%ia1(ip2+i-1)) = a%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
a%aspk(i) = work(i)
enddo
case(psb_upd_srch_)
! Nothing to be done here.
if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine jad_zsp_regen
end module psb_regen_mod

591
base/serial/psb_update_mod.f90
Unescape Escape View File

@ -30,12 +30,6 @@
!!$
module psb_update_mod
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
interface psb_srch_upd
module procedure psb_d_srch_upd, psb_z_srch_upd
end interface
@ -48,11 +42,21 @@ module psb_update_mod
module procedure d_csr_srch_upd, z_csr_srch_upd
end interface
interface jad_srch_upd
module procedure d_jad_srch_upd, z_jad_srch_upd
end interface
contains
subroutine psb_d_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_serial_mod
implicit none
type(psb_dspmat_type), intent(inout) :: a
@ -62,7 +66,7 @@ contains
real(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
info = 0
if (present(gtl)) then
@ -70,44 +74,34 @@ contains
info = -1
return
endif
select case(toupper(a%fida))
case ('CSR')
!!$ write(0,*) 'Calling csr_srch_upd'
call csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
!!$ write(0,*) 'From csr_srch_upd:',info
case ('COO')
call coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
case default
info = -9
end select
else
select case(toupper(a%fida))
case ('CSR')
!!$ write(0,*) 'Calling csr_srch_upd'
call csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info)
!!$ write(0,*) 'From csr_srch_upd:',info
case ('COO')
call coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info)
case default
info = -9
end select
end if
select case(tolower(a%fida))
case ('csr')
call csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
case ('coo')
call coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
case ('jad')
call jad_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
case default
info = -9
end select
end subroutine psb_d_srch_upd
subroutine psb_z_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_serial_mod
implicit none
type(psb_zspmat_type), intent(inout) :: a
@ -117,7 +111,7 @@ contains
complex(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
info = 0
if (present(gtl)) then
@ -125,7 +119,7 @@ contains
info = -1
return
endif
select case(toupper(a%fida))
case ('CSR')
!!$ write(0,*) 'Calling csr_srch_upd'
@ -135,11 +129,11 @@ contains
case ('COO')
call coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
case default
info = -9
end select
else
select case(toupper(a%fida))
@ -151,11 +145,11 @@ contains
case ('COO')
call coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info)
case default
info = -9
end select
end if
@ -164,6 +158,12 @@ contains
subroutine d_csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_serial_mod
implicit none
type(psb_dspmat_type), intent(inout) :: a
@ -387,6 +387,12 @@ contains
subroutine d_coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_serial_mod
implicit none
type(psb_dspmat_type), intent(inout) :: a
@ -583,9 +589,252 @@ contains
end subroutine d_coo_srch_upd
subroutine d_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_serial_mod
implicit none
type(psb_dspmat_type), intent(inout), target :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza
real(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, pointer :: ia1(:), ia2(:), ia3(:),&
& ja_(:), ka_(:)
integer, allocatable :: indices(:), blks(:), rows(:)
integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr, nzin_,&
& i,j,k,nr,dupl, ii, ir, ic
info = 0
dupl = psb_sp_getifld(psb_dupl_,a,info)
png = a%ia2(1) ! points to the number of blocks
pia = a%ia2(2) ! points to the beginning of ia(3,png)
pja = a%ia2(3) ! points to the beginning of ja(:)
ngr = a%ia2(png) ! the number of blocks
ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk
ka_ => a%ia1(:) ! the array containing the column indices
ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index
! of each block
ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos.
! in ja to the first jad column
ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos.
! in ja to the first csr column
if (a%pl(1) /= 0) then
if (present(gtl)) then
if (.not.present(ng)) then
info = -1
return
endif
allocate(rows(nz),stat=info)
if (info /= 0) then
info = -4010
return
endif
j=0
do i=1,nz
ir = ia(i)
if ((ir >=1).and.(ir<=ng)) then
ir = gtl(ir)
j = j + 1
rows(j) = ir
endif
enddo
call psb_msort_unique(rows(1:j),nr)
allocate(indices(nr),blks(nr),stat=info)
if (info /= 0) then
info = -4010
return
endif
do i=1,nr
indices(i)=a%pl(rows(i))
j=0
blkfnd_gtl: do
j=j+1
if(ia1(j).eq.indices(i)) then
blks(i)=j
ipx = ia1(j) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j)+rb
exit blkfnd_gtl
else if(ia1(j).gt.indices(i)) then
blks(i)=j-1
ipx = ia1(j-1) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j-1)+rb
exit blkfnd_gtl
end if
end do blkfnd_gtl
end do
! cycle over elements
update_gtl: do ii=1,nz
ir = ia(ii)
ic = ja(ii)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
if ((ir > 0).and.(ir <= a%m)) then
ic = gtl(ic)
call ibsrch(i,ir,nr,rows)
! find which block the row belongs to
blk = blks(i)
! extract first part of the row from the jad block
ipx = ia1(blk) ! the first row index of the block
k_pt= ia2(blk) ! the pointer to the beginning of a column in ja
rb = indices(i)-ipx ! the row offset within the block
npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block
do col = ia2(blk), ia3(blk)-1
if (ic == ka_(ja_(col)+rb)) then
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
a%aspk(ja_(col)+rb) = val(ii)
case(psb_dupl_add_)
a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii)
end select
cycle update_gtl
endif
end do
! extract second part of the row from the csr tail just in case
row=ia3(blk)+rb
do j=ja_(row), ja_(row+1)-1
if (ic == ka_(j)) then
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
a%aspk(j) = val(ii)
case(psb_dupl_add_)
a%aspk(j) = a%aspk(j) + val(ii)
end select
cycle update_gtl
endif
end do
end if
end if
end do update_gtl
else
allocate(rows(nz),stat=info)
if (info /= 0) then
info = -4010
return
endif
j=0
do i=1,nz
ir = ia(i)
if ((ir >=1).and.(ir<=a%m)) then
j = j + 1
rows(j) = ir
endif
enddo
call psb_msort_unique(rows(1:j),nr)
allocate(indices(nr),blks(nr),stat=info)
if (info /= 0) then
info = -4010
return
endif
do i=1,nr
indices(i)=a%pl(rows(i))
j=0
blkfnd: do
j=j+1
if(ia1(j).eq.indices(i)) then
blks(i)=j
ipx = ia1(j) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j)+rb
exit blkfnd
else if(ia1(j).gt.indices(i)) then
blks(i)=j-1
ipx = ia1(j-1) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j-1)+rb
exit blkfnd
end if
end do blkfnd
end do
! cycle over elements
update: do ii=1,nz
ir = ia(ii)
ic = ja(ii)
if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then
call ibsrch(i,ir,nr,rows)
! find which block the row belongs to
blk = blks(i)
! extract first part of the row from the jad block
ipx = ia1(blk) ! the first row index of the block
k_pt= ia2(blk) ! the pointer to the beginning of a column in ja
rb = indices(i)-ipx ! the row offset within the block
npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block
do col = ia2(blk), ia3(blk)-1
if (ic == ka_(ja_(col)+rb)) then
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
a%aspk(ja_(col)+rb) = val(ii)
case(psb_dupl_add_)
a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii)
end select
cycle update
endif
end do
! extract second part of the row from the csr tail just in case
row=ia3(blk)+rb
do j=ja_(row), ja_(row+1)-1
if (ic == ka_(j)) then
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
a%aspk(j) = val(ii)
case(psb_dupl_add_)
a%aspk(j) = a%aspk(j) + val(ii)
end select
cycle update
endif
end do
end if
end do update
end if
else
! There might be some problems
info=134
end if
end subroutine d_jad_srch_upd
subroutine z_csr_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_serial_mod
implicit none
type(psb_zspmat_type), intent(inout) :: a
@ -801,6 +1050,12 @@ contains
subroutine z_coo_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_serial_mod
implicit none
type(psb_zspmat_type), intent(inout) :: a
@ -813,7 +1068,7 @@ contains
integer :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nc,lb,ub,m,nnz,dupl,isrt
logical, parameter :: debug=.false.
info = 0
dupl = psb_sp_getifld(psb_dupl_,a,info)
@ -997,5 +1252,245 @@ contains
end subroutine z_coo_srch_upd
subroutine z_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng)
use psb_spmat_type
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_serial_mod
implicit none
type(psb_zspmat_type), intent(inout), target :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl
integer, intent(in) :: ia(*),ja(*)
integer, intent(inout) :: nza
complex(kind(1.d0)), intent(in) :: val(*)
integer, intent(out) :: info
integer, intent(in), optional :: ng,gtl(*)
integer, pointer :: ia1(:), ia2(:), ia3(:),&
& ja_(:), ka_(:)
integer, allocatable :: indices(:), blks(:), rows(:)
integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr, nzin_,&
& i,j,k,nr,dupl, ii, ir, ic
info = 0
dupl = psb_sp_getifld(psb_dupl_,a,info)
png = a%ia2(1) ! points to the number of blocks
pia = a%ia2(2) ! points to the beginning of ia(3,png)
pja = a%ia2(3) ! points to the beginning of ja(:)
ngr = a%ia2(png) ! the number of blocks
ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk
ka_ => a%ia1(:) ! the array containing the column indices
ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index
! of each block
ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos.
! in ja to the first jad column
ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos.
! in ja to the first csr column
if (a%pl(1) /= 0) then
if (present(gtl)) then
if (.not.present(ng)) then
info = -1
return
endif
allocate(rows(nz),stat=info)
if (info /= 0) then
info = -4010
return
endif
j=0
do i=1,nz
ir = ia(i)
if ((ir >=1).and.(ir<=ng)) then
ir = gtl(ir)
j = j + 1
rows(j) = ir
endif
enddo
call psb_msort_unique(rows(1:j),nr)
allocate(indices(nr),blks(nr),stat=info)
if (info /= 0) then
info = -4010
return
endif
do i=1,nr
indices(i)=a%pl(rows(i))
j=0
blkfnd_gtl: do
j=j+1
if(ia1(j).eq.indices(i)) then
blks(i)=j
ipx = ia1(j) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j)+rb
exit blkfnd_gtl
else if(ia1(j).gt.indices(i)) then
blks(i)=j-1
ipx = ia1(j-1) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j-1)+rb
exit blkfnd_gtl
end if
end do blkfnd_gtl
end do
! cycle over elements
update_gtl: do ii=1,nz
ir = ia(ii)
ic = ja(ii)
if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
ir = gtl(ir)
if ((ir > 0).and.(ir <= a%m)) then
ic = gtl(ic)
call ibsrch(i,ir,nr,rows)
! find which block the row belongs to
blk = blks(i)
! extract first part of the row from the jad block
ipx = ia1(blk) ! the first row index of the block
k_pt= ia2(blk) ! the pointer to the beginning of a column in ja
rb = indices(i)-ipx ! the row offset within the block
npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block
do col = ia2(blk), ia3(blk)-1
if (ic == ka_(ja_(col)+rb)) then
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
a%aspk(ja_(col)+rb) = val(ii)
case(psb_dupl_add_)
a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii)
end select
cycle update_gtl
endif
end do
! extract second part of the row from the csr tail just in case
row=ia3(blk)+rb
do j=ja_(row), ja_(row+1)-1
if (ic == ka_(j)) then
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
a%aspk(j) = val(ii)
case(psb_dupl_add_)
a%aspk(j) = a%aspk(j) + val(ii)
end select
cycle update_gtl
endif
end do
end if
end if
end do update_gtl
else
allocate(rows(nz),stat=info)
if (info /= 0) then
info = -4010
return
endif
j=0
do i=1,nz
ir = ia(i)
if ((ir >=1).and.(ir<=a%m)) then
j = j + 1
rows(j) = ir
endif
enddo
call psb_msort_unique(rows(1:j),nr)
allocate(indices(nr),blks(nr),stat=info)
if (info /= 0) then
info = -4010
return
endif
do i=1,nr
indices(i)=a%pl(rows(i))
j=0
blkfnd: do
j=j+1
if(ia1(j).eq.indices(i)) then
blks(i)=j
ipx = ia1(j) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j)+rb
exit blkfnd
else if(ia1(j).gt.indices(i)) then
blks(i)=j-1
ipx = ia1(j-1) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j-1)+rb
exit blkfnd
end if
end do blkfnd
end do
! cycle over elements
update: do ii=1,nz
ir = ia(ii)
ic = ja(ii)
if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then
call ibsrch(i,ir,nr,rows)
! find which block the row belongs to
blk = blks(i)
! extract first part of the row from the jad block
ipx = ia1(blk) ! the first row index of the block
k_pt= ia2(blk) ! the pointer to the beginning of a column in ja
rb = indices(i)-ipx ! the row offset within the block
npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block
do col = ia2(blk), ia3(blk)-1
if (ic == ka_(ja_(col)+rb)) then
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
a%aspk(ja_(col)+rb) = val(ii)
case(psb_dupl_add_)
a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii)
end select
cycle update
endif
end do
! extract second part of the row from the csr tail just in case
row=ia3(blk)+rb
do j=ja_(row), ja_(row+1)-1
if (ic == ka_(j)) then
select case(dupl)
case(psb_dupl_ovwrt_,psb_dupl_err_)
a%aspk(j) = val(ii)
case(psb_dupl_add_)
a%aspk(j) = a%aspk(j) + val(ii)
end select
cycle update
endif
end do
end if
end do update
end if
else
! There might be some problems
info=134
end if
end subroutine z_jad_srch_upd
end module psb_update_mod

30
base/serial/psb_zcoins.f90
Unescape Escape View File

@ -38,7 +38,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_realloc_mod
use psb_string_mod
use psb_error_mod
use psb_serial_mod, only : psb_sp_info, psb_csdp
use psb_serial_mod, psb_protect_name => psb_zcoins
use psb_update_mod
implicit none
@ -156,8 +156,12 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
case (psb_upd_perm_)
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
nzl = psb_sp_getifld(psb_del_bnd_,a,info)
nza = a%ia2(ip1+psb_nnz_)
select case(ufida)
case ('JAD')
nza = a%ia1(ip1+psb_nnz_)
case default
nza = a%ia2(ip1+psb_nnz_)
end select
call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
@ -172,11 +176,17 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
write(0,*) 'PSB_COINS: update discarded items '
end if
end if
a%ia2(ip1+psb_nnz_) = nza
select case(ufida)
case ('JAD')
a%ia1(ip1+psb_nnz_) = nza
case default
a%ia2(ip1+psb_nnz_) = nza
end select
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
case (psb_upd_dflt_, psb_upd_srch_)
case (psb_upd_srch_)
call psb_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info,gtl,ng)
@ -187,8 +197,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
& 'COINS: Going through rebuild_ fingers crossed!'
irst = info
call psb_nullify_sp(tmp)
tmp%fida='COO'
call psb_csdp(a,tmp,info)
call psb_spcnv(a,tmp,info,afmt='coo')
if(info /= izero) then
info=4010
ch_err='psb_csdp'
@ -349,7 +358,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
if (debug) write(0,*) 'From COINS(UPD) : NZA:',nza
case (psb_upd_dflt_, psb_upd_srch_)
case (psb_upd_srch_)
call psb_srch_upd(nz,ia,ja,val,nza,a,&
& imin,imax,jmin,jmax,nzl,info)
@ -360,8 +369,7 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
& 'COINS: Going through rebuild_ fingers crossed!'
irst = info
call psb_nullify_sp(tmp)
tmp%fida='COO'
call psb_csdp(a,tmp,info)
call psb_spcnv(a,tmp,info,afmt='coo')
call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info)
if (debug) then
write(0,*) 'COINS Rebuild: size',tmp%infoa(psb_nnz_) ,irst
@ -429,8 +437,6 @@ subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
endif
return
call psb_erractionrestore(err_act)
return

516
base/serial/psb_zcsdp.f90
Unescape Escape View File

@ -1,516 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psb_zcsdp.f90
!
! Subroutine: psb_zcsdp
! This subroutine performs the assembly of
! the local part of a sparse distributed matrix
!
! Parameters:
! a - type(<psb_spmat_type>). The input matrix to be assembled.
! b - type(<psb_spmat_type>). The assembled output matrix.
! info - integer. Eventually returns an error code.
! ifc - integer(optional). ???
! check - character(optional). ???
! trans - character(optional). ???
! unitd - character(optional). ???
!
subroutine psb_zcsdp(a, b,info,ifc,check,trans,unitd,upd,dupl)
use psb_const_mod
use psb_error_mod
use psb_spmat_type
use psb_string_mod
use psb_serial_mod, psb_protect_name => psb_zcsdp
implicit none
!....Parameters...
Type(psb_zspmat_type), intent(in) :: A
Type(psb_zspmat_type), intent(inout) :: B
Integer, intent(out) :: info
Integer, intent(in), optional :: ifc,upd,dupl
character, intent(in), optional :: check,trans,unitd
!...Locals...
complex(kind(1.d0)) :: d(1)
complex(kind(1.d0)), allocatable :: work(:)
type(psb_zspmat_type) :: temp_a
Integer :: nzr, ntry, ifc_, ia1_size,&
& ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_
integer :: ip1, ip2, nnz, iflag, ichk, nnzt,&
& ipc, i, count, err_act, i1, i2, ia
character :: check_,trans_,unitd_
Integer, Parameter :: maxtry=8
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
name='psb_csdp'
info = 0
call psb_erractionsave(err_act)
ntry=0
if (present(ifc)) then
ifc_ = max(1,ifc)
else
ifc_ = 1
endif
if (present(check)) then
check_ = toupper(check)
else
check_ = 'N'
endif
if (present(trans)) then
trans_ = toupper(trans)
else
trans_ = 'N'
endif
if (present(unitd)) then
unitd_ = toupper(unitd)
else
unitd_ = 'U'
endif
if (check_=='R') then
allocate(work(max(size(a%aspk),size(b%aspk))+1000),stat=info)
else
allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info)
endif
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (ifc_<1) then
write(0,*) 'csdp90 Error: invalid ifc ',ifc_
info = -4
call psb_errpush(info,name)
goto 9999
endif
if((check_=='Y').or.(check_=='C')) then
if(toupper(a%fida(1:3))=='CSR') then
call zcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info)
if(info /= 0) then
info=4010
ch_err='dcsrck'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
write(0,'("Check not yet suported for the ",a3," storage format")')a%fida(1:3)
end if
end if
if (check_/='R') then
if (present(upd)) then
call psb_sp_setifld(upd,psb_upd_,b,info)
end if
if (present(dupl)) then
call psb_sp_setifld(dupl,psb_dupl_,b,info)
end if
upd_ = psb_sp_getifld(psb_upd_,b,info)
select case(upd_)
case(psb_upd_dflt_,psb_upd_srch_,psb_upd_perm_)
! Legal value, do nothing
case default
! Fix bad value
upd_ = psb_upd_dflt_
call psb_sp_setifld(upd_,psb_upd_,b,info)
end select
dupl_ = psb_sp_getifld(psb_dupl_,b,info)
select case(dupl_)
case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
! Legal value, do nothing
case default
! Fix bad value
dupl_ = psb_dupl_def_
call psb_sp_setifld(dupl_,psb_dupl_,b,info)
end select
! ...matrix conversion...
b%m=a%m
b%k=a%k
size_req = psb_sp_get_nnzeros(a)
if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!
n_row=b%m
n_col=b%k
call psb_cest(b%fida, n_row,n_col,size_req,&
& ia1_size, ia2_size, aspk_size, upd_,info)
if (info /= psb_no_err_) then
info=4010
ch_err='psb_cest'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (.not.allocated(b%aspk).or.&
&.not.allocated(b%ia1).or.&
&.not.allocated(b%ia2).or.&
&.not.allocated(b%pl).or.&
&.not.allocated(b%pr)) then
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
else if ((size(b%aspk) < aspk_size) .or.&
&(size(b%ia1) < ia1_size) .or.&
&(size(b%ia2) < ia2_size) .or.&
&(size(b%pl) < b%m) .or.&
&(size(b%pr) < b%k )) then
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
endif
if (info /= psb_no_err_) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
b%pl(:) = 0
b%pr(:) = 0
b%descra = a%descra
select case (toupper(a%fida(1:3)))
case ('CSR')
select case (toupper(b%fida(1:3)))
case ('CSR')
call zcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), info)
if (info/=0) then
info=4010
ch_err='dcrcr'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case ('JAD')
!...converting to JAD
!...output matrix may not be big enough
do
call zcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), nzr, info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
endif
ntry = ntry + 1
if (debug) then
write(0,*) 'On out from dcrjad ',nzr,info
end if
if (nzr == 0) exit
if (ntry > maxtry ) then
write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.'
info=2040
call psb_errpush(info,name)
goto 9999
endif
call psb_sp_reall(b,nzr,info,ifc=ifc_)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
end do
if (info/=0) then
call psb_errpush(info,name)
goto 9999
end if
case ('COO')
call zcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrco')
goto 9999
end if
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
case ('COO','COI')
select case (toupper(b%fida(1:3)))
case ('CSR')
call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
case ('JAD')
call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
temp_a%m = a%m
temp_a%k = a%k
!...Dirty trick: converting to CSR and then to JAD
call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, &
& temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, &
& size(temp_a%aspk), size(temp_a%ia1),&
& size(temp_a%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
do
call zcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, &
& temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, &
& b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, &
& size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), nzr, info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
end if
ntry = ntry + 1
if (debug) then
write(0,*) 'On out from dcrjad ',nzr,info
end if
if (nzr == 0) exit
if (ntry > maxtry ) then
write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,&
& ': giving up now.'
info=2040
call psb_errpush(info,name)
goto 9999
endif
call psb_sp_reall(b,nzr,info,ifc=ifc_)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
end do
case ('COO')
call zcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcoco')
goto 9999
end if
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) &
& call psb_sp_trim(b,info)
else if (check_=='R') then
!...Regenerating matrix
if (psb_sp_getifld(psb_state_,b,info) /= psb_spmat_upd_) then
info = 8888
call psb_errpush(info,name)
goto 9999
endif
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,b,info))
case(psb_upd_perm_)
if (debug) write(0,*) 'Regeneration with psb_upd_perm_'
if (toupper(b%fida(1:3))/='JAD') then
ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
ip2 = b%ia2(ip1+psb_ip2_)
nnz = b%ia2(ip1+psb_nnz_)
iflag = b%ia2(ip1+psb_iflag_)
ichk = b%ia2(ip1+psb_ichk_)
nnzt = b%ia2(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = 0.d0
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(b%ia2(ip2+i-1)) = b%aspk(i) + work(b%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
b%aspk(i) = work(i)
enddo
else if (toupper(b%fida(1:3)) == 'JAD') then
ip1 = psb_sp_getifld(psb_upd_pnt_,b,info)
ip2 = b%ia1(ip1+psb_ip2_)
count = b%ia1(ip1+psb_zero_)
ipc = b%ia1(ip1+psb_ipc_)
nnz = b%ia1(ip1+psb_nnz_)
iflag = b%ia1(ip1+psb_iflag_)
ichk = b%ia1(ip1+psb_ichk_)
nnzt = b%ia1(ip1+psb_nnzt_)
if (debug) write(*,*) 'Regeneration start: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt,count, &
& iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 10
write(*,*) 'Regeneration start error: ',&
& b%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz+count
work(i) = 0.d0
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(b%ia1(ip2+i-1)) = b%aspk(i) + work(b%ia1(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz+count
b%aspk(i) = work(i)
enddo
do i=1, count
b%aspk(b%ia1(ipc+i-1)) = 0.d0
end do
endif
case(psb_upd_dflt_,psb_upd_srch_)
! Nothing to be done here.
if (debug) write(0,*) 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
end if
call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_zcsdp

170
base/serial/psb_zfixcoo.f90
Unescape Escape View File

@ -32,10 +32,12 @@
! Subroutine:
! Parameters:
Subroutine psb_zfixcoo(A,INFO,idir)
Subroutine psb_zfixcoo(a,info,idir)
use psb_spmat_type
use psb_const_mod
use psb_string_mod
use psb_serial_mod, psb_protect_name => psb_zfixcoo
use psb_error_mod
implicit none
!....Parameters...
@ -45,11 +47,14 @@ Subroutine psb_zfixcoo(A,INFO,idir)
integer, allocatable :: iaux(:)
!locals
Integer :: nza, nzl,iret,idir_
integer :: i,j, irw, icl
Integer :: nza, nzl,iret,idir_, dupl_
integer :: i,j, irw, icl, err_act
logical, parameter :: debug=.false.
character(len=20) :: name = 'psb_fixcoo'
info = 0
call psb_erractionsave(err_act)
if(debug) write(0,*)'fixcoo: ',size(a%ia1),size(a%ia2)
if (toupper(a%fida) /= 'COO') then
write(0,*) 'Fixcoo Invalid input ',a%fida
@ -62,9 +67,11 @@ Subroutine psb_zfixcoo(A,INFO,idir)
idir_ = 0
endif
nza = a%infoa(psb_nnz_)
nza = psb_sp_getifld(psb_nnz_,a,info)
if (nza < 2) return
dupl_ = psb_sp_getifld(psb_dupl_,a,info)
allocate(iaux(nza+2),stat=info)
if (info /= 0) return
@ -92,22 +99,61 @@ Subroutine psb_zfixcoo(A,INFO,idir)
irw = a%ia1(i)
icl = a%ia2(i)
j = 1
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(i) + a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
a%infoa(psb_nnz_) = i
a%infoa(psb_srtd_) = psb_isrtdcoo_
select case(dupl_)
case(psb_dupl_ovwrt_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
case(psb_dupl_add_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(i) + a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
case(psb_dupl_err_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
call psb_errpush(130,name)
goto 9999
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
end select
if(debug) write(0,*)'FIXCOO: end second loop'
@ -133,29 +179,79 @@ Subroutine psb_zfixcoo(A,INFO,idir)
irw = a%ia1(i)
icl = a%ia2(i)
j = 1
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(i) + a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
a%infoa(psb_nnz_) = i
a%infoa(psb_srtd_) = psb_isrtdcoo_
select case(dupl_)
case(psb_dupl_ovwrt_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
case(psb_dupl_add_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
a%aspk(i) = a%aspk(i) + a%aspk(j)
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
case(psb_dupl_err_)
do
j = j + 1
if (j > nza) exit
if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then
call psb_errpush(130,name)
goto 9999
else
i = i+1
a%aspk(i) = a%aspk(j)
a%ia1(i) = a%ia1(j)
a%ia2(i) = a%ia2(j)
irw = a%ia1(i)
icl = a%ia2(i)
endif
enddo
end select
if(debug) write(0,*)'FIXCOO: end second loop'
case default
write(0,*) 'Fixcoo: unknown direction ',idir_
end select
a%infoa(psb_upd_) = psb_upd_srch_
call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info)
call psb_sp_setifld(i,psb_nnz_,a,info)
call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info)
call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info)
deallocate(iaux)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end Subroutine psb_zfixcoo

5
base/serial/psb_zipcoo2csc.f90
Unescape Escape View File

@ -35,7 +35,7 @@
subroutine psb_zipcoo2csc(a,info,clshr)
use psb_spmat_type
use psb_const_mod
use psb_serial_mod, only : psb_fixcoo
use psb_serial_mod, psb_protect_name => psb_zipcoo2csc
use psb_error_mod
use psb_string_mod
use psb_realloc_mod
@ -49,7 +49,7 @@ subroutine psb_zipcoo2csc(a,info,clshr)
integer, allocatable :: iaux(:), itemp(:)
!locals
logical :: clshr_
Integer :: nza, i,j,irw, idl,err_act,nc,icl
Integer :: nza, nr, i,j, idl,err_act,nc,icl
Integer, Parameter :: maxtry=8
logical, parameter :: debug=.false.
character(len=20) :: name
@ -107,7 +107,6 @@ subroutine psb_zipcoo2csc(a,info,clshr)
if (clshr_) then
j = 1
i = 1
icl = itemp(j)

2
base/serial/psb_zipcsr2coo.f90
Unescape Escape View File

@ -38,6 +38,7 @@ Subroutine psb_zipcsr2coo(a,info)
use psb_error_mod
use psb_string_mod
use psb_realloc_mod
use psb_serial_mod, psb_protect_name => psb_zipcsr2coo
implicit none
!....Parameters...
@ -86,6 +87,7 @@ Subroutine psb_zipcsr2coo(a,info)
a%infoa(psb_upd_) = psb_upd_srch_
deallocate(itemp)
call psb_fixcoo(a,info)
call psb_erractionrestore(err_act)
return

553
base/serial/psb_zspcnv.f90
Unescape Escape View File

@ -0,0 +1,553 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psb_dcsdp.f90
!
! Subroutine: psb_dcsdp
! This subroutine performs the assembly of
! the local part of a sparse distributed matrix
!
! Parameters:
! a - type(<psb_spmat_type>). The input matrix to be assembled.
! b - type(<psb_spmat_type>). The assembled output matrix.
! info - integer. Eventually returns an error code.
! ifc - integer(optional). ???
! check - character(optional). ???
! trans - character(optional). ???
! unitd - character(optional). ???
!
subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl)
use psb_const_mod
use psb_error_mod
use psb_spmat_type
use psb_string_mod
use psb_serial_mod, psb_protect_name => psb_zspcnv2
implicit none
!....Parameters...
Type(psb_zspmat_type), intent(in) :: A
Type(psb_zspmat_type), intent(out) :: B
Integer, intent(out) :: info
Integer, intent(in), optional :: upd,dupl
character(len=*), optional, intent(in) :: afmt
!...Locals...
complex(kind(1.d0)) :: d(1)
complex(kind(1.d0)), allocatable :: work(:)
type(psb_zspmat_type) :: temp_a
Integer :: nzr, ntry, ifc_, ia1_size,&
& ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_
integer :: ip1, ip2, nnz, iflag, ichk, nnzt,&
& ipc, i, count, err_act, i1, i2, ia
character :: check_,trans_,unitd_
character(len=5) :: afmt_
Integer, Parameter :: maxtry=8
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
ntry=0
ifc_ = 2
check_ = 'N'
trans_ = 'N'
unitd_ = 'U'
allocate(work(max(size(a%ia1),size(a%ia2))+max(a%m,b%m)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (present(upd)) then
call psb_sp_setifld(upd,psb_upd_,b,info)
end if
if (present(dupl)) then
call psb_sp_setifld(dupl,psb_dupl_,b,info)
end if
if (present(afmt)) then
afmt_ = afmt
else
afmt_ = psb_fidef_
end if
upd_ = psb_sp_getifld(psb_upd_,b,info)
select case(upd_)
case(psb_upd_srch_,psb_upd_perm_)
! Legal value, do nothing
case default
! Fix bad value
upd_ = psb_upd_dflt_
call psb_sp_setifld(upd_,psb_upd_,b,info)
end select
dupl_ = psb_sp_getifld(psb_dupl_,b,info)
select case(dupl_)
case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
! Legal value, do nothing
case default
! Fix bad value
dupl_ = psb_dupl_def_
call psb_sp_setifld(dupl_,psb_dupl_,b,info)
end select
! ...matrix conversion...
b%m=a%m
b%k=a%k
b%fida=afmt_
size_req = psb_sp_get_nnzeros(a)
if (debug) write(0,*) 'DCSDP : size_req 1:',size_req
!
n_row=b%m
n_col=b%k
call psb_cest(afmt_,n_row,n_col,size_req,&
& ia1_size, ia2_size, aspk_size, upd_,info)
b%fida=afmt_
if (info /= psb_no_err_) then
info=4010
ch_err='psb_cest'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (.not.allocated(b%aspk).or.&
&.not.allocated(b%ia1).or.&
&.not.allocated(b%ia2).or.&
&.not.allocated(b%pl).or.&
&.not.allocated(b%pr)) then
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
else if ((size(b%aspk) < aspk_size) .or.&
&(size(b%ia1) < ia1_size) .or.&
&(size(b%ia2) < ia2_size) .or.&
&(size(b%pl) < b%m) .or.&
&(size(b%pr) < b%k )) then
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
endif
if (info /= psb_no_err_) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
b%pl(:) = 0
b%pr(:) = 0
b%descra = a%descra
select case (tolower(a%fida))
case ('csr')
select case (tolower(b%fida))
case ('csr')
call zcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), info)
if (info/=0) then
info=4010
ch_err='dcrcr'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case ('jad')
!...converting to JAD
!...output matrix may not be big enough
do
call zcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), nzr, info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
endif
ntry = ntry + 1
if (debug) then
write(0,*) 'On out from dcrjad ',nzr,info
end if
if (nzr == 0) exit
if (ntry > maxtry ) then
write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,': giving up now.'
info=2040
call psb_errpush(info,name)
goto 9999
endif
call psb_cest(afmt_,n_row,n_col,nzr,&
& ia1_size, ia2_size, aspk_size, upd_,info)
call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
end do
if (info/=0) then
call psb_errpush(info,name)
goto 9999
end if
case ('coo')
if (debug) write(0,*) 'Calling CRCO ',a%descra
call zcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrco')
goto 9999
end if
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
case ('coo','coi')
select case (tolower(b%fida))
case ('csr')
call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
case ('jad')
call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
temp_a%m = a%m
temp_a%k = a%k
temp_a%infoa=b%infoa
!...Dirty trick: converting to CSR and then to JAD
call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, &
& temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, &
& size(temp_a%aspk), size(temp_a%ia1),&
& size(temp_a%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
do
call zcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, &
& temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, &
& b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, &
& size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), nzr, info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
end if
ntry = ntry + 1
if (debug) then
write(0,*) 'On out from dcrjad ',nzr,info
end if
if (nzr == 0) exit
if (ntry > maxtry ) then
write(0,*) 'Tried reallocating for DCRJAD for ',maxtry,&
& ': giving up now.'
info=2040
call psb_errpush(info,name)
goto 9999
endif
call psb_sp_reall(b,nzr,info,ifc=ifc_)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
endif
end do
case ('coo')
call zcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcoco')
goto 9999
end if
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
case default
info=4010
call psb_errpush(info,name)
goto 9999
end select
if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) &
& call psb_sp_trim(b,info)
call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_zspcnv2
subroutine psb_zspcnv1(a, info, afmt, upd, dupl)
use psb_spmat_type
use psb_regen_mod
use psb_serial_mod, psb_protect_name => psb_zspcnv1
use psb_const_mod
use psi_mod
use psb_error_mod
use psb_string_mod
!use psb_penv_mod
implicit none
!...Parameters....
type(psb_zspmat_type), intent (inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
integer :: int_err(5)
type(psb_zspmat_type) :: atemp
integer :: np,me,n_col,iout, err_act
integer :: spstate
integer :: upd_, dupl_
integer :: ictxt,n_row
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name, ch_err
info = 0
int_err(1)=0
name = 'psb_spcnv'
call psb_erractionsave(err_act)
if (present(upd)) then
call psb_sp_setifld(upd,psb_upd_,a,info)
end if
if (present(dupl)) then
call psb_sp_setifld(dupl,psb_dupl_,a,info)
end if
upd_ = psb_sp_getifld(psb_upd_,a,info)
select case(upd_)
case(psb_upd_srch_,psb_upd_perm_)
! Legal value, do nothing
case default
! Fix bad value
upd_ = psb_upd_dflt_
call psb_sp_setifld(upd_,psb_upd_,a,info)
end select
dupl_ = psb_sp_getifld(psb_dupl_,a,info)
select case(dupl_)
case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
! Legal value, do nothing
case default
! Fix bad value
dupl_ = psb_dupl_def_
call psb_sp_setifld(dupl_,psb_dupl_,a,info)
end select
spstate = psb_sp_getifld(psb_state_,a,info)
if (info /= 0) then
goto 9999
endif
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
if (spstate /= psb_spmat_upd_) then
! Should we first figure out if we can do it in place?
if (debug) write(0,*) 'Update:',upd_,psb_upd_srch_,psb_upd_perm_
if (upd_ == psb_upd_srch_) then
if (present(afmt)) then
select case (tolower(a%fida))
case('coo')
select case(tolower(afmt))
case('coo')
call psb_fixcoo(a,info)
goto 9998
case('csr')
call psb_ipcoo2csr(a,info)
goto 9998
case('csc')
call psb_ipcoo2csc(a,info)
goto 9998
end select
case('csr')
select case(tolower(afmt))
case('coo')
call psb_ipcsr2coo(a,info)
goto 9998
end select
end select
end if
end if
call psb_sp_clone(a,atemp,info)
if(info /= psb_no_err_) then
info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
! convert to user requested format after the temp copy
end if
if (debugwrt) then
iout = 30+me
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
! Do the real conversion into the requested storage format
! result is put in A
call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl)
IF (debug) WRITE (*, *) me,' ASB: From SPCNV',info,' ',A%FIDA
if (info /= psb_no_err_) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debugwrt) then
iout = 60+me
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
call psb_sp_free(atemp,info)
else if (spstate == psb_spmat_upd_) then
!
! Second case: we come from an update loop.
!
select case(tolower(a%fida))
case('csr')
call csr_regen(a,info)
case ('coo','coi')
call coo_regen(a,info)
case('jad')
call jad_regen(a,info)
case default
info=136
ch_err=a%fida
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
! check on error retuned by dcsdp
if (info /= psb_no_err_) then
info = 4010
ch_err='xx_regen'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
info = 600
call psb_errpush(info,name)
goto 9999
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
endif
9998 continue
call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_zspcnv1

28
base/serial/psb_zspgetrow.f90
Unescape Escape View File

@ -87,21 +87,19 @@ subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
nzin_ = 0
endif
if (toupper(a%fida) == 'CSR') then
call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
else if (toupper(a%fida) == 'COO') then
call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
else if (toupper(a%fida) == 'JAD') then
call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
else
info=136
ch_err=a%fida(1:3)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
select case (tolower(a%fida))
case ('csr')
call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
case ('coo')
call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
case ('jad')
call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren)
case default
info=136
ch_err=a%fida(1:3)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end select
if (info /= 0) goto 9999
!!$ call psb_erractionrestore(err_act)

57
base/serial/psb_ztransc.f90
Unescape Escape View File

@ -36,11 +36,11 @@ subroutine psb_ztransc(a,b,c,fmt)
use psb_spmat_type
use psb_tools_mod
use psb_string_mod
use psb_realloc_mod
use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo, psb_csdp
use psb_serial_mod, psb_protect_name => psb_ztransc
implicit none
type(psb_zspmat_type) :: a,b
type(psb_zspmat_type), intent(inout) :: a
type(psb_zspmat_type), intent(out) :: b
integer, optional :: c
character(len=*), optional :: fmt
@ -59,55 +59,26 @@ subroutine psb_ztransc(a,b,c,fmt)
else
fmt_='CSR'
endif
if (.true.) then
if (allocated(b%aspk)) call psb_sp_free(b,info)
b%fida = 'COO'
b%descra = 'GUN'
call psb_csdp(a,b,info)
!!$ write(0,*) 'Check from CSDP',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_)
if (info /= 0) then
write(0,*) 'transp: info from CSDP ',info
return
end if
else
if (allocated(b%aspk)) call psb_sp_free(b,info)
call psb_sp_clone(a,b,info)
if (b%fida=='CSR') then
call psb_ipcsr2coo(b,info)
else if (b%fida=='COO') then
! do nothing
else
write(0,*) 'Unimplemented case in TRANSC '
endif
endif
call psb_nullify_sp(b)
call psb_spcnv(a,b,info,afmt='coo')
if (info /= 0) then
write(0,*) 'transp: info from CSDP ',info
return
end if
call psb_transfer(b%ia1,itmp,info)
call psb_transfer(b%ia2,b%ia1,info)
call psb_transfer(itmp,b%ia2,info)
b%m = a%k
b%k = a%m
do i=1, b%infoa(psb_nnz_)
b%aspk(i) = conjg(b%aspk(i))
end do
if (fmt_=='CSR') then
call psb_ipcoo2csr(b,info)
b%fida='CSR'
else if (fmt_=='COO') then
call psb_fixcoo(b,info)
b%fida='COO'
else
call psb_nullify_sp(tmp)
call psb_sp_clone(b,tmp,info)
b%fida=fmt_
call psb_csdp(tmp,b,info)
!!!!!! ADD HERE ERRPUSH!!!
call psb_sp_free(tmp,info)
endif
b%m = a%k
b%k = a%m
call psb_spcnv(b,info,afmt=fmt_)
return
end subroutine psb_ztransc

54
base/serial/psb_ztransp.f90
Unescape Escape View File

@ -36,11 +36,11 @@ subroutine psb_ztransp(a,b,c,fmt)
use psb_spmat_type
use psb_tools_mod
use psb_string_mod
use psb_realloc_mod
use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo, psb_csdp
use psb_serial_mod, psb_protect_name => psb_ztransp
implicit none
type(psb_zspmat_type) :: a,b
type(psb_zspmat_type), intent(inout) :: a
type(psb_zspmat_type), intent(out) :: b
integer, optional :: c
character(len=*), optional :: fmt
@ -60,51 +60,21 @@ subroutine psb_ztransp(a,b,c,fmt)
fmt_='CSR'
endif
if (.true.) then
if (allocated(b%aspk)) call psb_sp_free(b,info)
b%fida = 'COO'
b%descra = 'GUN'
call psb_csdp(a,b,info)
!!$ write(0,*) 'Check from CSDP',b%m,b%k,b%fida,b%descra,b%infoa(psb_nnz_)
if (info /= 0) then
write(0,*) 'transp: info from CSDP ',info
return
end if
else
if (allocated(b%aspk)) call psb_sp_free(b,info)
call psb_sp_clone(a,b,info)
if (b%fida=='CSR') then
call psb_ipcsr2coo(b,info)
else if (b%fida=='COO') then
! do nothing
else
write(0,*) 'Unimplemented case in TRANSP '
endif
endif
call psb_nullify_sp(b)
call psb_spcnv(a,b,info,afmt='coo')
if (info /= 0) then
write(0,*) 'transp: info from CSDP ',info
return
end if
call psb_transfer(b%ia1,itmp,info)
call psb_transfer(b%ia2,b%ia1,info)
call psb_transfer(itmp,b%ia2,info)
b%m = a%k
b%k = a%m
if (fmt_=='CSR') then
call psb_ipcoo2csr(b,info)
b%fida='CSR'
else if (fmt_=='COO') then
call psb_fixcoo(b,info)
b%fida='COO'
else
call psb_nullify_sp(tmp)
call psb_sp_clone(b,tmp,info)
b%fida=fmt_
call psb_csdp(tmp,b,info)
!!!!!! ADD HERE ERRPUSH!!!
call psb_sp_free(tmp,info)
endif
call psb_spcnv(b,info,afmt=fmt_)
return
end subroutine psb_ztransp

4
base/tools/Makefile
Unescape Escape View File

@ -6,11 +6,11 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_cdprt.o \
psb_cdfree.o psb_cdins.o \
psb_cdren.o psb_cdrep.o psb_cdtransfer.o psb_get_overlap.o\
psb_dspalloc.o psb_dspasb.o \
psb_dspcnv.o psb_dspfree.o psb_dspins.o psb_dsprn.o \
psb_dspfree.o psb_dspins.o psb_dsprn.o \
psb_glob_to_loc.o psb_ialloc.o psb_iasb.o \
psb_ifree.o psb_iins.o psb_loc_to_glob.o\
psb_zallc.o psb_zasb.o psb_zfree.o psb_zins.o \
psb_zspalloc.o psb_zspasb.o psb_zspcnv.o psb_zspfree.o\
psb_zspalloc.o psb_zspasb.o psb_zspfree.o\
psb_zspins.o psb_zsprn.o psb_zcdovr.o psb_zgelp.o
MPFOBJS = psb_dsphalo.o psb_zsphalo.o psb_icdasb.o psb_dcdovr.o psb_zcdovr.o

10
base/tools/psb_dspalloc.f90
Unescape Escape View File

@ -117,16 +117,6 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
goto 9999
end if
! set permutation matrices
a%pl(1)=0
a%pr(1)=0
! set infoa fields
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(psb_nnz_) = 0
a%infoa(psb_srtd_) = 0
a%infoa(psb_state_) = psb_spmat_bld_
if (debug) write(0,*) 'spall: ', &
& psb_cd_get_dectype(desc_a),psb_desc_bld_

125
base/tools/psb_dspasb.f90
Unescape Escape View File

@ -60,12 +60,12 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5
character(len=*), optional, intent(in) :: afmt
!....Locals....
integer :: int_err(5)
type(psb_dspmat_type) :: atemp
integer :: np,me,n_col,iout, err_act
integer :: dscstate, spstate
integer :: spstate
integer :: upd_, dupl_
integer :: ictxt,n_row
logical, parameter :: debug=.false., debugwrt=.false.
@ -77,7 +77,6 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
dscstate = psb_cd_get_dectype(desc_a)
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
@ -89,9 +88,9 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
goto 9999
endif
if (.not.psb_is_asb_dec(dscstate)) then
if (.not.psb_is_asb_desc(desc_a)) then
info = 600
int_err(1) = dscstate
int_err(1) = psb_cd_get_dectype(desc_a)
call psb_errpush(info,name)
goto 9999
endif
@ -105,121 +104,21 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl)
!
! First case: we come from a fresh build.
!
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
!
! Second step: handle the local matrix part.
!
if (present(upd)) then
upd_=upd
else
upd_ = psb_upd_dflt_
endif
if (present(dupl)) then
select case(dupl)
case (psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
dupl_ = dupl
case default
dupl_ = psb_dupl_def_
end select
else
dupl_ = psb_dupl_def_
endif
a%m = n_row
a%k = n_col
end if
call psb_sp_clone(a,atemp,info)
if(info /= psb_no_err_) then
info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
! convert to user requested format after the temp copy
end if
if (present(afmt)) then
a%fida = afmt
else
a%fida = '???'
endif
if (debugwrt) then
iout = 30+me
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
! Do the real conversion into the requested storage format
! result is put in A
call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_)
IF (debug) WRITE (*, *) me,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= psb_no_err_) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debugwrt) then
iout = 60+me
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
call psb_sp_free(atemp,info)
else if (spstate == psb_spmat_upd_) then
!
! Second case: we come from an update loop.
!
! Right now, almost nothing to be done, but this
! may change in the future
! as we revise the implementation of the update routine.
call psb_sp_all(atemp,1,info)
atemp%m=a%m
atemp%k=a%k
! check on allocation
if (info /= psb_no_err_) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
call psb_csdp(atemp,a,info,check='R')
! check on error retuned by dcsdp
if (info /= psb_no_err_) then
info = 4010
ch_err='psb_csdp90'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_sp_free(atemp,info)
if (info /= psb_no_err_) then
info = 4010
ch_err='sp_free'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
call psb_spcnv(a,info,afmt=afmt,upd=upd,dupl=dupl)
info = 600
call psb_errpush(info,name)
IF (debug) WRITE (*, *) me,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= psb_no_err_) then
info=4010
ch_err='psb_spcnv'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
endif
call psb_erractionrestore(err_act)

242
base/tools/psb_dspcnv.f90
Unescape Escape View File

@ -1,242 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psb_dspcnv.f90
!
! Subroutine: psb_dspcnv
! converts sparse matrix a into b
!
! Parameters:
! a - type(<psb_dspmat_type>). The sparse input matrix.
! b - type(<psb_dspmat_type>). The sparse output matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor.
! info - integer. Eventually returns an error code.
!
subroutine psb_dspcnv(a,b,desc_a,info)
use psb_descriptor_type
use psb_spmat_type
use psb_realloc_mod
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
interface dcsdp
subroutine dcsdp(check,trans,m,n,unitd,d,&
& fida,descra,a,ia1,ia2,infoa,&
& pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,&
& work,lwork,ierror)
integer, intent(in) :: lh, lwork, lh1, lh2, m, n
integer, intent(out) :: ierror
character, intent(in) :: check, trans, unitd
real(kind(1.d0)), intent(in) :: d(*), a(*)
real(kind(1.d0)), intent(out) :: h(*)
real(kind(1.d0)), intent(inout) :: work(*)
integer, intent(in) :: ia1(*), ia2(*), infoa(*)
integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*)
character, intent(in) :: fida*5, descra*11
character, intent(out) :: fidh*5, descrh*11
end subroutine dcsdp
end interface
interface dcsrp
subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,&
& infoa,p,work,lwork,ierror)
integer, intent(in) :: m, n, lwork
integer, intent(out) :: ierror
character, intent(in) :: trans
real(kind(1.d0)), intent(inout) :: work(*)
integer, intent(in) :: p(*)
integer, intent(inout) :: ia1(*), ia2(*), infoa(*)
character, intent(in) :: fida*5, descra*11
end subroutine dcsrp
end interface
interface dcsprt
subroutine dcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror)
integer, intent(in) :: iout,m, n
integer, intent(out) :: ierror
real(kind(1.d0)), intent(in) :: a(*)
integer, intent(in) :: ia1(*), ia2(*), infoa(*)
character, intent(in) :: fida*5, descra*11
end subroutine dcsprt
end interface
!...parameters....
type(psb_dspmat_type), intent(in) :: a
type(psb_dspmat_type), intent(out) :: b
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
!....locals....
integer :: int_err(5)
real(kind(1.d0)) :: d(1)
integer,allocatable :: i_temp(:)
real(kind(1.d0)),allocatable :: work_dcsdp(:)
integer :: ia1_size,ia2_size,aspk_size,&
& err_act,i,np,me,n_col,l_dcsdp
integer :: lwork_dcsdp,dectype
integer :: ictxt,n_row
character :: check*1, trans*1, unitd*1
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus() /= 0) return
info=0
name = 'psb_dspcnv'
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
dectype = psb_cd_get_dectype(desc_a)
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_ok_dec((dectype))) then
info = 600
int_err(1) = dectype
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
if (debug) write (0, *) name,' begin matrix assembly...'
ia1_size = size(a%ia1)
ia2_size = size(a%ia2)
aspk_size = size(a%aspk)
if (debug) write (0, *) name,' sizes',ia1_size,ia2_size,aspk_size
! convert only without check
check='N'
trans='N'
unitd='U'
! l_dcsdp is the size requested for dcsdp procedure
l_dcsdp=(ia1_size+100)
b%m=n_row
b%k=n_col
call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info)
allocate(work_dcsdp(l_dcsdp),stat=info)
if (info /= 0) then
info=4025
int_err(1)=l_dcsdp
call psb_errpush(info, name, i_err=int_err,a_err='real(kind(1.d0))')
goto 9999
endif
lwork_dcsdp=size(work_dcsdp)
! set infoa(1) to nnzero
b%pl(:) = 0
b%pr(:) = 0
if (debug) write (0, *) name,' calling dcsdp',lwork_dcsdp,&
&size(work_dcsdp)
! convert aspk,ia1,ia2 in requested representation mode
if (debug) then
endif
! result is put in b
call dcsdp(check,trans,n_row,n_col,unitd,d,a%fida,a%descra,&
& a%aspk,a%ia1,a%ia2,a%infoa,&
& b%pl,b%fida,b%descra,b%aspk,b%ia1,b%ia2,b%infoa,b%pr,&
& size(b%aspk),size(b%ia1),size(b%ia2),&
& work_dcsdp,size(work_dcsdp),info)
if(info /= psb_no_err_) then
info=4010
ch_err='dcsdp'
call psb_errpush(info, name, a_err=ch_err)
goto 9999
end if
!
! hmmm, have to fix b%pl and b%pr according to a%pl and a%pr!!!
! should work (crossed fingers :-)
if (a%pr(1) /= 0) then
if (b%pr(1) /= 0) then
allocate(i_temp(n_col))
do i=1, n_col
i_temp(i) = b%pr(a%pr(i))
enddo
call psb_transfer(i_temp,b%pr,info)
else
allocate(i_temp(n_col))
do i=1, n_col
i_temp(i) = a%pr(i)
enddo
call psb_transfer(i_temp,b%pr,info)
endif
endif
if (a%pl(1) /= 0) then
if (b%pr(1) /= 0) then
allocate(i_temp(n_row))
do i=1, n_row
i_temp(i) = a%pl(b%pl(i))
enddo
call psb_transfer(i_temp,b%pl,info)
else
allocate(i_temp(n_row))
do i=1, n_row
i_temp(i) = a%pl(i)
enddo
call psb_transfer(i_temp,b%pl,info)
endif
endif
if (debug) write (0, *) me,name,' from dcsdp ',&
&b%fida,' pl ', b%pl(:),'pr',b%pr(:)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_dspcnv

10
base/tools/psb_zspalloc.f90
Unescape Escape View File

@ -115,16 +115,6 @@ subroutine psb_zspalloc(a, desc_a, info, nnz)
goto 9999
end if
! set permutation matrices
a%pl(1)=0
a%pr(1)=0
! set infoa fields
a%fida = 'COO'
a%descra = 'GUN'
a%infoa(psb_nnz_) = 0
a%infoa(psb_srtd_) = 0
a%infoa(psb_state_) = psb_spmat_bld_
if (debug) write(0,*) 'spall: ', &
& psb_cd_get_dectype(desc_a),psb_desc_bld_

116
base/tools/psb_zspasb.f90
Unescape Escape View File

@ -60,7 +60,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character, optional, intent(in) :: afmt*5
character(len=*), optional, intent(in) :: afmt
!....Locals....
integer :: int_err(5)
type(psb_zspmat_type) :: atemp
@ -107,118 +107,18 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
!
! Second step: handle the local matrix part.
!
if (present(upd)) then
upd_=upd
else
upd_ = psb_upd_dflt_
endif
if (present(dupl)) then
select case(dupl)
case (psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_)
dupl_ = dupl
case default
dupl_ = psb_dupl_def_
end select
else
dupl_ = psb_dupl_def_
endif
a%m = n_row
a%k = n_col
end if
call psb_sp_clone(a,atemp,info)
if(info /= psb_no_err_) then
info=4010
ch_err='psb_sp_clone'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
! convert to user requested format after the temp copy
end if
if (present(afmt)) then
a%fida = afmt
else
a%fida = '???'
endif
if (debugwrt) then
iout = 30+me
open(iout)
call psb_csprt(iout,atemp,head='Input mat')
close(iout)
endif
! Do the real conversion into the requested storage format
! result is put in A
call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_)
IF (debug) WRITE (*, *) me,' ASB: From ZCSDP',info,' ',A%FIDA
if (info /= psb_no_err_) then
info=4010
ch_err='psb_csdp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debugwrt) then
iout = 60+me
open(iout)
call psb_csprt(iout,a,head='Output mat')
close(iout)
endif
call psb_sp_free(atemp,info)
else if (spstate == psb_spmat_upd_) then
!
! Second case: we come from an update loop.
!
! Right now, almost nothing to be done, but this
! may change in the future
! as we revise the implementation of the update routine.
call psb_sp_all(atemp,1,info)
atemp%m=a%m
atemp%k=a%k
! check on allocation
if (info /= psb_no_err_) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
call psb_csdp(atemp,a,info,check='R')
! check on error retuned by zcsdp
if (info /= psb_no_err_) then
info = 4010
ch_err='psb_csdp90'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_sp_free(atemp,info)
if (info /= psb_no_err_) then
info = 4010
ch_err='sp_free'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
call psb_spcnv(a,info,afmt=afmt,upd=upd,dupl=dupl)
info = 600
call psb_errpush(info,name)
IF (debug) WRITE (*, *) me,' ASB: From DCSDP',info,' ',A%FIDA
if (info /= psb_no_err_) then
info=4010
ch_err='psb_spcnv'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
if (debug) write(0,*) 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_
endif
call psb_erractionrestore(err_act)

243
base/tools/psb_zspcnv.f90
Unescape Escape View File

@ -1,243 +0,0 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psb_zspcnv.f90
!
! Subroutine: psb_zspcnv
! converts sparse matrix a into b
!
! Parameters:
! a - type(<psb_zspmat_type>). The sparse input matrix.
! b - type(<psb_zspmat_type>). The sparse output matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor.
! info - integer. Eventually returns an error code.
!
subroutine psb_zspcnv(a,b,desc_a,info)
use psb_descriptor_type
use psb_spmat_type
use psb_realloc_mod
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
interface zcsdp
subroutine zcsdp(check,trans,m,n,unitd,d,&
& fida,descra,a,ia1,ia2,infoa,&
& pl,fidh,descrh,h,ih1,ih2,infoh,pr,lh,lh1,lh2,&
& work,lwork,ierror)
integer, intent(in) :: lh, lwork, lh1, lh2, m, n
integer, intent(out) :: ierror
character, intent(in) :: check, trans, unitd
complex(kind(1.d0)), intent(in) :: d(*), a(*)
complex(kind(1.d0)), intent(out) :: h(*)
complex(kind(1.d0)), intent(inout) :: work(*)
integer, intent(in) :: ia1(*), ia2(*), infoa(*)
integer, intent(out) :: ih1(*), ih2(*), pl(*),pr(*), infoh(*)
character, intent(in) :: fida*5, descra*11
character, intent(out) :: fidh*5, descrh*11
end subroutine zcsdp
end interface
interface zcsrp
subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,&
& infoa,p,work,lwork,ierror)
integer, intent(in) :: m, n, lwork
integer, intent(out) :: ierror
character, intent(in) :: trans
complex(kind(1.d0)), intent(inout) :: work(*)
integer, intent(in) :: p(*)
integer, intent(inout) :: ia1(*), ia2(*), infoa(*)
character, intent(in) :: fida*5, descra*11
end subroutine zcsrp
end interface
interface zcsprt
subroutine zcsprt(m,n,fida,descra,a,ia1,ia2,infoa ,iout,ierror)
integer, intent(in) :: iout,m, n
integer, intent(out) :: ierror
complex(kind(1.d0)), intent(in) :: a(*)
integer, intent(in) :: ia1(*), ia2(*), infoa(*)
character, intent(in) :: fida*5, descra*11
end subroutine zcsprt
end interface
!...parameters....
type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(out) :: b
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
!....locals....
integer :: int_err(5)
complex(kind(1.d0)) :: d(1)
integer,allocatable :: i_temp(:)
complex(kind(1.d0)),allocatable :: work_dcsdp(:)
integer :: ia1_size,ia2_size,aspk_size,err_act&
& ,i,err,np,me,n_col,l_dcsdp
integer :: lwork_dcsdp,dectype
integer :: ictxt,n_row
character :: check*1, trans*1, unitd*1
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus() /= 0) return
info=0
name = 'psb_zspcnv'
call psb_erractionsave(err_act)
ictxt = psb_cd_get_context(desc_a)
dectype = psb_cd_get_dectype(desc_a)
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
! check on blacs grid
call psb_info(ictxt, me, np)
if (np == -1) then
info = 2010
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_ok_dec((dectype))) then
info = 600
int_err(1) = dectype
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
if (debug) write (0, *) name,' begin matrix assembly...'
ia1_size = size(a%ia1)
ia2_size = size(a%ia2)
aspk_size = size(a%aspk)
if (debug) write (0, *) name,' sizes',ia1_size,ia2_size,aspk_size
! convert only without check
check='N'
trans='N'
unitd='U'
! l_dcsdp is the size requested for dcsdp procedure
l_dcsdp=(ia1_size+100)
b%m=n_row
b%k=n_col
call psb_sp_all(b,ia1_size,ia2_size,aspk_size,info)
allocate(work_dcsdp(l_dcsdp),stat=info)
if (info /= 0) then
info=4025
int_err(1)=l_dcsdp
call psb_errpush(info, name, i_err=int_err,a_err='real(kind(1.d0))')
goto 9999
endif
lwork_dcsdp=size(work_dcsdp)
! set infoa(1) to nnzero
b%pl(:) = 0
b%pr(:) = 0
if (debug) write (0, *) name,' calling dcsdp',lwork_dcsdp,&
&size(work_dcsdp)
! convert aspk,ia1,ia2 in requested representation mode
if (debug) then
endif
! result is put in b
call zcsdp(check,trans,n_row,n_col,unitd,d,a%fida,a%descra,&
& a%aspk,a%ia1,a%ia2,a%infoa,&
& b%pl,b%fida,b%descra,b%aspk,b%ia1,b%ia2,b%infoa,b%pr,&
& size(b%aspk),size(b%ia1),size(b%ia2),&
& work_dcsdp,size(work_dcsdp),info)
if(info /= psb_no_err_) then
info=4010
ch_err='zcsdp'
call psb_errpush(info, name, a_err=ch_err)
goto 9999
end if
!
! hmmm, have to fix b%pl and b%pr according to a%pl and a%pr!!!
! should work (crossed fingers :-)
if (a%pr(1) /= 0) then
if (b%pr(1) /= 0) then
allocate(i_temp(n_col))
do i=1, n_col
i_temp(i) = b%pr(a%pr(i))
enddo
call psb_transfer(i_temp,b%pr,info)
else
allocate(i_temp(n_col))
do i=1, n_col
i_temp(i) = a%pr(i)
enddo
call psb_transfer(i_temp,b%pr,info)
endif
endif
if (a%pl(1) /= 0) then
if (b%pr(1) /= 0) then
allocate(i_temp(n_row))
do i=1, n_row
i_temp(i) = a%pl(b%pl(i))
enddo
call psb_transfer(i_temp,b%pl,info)
else
allocate(i_temp(n_row))
do i=1, n_row
i_temp(i) = a%pl(i)
enddo
call psb_transfer(i_temp,b%pl,info)
endif
endif
if (debug) write (0, *) me,name,' from zcsdp ',&
&b%fida,' pl ', b%pl(:),'pr',b%pr(:)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
end subroutine psb_zspcnv

234
krylov/psb_zgmresr.f90
Unescape Escape View File

@ -437,138 +437,122 @@ Subroutine psb_zgmresr(a,prec,b,x,eps,desc_a,info,&
contains
function safe_dn2(a,b)
real(kind(1.d0)), intent(in) :: a, b
real(kind(1.d0)) :: safe_dn2
real(kind(1.d0)) :: t
t = max(abs(a),abs(b))
if (t==0.d0) then
safe_dn2 = 0.d0
else
safe_dn2 = t * sqrt(abs(a/t)**2 + abs(b/t)**2)
endif
return
end function safe_dn2
End Subroutine psb_zgmresr
subroutine zrot( n, cx, incx, cy, incy, c, s )
!
! -- lapack auxiliary routine (version 3.0) --
! univ. of tennessee, univ. of california berkeley, nag ltd.,
! courant institute, argonne national lab, and rice university
! october 31, 1992
!
! .. scalar arguments ..
integer incx, incy, n
real(kind(1.d0)) c
complex(kind(1.d0)) s
! ..
! .. array arguments ..
complex(kind(1.d0)) cx( * ), cy( * )
! ..
!
! purpose
! =======
!
! zrot applies a plane rotation, where the cos (c) is real and the
! sin (s) is complex, and the vectors cx and cy are complex.
!
! arguments
! =========
!
! n (input) integer
! the number of elements in the vectors cx and cy.
!
! cx (input/output) complex*16 array, dimension (n)
! on input, the vector x.
! on output, cx is overwritten with c*x + s*y.
!
! incx (input) integer
! the increment between successive values of cy. incx <> 0.
!
! cy (input/output) complex*16 array, dimension (n)
! on input, the vector y.
! on output, cy is overwritten with -conjg(s)*x + c*y.
!
! incy (input) integer
! the increment between successive values of cy. incx <> 0.
!
! c (input) double precision
! s (input) complex*16
! c and s define a rotation
! [ c s ]
! [ -conjg(s) c ]
! where c*c + s*conjg(s) = 1.0.
!
! =====================================================================
!
! .. local scalars ..
integer i, ix, iy
complex(kind(1.d0)) stemp
! ..
! .. intrinsic functions ..
intrinsic dconjg
! ..
! .. executable statements ..
!
if( n.le.0 ) return
if( incx.eq.1 .and. incy.eq.1 ) then
subroutine zrot( n, cx, incx, cy, incy, c, s )
!
! code for both increments equal to 1
! -- lapack auxiliary routine (version 3.0) --
! univ. of tennessee, univ. of california berkeley, nag ltd.,
! courant institute, argonne national lab, and rice university
! october 31, 1992
!
do i = 1, n
stemp = c*cx(i) + s*cy(i)
cy(i) = c*cy(i) - dconjg(s)*cx(i)
cx(i) = stemp
end do
else
! .. scalar arguments ..
integer incx, incy, n
real(kind(1.d0)) c
complex(kind(1.d0)) s
! ..
! .. array arguments ..
complex(kind(1.d0)) cx( * ), cy( * )
! ..
!
! code for unequal increments or equal increments not equal to 1
! purpose
! =======
!
ix = 1
iy = 1
if( incx.lt.0 )ix = ( -n+1 )*incx + 1
if( incy.lt.0 )iy = ( -n+1 )*incy + 1
do i = 1, n
stemp = c*cx(ix) + s*cy(iy)
cy(iy) = c*cy(iy) - dconjg(s)*cx(ix)
cx(ix) = stemp
ix = ix + incx
iy = iy + incy
end do
end if
return
return
end subroutine zrot
!
!
subroutine zrotg(ca,cb,c,s)
complex(kind(1.d0)) ca,cb,s
real(kind(1.d0)) c
real(kind(1.d0)) norm,scale
complex(kind(1.d0)) alpha
!
if (cdabs(ca) == 0.0d0) then
! zrot applies a plane rotation, where the cos (c) is real and the
! sin (s) is complex, and the vectors cx and cy are complex.
!
! arguments
! =========
!
c = 0.0d0
s = (1.0d0,0.0d0)
ca = cb
! n (input) integer
! the number of elements in the vectors cx and cy.
!
! cx (input/output) complex*16 array, dimension (n)
! on input, the vector x.
! on output, cx is overwritten with c*x + s*y.
!
! incx (input) integer
! the increment between successive values of cy. incx <> 0.
!
! cy (input/output) complex*16 array, dimension (n)
! on input, the vector y.
! on output, cy is overwritten with -conjg(s)*x + c*y.
!
! incy (input) integer
! the increment between successive values of cy. incx <> 0.
!
! c (input) double precision
! s (input) complex*16
! c and s define a rotation
! [ c s ]
! [ -conjg(s) c ]
! where c*c + s*conjg(s) = 1.0.
!
! =====================================================================
!
! .. local scalars ..
integer i, ix, iy
complex(kind(1.d0)) stemp
! ..
! .. intrinsic functions ..
intrinsic dconjg
! ..
! .. executable statements ..
!
if( n.le.0 ) return
if( incx.eq.1 .and. incy.eq.1 ) then
!
! code for both increments equal to 1
!
do i = 1, n
stemp = c*cx(i) + s*cy(i)
cy(i) = c*cy(i) - dconjg(s)*cx(i)
cx(i) = stemp
end do
else
!
! code for unequal increments or equal increments not equal to 1
!
ix = 1
iy = 1
if( incx.lt.0 )ix = ( -n+1 )*incx + 1
if( incy.lt.0 )iy = ( -n+1 )*incy + 1
do i = 1, n
stemp = c*cx(ix) + s*cy(iy)
cy(iy) = c*cy(iy) - dconjg(s)*cx(ix)
cx(ix) = stemp
ix = ix + incx
iy = iy + incy
end do
end if
return
end if
return
end subroutine zrot
!
scale = cdabs(ca) + cdabs(cb)
norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 +&
& (cdabs(cb/dcmplx(scale,0.0d0)))**2)
alpha = ca /cdabs(ca)
c = cdabs(ca) / norm
s = alpha * dconjg(cb) / norm
ca = alpha * norm
!
subroutine zrotg(ca,cb,c,s)
complex(kind(1.d0)) ca,cb,s
real(kind(1.d0)) c
real(kind(1.d0)) norm,scale
complex(kind(1.d0)) alpha
!
if (cdabs(ca) == 0.0d0) then
!
c = 0.0d0
s = (1.0d0,0.0d0)
ca = cb
return
end if
!
return
end subroutine zrotg
scale = cdabs(ca) + cdabs(cb)
norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 +&
& (cdabs(cb/dcmplx(scale,0.0d0)))**2)
alpha = ca /cdabs(ca)
c = cdabs(ca) / norm
s = alpha * dconjg(cb) / norm
ca = alpha * norm
!
return
end subroutine zrotg
End Subroutine psb_zgmresr

Write Preview
Loading…
Cancel
Save