From ebe0d004ea37db9fe5e1da9720ec20085b3c01a8 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 5 Oct 2009 13:31:52 +0000 Subject: [PATCH] psblas3: base/modules/psb_base_mat_mod.f03 base/modules/psb_d_base_mat_mod.f03 base/modules/psb_d_mat_mod.f03 First version of transpose, only for D for the time being. --- base/modules/psb_base_mat_mod.f03 | 75 ++++++++++++- base/modules/psb_d_base_mat_mod.f03 | 165 +++++++++++++++++++++++++++- base/modules/psb_d_mat_mod.f03 | 160 ++++++++++++++++++++++++++- 3 files changed, 397 insertions(+), 3 deletions(-) diff --git a/base/modules/psb_base_mat_mod.f03 b/base/modules/psb_base_mat_mod.f03 index 4fda1f52..683faadd 100644 --- a/base/modules/psb_base_mat_mod.f03 +++ b/base/modules/psb_base_mat_mod.f03 @@ -81,6 +81,12 @@ module psb_base_mat_mod generic, public :: cp_from => base_cp_from procedure, pass(a) :: base_mv_from generic, public :: mv_from => base_mv_from + procedure, pass(a) :: base_transp_1mat + procedure, pass(a) :: base_transp_2mat + generic, public :: transp => base_transp_1mat, base_transp_2mat + procedure, pass(a) :: base_transc_1mat + procedure, pass(a) :: base_transc_2mat + generic, public :: transc => base_transc_1mat, base_transc_2mat end type psb_base_sparse_mat @@ -91,7 +97,8 @@ module psb_base_mat_mod & 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, reinit, csgetptn, & - & get_nz_row, get_aux, set_aux, base_cp_from, base_mv_from + & get_nz_row, get_aux, set_aux, base_cp_from, base_mv_from, & + & base_transp_1mat, base_transp_2mat, base_transc_1mat, base_transc_2mat contains @@ -481,6 +488,72 @@ contains end subroutine base_cp_from + + ! + ! Here we go. + ! + subroutine base_transp_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + a%m = b%n + a%n = b%m + a%state = b%state + a%duplicate = b%duplicate + a%triangle = b%triangle + a%unitd = b%unitd + a%upper = .not.b%upper + a%sorted = .false. + a%aux = b%aux + + return + + end subroutine base_transp_2mat + + subroutine base_transc_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transp(b) + end subroutine base_transc_2mat + + subroutine base_transp_1mat(a) + use psb_error_mod + implicit none + + class(psb_base_sparse_mat), intent(inout) :: a + integer :: itmp + + itmp = a%m + a%m = a%n + a%n = itmp + a%state = a%state + a%duplicate = a%duplicate + a%triangle = a%triangle + a%unitd = a%unitd + a%upper = .not.a%upper + a%sorted = .false. + + return + + end subroutine base_transp_1mat + + subroutine base_transc_1mat(a) + use psb_error_mod + implicit none + + class(psb_base_sparse_mat), intent(inout) :: a + + call a%transp() + end subroutine base_transc_1mat + + subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) use psb_error_mod implicit none diff --git a/base/modules/psb_d_base_mat_mod.f03 b/base/modules/psb_d_base_mat_mod.f03 index 9b14821a..7c1fefe0 100644 --- a/base/modules/psb_d_base_mat_mod.f03 +++ b/base/modules/psb_d_base_mat_mod.f03 @@ -36,6 +36,12 @@ module psb_d_base_mat_mod generic, public :: cp_from => d_base_cp_from procedure, pass(a) :: d_base_mv_from generic, public :: mv_from => d_base_mv_from + + procedure, pass(a) :: base_transp_1mat => d_base_transp_1mat + procedure, pass(a) :: base_transp_2mat => d_base_transp_2mat + procedure, pass(a) :: base_transc_1mat => d_base_transc_1mat + procedure, pass(a) :: base_transc_2mat => d_base_transc_2mat + end type psb_d_base_sparse_mat private :: d_base_csmv, d_base_csmm, d_base_cssv, d_base_cssm,& @@ -88,6 +94,8 @@ module psb_d_base_mat_mod generic, public :: cp_from => d_coo_cp_from procedure, pass(a) :: d_coo_mv_from generic, public :: mv_from => d_coo_mv_from + procedure, pass(a) :: base_transp_1mat => d_coo_transp_1mat + procedure, pass(a) :: base_transc_1mat => d_coo_transc_1mat end type psb_d_coo_sparse_mat @@ -99,7 +107,8 @@ module psb_d_base_mat_mod & d_cp_coo_to_fmt, d_cp_coo_from_fmt, & & d_coo_scals, d_coo_scal, d_coo_csgetrow, d_coo_sizeof, & & d_coo_csgetptn, d_coo_get_nz_row, d_coo_reinit,& - & d_coo_cp_from, d_coo_mv_from + & d_coo_cp_from, d_coo_mv_from, & + & d_coo_transp_1mat, d_coo_transc_1mat interface @@ -780,6 +789,160 @@ contains + ! + ! Here we go. + ! +!!$ subroutine d_coo_transp_2mat(a,b) +!!$ use psb_error_mod +!!$ implicit none +!!$ +!!$ class(psb_d_coo_sparse_mat), intent(out) :: a +!!$ type(psb_d_coo_sparse_mat), intent(in) :: b +!!$ +!!$ call a%psb_d_base_sparse_mat%psb_base_sparse_mat%transp(b%psb_d_base_sparse_mat%psb_base_sparse_mat) +!!$ a%ia = b%ja +!!$ a%ja = b%ia +!!$ a%val = b%val +!!$ +!!$ call a%fix() +!!$ +!!$ return +!!$ +!!$ end subroutine d_coo_transp_2mat +!!$ +!!$ subroutine d_coo_transc_2mat(a,b) +!!$ use psb_error_mod +!!$ implicit none +!!$ +!!$ class(psb_d_coo_sparse_mat), intent(out) :: a +!!$ class(psb_d_coo_sparse_mat), intent(in) :: b +!!$ +!!$ call a%transp(b) +!!$ end subroutine d_coo_transc_2mat +!!$ + subroutine d_coo_transp_1mat(a) + use psb_error_mod + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + + integer, allocatable :: itemp(:) + integer :: info + + call a%psb_d_base_sparse_mat%psb_base_sparse_mat%transp() + call move_alloc(a%ia,itemp) + call move_alloc(a%ja,a%ia) + call move_alloc(itemp,a%ja) + + call a%fix(info) + + return + + end subroutine d_coo_transp_1mat + + subroutine d_coo_transc_1mat(a) + use psb_error_mod + implicit none + + class(psb_d_coo_sparse_mat), intent(inout) :: a + + call a%transp() + end subroutine d_coo_transc_1mat + + subroutine d_base_transp_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_d_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_d_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='d_base_transp' + + call psb_erractionsave(err_act) + + info = 0 + select type(b) + class is (psb_d_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + class default + info = 700 + end select + if (info /= 0) then + call psb_errpush(info,name,a_err=b%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + + end subroutine d_base_transp_2mat + + subroutine d_base_transc_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_d_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transp(b) + end subroutine d_base_transc_2mat + + subroutine d_base_transp_1mat(a) + use psb_error_mod + implicit none + + class(psb_d_base_sparse_mat), intent(inout) :: a + + type(psb_d_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='d_base_transp' + + call psb_erractionsave(err_act) + info = 0 + call a%mv_to_coo(tmp,info) + if (info == 0) call tmp%transp() + if (info == 0) call a%mv_from_coo(tmp,info) + + if (info /= 0) then + info = 700 + call psb_errpush(info,name,a_err=a%get_fmt()) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + + + end subroutine d_base_transp_1mat + + subroutine d_base_transc_1mat(a) + use psb_error_mod + implicit none + + class(psb_d_base_sparse_mat), intent(inout) :: a + + call a%transp() + end subroutine d_base_transc_1mat + + + + !==================================== ! ! diff --git a/base/modules/psb_d_mat_mod.f03 b/base/modules/psb_d_mat_mod.f03 index 3d5d6e02..ac75facd 100644 --- a/base/modules/psb_d_mat_mod.f03 +++ b/base/modules/psb_d_mat_mod.f03 @@ -64,6 +64,13 @@ module psb_d_mat_mod generic, public :: mv_from => d_mv_from procedure, pass(a) :: d_cp_from generic, public :: cp_from => d_cp_from + procedure, pass(a) :: d_transp_1mat + procedure, pass(a) :: d_transp_2mat + generic, public :: transp => d_transp_1mat, d_transp_2mat + procedure, pass(a) :: d_transc_1mat + procedure, pass(a) :: d_transc_2mat + generic, public :: transc => d_transc_1mat, d_transc_2mat + ! Computational routines @@ -93,7 +100,9 @@ module psb_d_mat_mod & set_upd, set_asb, set_sorted, & & set_upper, set_lower, set_triangle, & & set_unit, get_diag, get_nz_row, d_csgetptn, & - & d_mv_from, d_cp_from + & d_mv_from, d_cp_from, & + & d_transp_1mat, d_transp_2mat, & + & d_transc_1mat, d_transc_2mat interface psb_sizeof module procedure d_sizeof @@ -1581,6 +1590,154 @@ contains end subroutine d_sparse_mat_clone + subroutine d_transp_1mat(a) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transp() + + 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_transp_1mat + + + subroutine d_transp_2mat(a,b) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transp' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transp(b%a) + + 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_transp_2mat + + subroutine d_transc_1mat(a) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_d_sparse_mat), intent(inout) :: a + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%transc() + + 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_transc_1mat + + + subroutine d_transc_2mat(a,b) + use psb_error_mod + use psb_string_mod + implicit none + class(psb_d_sparse_mat), intent(out) :: a + class(psb_d_sparse_mat), intent(in) :: b + + Integer :: err_act, info + character(len=20) :: name='transc' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + if (b%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + allocate(a%a,source=b%a,stat=info) + if (info /= 0) then + info = 4000 + goto 9999 + end if + call a%a%transc(b%a) + + 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_transc_2mat + + + subroutine reinit(a,clear) use psb_error_mod implicit none @@ -1613,6 +1770,7 @@ contains end subroutine reinit + !===================================== ! !