mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-24 14:51:49 +00:00
Merged new serial code.
This commit is contained in:
Salvatore Filippone
+244
-27
@@ -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,43 +625,59 @@ 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
|
||||
|
||||
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
|
||||
end if
|
||||
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
|
||||
|
||||
call isrx(n,x,ix,dir_,flag_)
|
||||
else
|
||||
call isr(n,x,dir_)
|
||||
end if
|
||||
|
||||
|
||||
9999 continue
|
||||
if (err_act.eq.psb_act_abort_) then
|
||||
@@ -633,6 +687,169 @@ contains
|
||||
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)
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
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_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 zqsort
|
||||
|
||||
end module psb_serial_mod
|
||||
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user