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

psblas3:

Browse Source 
Makefile
 base/modules/psb_error_mod.F90
 base/newserial/Makefile
 base/newserial/psbn_base_mat_mod.f03
 base/newserial/psbn_d_base_mat_mod.f03
 base/newserial/psbn_d_coo_impl.f03
 base/newserial/psbn_d_csr_impl.f03
 base/newserial/psbn_d_csr_mat_mod.f03
 base/newserial/psbn_mat_impl.f03
 base/newserial/psbn_mat_mod.f03
 test/serial/d_coo_matgen.f03
 test/serial/d_matgen.f03
 test/serial/psbn_d_cxx_impl.f03
 test/serial/psbn_d_cxx_mat_mod.f03

Renamed various methods.
Tight binding of methods to outer objects.
psblas3-type-indexed
Salvatore Filippone 16 years ago
parent 1d21c81827
commit 7ee565006c
13 changed files with 715 additions and 355 deletions
Show Stats Download Patch File Download Diff File

2
base/modules/psb_error_mod.F90
Unescape Escape View File

@ -474,7 +474,7 @@ contains
case(600)
write (0,'("Sparse Matrix and descriptors are in an invalid state for this subroutine call: ",i0)')i_e_d(1)
case(700)
write (0,'("Base version has been called: the actual derived type is incomplete!")')
write (0,'("Base version has been called; the class implementation for ",a," may be incomplete!")') a_e_d
case (1121)
write (0,'("Invalid state for sparse matrix A")')

2
base/newserial/Makefile
Unescape Escape View File

@ -1,7 +1,7 @@
include ../../Make.inc
MODULES = psbn_base_mat_mod.o psbn_d_base_mat_mod.o psbn_d_coo_impl.o psbn_mat_mod.o\
psbn_mat_impl.o psbn_d_csr_mat_mod.o psbn_d_csr_impl.o
psbn_d_csr_mat_mod.o psbn_d_csr_impl.o
LIBMOD=

14
base/newserial/psbn_base_mat_mod.f03
Unescape Escape View File

@ -318,7 +318,7 @@ contains
! 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)
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -342,7 +342,7 @@ contains
! 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)
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -372,7 +372,7 @@ contains
! 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)
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -401,7 +401,7 @@ contains
! 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)
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -424,7 +424,7 @@ contains
! 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)
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -446,7 +446,7 @@ contains
! 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)
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -467,7 +467,7 @@ contains
! 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)
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()

56
base/newserial/psbn_d_base_mat_mod.f03
Unescape Escape View File

@ -6,11 +6,11 @@ module psbn_d_base_mat_mod
contains
procedure, pass(a) :: d_base_csmv
procedure, pass(a) :: d_base_csmm
generic, public :: psbn_csmm => d_base_csmm, d_base_csmv
generic, public :: csmm => d_base_csmm, d_base_csmv
procedure, pass(a) :: d_base_cssv
procedure, pass(a) :: d_base_cssm
generic, public :: psbn_cssm => d_base_cssm, d_base_cssv
procedure, pass(a) :: csins
generic, public :: cssm => d_base_cssm, d_base_cssv
procedure, pass(a) :: csput
procedure, pass(a) :: cp_to_coo
procedure, pass(a) :: cp_from_coo
procedure, pass(a) :: cp_to_fmt
@ -21,7 +21,7 @@ module psbn_d_base_mat_mod
procedure, pass(a) :: mv_from_fmt
end type psbn_d_base_sparse_mat
private :: d_base_csmv, d_base_csmm, d_base_cssv, d_base_cssm,&
& csins, cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, &
& csput, cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, &
& mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt
@ -40,7 +40,7 @@ module psbn_d_base_mat_mod
procedure, pass(a) :: d_base_csmv => d_coo_csmv
procedure, pass(a) :: d_base_cssm => d_coo_cssm
procedure, pass(a) :: d_base_cssv => d_coo_cssv
procedure, pass(a) :: csins => d_coo_csins
procedure, pass(a) :: csput => d_coo_csput
procedure, pass(a) :: reallocate_nz => d_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz
procedure, pass(a) :: cp_to_coo => d_cp_coo_to_coo
@ -59,7 +59,7 @@ module psbn_d_base_mat_mod
end type psbn_d_coo_sparse_mat
private :: d_coo_get_nzeros, d_coo_set_nzeros, &
& d_coo_csmm, d_coo_csmv, d_coo_cssm, d_coo_cssv, &
& d_coo_csins, d_coo_reallocate_nz, d_coo_allocate_mnnz, &
& d_coo_csput, d_coo_reallocate_nz, d_coo_allocate_mnnz, &
& 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
@ -168,7 +168,7 @@ module psbn_d_base_mat_mod
interface
subroutine d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine d_coo_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_const_mod
import psbn_d_coo_sparse_mat
class(psbn_d_coo_sparse_mat), intent(inout) :: a
@ -176,7 +176,7 @@ module psbn_d_base_mat_mod
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
end subroutine d_coo_csins_impl
end subroutine d_coo_csput_impl
end interface
interface d_coo_cssm_impl
@ -241,7 +241,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -267,7 +267,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -294,7 +294,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -320,7 +320,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -347,7 +347,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -373,7 +373,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -400,7 +400,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -426,7 +426,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -477,7 +477,7 @@ contains
end subroutine d_fix_coo
subroutine csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
implicit none
@ -488,7 +488,7 @@ contains
integer, intent(in), optional :: gtl(:)
Integer :: err_act
character(len=20) :: name='csins'
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
@ -496,14 +496,14 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
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 csins
end subroutine csput
subroutine d_base_csmm(alpha,a,x,beta,y,info,trans)
use psb_error_mod
@ -523,7 +523,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -550,7 +550,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -578,7 +578,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -605,7 +605,7 @@ contains
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
@ -952,7 +952,7 @@ contains
end subroutine d_coo_set_nzeros
subroutine d_coo_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine d_coo_csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
implicit none
@ -964,7 +964,7 @@ contains
Integer :: err_act
character(len=20) :: name='d_coo_csins'
character(len=20) :: name='d_coo_csput'
logical, parameter :: debug=.false.
integer :: nza, i,j,k, nzl, isza, int_err(5)
@ -999,7 +999,7 @@ contains
if (nz == 0) return
nza = a%get_nzeros()
call d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
call d_coo_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@ -1014,7 +1014,7 @@ contains
end if
return
end subroutine d_coo_csins
end subroutine d_coo_csput
subroutine d_coo_csmv(alpha,a,x,beta,y,info,trans)

10
base/newserial/psbn_d_coo_impl.f03
Unescape Escape View File

@ -853,10 +853,10 @@ subroutine d_coo_csmm_impl(alpha,a,x,beta,y,info,trans)
end subroutine d_coo_csmm_impl
subroutine d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine d_coo_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psbn_d_base_mat_mod, psb_protect_name => d_coo_csins_impl
use psbn_d_base_mat_mod, psb_protect_name => d_coo_csput_impl
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
@ -867,7 +867,7 @@ subroutine d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
Integer :: err_act
character(len=20) :: name='d_coo_csins_impl'
character(len=20) :: name='d_coo_csput_impl'
logical, parameter :: debug=.false.
integer :: nza, i,j,k, nzl, isza, int_err(5)
@ -905,7 +905,7 @@ subroutine d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
nza = a%get_nzeros()
isza = a%get_size()
!!$ write(0,*) 'On entry to csins_impl: ',nza
!!$ write(0,*) 'On entry to csput_impl: ',nza
if (a%is_bld()) then
! Build phase. Must handle reallocations in a sensible way.
if (isza < (nza+nz)) then
@ -1303,7 +1303,7 @@ contains
end subroutine d_coo_srch_upd
end subroutine d_coo_csins_impl
end subroutine d_coo_csput_impl
subroutine d_cp_coo_to_coo_impl(a,b,info)

70
base/newserial/psbn_d_csr_impl.f03
Unescape Escape View File

@ -942,10 +942,10 @@ end subroutine d_csr_cssm_impl
subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine d_csr_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_csr_csins_impl
use psbn_d_csr_mat_mod, psb_protect_name => d_csr_csput_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
@ -956,7 +956,7 @@ subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
Integer :: err_act
character(len=20) :: name='d_csr_csins'
character(len=20) :: name='d_csr_csput'
logical, parameter :: debug=.false.
integer :: nza, i,j,k, nzl, isza, int_err(5)
@ -1193,7 +1193,7 @@ contains
end subroutine d_csr_srch_upd
end subroutine d_csr_csins_impl
end subroutine d_csr_csput_impl
@ -1438,22 +1438,27 @@ subroutine d_mv_csr_to_fmt_impl(a,b,info)
info = 0
call tmp%mv_from_fmt(a,info)
call b%mv_from_coo(tmp,info)
select type (b)
class is (psbn_d_coo_sparse_mat)
call a%mv_to_coo(b,info)
class default
call tmp%mv_from_fmt(a,info)
if (info == 0) call b%mv_from_coo(tmp,info)
end select
end subroutine d_mv_csr_to_fmt_impl
subroutine d_mv_csr_from_fmt_impl(a,b,info)
subroutine d_cp_csr_to_fmt_impl(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psbn_d_base_mat_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_mv_csr_from_fmt_impl
use psbn_d_csr_mat_mod, psb_protect_name => d_cp_csr_to_fmt_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
class(psbn_d_csr_sparse_mat), intent(in) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
!locals
type(psbn_d_coo_sparse_mat) :: tmp
@ -1465,23 +1470,28 @@ subroutine d_mv_csr_from_fmt_impl(a,b,info)
info = 0
call tmp%mv_from_fmt(b,info)
call a%mv_from_coo(tmp,info)
end subroutine d_mv_csr_from_fmt_impl
select type (b)
class is (psbn_d_coo_sparse_mat)
call a%cp_to_coo(b,info)
class default
call tmp%cp_from_fmt(a,info)
if (info == 0) call b%mv_from_coo(tmp,info)
end select
end subroutine d_cp_csr_to_fmt_impl
subroutine d_cp_csr_to_fmt_impl(a,b,info)
subroutine d_mv_csr_from_fmt_impl(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psbn_d_base_mat_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_cp_csr_to_fmt_impl
use psbn_d_csr_mat_mod, psb_protect_name => d_mv_csr_from_fmt_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
!locals
type(psbn_d_coo_sparse_mat) :: tmp
@ -1493,10 +1503,16 @@ subroutine d_cp_csr_to_fmt_impl(a,b,info)
info = 0
call tmp%cp_from_fmt(a,info)
call b%mv_from_coo(tmp,info)
select type (b)
class is (psbn_d_coo_sparse_mat)
call a%mv_from_coo(b,info)
class default
call tmp%mv_from_fmt(b,info)
if (info == 0) call a%mv_from_coo(tmp,info)
end select
end subroutine d_mv_csr_from_fmt_impl
end subroutine d_cp_csr_to_fmt_impl
subroutine d_cp_csr_from_fmt_impl(a,b,info)
@ -1520,8 +1536,12 @@ subroutine d_cp_csr_from_fmt_impl(a,b,info)
info = 0
call tmp%cp_from_fmt(b,info)
call a%mv_from_coo(tmp,info)
select type (b)
class is (psbn_d_coo_sparse_mat)
call a%cp_from_coo(b,info)
class default
call tmp%cp_from_fmt(b,info)
if (info == 0) call a%mv_from_coo(tmp,info)
end select
end subroutine d_cp_csr_from_fmt_impl

16
base/newserial/psbn_d_csr_mat_mod.f03
Unescape Escape View File

@ -14,7 +14,7 @@ module psbn_d_csr_mat_mod
procedure, pass(a) :: d_base_cssm => d_csr_cssm
procedure, pass(a) :: d_base_cssv => d_csr_cssv
procedure, pass(a) :: reallocate_nz => d_csr_reallocate_nz
procedure, pass(a) :: csins => d_csr_csins
procedure, pass(a) :: csput => d_csr_csput
procedure, pass(a) :: allocate_mnnz => d_csr_allocate_mnnz
procedure, pass(a) :: cp_to_coo => d_cp_csr_to_coo
procedure, pass(a) :: cp_from_coo => d_cp_csr_from_coo
@ -29,7 +29,7 @@ module psbn_d_csr_mat_mod
procedure, pass(a) :: get_fmt => d_csr_get_fmt
end type psbn_d_csr_sparse_mat
private :: d_csr_get_nzeros, d_csr_csmm, d_csr_csmv, d_csr_cssm, d_csr_cssv, &
& d_csr_csins, d_csr_reallocate_nz, d_csr_allocate_mnnz, &
& d_csr_csput, d_csr_reallocate_nz, d_csr_allocate_mnnz, &
& d_csr_free, d_csr_print, d_csr_get_fmt, &
& d_cp_csr_to_coo, d_cp_csr_from_coo, &
& d_mv_csr_to_coo, d_mv_csr_from_coo, &
@ -128,7 +128,7 @@ module psbn_d_csr_mat_mod
end interface
interface
subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine d_csr_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_const_mod
import psbn_d_csr_sparse_mat
class(psbn_d_csr_sparse_mat), intent(inout) :: a
@ -136,7 +136,7 @@ module psbn_d_csr_mat_mod
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
end subroutine d_csr_csins_impl
end subroutine d_csr_csput_impl
end interface
interface d_csr_cssm_impl
@ -235,7 +235,7 @@ contains
end function d_csr_get_nzeros
subroutine d_csr_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine d_csr_csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_const_mod
use psb_error_mod
implicit none
@ -247,7 +247,7 @@ contains
Integer :: err_act
character(len=20) :: name='d_csr_csins'
character(len=20) :: name='d_csr_csput'
logical, parameter :: debug=.false.
integer :: nza, i,j,k, nzl, isza, int_err(5)
@ -282,7 +282,7 @@ contains
if (nz == 0) return
call d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
call d_csr_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@ -296,7 +296,7 @@ contains
return
end if
return
end subroutine d_csr_csins
end subroutine d_csr_csput
subroutine d_csr_csmv(alpha,a,x,beta,y,info,trans)

115
base/newserial/psbn_mat_impl.f03
Unescape Escape View File

@ -12,16 +12,16 @@ subroutine psbn_d_csall(nr,nc,a,info,nz)
info = 0
call a%allocate(nr,nc,nz)
call a%set_state(psbn_spmat_bld_)
call a%set_bld()
return
end subroutine psbn_d_csall
subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine psbn_d_csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psbn_d_base_mat_mod
use psb_error_mod
use psbn_d_mat_mod, psb_protect_name => psbn_d_csins
use psbn_d_mat_mod, psb_protect_name => psbn_d_csput
implicit none
type(psbn_d_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
@ -30,7 +30,7 @@ subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
integer, intent(in), optional :: gtl(:)
Integer :: err_act
character(len=20) :: name='psbn_csins'
character(len=20) :: name='psbn_csput'
logical, parameter :: debug=.false.
info = 0
@ -42,7 +42,7 @@ subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
endif
call a%a%csins(nz,val,ia,ja,imin,imax,jmin,jmax,info,gtl)
call a%a%csput(nz,val,ia,ja,imin,imax,jmin,jmax,info,gtl)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@ -56,14 +56,14 @@ subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
return
end if
end subroutine psbn_d_csins
end subroutine psbn_d_csput
subroutine psbn_d_spcnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod
use psb_string_mod
use psbn_d_mat_mod, psb_protect_name => psbn_d_spcnv
use psb_realloc_mod
use psb_sort_mod
implicit none
type(psbn_d_sparse_mat), intent(in) :: a
type(psbn_d_sparse_mat), intent(out) :: b
@ -73,7 +73,80 @@ subroutine psbn_d_spcnv(a,b,info,type,mold,upd,dupl)
class(psbn_d_base_sparse_mat), intent(in), optional :: mold
write(0,*) 'TO BE IMPLEMENTED '
class(psbn_d_base_sparse_mat), allocatable :: altmp
Integer :: err_act
character(len=20) :: name='psbn_cscnv'
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
if (present(dupl)) then
call b%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call b%set_dupl(psbn_dupl_def_)
end if
if (count( (/present(mold),present(type) /)) > 1) then
info = 583
call psb_errpush(info,name,a_err='TYPE, MOLD')
goto 9999
end if
if (present(mold)) then
allocate(altmp, source=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psbn_d_coo_sparse_mat :: altmp, stat=info)
case default
info = 136
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
end if
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
call altmp%cp_from_fmt(a%a, info)
if (info /= 0) then
info = 4010
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b%a)
call b%set_asb()
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 psbn_d_spcnv
@ -91,8 +164,6 @@ subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl)
class(psbn_d_base_sparse_mat), allocatable :: altmp
class(psbn_d_base_sparse_mat), pointer :: aslct
type(psbn_d_csr_sparse_mat) :: csrtmp
Integer :: err_act
character(len=20) :: name='psbn_cscnv'
logical, parameter :: debug=.false.
@ -108,7 +179,7 @@ subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl)
if (present(dupl)) then
call a%set_dupl(dupl)
else
else if (a%is_bld()) then
call a%set_dupl(psbn_dupl_def_)
end if
@ -135,20 +206,20 @@ subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl)
goto 9999
end select
else
allocate(altmp, source=csrtmp,stat=info)
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
end if
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
select type ( aa => a%a )
class is (psbn_d_coo_sparse_mat)
! Quick route from coo
call altmp%mv_from_coo(aa, info)
class default
call altmp%mv_from_fmt(aa, info)
end select
call altmp%mv_from_fmt(a%a, info)
if (info /= 0) then
info = 1121
call psb_errpush(info,name)
info = 4010
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if

621
base/newserial/psbn_mat_mod.f03
Unescape Escape View File

@ -7,9 +7,9 @@ module psbn_d_mat_mod
type :: psbn_d_sparse_mat
class(psbn_d_base_sparse_mat), allocatable :: a
contains
! Setters
procedure, pass(a) :: set_nrows
procedure, pass(a) :: set_ncols
procedure, pass(a) :: set_dupl
@ -23,13 +23,12 @@ module psbn_d_mat_mod
procedure, pass(a) :: set_lower
procedure, pass(a) :: set_triangle
procedure, pass(a) :: set_unit
! Getters
procedure, pass(a) :: get_nrows
procedure, pass(a) :: get_ncols
procedure, pass(a) :: get_nzeros
procedure, pass(a) :: get_size
procedure, pass(a) :: get_state
procedure, pass(a) :: get_dupl
procedure, pass(a) :: is_null
procedure, pass(a) :: is_bld
@ -40,97 +39,67 @@ module psbn_d_mat_mod
procedure, pass(a) :: is_lower
procedure, pass(a) :: is_triangle
procedure, pass(a) :: is_unit
procedure, pass(a) :: get_neigh
procedure, pass(a) :: allocate_mnnz
procedure, pass(a) :: reallocate_nz
procedure, pass(a) :: free
procedure, pass(a) :: print => sparse_print
procedure, pass(a) :: get_fmt => sparse_get_fmt
generic, public :: allocate => allocate_mnnz
generic, public :: reallocate => reallocate_nz
! Memory/data management
procedure, pass(a) :: csall
procedure, pass(a) :: free
procedure, pass(a) :: csput
procedure, pass(a) :: csget
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) :: print => sparse_print
! Computational routines
procedure, pass(a) :: d_csmv
procedure, pass(a) :: d_csmm
generic, public :: psbn_csmm => d_csmm, d_csmv
generic, public :: csmm => d_csmm, d_csmv
procedure, pass(a) :: d_cssv
procedure, pass(a) :: d_cssm
generic, public :: psbn_cssm => d_cssm, d_cssv
generic, public :: cssm => d_cssm, d_cssv
end type psbn_d_sparse_mat
private :: get_nrows, get_ncols, 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_mnnz, &
& is_unit, get_neigh, csall, csput, csget, d_cscnv, d_cscnv_ip, &
& reallocate_nz, free, d_csmv, d_csmm, d_cssv, d_cssm, sparse_print, &
& 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
contains
interface psbn_csall
subroutine psbn_d_csall(nr,nc,a,info,nz)
use psbn_d_base_mat_mod
import psbn_d_sparse_mat
type(psbn_d_sparse_mat), intent(out) :: a
integer, intent(in) :: nr,nc
integer, intent(out) :: info
integer, intent(in), optional :: nz
end subroutine psbn_d_csall
end interface
interface psbn_csins
subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psbn_d_base_mat_mod
import psbn_d_sparse_mat
type(psbn_d_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
end subroutine psbn_d_csins
end interface
interface psbn_cscnv
subroutine psbn_d_spcnv(a,b,info,type,mold,upd,dupl)
use psbn_d_base_mat_mod
import psbn_d_sparse_mat
type(psbn_d_sparse_mat), intent(in) :: a
type(psbn_d_sparse_mat), intent(out) :: b
integer, intent(out) :: info
integer, optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: type
class(psbn_d_base_sparse_mat), intent(in), optional :: mold
end subroutine psbn_d_spcnv
subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl)
use psbn_d_base_mat_mod
import psbn_d_sparse_mat
type(psbn_d_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psbn_d_base_sparse_mat), intent(in), optional :: mold
end subroutine psbn_d_spcnv_ip
end interface
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
!
! Getters
!
!
!
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
contains
function sparse_get_fmt(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
character(len=5) :: res
if (allocated(a%a)) then
res = a%a%get_fmt()
else
res = 'NULL'
end if
end function sparse_get_fmt
@ -140,32 +109,32 @@ contains
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
if (allocated(a%a)) then
res = a%a%get_dupl()
else
res = psbn_invalid_
end if
end function get_dupl
function get_state(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
if (allocated(a%a)) then
res = a%a%get_state()
else
res = psbn_spmat_null_
end if
end function get_state
function get_nrows(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
if (allocated(a%a)) then
res = a%a%get_nrows()
else
@ -243,7 +212,7 @@ contains
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_null()
else
@ -304,7 +273,89 @@ contains
end function is_sorted
function get_nzeros(a) result(res)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act, info
character(len=20) :: name='get_nzeros'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
res = a%a%get_nzeros()
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 function get_nzeros
function get_size(a) result(res)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act, info
character(len=20) :: name='get_size'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
res = a%a%get_size()
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 function get_size
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
!
! Setters
!
!
!
!
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine set_nrows(m,a)
use psb_error_mod
implicit none
@ -447,7 +498,7 @@ contains
call psb_errpush(info,name)
goto 9999
endif
call a%a%set_null()
call psb_erractionrestore(err_act)
@ -480,7 +531,7 @@ contains
endif
call a%a%set_bld()
call psb_erractionrestore(err_act)
return
@ -539,7 +590,7 @@ contains
call psb_errpush(info,name)
goto 9999
endif
call a%a%set_asb()
call psb_erractionrestore(err_act)
@ -570,9 +621,9 @@ contains
call psb_errpush(info,name)
goto 9999
endif
call a%a%set_sorted(val)
call psb_erractionrestore(err_act)
return
@ -632,7 +683,7 @@ contains
call psb_errpush(info,name)
goto 9999
endif
call a%a%set_unit(val)
call psb_erractionrestore(err_act)
@ -711,18 +762,37 @@ contains
end subroutine set_upper
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
!
! Data management
!
!
!
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function get_nzeros(a) result(res)
subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
integer, intent(in) :: iout
class(psbn_d_sparse_mat), intent(in) :: a
integer, intent(in), optional :: iv(:)
integer, intent(in), optional :: eirs,eics
character(len=*), optional :: head
integer, intent(in), optional :: ivr(:), ivc(:)
Integer :: err_act, info
character(len=20) :: name='get_nzeros'
character(len=20) :: name='sparse_print'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
@ -730,7 +800,8 @@ contains
goto 9999
endif
res = a%a%get_nzeros()
call a%a%print(iout,iv,eirs,eics,head,ivr,ivc)
call psb_erractionrestore(err_act)
return
@ -742,27 +813,37 @@ contains
call psb_error()
return
end if
return
end function get_nzeros
end subroutine sparse_print
function get_size(a) result(res)
subroutine get_neigh(a,idx,neigh,n,info,lev)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act, info
character(len=20) :: name='get_size'
class(psbn_d_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
integer, allocatable, intent(out) :: neigh(:)
integer, intent(out) :: info
integer, optional, intent(in) :: lev
Integer :: err_act
character(len=20) :: name='get_neigh'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
res = a%a%get_size()
call a%a%get_neigh(idx,neigh,n,info,lev)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
@ -776,33 +857,66 @@ contains
end if
return
end function get_size
end subroutine get_neigh
subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc)
subroutine csall(nr,nc,a,info,nz)
use psbn_d_base_mat_mod
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(out) :: a
integer, intent(in) :: nr,nc
integer, intent(out) :: info
integer, intent(in), optional :: nz
integer, intent(in) :: iout
class(psbn_d_sparse_mat), intent(in) :: a
integer, intent(in), optional :: iv(:)
integer, intent(in), optional :: eirs,eics
character(len=*), optional :: head
integer, intent(in), optional :: ivr(:), ivc(:)
Integer :: err_act
character(len=20) :: name='csall'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
allocate(psbn_d_coo_sparse_mat :: a%a, stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info, name)
goto 9999
end if
call a%a%allocate(nr,nc,nz)
call a%set_bld()
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 csall
subroutine reallocate_nz(nz,a)
use psb_error_mod
implicit none
integer, intent(in) :: nz
class(psbn_d_sparse_mat), intent(inout) :: a
Integer :: err_act, info
character(len=20) :: name='sparse_print'
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
call a%a%print(iout,iv,eirs,eics,head,ivr,ivc)
call a%a%reallocate(nz)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
@ -816,23 +930,16 @@ contains
end if
return
end subroutine sparse_print
end subroutine reallocate_nz
subroutine get_neigh(a,idx,neigh,n,info,lev)
subroutine free(a)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
integer, allocatable, intent(out) :: neigh(:)
integer, intent(out) :: info
integer, optional, intent(in) :: lev
Integer :: err_act
character(len=20) :: name='get_neigh'
class(psbn_d_sparse_mat), intent(inout) :: a
Integer :: err_act, info
character(len=20) :: name='free'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
@ -840,9 +947,7 @@ contains
goto 9999
endif
call a%a%get_neigh(idx,neigh,n,info,lev)
if (info /= 0) goto 9999
call a%a%free()
call psb_erractionrestore(err_act)
return
@ -856,64 +961,79 @@ contains
end if
return
end subroutine get_neigh
end subroutine free
subroutine allocate_mnnz(m,n,a,nz,type,mold)
subroutine csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psbn_d_base_mat_mod
use psb_error_mod
use psb_string_mod
implicit none
integer, intent(in) :: m,n
class(psbn_d_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
character(len=*), intent(in), optional :: type
class(psbn_d_base_sparse_mat), intent(in), optional :: mold
real(psb_dpk_), intent(in) :: val(:)
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
Integer :: err_act, info
character(len=20) :: name='allocate_mnnz'
character(len=8) :: type_
Integer :: err_act
character(len=20) :: name='csput'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
info = 0
if (allocated(a%a)) then
call a%a%free()
deallocate(a%a)
end if
if (.not.a%is_bld()) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
if (present(mold)) then
allocate(a%a, source=mold, stat=info)
else
call a%a%csput(nz,val,ia,ja,imin,imax,jmin,jmax,info,gtl)
if (info /= 0) goto 9999
if (present(type)) then
type_ = psb_toupper(type)
else
type_ = 'COO'
end if
call psb_erractionrestore(err_act)
return
select case(type)
case('COO')
allocate(psbn_d_coo_sparse_mat :: a%a, stat=info)
! Add here a few other data structures inplemented by default.
9999 continue
call psb_erractionrestore(err_act)
!!$ case('CSR')
!!$ allocate(psbn_d_csr_sparse_mat :: a%a, stat=info)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
case default
allocate(psbn_d_coo_sparse_mat :: a%a, stat=info)
end select
end subroutine csput
end if
subroutine csget(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psbn_d_base_mat_mod
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: nz, ia(:), ja(:)
integer, intent(in) :: imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
if (info /= 0) then
info = 4010
Integer :: err_act
character(len=20) :: name='csput'
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
end if
call a%a%allocate(m,n,nz)
endif
info = 700
call psb_errpush(info,name,a_err='CSGET')
goto 9999
!!$
!!$ call a%a%csget(nz,val,ia,ja,imin,imax,jmin,jmax,info,gtl)
!!$ if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
@ -924,29 +1044,85 @@ contains
call psb_error()
return
end if
return
end subroutine csget
end subroutine allocate_mnnz
subroutine reallocate_nz(nz,a)
subroutine d_cscnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod
use psb_string_mod
implicit none
integer, intent(in) :: nz
class(psbn_d_sparse_mat), intent(inout) :: a
Integer :: err_act, info
character(len=20) :: name='reallocate_nz'
class(psbn_d_sparse_mat), intent(in) :: a
class(psbn_d_sparse_mat), intent(out) :: b
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: type
class(psbn_d_base_sparse_mat), intent(in), optional :: mold
class(psbn_d_base_sparse_mat), allocatable :: altmp
Integer :: err_act
character(len=20) :: name='cscnv'
logical, parameter :: debug=.false.
if (.not.allocated(a%a)) then
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%reallocate(nz)
if (present(dupl)) then
call b%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call b%set_dupl(psbn_dupl_def_)
end if
if (info /= 0) goto 9999
if (count( (/present(mold),present(type) /)) > 1) then
info = 583
call psb_errpush(info,name,a_err='TYPE, MOLD')
goto 9999
end if
if (present(mold)) then
allocate(altmp, source=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psbn_d_coo_sparse_mat :: altmp, stat=info)
case default
info = 136
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
end if
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
call altmp%cp_from_fmt(a%a, info)
if (info /= 0) then
info = 4010
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b%a)
call b%set_asb()
call psb_erractionrestore(err_act)
return
@ -958,26 +1134,84 @@ contains
call psb_error()
return
end if
return
end subroutine reallocate_nz
end subroutine d_cscnv
subroutine free(a)
subroutine d_cscnv_ip(a,info,type,mold,dupl)
use psb_error_mod
use psb_string_mod
implicit none
class(psbn_d_sparse_mat), intent(inout) :: a
Integer :: err_act, info
character(len=20) :: name='free'
integer, intent(out) :: info
integer,optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psbn_d_base_sparse_mat), intent(in), optional :: mold
class(psbn_d_base_sparse_mat), allocatable :: altmp
Integer :: err_act
character(len=20) :: name='cscnv_ip'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
if (a%is_null()) then
info = 1121
call psb_errpush(info,name)
goto 9999
endif
call a%a%free()
if (present(dupl)) then
call a%set_dupl(dupl)
else if (a%is_bld()) then
call a%set_dupl(psbn_dupl_def_)
end if
if (count( (/present(mold),present(type) /)) > 1) then
info = 583
call psb_errpush(info,name,a_err='TYPE, MOLD')
goto 9999
end if
if (present(mold)) then
allocate(altmp, source=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psbn_d_coo_sparse_mat :: altmp, stat=info)
case default
info = 136
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psbn_d_csr_sparse_mat :: altmp, stat=info)
end if
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
call altmp%mv_from_fmt(a%a, info)
if (info /= 0) then
info = 4010
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a%a)
call a%set_asb()
call psb_erractionrestore(err_act)
return
@ -989,9 +1223,26 @@ contains
call psb_error()
return
end if
return
end subroutine free
end subroutine d_cscnv_ip
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!
!
! Computational routines
!
!
!
!
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_csmm(alpha,a,x,beta,y,info,trans)
@ -1014,7 +1265,7 @@ contains
goto 9999
endif
call a%a%psbn_csmm(alpha,x,beta,y,info,trans)
call a%a%csmm(alpha,x,beta,y,info,trans)
call psb_erractionrestore(err_act)
return
@ -1050,7 +1301,7 @@ contains
goto 9999
endif
call a%a%psbn_csmm(alpha,x,beta,y,info,trans)
call a%a%csmm(alpha,x,beta,y,info,trans)
call psb_erractionrestore(err_act)
return
@ -1085,8 +1336,8 @@ contains
call psb_errpush(info,name)
goto 9999
endif
call a%a%psbn_cssm(alpha,x,beta,y,info,trans)
call a%a%cssm(alpha,x,beta,y,info,trans)
call psb_erractionrestore(err_act)
return
@ -1122,7 +1373,7 @@ contains
goto 9999
endif
call a%a%psbn_cssm(alpha,x,beta,y,info,trans)
call a%a%cssm(alpha,x,beta,y,info,trans)
call psb_erractionrestore(err_act)

2
test/serial/d_coo_matgen.f03
Unescape Escape View File

@ -357,7 +357,7 @@ contains
endif
end do
call acoo%csins(element-1,val,irow,icol,1,nr,1,nr,info)
call acoo%csput(element-1,val,irow,icol,1,nr,1,nr,info)
end do

29
test/serial/d_matgen.f03
Unescape Escape View File

@ -201,7 +201,7 @@ contains
t0 = psb_wtime()
call psbn_csall(nr,nr,a_n,info)
call a_n%csall(nr,nr,info)
talc = psb_wtime()-t0
@ -357,7 +357,7 @@ contains
endif
end do
call psbn_csins(element-1,val,irow,icol,a_n,1,nr,1,nr,info)
call a_n%csput(element-1,val,irow,icol,1,nr,1,nr,info)
end do
@ -368,9 +368,9 @@ contains
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call a_n%print(19)
t1 = psb_wtime()
call psbn_cscnv(a_n,info,mold=acxx)
call a_n%cscnv(info,mold=acsr)
if(info /= 0) then
info=4010
@ -380,18 +380,19 @@ contains
end if
tasb = psb_wtime()-t1
call a_n%print(20)
!!$ t1 = psb_wtime()
!!$ call psbn_cscnv(a_n,info,mold=acoo)
!!$
!!$ if(info /= 0) then
!!$ info=4010
!!$ ch_err='asb rout.'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ end if
!!$ tmov = psb_wtime()-t1
t1 = psb_wtime()
call a_n%cscnv(info,mold=acxx)
if(info /= 0) then
info=4010
ch_err='asb rout.'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
tmov = psb_wtime()-t1
call a_n%print(21)
!!$
if(iam == psb_root_) then
write(*,'("The matrix has been generated and is currently in ",a3," format.")')&

85
test/serial/psbn_d_cxx_impl.f03
Unescape Escape View File

@ -942,10 +942,10 @@ end subroutine d_cxx_cssm_impl
subroutine d_cxx_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine d_cxx_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psbn_d_cxx_mat_mod, psb_protect_name => d_cxx_csins_impl
use psbn_d_cxx_mat_mod, psb_protect_name => d_cxx_csput_impl
implicit none
class(psbn_d_cxx_sparse_mat), intent(inout) :: a
@ -956,7 +956,7 @@ subroutine d_cxx_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
Integer :: err_act
character(len=20) :: name='d_cxx_csins'
character(len=20) :: name='d_cxx_csput'
logical, parameter :: debug=.false.
integer :: nza, i,j,k, nzl, isza, int_err(5)
@ -1193,7 +1193,7 @@ contains
end subroutine d_cxx_srch_upd
end subroutine d_cxx_csins_impl
end subroutine d_cxx_csput_impl
@ -1438,22 +1438,28 @@ subroutine d_mv_cxx_to_fmt_impl(a,b,info)
info = 0
call tmp%mv_from_fmt(a,info)
call b%mv_from_coo(tmp,info)
select type (b)
class is (psbn_d_coo_sparse_mat)
call a%mv_to_coo(b,info)
class default
call tmp%mv_from_fmt(a,info)
if (info == 0) call b%mv_from_coo(tmp,info)
end select
end subroutine d_mv_cxx_to_fmt_impl
subroutine d_mv_cxx_from_fmt_impl(a,b,info)
subroutine d_cp_cxx_to_fmt_impl(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psbn_d_base_mat_mod
use psbn_d_cxx_mat_mod, psb_protect_name => d_mv_cxx_from_fmt_impl
use psbn_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_to_fmt_impl
implicit none
class(psbn_d_cxx_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
class(psbn_d_cxx_sparse_mat), intent(in) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
!locals
type(psbn_d_coo_sparse_mat) :: tmp
@ -1465,23 +1471,26 @@ subroutine d_mv_cxx_from_fmt_impl(a,b,info)
info = 0
call tmp%mv_from_fmt(b,info)
call a%mv_from_coo(tmp,info)
end subroutine d_mv_cxx_from_fmt_impl
select type (b)
class is (psbn_d_coo_sparse_mat)
call a%cp_to_coo(b,info)
class default
call tmp%cp_from_fmt(a,info)
if (info == 0) call b%mv_from_coo(tmp,info)
end select
end subroutine d_cp_cxx_to_fmt_impl
subroutine d_cp_cxx_to_fmt_impl(a,b,info)
subroutine d_cp_cxx_from_fmt_impl(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psbn_d_base_mat_mod
use psbn_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_to_fmt_impl
use psbn_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_from_fmt_impl
implicit none
class(psbn_d_cxx_sparse_mat), intent(in) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
class(psbn_d_cxx_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
!locals
type(psbn_d_coo_sparse_mat) :: tmp
@ -1493,22 +1502,26 @@ subroutine d_cp_cxx_to_fmt_impl(a,b,info)
info = 0
call tmp%cp_from_fmt(a,info)
call b%mv_from_coo(tmp,info)
end subroutine d_cp_cxx_to_fmt_impl
select type (b)
class is (psbn_d_coo_sparse_mat)
call a%cp_from_coo(b,info)
class default
call tmp%cp_from_fmt(b,info)
if (info == 0) call a%mv_from_coo(tmp,info)
end select
end subroutine d_cp_cxx_from_fmt_impl
subroutine d_cp_cxx_from_fmt_impl(a,b,info)
subroutine d_mv_cxx_from_fmt_impl(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psbn_d_base_mat_mod
use psbn_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_from_fmt_impl
use psbn_d_cxx_mat_mod, psb_protect_name => d_mv_cxx_from_fmt_impl
implicit none
class(psbn_d_cxx_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
class(psbn_d_cxx_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
!locals
type(psbn_d_coo_sparse_mat) :: tmp
@ -1520,8 +1533,12 @@ subroutine d_cp_cxx_from_fmt_impl(a,b,info)
info = 0
call tmp%cp_from_fmt(b,info)
call a%mv_from_coo(tmp,info)
end subroutine d_cp_cxx_from_fmt_impl
select type (b)
class is (psbn_d_coo_sparse_mat)
call a%mv_from_coo(b,info)
class default
call tmp%mv_from_fmt(b,info)
if (info == 0) call a%mv_from_coo(tmp,info)
end select
end subroutine d_mv_cxx_from_fmt_impl

48
test/serial/psbn_d_cxx_mat_mod.f03
Unescape Escape View File

@ -14,7 +14,7 @@ module psbn_d_cxx_mat_mod
procedure, pass(a) :: d_base_cssm => d_cxx_cssm
procedure, pass(a) :: d_base_cssv => d_cxx_cssv
procedure, pass(a) :: reallocate_nz => d_cxx_reallocate_nz
procedure, pass(a) :: csins => d_cxx_csins
procedure, pass(a) :: csput => d_cxx_csput
procedure, pass(a) :: allocate_mnnz => d_cxx_allocate_mnnz
procedure, pass(a) :: cp_to_coo => d_cp_cxx_to_coo
procedure, pass(a) :: cp_from_coo => d_cp_cxx_from_coo
@ -29,7 +29,7 @@ module psbn_d_cxx_mat_mod
procedure, pass(a) :: get_fmt => d_cxx_get_fmt
end type psbn_d_cxx_sparse_mat
private :: d_cxx_get_nzeros, d_cxx_csmm, d_cxx_csmv, d_cxx_cssm, d_cxx_cssv, &
& d_cxx_csins, d_cxx_reallocate_nz, d_cxx_allocate_mnnz, &
& d_cxx_csput, d_cxx_reallocate_nz, d_cxx_allocate_mnnz, &
& d_cxx_free, d_cxx_print, d_cxx_get_fmt, &
& d_cp_cxx_to_coo, d_cp_cxx_from_coo, &
& d_mv_cxx_to_coo, d_mv_cxx_from_coo, &
@ -128,7 +128,7 @@ module psbn_d_cxx_mat_mod
end interface
interface
subroutine d_cxx_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine d_cxx_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_const_mod
import psbn_d_cxx_sparse_mat
class(psbn_d_cxx_sparse_mat), intent(inout) :: a
@ -136,7 +136,7 @@ module psbn_d_cxx_mat_mod
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
end subroutine d_cxx_csins_impl
end subroutine d_cxx_csput_impl
end interface
interface d_cxx_cssm_impl
@ -235,7 +235,7 @@ contains
end function d_cxx_get_nzeros
subroutine d_cxx_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
subroutine d_cxx_csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_const_mod
use psb_error_mod
implicit none
@ -247,7 +247,7 @@ contains
Integer :: err_act
character(len=20) :: name='d_cxx_csins'
character(len=20) :: name='d_cxx_csput'
logical, parameter :: debug=.false.
integer :: nza, i,j,k, nzl, isza, int_err(5)
@ -282,7 +282,7 @@ contains
if (nz == 0) return
call d_cxx_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
call d_cxx_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@ -296,7 +296,7 @@ contains
return
end if
return
end subroutine d_cxx_csins
end subroutine d_cxx_csput
subroutine d_cxx_csmv(alpha,a,x,beta,y,info,trans)
@ -601,22 +601,22 @@ contains
return
end subroutine d_cp_cxx_to_fmt
subroutine d_cp_cxx_from_fmt(a,b,info)
subroutine d_mv_cxx_to_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_cxx_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='from_fmt'
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_cp_cxx_from_fmt_impl(a,b,info)
call d_mv_cxx_to_coo_impl(a,b,info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@ -632,24 +632,24 @@ contains
end if
return
end subroutine d_cp_cxx_from_fmt
subroutine d_mv_cxx_to_coo(a,b,info)
end subroutine d_mv_cxx_to_coo
subroutine d_cp_cxx_from_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_cxx_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
class(psbn_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='to_coo'
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_mv_cxx_to_coo_impl(a,b,info)
call d_cp_cxx_from_fmt_impl(a,b,info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@ -665,8 +665,8 @@ contains
end if
return
end subroutine d_mv_cxx_to_coo
end subroutine d_cp_cxx_from_fmt
subroutine d_mv_cxx_from_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod

Write Preview
Loading…
Cancel
Save