fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 04:42:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
Changelog
 base/modules/psb_base_mat_mod.f03
 base/modules/psb_base_mod.f90
 base/modules/psb_d_base_mat_mod.f03
 base/modules/psb_d_csr_mat_mod.f03
 base/modules/psb_inter_desc_mod.f90
 base/modules/psb_inter_desc_type.f90
 base/modules/psb_linmap_mod.f90
 base/modules/psb_linmap_type_mod.f90
 base/modules/psb_mat_mod.f03
 base/modules/psb_spmat_type.f03
 base/modules/psb_tools_mod.f90
 base/psblas/psb_dnrmi.f90
 base/psblas/psb_dspmm.f90
 base/psblas/psb_dspsm.f90
 base/serial/Makefile
 base/serial/coo/Makefile
 base/serial/csr/Makefile
 base/serial/dp/Makefile
 base/serial/f03/psbn_d_coo_impl.f03
 base/serial/f03/psbn_d_csr_impl.f03
 base/serial/f77/Makefile
 base/serial/jad/Makefile
 base/serial/psb_getrow_mod.f90
 base/serial/psb_regen_mod.f90
 base/serial/psb_update_mod.f90
 base/tools/psb_dcdbldext.F90
 base/tools/psb_dspalloc.f90
 base/tools/psb_dspasb.f90
 base/tools/psb_dspfree.f90
 base/tools/psb_dsphalo.F90
 base/tools/psb_dspins.f90
 base/tools/psb_dsprn.f90
 base/tools/psb_linmap.f90
 krylov/psb_dbicg.f90
 krylov/psb_dcg.F90
 krylov/psb_dcgs.f90
 krylov/psb_dcgstab.F90
 krylov/psb_dcgstabl.f90
 krylov/psb_drgmres.f90
 krylov/psb_krylov_mod.f90
 prec/psb_dbjac_aply.f90
 prec/psb_dbjac_bld.f90
 prec/psb_ddiagsc_bld.f90
 prec/psb_dilu_fct.f90
 prec/psb_dprecbld.f90
 prec/psb_prec_mod.f90
 test/fileread/df_sample.f90
 test/fileread/runs/dfs.inp
 test/pargen/ppde.f90
 util/psb_hbio_mod.f90
 util/psb_mat_dist_mod.f90
 util/psb_mmio_mod.f90

Fixed toolchain: now fileread works.
This commit is contained in:
Salvatore Filippone
2009-09-19 18:23:20 +00:00
parent 6824977d63
commit 047eb9933b
53 changed files with 3015 additions and 2447 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_base_mat_mod.f03
+136 -26
View File
@@ -2,30 +2,8 @@ module psb_base_mat_mod
use psb_const_mod
!!$ integer, parameter :: psb_invalid_ = -1
!!$ 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_
!!$ ! Matrix update mode
!!$ integer, parameter :: psb_upd_srch_ = 98764
!!$ integer, parameter :: psb_upd_perm_ = 98765
!!$ integer, parameter :: psb_upd_dflt_ = psb_upd_srch_
!!$ integer, parameter :: psb_maxjdrows_=8, psb_minjdrows_=4
!!$ integer, parameter :: psb_dbleint_=2
type :: psb_base_sparse_mat
integer :: m, n
integer, private :: m, n
integer, private :: state, duplicate
logical, private :: triangle, unitd, upper, sorted
contains
@@ -39,6 +17,7 @@ module psb_base_mat_mod
procedure, pass(a) :: get_nrows
procedure, pass(a) :: get_ncols
procedure, pass(a) :: get_nzeros
procedure, pass(a) :: get_nz_row
procedure, pass(a) :: get_size
procedure, pass(a) :: get_state
procedure, pass(a) :: get_dupl
@@ -84,8 +63,11 @@ module psb_base_mat_mod
procedure, pass(a) :: reallocate_nz
procedure, pass(a) :: free
procedure, pass(a) :: trim
procedure, pass(a) :: reinit
generic, public :: allocate => allocate_mnnz
generic, public :: reallocate => reallocate_nz
procedure, pass(a) :: csgetptn
generic, public :: csget => csgetptn
procedure, pass(a) :: print => sparse_print
procedure, pass(a) :: sizeof
@@ -97,12 +79,11 @@ module psb_base_mat_mod
& get_nzeros, get_size, get_state, get_dupl, is_null, is_bld, &
& is_upd, is_asb, is_sorted, is_upper, is_lower, is_triangle, &
& is_unit, get_neigh, allocate_mn, allocate_mnnz, reallocate_nz, &
& free, sparse_print, get_fmt, trim, sizeof
& free, sparse_print, get_fmt, trim, sizeof, reinit, csgetptn, &
& get_nz_row
contains
function sizeof(a) result(res)
implicit none
class(psb_base_sparse_mat), intent(in) :: a
@@ -331,6 +312,31 @@ contains
end function is_sorted
function get_nz_row(idx,a) result(res)
use psb_error_mod
implicit none
integer, intent(in) :: idx
class(psb_base_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
character(len=20) :: name='base_get_nz_row'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
res = -1
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function get_nz_row
function get_nzeros(a) result(res)
use psb_error_mod
implicit none
@@ -379,6 +385,76 @@ contains
end function get_size
subroutine reinit(a,clear)
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
Integer :: err_act, info
character(len=20) :: name='reinit'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
info = 700
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine reinit
!!$
!!$ !
!!$ ! Since at this level we have only simple components,
!!$ ! mv_from is identical to cp_from.
!!$ !
!!$ subroutine mv_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_base_sparse_mat), intent(out) :: a
!!$ type(psb_base_sparse_mat), intent(inout) :: b
!!$
!!$ a%m = b%m
!!$ a%n = b%n
!!$ a%state = b%state
!!$ a%duplicate = b%duplicate
!!$ a%triangle = b%triangle
!!$ a%unitd = b%unitd
!!$ a%upper = b%upper
!!$ a%sorted = b%sorted
!!$
!!$ return
!!$
!!$ end subroutine mv_from
!!$
!!$ subroutine cp_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_base_sparse_mat), intent(out) :: a
!!$ type(psb_base_sparse_mat), intent(in) :: b
!!$
!!$ a%m = b%m
!!$ a%n = b%n
!!$ a%state = b%state
!!$ a%duplicate = b%duplicate
!!$ a%triangle = b%triangle
!!$ a%unitd = b%unitd
!!$ a%upper = b%upper
!!$ a%sorted = b%sorted
!!$
!!$ return
!!$
!!$ end subroutine cp_from
!!$
subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc)
use psb_error_mod
implicit none
@@ -408,6 +484,39 @@ contains
end subroutine sparse_print
subroutine csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
Integer :: err_act
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine csgetptn
subroutine get_neigh(a,idx,neigh,n,info,lev)
use psb_error_mod
@@ -524,5 +633,6 @@ contains
end subroutine trim
end module psb_base_mat_mod
base/modules/psb_base_mod.f90
+1
View File
@@ -41,4 +41,5 @@ module psb_base_mod
use psb_psblas_mod
use psb_gps_mod
use psb_tools_mod
use psb_mat_mod
end module psb_base_mod
base/modules/psb_d_base_mat_mod.f03
+235 -48
View File
@@ -38,9 +38,8 @@ module psb_d_base_mat_mod
& d_scals, d_scal, csnmi, csput, d_csgetrow, d_csgetblk, &
& cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, &
& mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, &
& get_diag, csclip, d_cssv, d_cssm
& get_diag, csclip, d_cssv, d_cssm
type, extends(psb_d_base_sparse_mat) :: psb_d_coo_sparse_mat
integer :: nnz
@@ -75,9 +74,12 @@ module psb_d_base_mat_mod
procedure, pass(a) :: free => d_coo_free
procedure, pass(a) :: trim => d_coo_trim
procedure, pass(a) :: d_csgetrow => d_coo_csgetrow
procedure, pass(a) :: csgetptn => d_coo_csgetptn
procedure, pass(a) :: print => d_coo_print
procedure, pass(a) :: get_fmt => d_coo_get_fmt
procedure, pass(a) :: get_nz_row => d_coo_get_nz_row
procedure, pass(a) :: sizeof => d_coo_sizeof
procedure, pass(a) :: reinit => d_coo_reinit
end type psb_d_coo_sparse_mat
@@ -87,8 +89,9 @@ module psb_d_base_mat_mod
& d_fix_coo, d_coo_free, d_coo_print, d_coo_get_fmt, &
& d_cp_coo_to_coo, d_cp_coo_from_coo, &
& d_cp_coo_to_fmt, d_cp_coo_from_fmt, &
& d_coo_scals, d_coo_scal, d_coo_csgetrow, d_coo_sizeof
& d_coo_scals, d_coo_scal, d_coo_csgetrow, d_coo_sizeof, &
& d_coo_csgetptn, d_coo_get_nz_row, d_coo_reinit
interface
subroutine d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir)
@@ -125,7 +128,7 @@ module psb_d_base_mat_mod
subroutine d_cp_coo_from_coo_impl(a,b,info)
use psb_const_mod
import psb_d_coo_sparse_mat
class(psb_d_coo_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(out) :: a
class(psb_d_coo_sparse_mat), intent(in) :: b
integer, intent(out) :: info
end subroutine d_cp_coo_from_coo_impl
@@ -205,6 +208,24 @@ module psb_d_base_mat_mod
end subroutine d_coo_csput_impl
end interface
interface
subroutine d_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
use psb_const_mod
import psb_d_coo_sparse_mat
implicit none
class(psb_d_coo_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
end subroutine d_coo_csgetptn_impl
end interface
interface
subroutine d_coo_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
@@ -293,7 +314,6 @@ contains
!
!====================================
subroutine cp_to_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
@@ -1278,6 +1298,56 @@ contains
end function d_coo_get_nzeros
function d_coo_get_nz_row(idx,a) result(res)
use psb_const_mod
use psb_sort_mod
implicit none
class(psb_d_coo_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer :: res
integer :: nzin_, nza,ip,jp,i,k
res = 0
nza = a%get_nzeros()
if (a%is_sorted()) then
! In this case we can do a binary search.
ip = psb_ibsrch(idx,nza,a%ia)
if (ip /= -1) return
jp = ip
do
if (ip < 2) exit
if (a%ia(ip-1) == idx) then
ip = ip -1
else
exit
end if
end do
do
if (jp == nza) exit
if (a%ia(jp+1) == idx) then
jp = jp + 1
else
exit
end if
end do
res = jp - ip +1
else
res = 0
do i=1, nza
if (a%ia(i) == idx) then
res = res + 1
end if
end do
end if
end function d_coo_get_nz_row
!====================================
!
!
@@ -1383,7 +1453,7 @@ contains
use psb_error_mod
use psb_realloc_mod
implicit none
class(psb_d_coo_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(out) :: a
class(psb_d_coo_sparse_mat), intent(in) :: b
integer, intent(out) :: info
@@ -1411,6 +1481,7 @@ contains
end subroutine d_cp_coo_from_coo
subroutine d_cp_coo_to_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
@@ -1541,6 +1612,73 @@ contains
end subroutine d_mv_coo_from_coo
!!$
!!$ subroutine d_coo_cp_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_d_coo_sparse_mat), intent(out) :: a
!!$ type(psb_d_coo_sparse_mat), intent(inout) :: b
!!$
!!$
!!$ Integer :: err_act, info
!!$ character(len=20) :: name='mv_from'
!!$ logical, parameter :: debug=.false.
!!$
!!$ call psb_erractionsave(err_act)
!!$ info = 0
!!$ call d_cp_coo_from_coo_impl(a,b,info)
!!$ if (info /= 0) goto 9999
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$
!!$ call psb_errpush(info,name)
!!$
!!$ if (err_act /= psb_act_ret_) then
!!$ call psb_error()
!!$ end if
!!$ return
!!$
!!$ end subroutine d_coo_cp_from
!!$
!!$ subroutine d_coo_mv_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_d_coo_sparse_mat), intent(out) :: a
!!$ type(psb_d_coo_sparse_mat), intent(inout) :: b
!!$
!!$
!!$ Integer :: err_act, info
!!$ character(len=20) :: name='mv_from'
!!$ logical, parameter :: debug=.false.
!!$
!!$ call psb_erractionsave(err_act)
!!$ info = 0
!!$ call d_mv_coo_from_coo_impl(a,b,info)
!!$ if (info /= 0) goto 9999
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$
!!$ call psb_errpush(info,name)
!!$
!!$ if (err_act /= psb_act_ret_) then
!!$ call psb_error()
!!$ end if
!!$ return
!!$
!!$ end subroutine d_coo_mv_from
!!$
subroutine d_mv_coo_to_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
@@ -1750,46 +1888,47 @@ contains
end subroutine d_coo_csgetrow
!!$
!!$ subroutine d_coo_csget(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
!!$ ! Output is always in COO format
!!$ use psb_error_mod
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ class(psb_d_coo_sparse_mat), intent(inout) :: a
!!$ integer, intent(in) :: irw
!!$ integer, intent(out) :: nz
!!$ integer, allocatable, intent(inout) :: ia(:), ja(:)
!!$ real(psb_dpk_), allocatable, intent(inout) :: val(:)
!!$ integer,intent(out) :: info
!!$ logical, intent(in), optional :: append
!!$ integer, intent(in), optional :: iren(:)
!!$ integer, intent(in), optional :: lrw, nzin
!!$ Integer :: err_act
!!$ character(len=20) :: name='csget'
!!$ logical, parameter :: debug=.false.
!!$
!!$ call psb_erractionsave(err_act)
!!$ info = 0
!!$
!!$ call d_coo_csget_impl(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
!!$ if (info /= 0) goto 9999
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$
!!$ if (err_act == psb_act_abort_) then
!!$ call psb_error()
!!$ return
!!$ end if
!!$ return
!!$
!!$ end subroutine d_coo_csget
!!$
subroutine d_coo_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
implicit none
class(psb_d_coo_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
Integer :: err_act
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_coo_csgetptn_impl(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_coo_csgetptn
subroutine d_coo_free(a)
@@ -1808,6 +1947,54 @@ contains
end subroutine d_coo_free
subroutine d_coo_reinit(a,clear)
use psb_error_mod
implicit none
class(psb_d_coo_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
Integer :: err_act, info
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
if (present(clear)) then
clear_ = clear
else
clear_ = .true.
end if
if (a%is_bld() .or. a%is_upd()) then
! do nothing
return
else if (a%is_asb()) then
if (clear_) a%val(:) = dzero
call a%set_upd()
else
info = 1121
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_coo_reinit
subroutine d_coo_trim(a)
use psb_realloc_mod
base/modules/psb_d_csr_mat_mod.f03
+218 -3
View File
@@ -29,12 +29,18 @@ module psb_d_csr_mat_mod
procedure, pass(a) :: mv_from_coo => d_mv_csr_from_coo
procedure, pass(a) :: mv_to_fmt => d_mv_csr_to_fmt
procedure, pass(a) :: mv_from_fmt => d_mv_csr_from_fmt
!!$ procedure, pass(a) :: mv_from => d_csr_mv_from
!!$ procedure, pass(a) :: cp_from => d_csr_cp_from
procedure, pass(a) :: csgetptn => d_csr_csgetptn
procedure, pass(a) :: d_csgetrow => d_csr_csgetrow
procedure, pass(a) :: get_nz_row => d_csr_get_nz_row
procedure, pass(a) :: get_size => d_csr_get_size
procedure, pass(a) :: free => d_csr_free
procedure, pass(a) :: trim => d_csr_trim
procedure, pass(a) :: print => d_csr_print
procedure, pass(a) :: sizeof => d_csr_sizeof
procedure, pass(a) :: reinit => d_csr_reinit
end type psb_d_csr_sparse_mat
private :: d_csr_get_nzeros, d_csr_csmm, d_csr_csmv, d_csr_cssm, d_csr_cssv, &
& d_csr_csput, d_csr_reallocate_nz, d_csr_allocate_mnnz, &
@@ -44,7 +50,9 @@ module psb_d_csr_mat_mod
& d_cp_csr_to_fmt, d_cp_csr_from_fmt, &
& d_mv_csr_to_fmt, d_mv_csr_from_fmt, &
& d_csr_scals, d_csr_scal, d_csr_trim, d_csr_csgetrow, d_csr_get_size, &
& d_csr_sizeof
& d_csr_sizeof, d_csr_csgetptn, d_csr_get_nz_row, d_csr_reinit
!!$, &
!!$ & d_csr_mv_from, d_csr_mv_from
interface
@@ -149,6 +157,25 @@ module psb_d_csr_mat_mod
end subroutine d_csr_csput_impl
end interface
interface
subroutine d_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
use psb_const_mod
import psb_d_csr_sparse_mat
implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
end subroutine d_csr_csgetptn_impl
end interface
interface
subroutine d_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
@@ -259,7 +286,7 @@ contains
implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a
integer :: res
res = a%irp(a%m+1)-1
res = a%irp(a%get_nrows()+1)-1
end function d_csr_get_nzeros
function d_csr_get_size(a) result(res)
@@ -286,6 +313,26 @@ contains
end function d_csr_get_size
function d_csr_get_nz_row(idx,a) result(res)
use psb_const_mod
implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer :: res
res = 0
if ((1<=idx).and.(idx<=a%get_nrows())) then
res = a%irp(idx+1)-a%irp(idx)
end if
end function d_csr_get_nz_row
!=====================================
!
!
@@ -313,7 +360,8 @@ contains
call psb_realloc(nz,a%ja,info)
if (info == 0) call psb_realloc(nz,a%val,info)
if (info == 0) call psb_realloc(max(nz,a%m+1,a%n+1),a%irp,info)
if (info == 0) call psb_realloc(&
& max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
@@ -396,6 +444,49 @@ contains
return
end subroutine d_csr_csput
subroutine d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
Integer :: err_act
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_csr_csgetptn
subroutine d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
@@ -605,6 +696,55 @@ contains
end subroutine d_csr_free
subroutine d_csr_reinit(a,clear)
use psb_error_mod
implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
Integer :: err_act, info
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
if (present(clear)) then
clear_ = clear
else
clear_ = .true.
end if
if (a%is_bld() .or. a%is_upd()) then
! do nothing
return
else if (a%is_asb()) then
if (clear_) a%val(:) = dzero
call a%set_upd()
else
info = 1121
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_csr_reinit
subroutine d_csr_trim(a)
use psb_realloc_mod
use psb_error_mod
@@ -1039,6 +1179,81 @@ contains
end subroutine d_csr_print
!!$
!!$ subroutine d_csr_cp_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_d_csr_sparse_mat), intent(out) :: a
!!$ class(psb_d_csr_sparse_mat), intent(inout) :: b
!!$
!!$
!!$ Integer :: err_act, info
!!$ character(len=20) :: name='cp_from'
!!$ logical, parameter :: debug=.false.
!!$
!!$ call psb_erractionsave(err_act)
!!$
!!$ info = 0
!!$
!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros())
!!$ a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat
!!$ a%irp = b%irp
!!$ a%ja = b%ja
!!$ a%val = b%val
!!$
!!$ if (info /= 0) goto 9999
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$
!!$ call psb_errpush(info,name)
!!$
!!$ if (err_act /= psb_act_ret_) then
!!$ call psb_error()
!!$ end if
!!$ return
!!$
!!$ end subroutine d_csr_cp_from
!!$
!!$ subroutine d_csr_mv_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_d_csr_sparse_mat), intent(out) :: a
!!$ class(psb_d_csr_sparse_mat), intent(inout) :: b
!!$
!!$
!!$ Integer :: err_act, info
!!$ character(len=20) :: name='mv_from'
!!$ logical, parameter :: debug=.false.
!!$
!!$ call psb_erractionsave(err_act)
!!$ info = 0
!!$ call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat)
!!$ call move_alloc(b%irp, a%irp)
!!$ call move_alloc(b%ja, a%ja)
!!$ call move_alloc(b%val, a%val)
!!$ call b%free()
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$
!!$ call psb_errpush(info,name)
!!$
!!$ if (err_act /= psb_act_ret_) then
!!$ call psb_error()
!!$ end if
!!$ return
!!$
!!$ end subroutine d_csr_mv_from
!!$
!=====================================
!
base/modules/psb_inter_desc_mod.f90
-431
View File
@@ -1,431 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 2.2
!!$ (C) Copyright 2006/2007/2008
!!$ 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.
!!$
!!$
!
!
! package: psb_inter_descriptor_type
! Defines facilities for mapping between vectors belonging
! to different spaces.
!
module psb_inter_desc_mod
use psb_inter_descriptor_type
use psb_descriptor_type
interface psb_forward_map
subroutine psb_s_forward_map(alpha,x,beta,y,desc,info,work)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type), intent(in) :: desc
real(psb_spk_), intent(in) :: alpha,beta
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), intent(out) :: y(:)
integer, intent(out) :: info
real(psb_spk_), optional :: work(:)
end subroutine psb_s_forward_map
subroutine psb_d_forward_map(alpha,x,beta,y,desc,info,work)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type), intent(in) :: desc
real(psb_dpk_), intent(in) :: alpha,beta
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(out) :: y(:)
integer, intent(out) :: info
real(psb_dpk_), optional :: work(:)
end subroutine psb_d_forward_map
subroutine psb_c_forward_map(alpha,x,beta,y,desc,info,work)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type), intent(in) :: desc
complex(psb_spk_), intent(in) :: alpha,beta
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), intent(out) :: y(:)
integer, intent(out) :: info
complex(psb_spk_), optional :: work(:)
end subroutine psb_c_forward_map
subroutine psb_z_forward_map(alpha,x,beta,y,desc,info,work)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type), intent(in) :: desc
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), intent(out) :: y(:)
integer, intent(out) :: info
complex(psb_dpk_), optional :: work(:)
end subroutine psb_z_forward_map
end interface
interface psb_backward_map
subroutine psb_s_backward_map(alpha,x,beta,y,desc,info,work)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type), intent(in) :: desc
real(psb_spk_), intent(in) :: alpha,beta
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), intent(out) :: y(:)
integer, intent(out) :: info
real(psb_spk_), optional :: work(:)
end subroutine psb_s_backward_map
subroutine psb_d_backward_map(alpha,x,beta,y,desc,info,work)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type), intent(in) :: desc
real(psb_dpk_), intent(in) :: alpha,beta
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(out) :: y(:)
integer, intent(out) :: info
real(psb_dpk_), optional :: work(:)
end subroutine psb_d_backward_map
subroutine psb_c_backward_map(alpha,x,beta,y,desc,info,work)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type), intent(in) :: desc
complex(psb_spk_), intent(in) :: alpha,beta
complex(psb_spk_), intent(inout) :: x(:)
complex(psb_spk_), intent(out) :: y(:)
integer, intent(out) :: info
complex(psb_spk_), optional :: work(:)
end subroutine psb_c_backward_map
subroutine psb_z_backward_map(alpha,x,beta,y,desc,info,work)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type), intent(in) :: desc
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(inout) :: x(:)
complex(psb_dpk_), intent(out) :: y(:)
integer, intent(out) :: info
complex(psb_dpk_), optional :: work(:)
end subroutine psb_z_backward_map
end interface
interface psb_is_ok_desc
module procedure psb_is_ok_inter_desc
end interface
interface psb_is_asb_desc
module procedure psb_is_asb_inter_desc
end interface
interface psb_inter_desc
function psb_s_inter_desc(map_kind,desc1,desc2,map_fw,map_bk,idx_fw,idx_bk)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type) :: psb_s_inter_desc
type(psb_desc_type), target :: desc1, desc2
type(psb_sspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind,idx_fw(:), idx_bk(:)
end function psb_s_inter_desc
function psb_s_inter_desc_noidx(map_kind,desc1, desc2, map_fw, map_bk)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type) :: psb_s_inter_desc_noidx
type(psb_desc_type), target :: desc1, desc2
type(psb_sspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind
end function psb_s_inter_desc_noidx
function psb_d_inter_desc(map_kind,desc1,desc2,map_fw,map_bk,idx_fw,idx_bk)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type) :: psb_d_inter_desc
type(psb_desc_type), target :: desc1, desc2
type(psb_dspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind,idx_fw(:), idx_bk(:)
end function psb_d_inter_desc
function psb_d_inter_desc_noidx(map_kind,desc1, desc2, map_fw, map_bk)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type) :: psb_d_inter_desc_noidx
type(psb_desc_type), target :: desc1, desc2
type(psb_dspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind
end function psb_d_inter_desc_noidx
function psb_c_inter_desc(map_kind,desc1,desc2,map_fw,map_bk,idx_fw,idx_bk)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type) :: psb_c_inter_desc
type(psb_desc_type), target :: desc1, desc2
type(psb_cspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind,idx_fw(:), idx_bk(:)
end function psb_c_inter_desc
function psb_c_inter_desc_noidx(map_kind,desc1, desc2, map_fw, map_bk)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type) :: psb_c_inter_desc_noidx
type(psb_desc_type), target :: desc1, desc2
type(psb_cspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind
end function psb_c_inter_desc_noidx
function psb_z_inter_desc(map_kind,desc1,desc2,map_fw,map_bk,idx_fw,idx_bk)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type) :: psb_z_inter_desc
type(psb_desc_type), target :: desc1, desc2
type(psb_zspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind,idx_fw(:), idx_bk(:)
end function psb_z_inter_desc
function psb_z_inter_desc_noidx(map_kind,desc1, desc2, map_fw, map_bk)
use psb_inter_descriptor_type
implicit none
type(psb_inter_desc_type) :: psb_z_inter_desc_noidx
type(psb_desc_type), target :: desc1, desc2
type(psb_zspmat_type), intent(in) :: map_fw, map_bk
integer, intent(in) :: map_kind
end function psb_z_inter_desc_noidx
end interface
interface psb_sizeof
module procedure psb_itd_sizeof,&
& psb_s_map_sizeof, psb_c_map_sizeof,&
& psb_d_map_sizeof, psb_z_map_sizeof
end interface
interface psb_linmap
subroutine psb_s_apply_linmap(alpha,x,beta,y,a_map,cd_xt,descin,descout)
use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_descriptor_type, only: psb_desc_type
implicit none
real(psb_spk_), intent(in) :: alpha,beta
real(psb_spk_), intent(inout) :: x(:),y(:)
type(psb_sspmat_type), intent(in) :: a_map
type(psb_desc_type), intent(in) :: cd_xt,descin, descout
end subroutine psb_s_apply_linmap
subroutine psb_d_apply_linmap(alpha,x,beta,y,a_map,cd_xt,descin,descout)
use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_descriptor_type, only: psb_desc_type
implicit none
real(psb_dpk_), intent(in) :: alpha,beta
real(psb_dpk_), intent(inout) :: x(:),y(:)
type(psb_dspmat_type), intent(in) :: a_map
type(psb_desc_type), intent(in) :: cd_xt,descin, descout
end subroutine psb_d_apply_linmap
subroutine psb_c_apply_linmap(alpha,x,beta,y,a_map,cd_xt,descin,descout)
use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_descriptor_type, only: psb_desc_type
implicit none
complex(psb_spk_), intent(in) :: alpha,beta
complex(psb_spk_), intent(inout) :: x(:),y(:)
type(psb_cspmat_type), intent(in) :: a_map
type(psb_desc_type), intent(in) :: cd_xt,descin, descout
end subroutine psb_c_apply_linmap
subroutine psb_z_apply_linmap(alpha,x,beta,y,a_map,cd_xt,descin,descout)
use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_descriptor_type, only: psb_desc_type
implicit none
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(inout) :: x(:),y(:)
type(psb_zspmat_type), intent(in) :: a_map
type(psb_desc_type), intent(in) :: cd_xt,descin, descout
end subroutine psb_z_apply_linmap
end interface
contains
function psb_cd_get_map_kind(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_cd_get_map_kind
if (psb_is_ok_desc(desc)) then
psb_cd_get_map_kind = desc%itd_data(psb_map_kind_)
else
psb_cd_get_map_kind = -1
end if
end function psb_cd_get_map_kind
subroutine psb_cd_set_map_kind(map_kind,desc)
implicit none
integer, intent(in) :: map_kind
type(psb_inter_desc_type), intent(inout) :: desc
desc%itd_data(psb_map_kind_) = map_kind
end subroutine psb_cd_set_map_kind
function psb_cd_get_map_data(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_cd_get_map_data
if (psb_is_ok_desc(desc)) then
psb_cd_get_map_data = desc%itd_data(psb_map_data_)
else
psb_cd_get_map_data = -1
end if
end function psb_cd_get_map_data
subroutine psb_cd_set_map_data(map_data,desc)
implicit none
integer, intent(in) :: map_data
type(psb_inter_desc_type), intent(inout) :: desc
desc%itd_data(psb_map_data_) = map_data
end subroutine psb_cd_set_map_data
function psb_cd_get_fw_tmp_sz(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_cd_get_fw_tmp_sz
psb_cd_get_fw_tmp_sz = desc%itd_data(psb_fw_tmp_sz_)
end function psb_cd_get_fw_tmp_sz
function psb_cd_get_bk_tmp_sz(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
Integer :: psb_cd_get_bk_tmp_sz
psb_cd_get_bk_tmp_sz = desc%itd_data(psb_bk_tmp_sz_)
end function psb_cd_get_bk_tmp_sz
subroutine psb_cd_set_fw_tmp_sz(isz,desc)
implicit none
type(psb_inter_desc_type), intent(inout) :: desc
integer, intent(in) :: isz
desc%itd_data(psb_fw_tmp_sz_) =isz
end subroutine psb_cd_set_fw_tmp_sz
subroutine psb_cd_set_bk_tmp_sz(isz,desc)
implicit none
type(psb_inter_desc_type), intent(inout) :: desc
integer, intent(in) :: isz
desc%itd_data(psb_bk_tmp_sz_) =isz
end subroutine psb_cd_set_bk_tmp_sz
logical function psb_is_asb_inter_desc(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
psb_is_asb_inter_desc = .false.
if (.not.allocated(desc%itd_data)) return
if (.not.associated(desc%desc_1)) return
if (.not.associated(desc%desc_2)) return
psb_is_asb_inter_desc = &
& psb_is_asb_desc(desc%desc_1).and.psb_is_asb_desc(desc%desc_2)
end function psb_is_asb_inter_desc
logical function psb_is_ok_inter_desc(desc)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
psb_is_ok_inter_desc = .false.
if (.not.allocated(desc%itd_data)) return
select case(desc%itd_data(psb_map_data_))
case(psb_map_integer_, psb_map_single_, psb_map_complex_,&
& psb_map_double_, psb_map_double_complex_)
! Ok go ahead
case default
! Since it's false so far, simply return
return
end select
if (.not.associated(desc%desc_1)) return
if (.not.associated(desc%desc_2)) return
psb_is_ok_inter_desc = &
& psb_is_ok_desc(desc%desc_1).and.psb_is_ok_desc(desc%desc_2)
end function psb_is_ok_inter_desc
function psb_s_map_sizeof(map) result(val)
implicit none
type(psb_s_map_type), intent(in) :: map
integer(psb_long_int_k_) :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
end function psb_s_map_sizeof
function psb_d_map_sizeof(map) result(val)
implicit none
type(psb_d_map_type), intent(in) :: map
integer(psb_long_int_k_) :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
end function psb_d_map_sizeof
function psb_c_map_sizeof(map) result(val)
implicit none
type(psb_c_map_type), intent(in) :: map
integer(psb_long_int_k_) :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
end function psb_c_map_sizeof
function psb_z_map_sizeof(map) result(val)
implicit none
type(psb_z_map_type), intent(in) :: map
integer(psb_long_int_k_) :: val
val = 0
val = val + psb_sizeof(map%map_fw)
val = val + psb_sizeof(map%map_bk)
end function psb_z_map_sizeof
function psb_itd_sizeof(desc) result(val)
implicit none
type(psb_inter_desc_type), intent(in) :: desc
integer(psb_long_int_k_) :: val
val = 0
if (allocated(desc%itd_data)) val = val + psb_sizeof_int*size(desc%itd_data)
if (allocated(desc%exch_fw_idx)) val = val + psb_sizeof_int*size(desc%exch_fw_idx)
if (allocated(desc%exch_bk_idx)) val = val + psb_sizeof_int*size(desc%exch_bk_idx)
val = val + psb_sizeof(desc%desc_fw)
val = val + psb_sizeof(desc%desc_bk)
val = val + psb_sizeof(desc%dmap)
val = val + psb_sizeof(desc%zmap)
end function psb_itd_sizeof
end module psb_inter_desc_mod
base/modules/psb_inter_desc_type.f90
-89
View File
@@ -1,89 +0,0 @@
!!$
!!$ Parallel Sparse BLAS version 2.2
!!$ (C) Copyright 2006/2007/2008
!!$ 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.
!!$
!!$
!
!
! package: psb_inter_descriptor_type
! Defines facilities for mapping between vectors belonging
! to different spaces.
!
module psb_inter_descriptor_type
use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_descriptor_type, only: psb_desc_type
! Inter-descriptor mapping data structures.
integer, parameter :: psb_map_kind_ = 1
integer, parameter :: psb_map_data_ = 2
integer, parameter :: psb_map_integer_ = 1
integer, parameter :: psb_map_single_ = 2
integer, parameter :: psb_map_double_ = 3
integer, parameter :: psb_map_complex_ = 4
integer, parameter :: psb_map_double_complex_ = 5
integer, parameter :: psb_fw_tmp_kind_ = 5
integer, parameter :: psb_fw_tmp_sz_ = 6
integer, parameter :: psb_bk_tmp_kind_ = 7
integer, parameter :: psb_bk_tmp_sz_ = 8
integer, parameter :: psb_itd_data_size_=20
type psb_s_map_type
type(psb_sspmat_type) :: map_fw, map_bk
end type psb_s_map_type
type psb_d_map_type
type(psb_dspmat_type) :: map_fw, map_bk
end type psb_d_map_type
type psb_c_map_type
type(psb_cspmat_type) :: map_fw, map_bk
end type psb_c_map_type
type psb_z_map_type
type(psb_zspmat_type) :: map_fw, map_bk
end type psb_z_map_type
type psb_inter_desc_type
integer, allocatable :: itd_data(:)
type(psb_desc_type), pointer :: desc_1=>null(), desc_2=>null()
integer, allocatable :: exch_fw_idx(:), exch_bk_idx(:)
type(psb_desc_type) :: desc_fw, desc_bk
type(psb_s_map_type) :: smap
type(psb_d_map_type) :: dmap
type(psb_c_map_type) :: cmap
type(psb_z_map_type) :: zmap
end type psb_inter_desc_type
end module psb_inter_descriptor_type
base/modules/psb_linmap_mod.f90
+5 -3
View File
@@ -175,7 +175,7 @@ module psb_linmap_mod
implicit none
type(psb_dlinmap_type) :: psb_d_linmap
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_dspmat_type), intent(in) :: map_X2Y, map_Y2X
type(psb_d_sparse_mat), intent(in) :: map_X2Y, map_Y2X
integer, intent(in) :: map_kind
integer, intent(in), optional :: iaggr(:), naggr(:)
end function psb_d_linmap
@@ -471,6 +471,7 @@ contains
end function psb_slinmap_sizeof
function psb_dlinmap_sizeof(map) result(val)
use psb_d_mat_mod
implicit none
type(psb_dlinmap_type), intent(in) :: map
integer(psb_long_int_k_) :: val
@@ -544,7 +545,7 @@ contains
implicit none
type(psb_dlinmap_type), intent(out) :: out_map
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_dspmat_type), intent(in) :: map_X2Y, map_Y2X
type(psb_d_sparse_mat), intent(in) :: map_X2Y, map_Y2X
integer, intent(in) :: map_kind
integer, intent(in), optional :: iaggr(:), naggr(:)
out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr)
@@ -595,8 +596,9 @@ contains
end subroutine psb_slinmap_transfer
subroutine psb_dlinmap_transfer(mapin,mapout,info)
use psb_spmat_type
use psb_realloc_mod
use psb_descriptor_type
use psb_mat_mod
implicit none
type(psb_dlinmap_type) :: mapin,mapout
integer, intent(out) :: info
base/modules/psb_linmap_type_mod.f90
+2 -1
View File
@@ -39,6 +39,7 @@ module psb_linmap_type_mod
use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_d_mat_mod, only: psb_d_sparse_mat
use psb_descriptor_type, only: psb_desc_type
@@ -65,7 +66,7 @@ module psb_linmap_type_mod
integer, allocatable :: itd_data(:), iaggr(:), naggr(:)
type(psb_desc_type), pointer :: p_desc_X=>null(), p_desc_Y=>null()
type(psb_desc_type) :: desc_X, desc_Y
type(psb_dspmat_type) :: map_X2Y, map_Y2X
type(psb_d_sparse_mat) :: map_X2Y, map_Y2X
end type psb_dlinmap_type
type psb_clinmap_type
base/modules/psb_mat_mod.f03
+215 -8
View File
@@ -27,6 +27,7 @@ module psb_d_mat_mod
procedure, pass(a) :: get_nrows
procedure, pass(a) :: get_ncols
procedure, pass(a) :: get_nzeros
procedure, pass(a) :: get_nz_row
procedure, pass(a) :: get_size
procedure, pass(a) :: get_state
procedure, pass(a) :: get_dupl
@@ -48,17 +49,24 @@ module psb_d_mat_mod
procedure, pass(a) :: free
procedure, pass(a) :: trim
procedure, pass(a) :: csput
procedure, pass(a) :: d_csgetptn
procedure, pass(a) :: d_csgetrow
procedure, pass(a) :: d_csgetblk
generic, public :: csget => d_csgetrow, d_csgetblk
generic, public :: csget => d_csgetptn, d_csgetrow, d_csgetblk
procedure, pass(a) :: csclip
procedure, pass(a) :: reall => reallocate_nz
procedure, pass(a) :: get_neigh
procedure, pass(a) :: d_cscnv
procedure, pass(a) :: d_cscnv_ip
generic, public :: cscnv => d_cscnv, d_cscnv_ip
procedure, pass(a) :: reinit
procedure, pass(a) :: print => sparse_print
procedure, pass(a) :: d_mv_from
generic, public :: mv_from => d_mv_from
procedure, pass(a) :: d_cp_from
generic, public :: cp_from => d_cp_from
! Computational routines
procedure, pass(a) :: get_diag
procedure, pass(a) :: csnmi
@@ -80,17 +88,26 @@ module psb_d_mat_mod
& is_unit, get_neigh, csall, csput, d_csgetrow,&
& d_csgetblk, csclip, d_cscnv, d_cscnv_ip, &
& reallocate_nz, free, trim, &
& sparse_print, &
& sparse_print, reinit, &
& set_nrows, set_ncols, set_dupl, &
& set_state, set_null, set_bld, &
& set_upd, set_asb, set_sorted, &
& set_upper, set_lower, set_triangle, &
& set_unit, get_diag
& set_unit, get_diag, get_nz_row, d_csgetptn, &
& d_mv_from, d_cp_from
interface psb_sizeof
module procedure d_sizeof
end interface
interface psb_move_alloc
module procedure d_sparse_mat_move
end interface
interface psb_clone
module procedure d_sparse_mat_clone
end interface
interface psb_csmm
module procedure d_csmm, d_csmv
end interface
@@ -389,6 +406,22 @@ contains
end function get_size
function get_nz_row(idx,a) result(res)
use psb_error_mod
implicit none
integer, intent(in) :: idx
class(psb_d_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
res = 0
if (allocated(a%a)) res = a%a%get_nz_row(idx)
end function get_nz_row
!=====================================
!
@@ -823,8 +856,6 @@ contains
!=====================================
subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc)
use psb_error_mod
implicit none
@@ -989,7 +1020,7 @@ contains
endif
call a%a%free()
deallocate(a%a)
return
9999 continue
@@ -1071,6 +1102,54 @@ contains
end subroutine csput
subroutine d_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
use psb_d_base_mat_mod
implicit none
class(psb_d_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
Integer :: err_act
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (a%is_null()) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
call a%a%csget(imin,imax,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
end subroutine d_csgetptn
subroutine d_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
@@ -1407,7 +1486,132 @@ contains
end subroutine d_cscnv_ip
subroutine d_mv_from(a,b)
use psb_error_mod
use psb_string_mod
implicit none
class(psb_d_sparse_mat), intent(out) :: a
class(psb_d_base_sparse_mat), intent(inout) :: b
integer :: info
allocate(a%a,source=b, stat=info)
call a%a%mv_from_fmt(b,info)
return
end subroutine d_mv_from
subroutine d_cp_from(a,b)
use psb_error_mod
use psb_string_mod
implicit none
class(psb_d_sparse_mat), intent(out) :: a
class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
Integer :: err_act, info
character(len=20) :: name='clone'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
allocate(a%a,source=b,stat=info)
if (info /= 0) info = 4000
if (info == 0) call a%a%cp_from_fmt(b, info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
end subroutine d_cp_from
subroutine d_sparse_mat_move(a,b,info)
use psb_error_mod
use psb_string_mod
implicit none
class(psb_d_sparse_mat), intent(inout) :: a
class(psb_d_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='move_alloc'
logical, parameter :: debug=.false.
info = 0
call move_alloc(a%a,b%a)
return
end subroutine d_sparse_mat_move
subroutine d_sparse_mat_clone(a,b,info)
use psb_error_mod
use psb_string_mod
implicit none
class(psb_d_sparse_mat), intent(in) :: a
class(psb_d_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='clone'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
allocate(b%a,source=a%a,stat=info)
if (info /= 0) info = 4000
if (info == 0) call b%a%cp_from_fmt(a%a, info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
end subroutine d_sparse_mat_clone
subroutine reinit(a,clear)
use psb_error_mod
implicit none
class(psb_d_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
Integer :: err_act, info
character(len=20) :: name='reinit'
call psb_erractionsave(err_act)
if (a%is_null()) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
call a%a%reinit(clear)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
end subroutine reinit
!=====================================
@@ -1554,7 +1758,7 @@ contains
call psb_errpush(info,name)
goto 9999
endif
call a%a%cssm(alpha,x,beta,y,info,trans,side,d)
if (info /= 0) goto 9999
@@ -1720,3 +1924,6 @@ contains
end module psb_d_mat_mod
module psb_mat_mod
use psb_d_mat_mod
end module psb_mat_mod
base/modules/psb_spmat_type.f03
+7 -7
View File
@@ -115,13 +115,13 @@ module psb_spmat_type
type, extends(psb_base_spmat_type) :: psb_dspmat_type
real(psb_dpk_), allocatable :: aspk(:)
contains
procedure, pass(a) :: psb_dcsmm
procedure, pass(a) :: psb_dcsmv
generic, public :: csmm => psb_dcsmm, psb_dcsmv
procedure, pass(t) :: psb_dcssm
procedure, pass(t) :: psb_dcssv
generic, public :: cssm => psb_dcssm, psb_dcssv
!!$ contains
!!$ procedure, pass(a) :: psb_dcsmm
!!$ procedure, pass(a) :: psb_dcsmv
!!$ generic, public :: csmm => psb_dcsmm, psb_dcsmv
!!$ procedure, pass(t) :: psb_dcssm
!!$ procedure, pass(t) :: psb_dcssv
!!$ generic, public :: cssm => psb_dcssm, psb_dcssv
end type psb_dspmat_type
type, extends(psb_base_spmat_type) :: psb_zspmat_type
base/modules/psb_tools_mod.f90
+18 -19
View File
@@ -33,7 +33,6 @@ Module psb_tools_mod
use psb_const_mod
use psb_spmat_type
interface psb_cd_set_bld
subroutine psb_cd_set_bld(desc,info)
use psb_descriptor_type
@@ -232,9 +231,9 @@ Module psb_tools_mod
Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,outfmt,data)
use psb_descriptor_type
use psb_spmat_type
Type(psb_dspmat_type),Intent(in) :: a
Type(psb_dspmat_type),Intent(inout) :: blk
use psb_mat_mod
Type(psb_d_sparse_mat),Intent(in) :: a
Type(psb_d_sparse_mat),Intent(inout) :: blk
Type(psb_desc_type),Intent(in),target :: desc_a
integer, intent(out) :: info
logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale
@@ -488,9 +487,9 @@ Module psb_tools_mod
end Subroutine psb_scdbldext
Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info,extype)
use psb_descriptor_type
Use psb_spmat_type
Use psb_mat_mod
integer, intent(in) :: novr
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_d_sparse_mat), Intent(in) :: a
Type(psb_desc_type), Intent(in), target :: desc_a
Type(psb_desc_type), Intent(out) :: desc_ov
integer, intent(out) :: info
@@ -686,10 +685,10 @@ Module psb_tools_mod
end subroutine psb_dspins
subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
use psb_descriptor_type
use psb_spmat_type
use psb_d_mat_mod
type(psb_d_sparse_mat), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_ar
type(psb_desc_type), intent(inout) :: desc_ac
type(psb_dspmat_type), intent(inout) :: a
integer, intent(in) :: nz,ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
@@ -748,9 +747,9 @@ Module psb_tools_mod
end subroutine psb_ssprn
subroutine psb_dsprn(a, desc_a,info,clear)
use psb_descriptor_type
use psb_spmat_type
use psb_mat_mod
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(inout) :: a
type(psb_d_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
logical, intent(in), optional :: clear
end subroutine psb_dsprn
@@ -1159,13 +1158,13 @@ contains
subroutine psb_dlinmap_init(a_map,cd_xt,descin,descout)
use psb_spmat_type
use psb_descriptor_type
use psb_serial_mod
use psb_penv_mod
use psb_error_mod
use psb_mat_mod
implicit none
type(psb_dspmat_type), intent(out) :: a_map
type(psb_d_sparse_mat), intent(out) :: a_map
type(psb_desc_type), intent(out) :: cd_xt
type(psb_desc_type), intent(in) :: descin, descout
@@ -1185,18 +1184,18 @@ contains
ncol_in = psb_cd_get_local_cols(cd_xt)
nrow_out = psb_cd_get_local_rows(descout)
call psb_sp_all(nrow_out,ncol_in,a_map,info)
call a_map%csall(nrow_out,ncol_in,info)
end subroutine psb_dlinmap_init
subroutine psb_dlinmap_ins(nz,ir,ic,val,a_map,cd_xt,descin,descout)
use psb_spmat_type
use psb_mat_mod
use psb_descriptor_type
implicit none
integer, intent(in) :: nz
integer, intent(in) :: ir(:),ic(:)
real(kind(1.d0)), intent(in) :: val(:)
type(psb_dspmat_type), intent(inout) :: a_map
type(psb_d_sparse_mat), intent(inout) :: a_map
type(psb_desc_type), intent(inout) :: cd_xt
type(psb_desc_type), intent(in) :: descin, descout
integer :: info
@@ -1205,11 +1204,11 @@ contains
end subroutine psb_dlinmap_ins
subroutine psb_dlinmap_asb(a_map,cd_xt,descin,descout,afmt)
use psb_spmat_type
use psb_mat_mod
use psb_descriptor_type
use psb_serial_mod
implicit none
type(psb_dspmat_type), intent(inout) :: a_map
type(psb_d_sparse_mat), intent(inout) :: a_map
type(psb_desc_type), intent(inout) :: cd_xt
type(psb_desc_type), intent(in) :: descin, descout
character(len=*), optional, intent(in) :: afmt
@@ -1220,8 +1219,8 @@ contains
ictxt = psb_cd_get_context(descin)
call psb_cdasb(cd_xt,info)
a_map%k = psb_cd_get_local_cols(cd_xt)
call psb_spcnv(a_map,info,afmt=afmt)
call a_map%set_ncols(psb_cd_get_local_cols(cd_xt))
call a_map%cscnv(info,type=afmt)
end subroutine psb_dlinmap_asb