From e8b376b22cc600df8148a2447dca9fb427818588 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sun, 8 Nov 2009 17:03:55 +0000 Subject: [PATCH] psblas3: base/modules/psb_c_base_mat_mod.f03 base/modules/psb_d_base_mat_mod.f03 base/modules/psb_s_base_mat_mod.f03 base/modules/psb_z_base_mat_mod.f03 base/serial/f03/psb_d_csc_impl.f03 Fixes for compilation with GNU 4.5.0 (fortran-dev branch). Added transpose to S/C/Z. --- base/modules/psb_c_base_mat_mod.f03 | 192 +++++++++++++++++++++++++++- base/modules/psb_d_base_mat_mod.f03 | 28 ---- base/modules/psb_s_base_mat_mod.f03 | 132 ++++++++++++++++++- base/modules/psb_z_base_mat_mod.f03 | 191 ++++++++++++++++++++++++++- base/serial/f03/psb_d_csc_impl.f03 | 5 +- 5 files changed, 515 insertions(+), 33 deletions(-) diff --git a/base/modules/psb_c_base_mat_mod.f03 b/base/modules/psb_c_base_mat_mod.f03 index ca40d8fc..06e064f7 100644 --- a/base/modules/psb_c_base_mat_mod.f03 +++ b/base/modules/psb_c_base_mat_mod.f03 @@ -36,6 +36,11 @@ module psb_c_base_mat_mod generic, public :: cp_from => c_base_cp_from procedure, pass(a) :: c_base_mv_from generic, public :: mv_from => c_base_mv_from + + procedure, pass(a) :: base_transp_1mat => c_base_transp_1mat + procedure, pass(a) :: base_transp_2mat => c_base_transp_2mat + procedure, pass(a) :: base_transc_1mat => c_base_transc_1mat + procedure, pass(a) :: base_transc_2mat => c_base_transc_2mat end type psb_c_base_sparse_mat private :: c_base_csmv, c_base_csmm, c_base_cssv, c_base_cssm,& @@ -88,7 +93,9 @@ module psb_c_base_mat_mod generic, public :: cp_from => c_coo_cp_from procedure, pass(a) :: c_coo_mv_from generic, public :: mv_from => c_coo_mv_from - + procedure, pass(a) :: base_transp_1mat => c_coo_transp_1mat + procedure, pass(a) :: base_transc_1mat => c_coo_transc_1mat + end type psb_c_coo_sparse_mat private :: c_coo_get_nzeros, c_coo_set_nzeros, c_coo_get_diag, & @@ -99,7 +106,8 @@ module psb_c_base_mat_mod & c_cp_coo_to_fmt, c_cp_coo_from_fmt, & & c_coo_scals, c_coo_scal, c_coo_csgetrow, c_coo_sizeof, & & c_coo_csgetptn, c_coo_get_nz_row, c_coo_reinit,& - & c_coo_cp_from, c_coo_mv_from + & c_coo_cp_from, c_coo_mv_from, & + & c_coo_transp_1mat, c_coo_transc_1mat interface @@ -779,6 +787,186 @@ contains end subroutine csclip + ! + ! Here we go. + ! + subroutine c_coo_transp_1mat(a) + use psb_error_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + + integer, allocatable :: itemp(:) + integer :: info + + call a%psb_c_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 c_coo_transp_1mat + + subroutine c_coo_transc_1mat(a) + use psb_error_mod + implicit none + + class(psb_c_coo_sparse_mat), intent(inout) :: a + + call a%transp() + a%val(:) = conjg(a%val) + + end subroutine c_coo_transc_1mat + + subroutine c_base_transp_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_c_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='c_base_transp' + + call psb_erractionsave(err_act) + + info = 0 + select type(b) + class is (psb_c_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 c_base_transp_2mat + + subroutine c_base_transc_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_c_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='c_base_transc' + + call psb_erractionsave(err_act) + + + info = 0 + select type(b) + class is (psb_c_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == 0) call tmp%transc() + 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 c_base_transc_2mat + + subroutine c_base_transp_1mat(a) + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(inout) :: a + + type(psb_c_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='c_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 c_base_transp_1mat + + subroutine c_base_transc_1mat(a) + use psb_error_mod + implicit none + + class(psb_c_base_sparse_mat), intent(inout) :: a + + type(psb_c_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='c_base_transc' + + call psb_erractionsave(err_act) + info = 0 + call a%mv_to_coo(tmp,info) + if (info == 0) call tmp%transc() + 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 c_base_transc_1mat + + + !==================================== ! diff --git a/base/modules/psb_d_base_mat_mod.f03 b/base/modules/psb_d_base_mat_mod.f03 index 7c617b13..c5e14332 100644 --- a/base/modules/psb_d_base_mat_mod.f03 +++ b/base/modules/psb_d_base_mat_mod.f03 @@ -790,34 +790,6 @@ 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 diff --git a/base/modules/psb_s_base_mat_mod.f03 b/base/modules/psb_s_base_mat_mod.f03 index 8f453cb2..4dd953c1 100644 --- a/base/modules/psb_s_base_mat_mod.f03 +++ b/base/modules/psb_s_base_mat_mod.f03 @@ -36,6 +36,11 @@ module psb_s_base_mat_mod generic, public :: cp_from => s_base_cp_from procedure, pass(a) :: s_base_mv_from generic, public :: mv_from => s_base_mv_from + + procedure, pass(a) :: base_transp_1mat => s_base_transp_1mat + procedure, pass(a) :: base_transp_2mat => s_base_transp_2mat + procedure, pass(a) :: base_transc_1mat => s_base_transc_1mat + procedure, pass(a) :: base_transc_2mat => s_base_transc_2mat end type psb_s_base_sparse_mat private :: s_base_csmv, s_base_csmm, s_base_cssv, s_base_cssm,& @@ -88,6 +93,8 @@ module psb_s_base_mat_mod generic, public :: cp_from => s_coo_cp_from procedure, pass(a) :: s_coo_mv_from generic, public :: mv_from => s_coo_mv_from + procedure, pass(a) :: base_transp_1mat => s_coo_transp_1mat + procedure, pass(a) :: base_transc_1mat => s_coo_transc_1mat end type psb_s_coo_sparse_mat @@ -99,7 +106,9 @@ module psb_s_base_mat_mod & s_cp_coo_to_fmt, s_cp_coo_from_fmt, & & s_coo_scals, s_coo_scal, s_coo_csgetrow, s_coo_sizeof, & & s_coo_csgetptn, s_coo_get_nz_row, s_coo_reinit,& - & s_coo_cp_from, s_coo_mv_from + & s_coo_cp_from, s_coo_mv_from, & + & s_coo_transp_1mat, s_coo_transc_1mat + interface @@ -778,6 +787,127 @@ contains end subroutine csclip + subroutine s_coo_transp_1mat(a) + use psb_error_mod + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + + integer, allocatable :: itemp(:) + integer :: info + + call a%psb_s_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 s_coo_transp_1mat + + subroutine s_coo_transc_1mat(a) + use psb_error_mod + implicit none + + class(psb_s_coo_sparse_mat), intent(inout) :: a + + call a%transp() + end subroutine s_coo_transc_1mat + + subroutine s_base_transp_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_s_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_s_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='s_base_transp' + + call psb_erractionsave(err_act) + + info = 0 + select type(b) + class is (psb_s_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 s_base_transp_2mat + + subroutine s_base_transc_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_s_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + call a%transp(b) + end subroutine s_base_transc_2mat + + subroutine s_base_transp_1mat(a) + use psb_error_mod + implicit none + + class(psb_s_base_sparse_mat), intent(inout) :: a + + type(psb_s_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='s_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 s_base_transp_1mat + + subroutine s_base_transc_1mat(a) + use psb_error_mod + implicit none + + class(psb_s_base_sparse_mat), intent(inout) :: a + + call a%transp() + end subroutine s_base_transc_1mat + + !==================================== diff --git a/base/modules/psb_z_base_mat_mod.f03 b/base/modules/psb_z_base_mat_mod.f03 index 95d860ee..950a8d40 100644 --- a/base/modules/psb_z_base_mat_mod.f03 +++ b/base/modules/psb_z_base_mat_mod.f03 @@ -36,6 +36,11 @@ module psb_z_base_mat_mod generic, public :: cp_from => z_base_cp_from procedure, pass(a) :: z_base_mv_from generic, public :: mv_from => z_base_mv_from + + procedure, pass(a) :: base_transp_1mat => z_base_transp_1mat + procedure, pass(a) :: base_transp_2mat => z_base_transp_2mat + procedure, pass(a) :: base_transc_1mat => z_base_transc_1mat + procedure, pass(a) :: base_transc_2mat => z_base_transc_2mat end type psb_z_base_sparse_mat private :: z_base_csmv, z_base_csmm, z_base_cssv, z_base_cssm,& @@ -88,6 +93,8 @@ module psb_z_base_mat_mod generic, public :: cp_from => z_coo_cp_from procedure, pass(a) :: z_coo_mv_from generic, public :: mv_from => z_coo_mv_from + procedure, pass(a) :: base_transp_1mat => z_coo_transp_1mat + procedure, pass(a) :: base_transc_1mat => z_coo_transc_1mat end type psb_z_coo_sparse_mat @@ -99,7 +106,8 @@ module psb_z_base_mat_mod & z_cp_coo_to_fmt, z_cp_coo_from_fmt, & & z_coo_scals, z_coo_scal, z_coo_csgetrow, z_coo_sizeof, & & z_coo_csgetptn, z_coo_get_nz_row, z_coo_reinit,& - & z_coo_cp_from, z_coo_mv_from + & z_coo_cp_from, z_coo_mv_from, & + & z_coo_transp_1mat, z_coo_transc_1mat interface @@ -779,6 +787,187 @@ contains end subroutine csclip + ! + ! Here we go. + ! + subroutine z_coo_transp_1mat(a) + use psb_error_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + + integer, allocatable :: itemp(:) + integer :: info + + call a%psb_z_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 z_coo_transp_1mat + + subroutine z_coo_transc_1mat(a) + use psb_error_mod + implicit none + + class(psb_z_coo_sparse_mat), intent(inout) :: a + + call a%transp() + a%val(:) = conjg(a%val) + + end subroutine z_coo_transc_1mat + + subroutine z_base_transp_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_z_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='z_base_transp' + + call psb_erractionsave(err_act) + + info = 0 + select type(b) + class is (psb_z_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 z_base_transp_2mat + + subroutine z_base_transc_2mat(a,b) + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(out) :: a + class(psb_base_sparse_mat), intent(in) :: b + + type(psb_z_coo_sparse_mat) :: tmp + integer err_act, info + character(len=*), parameter :: name='z_base_transc' + + call psb_erractionsave(err_act) + + + info = 0 + select type(b) + class is (psb_z_base_sparse_mat) + call b%cp_to_coo(tmp,info) + if (info == 0) call tmp%transc() + 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 z_base_transc_2mat + + subroutine z_base_transp_1mat(a) + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(inout) :: a + + type(psb_z_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='z_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 z_base_transp_1mat + + subroutine z_base_transc_1mat(a) + use psb_error_mod + implicit none + + class(psb_z_base_sparse_mat), intent(inout) :: a + + type(psb_z_coo_sparse_mat) :: tmp + integer :: err_act, info + character(len=*), parameter :: name='z_base_transc' + + call psb_erractionsave(err_act) + info = 0 + call a%mv_to_coo(tmp,info) + if (info == 0) call tmp%transc() + 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 z_base_transc_1mat + + + + !==================================== ! diff --git a/base/serial/f03/psb_d_csc_impl.f03 b/base/serial/f03/psb_d_csc_impl.f03 index 3de5d136..8bd90158 100644 --- a/base/serial/f03/psb_d_csc_impl.f03 +++ b/base/serial/f03/psb_d_csc_impl.f03 @@ -1929,7 +1929,10 @@ subroutine d_cp_csc_to_fmt_impl(a,b,info) call a%cp_to_coo(b,info) type is (psb_d_csc_sparse_mat) - b = a + call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + b%icp = a%icp + b%ia = a%ia + b%val = a%val class default call tmp%cp_from_fmt(a,info)