mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-19 12:22:10 +00:00
Modified interface to GEALL, GEINS et al.
Changed ITRACE behaviour in solver routines. Updated documentation.
This commit is contained in:
Salvatore Filippone
+28
-91
@@ -35,13 +35,11 @@
|
||||
! Allocates dense matrix for PSBLAS routines
|
||||
!
|
||||
! Parameters:
|
||||
! m - number of rows.
|
||||
! n - number of columns.
|
||||
! x - the matrix to be allocated.
|
||||
! desc_a - the communication descriptor.
|
||||
! info - eventually returns an error code
|
||||
! js - (optional) the starting column
|
||||
subroutine psb_dalloc(m, n, x, desc_a, info, js)
|
||||
! info - possibly returns an error code
|
||||
! n - optional number of columns.
|
||||
subroutine psb_dalloc(x, desc_a, info, n)
|
||||
!....allocate dense matrix for psblas routines.....
|
||||
use psb_descriptor_type
|
||||
use psb_const_mod
|
||||
@@ -50,18 +48,17 @@ subroutine psb_dalloc(m, n, x, desc_a, info, js)
|
||||
implicit none
|
||||
|
||||
!....parameters...
|
||||
integer, intent(in) :: m,n
|
||||
real(kind(1.d0)), pointer :: x(:,:)
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer :: info
|
||||
integer, optional, intent(in) :: js
|
||||
integer, optional, intent(in) :: n
|
||||
|
||||
|
||||
!locals
|
||||
integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,i,j,jj,err_act
|
||||
integer :: icontxt,dectype
|
||||
integer :: icontxt,dectype,n_
|
||||
integer :: int_err(5),temp(1),exch(3)
|
||||
real(kind(1.d0)) :: real_err(5)
|
||||
integer, allocatable:: prc_v(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_dallc'
|
||||
@@ -88,88 +85,56 @@ subroutine psb_dalloc(m, n, x, desc_a, info, js)
|
||||
|
||||
dectype=desc_a%matrix_data(psb_dec_type_)
|
||||
!... check m and n parameters....
|
||||
if (m.lt.0) then
|
||||
info = 10
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (n.lt.0) then
|
||||
info = 10
|
||||
int_err(1) = 2
|
||||
int_err(2) = n
|
||||
call psb_errpush(info,name,int_err)
|
||||
else if (.not.psb_is_ok_dec(dectype)) then
|
||||
if (.not.psb_is_ok_dec(dectype)) then
|
||||
info = 3110
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else if (m.ne.desc_a%matrix_data(psb_n_)) then
|
||||
info = 300
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
int_err(3) = 4
|
||||
int_err(4) = psb_n_
|
||||
int_err(5) = desc_a%matrix_data(psb_n_)
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
if (present(js)) then
|
||||
j=js
|
||||
if (present(n)) then
|
||||
n_ = n
|
||||
else
|
||||
j=1
|
||||
n_ = 1
|
||||
endif
|
||||
!global check on m and n parameters
|
||||
!global check on n parameters
|
||||
if (myrow.eq.psb_root_) then
|
||||
exch(1)=m
|
||||
exch(2)=n
|
||||
exch(3)=j
|
||||
call igebs2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree)
|
||||
exch(1)=n_
|
||||
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
|
||||
else
|
||||
call igebr2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree, psb_root_, 0)
|
||||
if (exch(1).ne.m) then
|
||||
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
|
||||
if (exch(1).ne.n_) then
|
||||
info=550
|
||||
int_err(1)=1
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (exch(2).ne.n) then
|
||||
info=550
|
||||
int_err(1)=2
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (exch(3).ne.j) then
|
||||
info=550
|
||||
int_err(1)=3
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
endif
|
||||
|
||||
!....allocate x .....
|
||||
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
|
||||
n_col = max(1,desc_a%matrix_data(psb_n_col_))
|
||||
allocate(x(n_col,j:j+n-1),stat=info)
|
||||
allocate(x(n_col,n_),stat=info)
|
||||
if (info.ne.0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
do jj=j,j+n-1
|
||||
do j=1,n_
|
||||
do i=1,n_col
|
||||
x(i,j) = 0.0d0
|
||||
end do
|
||||
end do
|
||||
else if (psb_is_bld_dec(dectype)) then
|
||||
n_row = max(1,desc_a%matrix_data(psb_n_row_))
|
||||
allocate(x(n_row,j:j+n-1),stat=info)
|
||||
allocate(x(n_row,n_),stat=info)
|
||||
if (info.ne.0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
do jj=j,j+n-1
|
||||
do j = 1, n_
|
||||
do i=1,n_row
|
||||
x(i,j) = 0.0d0
|
||||
end do
|
||||
@@ -224,11 +189,10 @@ end subroutine psb_dalloc
|
||||
! Allocates dense matrix for PSBLAS routines
|
||||
!
|
||||
! Parameters:
|
||||
! m - number of rows.
|
||||
! x - the matrix to be allocated.
|
||||
! desc_a - the communication descriptor.
|
||||
! info - eventually returns an error code
|
||||
subroutine psb_dallocv(m, x, desc_a,info)
|
||||
! info - possibly returns an error code
|
||||
subroutine psb_dallocv(x, desc_a,info,n)
|
||||
!....allocate sparse matrix structure for psblas routines.....
|
||||
use psb_descriptor_type
|
||||
use psb_const_mod
|
||||
@@ -238,14 +202,14 @@ subroutine psb_dallocv(m, x, desc_a,info)
|
||||
implicit none
|
||||
|
||||
!....parameters...
|
||||
integer, intent(in) :: m
|
||||
real(kind(1.d0)), pointer :: x(:)
|
||||
type(psb_desc_type), intent(in):: desc_a
|
||||
integer :: info
|
||||
real(kind(1.d0)), pointer :: x(:)
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer :: info
|
||||
integer, optional, intent(in) :: n
|
||||
|
||||
!locals
|
||||
integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,dectype,i,err_act
|
||||
integer :: icontxt
|
||||
integer :: icontxt, n_
|
||||
integer :: int_err(5),temp(1),exch
|
||||
real(kind(1.d0)) :: real_err(5)
|
||||
logical, parameter :: debug=.false.
|
||||
@@ -275,40 +239,13 @@ subroutine psb_dallocv(m, x, desc_a,info)
|
||||
if (debug) write(0,*) 'dall: dectype',dectype
|
||||
if (debug) write(0,*) 'dall: is_ok? dectype',psb_is_ok_dec(dectype)
|
||||
!... check m and n parameters....
|
||||
if (m.lt.0) then
|
||||
info = 10
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (.not.psb_is_ok_dec(dectype)) then
|
||||
if (.not.psb_is_ok_dec(dectype)) then
|
||||
info = 3110
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else if (m.ne.desc_a%matrix_data(psb_n_)) then
|
||||
info = 300
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
int_err(3) = 4
|
||||
int_err(4) = psb_n_
|
||||
int_err(5) = desc_a%matrix_data(psb_n_)
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
!global check on m and n parameters
|
||||
if (myrow.eq.psb_root_) then
|
||||
exch = m
|
||||
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
|
||||
else
|
||||
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
|
||||
if (exch .ne. m) then
|
||||
info = 550
|
||||
int_err(1) = 1
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
endif
|
||||
! As this is a rank-1 array, optional parameter N is actually ignored.
|
||||
|
||||
!....allocate x .....
|
||||
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
|
||||
|
||||
@@ -44,7 +44,7 @@
|
||||
! info - integer. Eventually returns an error code
|
||||
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
|
||||
! jblck - integer(optional). First col of submatrix belonging to blck to be inserted.
|
||||
subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
|
||||
subroutine psb_dins(m, n, blck, x, ix, jx, desc_a, info,&
|
||||
& iblck, jblck,dupl)
|
||||
!....insert dense submatrix to dense matrix .....
|
||||
use psb_descriptor_type
|
||||
@@ -270,7 +270,7 @@ end subroutine psb_dins
|
||||
! desc_a - type(<psb_desc_type>). The communication descriptor.
|
||||
! info - integer. Eventually returns an error code
|
||||
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
|
||||
subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
|
||||
subroutine psb_dinsvm(m, blck, x, ix, jx, desc_a,info,&
|
||||
& iblck,dupl)
|
||||
!....insert dense submatrix to dense matrix .....
|
||||
use psb_descriptor_type
|
||||
@@ -485,7 +485,7 @@ end subroutine psb_dinsvm
|
||||
! info - integer. Eventually returns an error code
|
||||
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
|
||||
! insflag - integer(optional). ???
|
||||
subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
|
||||
subroutine psb_dinsvv(m, blck, x, ix, desc_a, info,&
|
||||
& iblck,insflag,dupl)
|
||||
!....insert dense submatrix to dense matrix .....
|
||||
use psb_descriptor_type
|
||||
|
||||
+88
-146
@@ -34,13 +34,11 @@
|
||||
! Allocates dense integer matrix for PSBLAS routines
|
||||
!
|
||||
! Parameters:
|
||||
! m - integer. The number of rows.
|
||||
! n - integer. The number of columns.
|
||||
! x - integer,dimension(:,:). The matrix to be allocated.
|
||||
! desc_a - type(<psb_desc_type>). The communication descriptor.
|
||||
! info - integer. Eventually returns an error code
|
||||
! js - integer(optional). The starting column
|
||||
subroutine psb_ialloc(m, n, x, desc_a, info,js)
|
||||
! x - the matrix to be allocated.
|
||||
! desc_a - the communication descriptor.
|
||||
! info - possibly returns an error code
|
||||
! n - optional number of columns.
|
||||
subroutine psb_ialloc(x, desc_a, info, n)
|
||||
!....allocate dense matrix for psblas routines.....
|
||||
use psb_descriptor_type
|
||||
use psb_const_mod
|
||||
@@ -48,19 +46,18 @@ subroutine psb_ialloc(m, n, x, desc_a, info,js)
|
||||
implicit none
|
||||
|
||||
!....parameters...
|
||||
integer, intent(in) :: m,n
|
||||
integer, pointer :: x(:,:)
|
||||
type(psb_desc_type), intent(inout) :: desc_a
|
||||
integer, intent(out) :: info
|
||||
integer, optional, intent(in) :: js
|
||||
integer, pointer :: x(:,:)
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer, intent(out) :: info
|
||||
integer, optional, intent(in) :: n
|
||||
|
||||
|
||||
!locals
|
||||
integer :: j,nprow,npcol,myrow,mypcol,&
|
||||
& n_col,n_row, err_act
|
||||
integer :: icontxt,dectype
|
||||
integer :: nprow,npcol,myrow,mypcol,err,n_col,n_row,i,j,jj,err_act
|
||||
integer :: icontxt,dectype,n_
|
||||
integer :: int_err(5),temp(1),exch(3)
|
||||
real(kind(1.d0)) :: real_err(5)
|
||||
character(len=20) :: name, char_err
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
@@ -84,97 +81,70 @@ subroutine psb_ialloc(m, n, x, desc_a, info,js)
|
||||
|
||||
dectype=desc_a%matrix_data(psb_dec_type_)
|
||||
!... check m and n parameters....
|
||||
if (m.lt.0) then
|
||||
info = 10
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (n.lt.0) then
|
||||
info = 10
|
||||
int_err(1) = 2
|
||||
int_err(2) = n
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (.not.psb_is_ok_dec(dectype)) then
|
||||
info = 3110
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else if (m.ne.desc_a%matrix_data(psb_n_)) then
|
||||
info = 300
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
int_err(3) = 4
|
||||
int_err(4) = psb_n_
|
||||
int_err(5) = desc_a%matrix_data(psb_n_)
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
if (.not.psb_is_ok_dec(dectype)) then
|
||||
info = 3110
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
if (present(js)) then
|
||||
j=js
|
||||
|
||||
if (present(n)) then
|
||||
n_ = n
|
||||
else
|
||||
j=1
|
||||
n_ = 1
|
||||
endif
|
||||
!global check on m and n parameters
|
||||
!global check on n parameters
|
||||
if (myrow.eq.psb_root_) then
|
||||
exch(1)=m
|
||||
exch(2)=n
|
||||
exch(3)=j
|
||||
call igebs2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree)
|
||||
exch(1)=n_
|
||||
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
|
||||
else
|
||||
call igebr2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree, psb_root_, 0)
|
||||
if (exch(1).ne.m) then
|
||||
info=550
|
||||
int_err(1)=1
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (exch(2).ne.n) then
|
||||
info=550
|
||||
int_err(1)=2
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (exch(3).ne.j) then
|
||||
info=550
|
||||
int_err(1)=3
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
|
||||
if (exch(1).ne.n_) then
|
||||
info=550
|
||||
int_err(1)=1
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
endif
|
||||
|
||||
!....allocate x .....
|
||||
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
|
||||
n_col = max(1,desc_a%matrix_data(psb_n_col_))
|
||||
allocate(x(n_col,j:j+n-1),stat=info)
|
||||
if (info.ne.0) then
|
||||
info=2025
|
||||
int_err(1)=n_col
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
n_col = max(1,desc_a%matrix_data(psb_n_col_))
|
||||
allocate(x(n_col,n_),stat=info)
|
||||
if (info.ne.0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
do j=1,n_
|
||||
do i=1,n_col
|
||||
x(i,j) = 0
|
||||
end do
|
||||
end do
|
||||
else if (psb_is_bld_dec(dectype)) then
|
||||
n_row = max(1,desc_a%matrix_data(psb_n_row_))
|
||||
allocate(x(n_row,j:j+n-1),stat=info)
|
||||
if (info.ne.0) then
|
||||
info=2025
|
||||
int_err(1)=n_row
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
n_row = max(1,desc_a%matrix_data(psb_n_row_))
|
||||
allocate(x(n_row,n_),stat=info)
|
||||
if (info.ne.0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
do j = 1, n_
|
||||
do i=1,n_row
|
||||
x(i,j) = 0
|
||||
end do
|
||||
end do
|
||||
endif
|
||||
|
||||
x = 0
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
|
||||
if (err_act.eq.act_ret) then
|
||||
return
|
||||
else
|
||||
call psb_error(icontxt)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error(icontxt)
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
@@ -220,26 +190,28 @@ end subroutine psb_ialloc
|
||||
! x - integer,dimension(:). The matrix to be allocated.
|
||||
! desc_a - type(<psb_desc_type>). The communication descriptor.
|
||||
! info - integer. Eventually returns an error code
|
||||
subroutine psb_iallocv(m, x, desc_a, info)
|
||||
subroutine psb_iallocv(x, desc_a, info,n)
|
||||
!....allocate sparse matrix structure for psblas routines.....
|
||||
use psb_descriptor_type
|
||||
use psb_const_mod
|
||||
use psb_realloc_mod
|
||||
use psb_error_mod
|
||||
|
||||
implicit none
|
||||
|
||||
!....parameters...
|
||||
integer, intent(in) :: m
|
||||
integer, pointer :: x(:)
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer, intent(out) :: info
|
||||
integer, pointer :: x(:)
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer, intent(out) :: info
|
||||
integer, optional, intent(in) :: n
|
||||
|
||||
!locals
|
||||
integer :: nprow,npcol,myrow,mypcol,err,n_col,n_row,dectype,err_act
|
||||
integer :: icontxt
|
||||
integer :: int_err(5),temp(1),exch(2)
|
||||
integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,dectype,i,err_act
|
||||
integer :: icontxt, n_
|
||||
integer :: int_err(5),temp(1),exch
|
||||
real(kind(1.d0)) :: real_err(5)
|
||||
logical, parameter :: debug=.false.
|
||||
character(len=20) :: name, char_err
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
if(psb_get_errstatus().ne.0) return
|
||||
info=0
|
||||
@@ -247,59 +219,31 @@ subroutine psb_iallocv(m, x, desc_a, info)
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
icontxt=desc_a%matrix_data(psb_ctxt_)
|
||||
|
||||
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mypcol)
|
||||
|
||||
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol)
|
||||
! ....verify blacs grid correctness..
|
||||
if (nprow.eq.-1) then
|
||||
info = 2010
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
info = 2010
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else if (npcol.ne.1) then
|
||||
info = 2030
|
||||
int_err(1) = npcol
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
info = 2030
|
||||
int_err(1) = npcol
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
dectype=desc_a%matrix_data(psb_dec_type_)
|
||||
if (debug) write(0,*) 'dall: dectype',dectype
|
||||
if (debug) write(0,*) 'dall: is_ok? dectype',psb_is_ok_dec(dectype)
|
||||
!... check m and n parameters....
|
||||
if (m.lt.0) then
|
||||
info = 10
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (.not.psb_is_ok_dec(dectype)) then
|
||||
info = 3110
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else if (m.ne.desc_a%matrix_data(psb_n_)) then
|
||||
info = 300
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
int_err(3) = 4
|
||||
int_err(4) = psb_n_
|
||||
int_err(5) = desc_a%matrix_data(psb_n_)
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
!global check on m and n parameters
|
||||
if (myrow.eq.psb_root_) then
|
||||
exch(1) = m
|
||||
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
|
||||
else
|
||||
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
|
||||
if (exch(1) .ne. m) then
|
||||
info = 550
|
||||
int_err(1) = 1
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
if (.not.psb_is_ok_dec(dectype)) then
|
||||
info = 3110
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
! As this is a rank-1 array, optional parameter N is actually ignored.
|
||||
|
||||
!....allocate x .....
|
||||
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
|
||||
@@ -329,11 +273,9 @@ subroutine psb_iallocv(m, x, desc_a, info)
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
|
||||
if (err_act.eq.act_ret) then
|
||||
return
|
||||
else
|
||||
call psb_error(icontxt)
|
||||
if (err_act.eq.act_abort) then
|
||||
call psb_error(icontxt)
|
||||
return
|
||||
end if
|
||||
return
|
||||
|
||||
|
||||
@@ -44,7 +44,7 @@
|
||||
! info - integer. Eventually returns an error code
|
||||
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
|
||||
! jblck - integer(optional). First col of submatrix belonging to blck to be inserted.
|
||||
subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
|
||||
subroutine psb_iins(m, n, blck, x, ix, jx, desc_a, info,&
|
||||
& iblck, jblck,dupl)
|
||||
!....insert dense submatrix to dense matrix .....
|
||||
use psb_descriptor_type
|
||||
@@ -266,7 +266,7 @@ end subroutine psb_iins
|
||||
! desc_a - type(<psb_desc_type>). The communication descriptor.
|
||||
! info - integer. Eventually returns an error code
|
||||
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
|
||||
subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
|
||||
subroutine psb_iinsvm(m, blck, x, ix, jx, desc_a, info,&
|
||||
& iblck,dupl)
|
||||
!....insert dense submatrix to dense matrix .....
|
||||
use psb_descriptor_type
|
||||
@@ -413,7 +413,7 @@ end subroutine psb_iinsvm
|
||||
! desc_a - type(<psb_desc_type>). The communication descriptor.
|
||||
! info - integer. Eventually returns an error code
|
||||
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
|
||||
subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
|
||||
subroutine psb_iinsvv(m, blck, x, ix, desc_a, info,&
|
||||
& iblck,dupl)
|
||||
!....insert dense submatrix to dense matrix .....
|
||||
use psb_descriptor_type
|
||||
|
||||
+28
-92
@@ -35,13 +35,11 @@
|
||||
! Allocates dense matrix for PSBLAS routines
|
||||
!
|
||||
! Parameters:
|
||||
! m - number of rows.
|
||||
! n - number of columns.
|
||||
! x - the matrix to be allocated.
|
||||
! desc_a - the communication descriptor.
|
||||
! info - eventually returns an error code
|
||||
! js - (optional) the starting column
|
||||
subroutine psb_zalloc(m, n, x, desc_a, info, js)
|
||||
! info - possibly returns an error code
|
||||
! n - optional number of columns.
|
||||
subroutine psb_zalloc(x, desc_a, info, n)
|
||||
!....allocate dense matrix for psblas routines.....
|
||||
use psb_descriptor_type
|
||||
use psb_const_mod
|
||||
@@ -50,18 +48,16 @@ subroutine psb_zalloc(m, n, x, desc_a, info, js)
|
||||
implicit none
|
||||
|
||||
!....parameters...
|
||||
integer, intent(in) :: m,n
|
||||
complex(kind(1.d0)), pointer :: x(:,:)
|
||||
complex(kind(1.d0)), pointer :: x(:,:)
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer :: info
|
||||
integer, optional, intent(in) :: js
|
||||
integer, optional, intent(in) :: n
|
||||
|
||||
!locals
|
||||
integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,i,j,jj,err_act
|
||||
integer :: icontxt,dectype
|
||||
integer :: icontxt,dectype,n_
|
||||
integer :: int_err(5),temp(1),exch(3)
|
||||
real(kind(1.d0)) :: real_err(5)
|
||||
integer, allocatable:: prc_v(:)
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
name='psb_zallc'
|
||||
@@ -88,88 +84,56 @@ subroutine psb_zalloc(m, n, x, desc_a, info, js)
|
||||
|
||||
dectype=desc_a%matrix_data(psb_dec_type_)
|
||||
!... check m and n parameters....
|
||||
if (m.lt.0) then
|
||||
info = 10
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (n.lt.0) then
|
||||
info = 10
|
||||
int_err(1) = 2
|
||||
int_err(2) = n
|
||||
call psb_errpush(info,name,int_err)
|
||||
else if (.not.psb_is_ok_dec(dectype)) then
|
||||
if (.not.psb_is_ok_dec(dectype)) then
|
||||
info = 3110
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else if (m.ne.desc_a%matrix_data(psb_n_)) then
|
||||
info = 300
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
int_err(3) = 4
|
||||
int_err(4) = psb_n_
|
||||
int_err(5) = desc_a%matrix_data(psb_n_)
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
if (present(js)) then
|
||||
j=js
|
||||
if (present(n)) then
|
||||
n_ = n
|
||||
else
|
||||
j=1
|
||||
n_ = 1
|
||||
endif
|
||||
!global check on m and n parameters
|
||||
!global check on n parameters
|
||||
if (myrow.eq.psb_root_) then
|
||||
exch(1)=m
|
||||
exch(2)=n
|
||||
exch(3)=j
|
||||
call igebs2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree)
|
||||
exch(1)=n_
|
||||
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
|
||||
else
|
||||
call igebr2d(icontxt,psb_all_,psb_topdef_, ithree,ione, exch, ithree, psb_root_, 0)
|
||||
if (exch(1).ne.m) then
|
||||
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
|
||||
if (exch(1).ne.n_) then
|
||||
info=550
|
||||
int_err(1)=1
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (exch(2).ne.n) then
|
||||
info=550
|
||||
int_err(1)=2
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (exch(3).ne.j) then
|
||||
info=550
|
||||
int_err(1)=3
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
endif
|
||||
|
||||
!....allocate x .....
|
||||
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
|
||||
n_col = max(1,desc_a%matrix_data(psb_n_col_))
|
||||
allocate(x(n_col,j:j+n-1),stat=info)
|
||||
allocate(x(n_col,n_),stat=info)
|
||||
if (info.ne.0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
do jj=j,j+n-1
|
||||
do j=1,n_
|
||||
do i=1,n_col
|
||||
x(i,j) = 0.0d0
|
||||
end do
|
||||
end do
|
||||
else if (psb_is_bld_dec(dectype)) then
|
||||
n_row = max(1,desc_a%matrix_data(psb_n_row_))
|
||||
allocate(x(n_row,j:j+n-1),stat=info)
|
||||
allocate(x(n_row,n_),stat=info)
|
||||
if (info.ne.0) then
|
||||
info=4010
|
||||
ch_err='allocate'
|
||||
call psb_errpush(info,name,a_err=ch_err)
|
||||
goto 9999
|
||||
endif
|
||||
do jj=j,j+n-1
|
||||
do j = 1, n_
|
||||
do i=1,n_row
|
||||
x(i,j) = 0.0d0
|
||||
end do
|
||||
@@ -224,11 +188,10 @@ end subroutine psb_zalloc
|
||||
! Allocates dense matrix for PSBLAS routines
|
||||
!
|
||||
! Parameters:
|
||||
! m - number of rows.
|
||||
! x - the matrix to be allocated.
|
||||
! desc_a - the communication descriptor.
|
||||
! info - eventually returns an error code
|
||||
subroutine psb_zallocv(m, x, desc_a,info)
|
||||
! info - possibly returns an error code
|
||||
subroutine psb_zallocv(x, desc_a,info,n)
|
||||
!....allocate sparse matrix structure for psblas routines.....
|
||||
use psb_descriptor_type
|
||||
use psb_const_mod
|
||||
@@ -238,14 +201,14 @@ subroutine psb_zallocv(m, x, desc_a,info)
|
||||
implicit none
|
||||
|
||||
!....parameters...
|
||||
integer, intent(in) :: m
|
||||
complex(kind(1.d0)), pointer :: x(:)
|
||||
type(psb_desc_type), intent(in):: desc_a
|
||||
integer :: info
|
||||
complex(kind(1.d0)), pointer :: x(:)
|
||||
type(psb_desc_type), intent(in) :: desc_a
|
||||
integer :: info
|
||||
integer, optional, intent(in) :: n
|
||||
|
||||
!locals
|
||||
integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,dectype,i,err_act
|
||||
integer :: icontxt
|
||||
integer :: icontxt, n_
|
||||
integer :: int_err(5),temp(1),exch
|
||||
real(kind(1.d0)) :: real_err(5)
|
||||
logical, parameter :: debug=.false.
|
||||
@@ -275,40 +238,13 @@ subroutine psb_zallocv(m, x, desc_a,info)
|
||||
if (debug) write(0,*) 'dall: dectype',dectype
|
||||
if (debug) write(0,*) 'dall: is_ok? dectype',psb_is_ok_dec(dectype)
|
||||
!... check m and n parameters....
|
||||
if (m.lt.0) then
|
||||
info = 10
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
else if (.not.psb_is_ok_dec(dectype)) then
|
||||
if (.not.psb_is_ok_dec(dectype)) then
|
||||
info = 3110
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
else if (m.ne.desc_a%matrix_data(psb_n_)) then
|
||||
info = 300
|
||||
int_err(1) = 1
|
||||
int_err(2) = m
|
||||
int_err(3) = 4
|
||||
int_err(4) = psb_n_
|
||||
int_err(5) = desc_a%matrix_data(psb_n_)
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
!global check on m and n parameters
|
||||
if (myrow.eq.psb_root_) then
|
||||
exch = m
|
||||
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
|
||||
else
|
||||
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
|
||||
if (exch .ne. m) then
|
||||
info = 550
|
||||
int_err(1) = 1
|
||||
call psb_errpush(info,name,int_err)
|
||||
goto 9999
|
||||
endif
|
||||
endif
|
||||
! As this is a rank-1 array, optional parameter N is actually ignored.
|
||||
|
||||
!....allocate x .....
|
||||
if (psb_is_asb_dec(dectype).or.psb_is_upd_dec(dectype)) then
|
||||
|
||||
@@ -44,7 +44,7 @@
|
||||
! info - integer. Eventually returns an error code
|
||||
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
|
||||
! jblck - integer(optional). First col of submatrix belonging to blck to be inserted.
|
||||
subroutine psb_zins(m, n, x, ix, jx, blck, desc_a, info,&
|
||||
subroutine psb_zins(m, n, blck, x, ix, jx, desc_a, info,&
|
||||
& iblck, jblck,dupl)
|
||||
!....insert dense submatrix to dense matrix .....
|
||||
use psb_descriptor_type
|
||||
@@ -268,7 +268,7 @@ end subroutine psb_zins
|
||||
! desc_a - type(<psb_desc_type>). The communication descriptor.
|
||||
! info - integer. Eventually returns an error code
|
||||
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
|
||||
subroutine psb_zinsvm(m, x, ix, jx, blck, desc_a,info,&
|
||||
subroutine psb_zinsvm(m, blck, x, ix, jx, desc_a,info,&
|
||||
& iblck,dupl)
|
||||
!....insert dense submatrix to dense matrix .....
|
||||
use psb_descriptor_type
|
||||
@@ -483,7 +483,7 @@ end subroutine psb_zinsvm
|
||||
! info - integer. Eventually returns an error code
|
||||
! iblck - integer(optional). First row of submatrix belonging to blck to be inserted.
|
||||
! insflag - integer(optional). ???
|
||||
subroutine psb_zinsvv(m, x, ix, blck, desc_a, info,&
|
||||
subroutine psb_zinsvv(m, blck, x, ix, desc_a, info,&
|
||||
& iblck,insflag,dupl)
|
||||
!....insert dense submatrix to dense matrix .....
|
||||
use psb_descriptor_type
|
||||
|
||||
@@ -162,6 +162,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl)
|
||||
|
||||
! Do the real conversion into the requested storage format
|
||||
! result is put in A
|
||||
write(0,*) 'Calling csdp from SPASB'
|
||||
call psb_csdp(atemp,a,info,ifc=2,upd=upd_,dupl=dupl_)
|
||||
|
||||
IF (debug) WRITE (*, *) myrow,' ASB: From DCSDP',info,' ',A%FIDA
|
||||
|
||||
Reference in New Issue
Block a user