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

psblas3:

Browse Source 
base/serial/f77/smmp.f
 base/serial/impl/psb_c_mat_impl.F90
 base/serial/impl/psb_d_mat_impl.F90
 base/serial/impl/psb_s_mat_impl.F90
 base/serial/impl/psb_z_mat_impl.F90
 base/serial/psb_cnumbmm.f90
 base/serial/psb_csymbmm.f90
 base/serial/psb_dnumbmm.f90
 base/serial/psb_dsymbmm.f90
 base/serial/psb_snumbmm.f90
 base/serial/psb_ssymbmm.f90
 base/serial/psb_znumbmm.f90
 base/serial/psb_zsymbmm.f90

Fixed usage of move_alloc with polymorphic arguments.
This commit is contained in:
Salvatore Filippone
2011-11-30 12:52:41 +00:00
parent fa59304911
commit 08ca708f7d
13 changed files with 192 additions and 86 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/serial/f77/smmp.f
+1 -1
View File
@@ -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,
base/serial/impl/psb_c_mat_impl.F90
+32 -12
View File
@@ -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)
base/serial/impl/psb_d_mat_impl.F90
+32 -12
View File
@@ -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)
base/serial/impl/psb_s_mat_impl.F90
+32 -12
View File
@@ -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)
base/serial/impl/psb_z_mat_impl.F90
+32 -12
View File
@@ -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)
base/serial/psb_cnumbmm.f90
+2 -3
View File
@@ -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
base/serial/psb_csymbmm.f90
+14 -7
View File
@@ -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
base/serial/psb_dnumbmm.f90
+1 -1
View File
@@ -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)
base/serial/psb_dsymbmm.f90
+14 -7
View File
@@ -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
base/serial/psb_snumbmm.f90
+2 -2
View File
@@ -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
base/serial/psb_ssymbmm.f90
+14 -7
View File
@@ -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
base/serial/psb_znumbmm.f90
+2 -3
View File
@@ -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
base/serial/psb_zsymbmm.f90
+14 -7
View File
@@ -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