diff --git a/base/serial/f77/smmp.f b/base/serial/f77/smmp.f index 6285cac7..4acf6f41 100644 --- a/base/serial/f77/smmp.f +++ b/base/serial/f77/smmp.f @@ -210,7 +210,7 @@ c$$$ ' NUMBMM: Fixing row ',i,ic(i),ic(i+1)-1 50 continue return end - subroutine numbmm(n, m, l, + subroutine dnumbmm(n, m, l, * ia, ja, diaga, a, * ib, jb, diagb, b, * ic, jc, diagc, c, diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index 552d8802..2078fb82 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -867,7 +867,7 @@ subroutine psb_c_csgetblk(imin,imax,a,b,info,& Integer :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. - type(psb_c_coo_sparse_mat), allocatable :: acoo + class(psb_c_base_sparse_mat), allocatable :: acoo info = psb_success_ @@ -878,12 +878,21 @@ subroutine psb_c_csgetblk(imin,imax,a,b,info,& goto 9999 endif - allocate(acoo,stat=info) + allocate(psb_c_coo_sparse_mat :: acoo,stat=info) - if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) -!!$ if (info == psb_success_) call move_alloc(acoo,b%a) - if (info == psb_success_) call b%mv_from(acoo) + if (info == psb_success_) then + select type (acoo) + type is (psb_c_coo_sparse_mat) + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -920,7 +929,7 @@ subroutine psb_c_csclip(a,b,info,& Integer :: err_act character(len=20) :: name='csclip' logical, parameter :: debug=.false. - type(psb_c_coo_sparse_mat), allocatable :: acoo + class(psb_c_base_sparse_mat), allocatable :: acoo info = psb_success_ call psb_erractionsave(err_act) @@ -930,11 +939,22 @@ subroutine psb_c_csclip(a,b,info,& goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) call a%a%csclip(acoo,info,& - & imin,imax,jmin,jmax,rscale,cscale) -!!$ if (info == psb_success_) call move_alloc(acoo,b%a) - if (info == psb_success_) call b%mv_from(acoo) + allocate(psb_c_coo_sparse_mat :: acoo,stat=info) + + if (info == psb_success_) then + select type (acoo) + type is (psb_c_coo_sparse_mat) + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index 22f72001..bc45e56b 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -867,7 +867,7 @@ subroutine psb_d_csgetblk(imin,imax,a,b,info,& Integer :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. - type(psb_d_coo_sparse_mat), allocatable :: acoo + class(psb_d_base_sparse_mat), allocatable :: acoo info = psb_success_ @@ -878,12 +878,21 @@ subroutine psb_d_csgetblk(imin,imax,a,b,info,& goto 9999 endif - allocate(acoo,stat=info) + allocate(psb_d_coo_sparse_mat :: acoo,stat=info) - if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) -!!$ if (info == psb_success_) call move_alloc(acoo,b%a) - if (info == psb_success_) call b%mv_from(acoo) + if (info == psb_success_) then + select type (acoo) + type is (psb_d_coo_sparse_mat) + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -920,7 +929,7 @@ subroutine psb_d_csclip(a,b,info,& Integer :: err_act character(len=20) :: name='csclip' logical, parameter :: debug=.false. - type(psb_d_coo_sparse_mat), allocatable :: acoo + class(psb_d_base_sparse_mat), allocatable :: acoo info = psb_success_ call psb_erractionsave(err_act) @@ -930,11 +939,22 @@ subroutine psb_d_csclip(a,b,info,& goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) call a%a%csclip(acoo,info,& - & imin,imax,jmin,jmax,rscale,cscale) -!!$ if (info == psb_success_) call move_alloc(acoo,b%a) - if (info == psb_success_) call b%mv_from(acoo) + allocate(psb_d_coo_sparse_mat :: acoo,stat=info) + + if (info == psb_success_) then + select type (acoo) + type is (psb_d_coo_sparse_mat) + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index 89eef2d5..de6e5679 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -867,7 +867,7 @@ subroutine psb_s_csgetblk(imin,imax,a,b,info,& Integer :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. - type(psb_s_coo_sparse_mat), allocatable :: acoo + class(psb_s_base_sparse_mat), allocatable :: acoo info = psb_success_ @@ -878,12 +878,21 @@ subroutine psb_s_csgetblk(imin,imax,a,b,info,& goto 9999 endif - allocate(acoo,stat=info) + allocate(psb_s_coo_sparse_mat :: acoo,stat=info) - if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) -!!$ if (info == psb_success_) call move_alloc(acoo,b%a) - if (info == psb_success_) call b%mv_from(acoo) + if (info == psb_success_) then + select type (acoo) + type is (psb_s_coo_sparse_mat) + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -920,7 +929,7 @@ subroutine psb_s_csclip(a,b,info,& Integer :: err_act character(len=20) :: name='csclip' logical, parameter :: debug=.false. - type(psb_s_coo_sparse_mat), allocatable :: acoo + class(psb_s_base_sparse_mat), allocatable :: acoo info = psb_success_ call psb_erractionsave(err_act) @@ -930,11 +939,22 @@ subroutine psb_s_csclip(a,b,info,& goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) call a%a%csclip(acoo,info,& - & imin,imax,jmin,jmax,rscale,cscale) -!!$ if (info == psb_success_) call move_alloc(acoo,b%a) - if (info == psb_success_) call b%mv_from(acoo) + allocate(psb_s_coo_sparse_mat :: acoo,stat=info) + + if (info == psb_success_) then + select type (acoo) + type is (psb_s_coo_sparse_mat) + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index f5102ed5..4fd791cd 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -867,7 +867,7 @@ subroutine psb_z_csgetblk(imin,imax,a,b,info,& Integer :: err_act character(len=20) :: name='csget' logical, parameter :: debug=.false. - type(psb_z_coo_sparse_mat), allocatable :: acoo + class(psb_z_base_sparse_mat), allocatable :: acoo info = psb_success_ @@ -878,12 +878,21 @@ subroutine psb_z_csgetblk(imin,imax,a,b,info,& goto 9999 endif - allocate(acoo,stat=info) + allocate(psb_z_coo_sparse_mat :: acoo,stat=info) - if (info == psb_success_) call a%a%csget(imin,imax,acoo,info,& - & jmin,jmax,iren,append,rscale,cscale) -!!$ if (info == psb_success_) call move_alloc(acoo,b%a) - if (info == psb_success_) call b%mv_from(acoo) + if (info == psb_success_) then + select type (acoo) + type is (psb_z_coo_sparse_mat) + call a%a%csget(imin,imax,acoo,info,& + & jmin,jmax,iren,append,rscale,cscale) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ + end if + if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) @@ -920,7 +929,7 @@ subroutine psb_z_csclip(a,b,info,& Integer :: err_act character(len=20) :: name='csclip' logical, parameter :: debug=.false. - type(psb_z_coo_sparse_mat), allocatable :: acoo + class(psb_z_base_sparse_mat), allocatable :: acoo info = psb_success_ call psb_erractionsave(err_act) @@ -930,11 +939,22 @@ subroutine psb_z_csclip(a,b,info,& goto 9999 endif - allocate(acoo,stat=info) - if (info == psb_success_) call a%a%csclip(acoo,info,& - & imin,imax,jmin,jmax,rscale,cscale) -!!$ if (info == psb_success_) call move_alloc(acoo,b%a) - if (info == psb_success_) call b%mv_from(acoo) + allocate(psb_z_coo_sparse_mat :: acoo,stat=info) + + if (info == psb_success_) then + select type (acoo) + type is (psb_z_coo_sparse_mat) + call a%a%csclip(acoo,info,& + & imin,imax,jmin,jmax,rscale,cscale) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ + end if + + if (info == psb_success_) call move_alloc(acoo,b%a) if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/base/serial/psb_cnumbmm.f90 b/base/serial/psb_cnumbmm.f90 index d240a12d..55a69485 100644 --- a/base/serial/psb_cnumbmm.f90 +++ b/base/serial/psb_cnumbmm.f90 @@ -198,7 +198,7 @@ contains endif do i = 1,maxlmn - temp(i) = dzero + temp(i) = czero end do minlm = min(l,m) minln = min(l,n) @@ -233,7 +233,7 @@ contains return else c%val(j) = temp(c%ja(j)) - temp(c%ja(j)) = dzero + temp(c%ja(j)) = czero endif end do end do @@ -242,4 +242,3 @@ contains end subroutine gen_numbmm end subroutine psb_cbase_numbmm - diff --git a/base/serial/psb_csymbmm.f90 b/base/serial/psb_csymbmm.f90 index 10ce2087..2bb1ee37 100644 --- a/base/serial/psb_csymbmm.f90 +++ b/base/serial/psb_csymbmm.f90 @@ -46,7 +46,7 @@ subroutine psb_csymbmm(a,b,c,info) type(psb_cspmat_type), intent(in) :: a,b type(psb_cspmat_type), intent(out) :: c integer, intent(out) :: info - type(psb_c_csr_sparse_mat), allocatable :: ccsr + class(psb_c_base_sparse_mat), allocatable :: ccsr integer :: err_act character(len=*), parameter :: name='psb_symbmm' call psb_erractionsave(err_act) @@ -58,13 +58,20 @@ subroutine psb_csymbmm(a,b,c,info) goto 9999 endif - allocate(ccsr, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 + allocate(psb_c_csr_sparse_mat :: ccsr,stat=info) + + if (info == psb_success_) then + select type (ccsr) + type is (psb_c_csr_sparse_mat) + call psb_symbmm(a%a,b%a,ccsr,info) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ end if - call psb_symbmm(a%a,b%a,ccsr,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 diff --git a/base/serial/psb_dnumbmm.f90 b/base/serial/psb_dnumbmm.f90 index b9f90172..8e132301 100644 --- a/base/serial/psb_dnumbmm.f90 +++ b/base/serial/psb_dnumbmm.f90 @@ -169,7 +169,7 @@ contains mb = b%get_nrows() nb = b%get_ncols() - call numbmm(ma,na,nb,a%irp,a%ja,0,a%val,& + call dnumbmm(ma,na,nb,a%irp,a%ja,0,a%val,& & b%irp,b%ja,0,b%val,& & c%irp,c%ja,0,c%val,temp) diff --git a/base/serial/psb_dsymbmm.f90 b/base/serial/psb_dsymbmm.f90 index 72af99da..e4f50b58 100644 --- a/base/serial/psb_dsymbmm.f90 +++ b/base/serial/psb_dsymbmm.f90 @@ -46,7 +46,7 @@ subroutine psb_dsymbmm(a,b,c,info) type(psb_dspmat_type), intent(in) :: a,b type(psb_dspmat_type), intent(out) :: c integer, intent(out) :: info - type(psb_d_csr_sparse_mat), allocatable :: ccsr + class(psb_d_base_sparse_mat), allocatable :: ccsr integer :: err_act character(len=*), parameter :: name='psb_symbmm' call psb_erractionsave(err_act) @@ -58,13 +58,20 @@ subroutine psb_dsymbmm(a,b,c,info) goto 9999 endif - allocate(ccsr, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 + allocate(psb_d_csr_sparse_mat :: ccsr,stat=info) + + if (info == psb_success_) then + select type (ccsr) + type is (psb_d_csr_sparse_mat) + call psb_symbmm(a%a,b%a,ccsr,info) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ end if - call psb_symbmm(a%a,b%a,ccsr,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 diff --git a/base/serial/psb_snumbmm.f90 b/base/serial/psb_snumbmm.f90 index 95525a08..70e5733d 100644 --- a/base/serial/psb_snumbmm.f90 +++ b/base/serial/psb_snumbmm.f90 @@ -198,7 +198,7 @@ contains endif do i = 1,maxlmn - temp(i) = dzero + temp(i) = szero end do minlm = min(l,m) minln = min(l,n) @@ -233,7 +233,7 @@ contains return else c%val(j) = temp(c%ja(j)) - temp(c%ja(j)) = dzero + temp(c%ja(j)) = szero endif end do end do diff --git a/base/serial/psb_ssymbmm.f90 b/base/serial/psb_ssymbmm.f90 index 46ab153c..7b618536 100644 --- a/base/serial/psb_ssymbmm.f90 +++ b/base/serial/psb_ssymbmm.f90 @@ -46,7 +46,7 @@ subroutine psb_ssymbmm(a,b,c,info) type(psb_sspmat_type), intent(in) :: a,b type(psb_sspmat_type), intent(out) :: c integer, intent(out) :: info - type(psb_s_csr_sparse_mat), allocatable :: ccsr + class(psb_s_base_sparse_mat), allocatable :: ccsr integer :: err_act character(len=*), parameter :: name='psb_symbmm' call psb_erractionsave(err_act) @@ -58,13 +58,20 @@ subroutine psb_ssymbmm(a,b,c,info) goto 9999 endif - allocate(ccsr, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 + allocate(psb_s_csr_sparse_mat :: ccsr,stat=info) + + if (info == psb_success_) then + select type (ccsr) + type is (psb_s_csr_sparse_mat) + call psb_symbmm(a%a,b%a,ccsr,info) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ end if - call psb_symbmm(a%a,b%a,ccsr,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999 diff --git a/base/serial/psb_znumbmm.f90 b/base/serial/psb_znumbmm.f90 index 6db7e4c2..5157c78a 100644 --- a/base/serial/psb_znumbmm.f90 +++ b/base/serial/psb_znumbmm.f90 @@ -198,7 +198,7 @@ contains endif do i = 1,maxlmn - temp(i) = dzero + temp(i) = zzero end do minlm = min(l,m) minln = min(l,n) @@ -233,7 +233,7 @@ contains return else c%val(j) = temp(c%ja(j)) - temp(c%ja(j)) = dzero + temp(c%ja(j)) = zzero endif end do end do @@ -242,4 +242,3 @@ contains end subroutine gen_numbmm end subroutine psb_zbase_numbmm - diff --git a/base/serial/psb_zsymbmm.f90 b/base/serial/psb_zsymbmm.f90 index 30108e4a..642b0ce7 100644 --- a/base/serial/psb_zsymbmm.f90 +++ b/base/serial/psb_zsymbmm.f90 @@ -46,7 +46,7 @@ subroutine psb_zsymbmm(a,b,c,info) type(psb_zspmat_type), intent(in) :: a,b type(psb_zspmat_type), intent(out) :: c integer, intent(out) :: info - type(psb_z_csr_sparse_mat), allocatable :: ccsr + class(psb_z_base_sparse_mat), allocatable :: ccsr integer :: err_act character(len=*), parameter :: name='psb_symbmm' call psb_erractionsave(err_act) @@ -58,13 +58,20 @@ subroutine psb_zsymbmm(a,b,c,info) goto 9999 endif - allocate(ccsr, stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 + allocate(psb_z_csr_sparse_mat :: ccsr,stat=info) + + if (info == psb_success_) then + select type (ccsr) + type is (psb_z_csr_sparse_mat) + call psb_symbmm(a%a,b%a,ccsr,info) + class default + ! This is impossible + info = psb_err_internal_error_ + end select + else + info = psb_err_alloc_dealloc_ end if - call psb_symbmm(a%a,b%a,ccsr,info) + if (info /= psb_success_) then call psb_errpush(info,name) goto 9999