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

Third batch of restructuring preconditioners.

Browse Source
This commit is contained in:
Salvatore Filippone
2006-03-08 13:44:02 +00:00
parent 14e7e0d1db
commit 67b7449bb6
15 changed files with 490 additions and 281 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Changelog
+8
View File
@@ -1,6 +1,14 @@
Changelog. A lot less detailed than usual, at least for past
history.
2006/03/01: Complete restructure of PREC section.
2006/02/01: New naming scheme.
2006/01/01: New multilevel preconditioning wih smoothed aggregation.
2005/09 : Now enabled UMFPACK complete factorization as basis for AS.
2005/05/04: Now enabled SuperLU complete factorization as basis for AS.
2005/04/29: First version with decoupled 2-level.
src/modules/psb_prec_mod.f90
+6 -4
View File
@@ -33,14 +33,16 @@ module psb_prec_mod
use psb_prec_type
interface psb_bldaggrmat
subroutine psb_dbldaggrmat(a,desc_a,p,info)
subroutine psb_dbldaggrmat(a,desc_a,ac,p,desc_p,info)
use psb_prec_type
use psb_descriptor_type
use psb_spmat_type
type(psb_dspmat_type), intent(in), target :: a
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(out), target :: ac
type(psb_dbase_prec), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
type(psb_desc_type), intent(inout) :: desc_p
integer, intent(out) :: info
end subroutine psb_dbldaggrmat
end interface
src/modules/psb_spmat_type.f90
+55
View File
@@ -64,6 +64,10 @@ module psb_spmat_type
module procedure psb_dspclone
end interface
interface psb_sp_transfer
module procedure psb_dsp_transfer
end interface
interface psb_spreall
module procedure psb_dspreallocate, psb_dspreall3
end interface
@@ -347,6 +351,57 @@ contains
End Subroutine psb_dspclone
! This is done with pointer assignments, but it
! will be feasible with MOVE_ALLOC when we move
! to ALLOCATABLE components.
subroutine psb_dsp_transfer(a, b,info)
implicit none
!....Parameters...
Type(psb_dspmat_type), intent(inout) :: A
Type(psb_dspmat_type), intent(inout) :: B
Integer, intent(out) :: info
!locals
Integer :: nza,nz1, nz2, nzl, nzr
logical, parameter :: debug=.false.
INFO = 0
if (associated(b%pr)) then
deallocate(b%pr,stat=info)
end if
if (associated(b%pl)) then
deallocate(b%pl,stat=info)
end if
if (associated(b%ia2)) then
deallocate(b%ia2,stat=info)
end if
if (associated(b%ia1)) then
deallocate(b%ia1,stat=info)
endif
if (associated(b%aspk)) then
deallocate(b%aspk,stat=info)
endif
b%aspk => a%aspk
b%ia1 => a%ia1
b%ia2 => a%ia2
b%pl => a%pl
b%pr => a%pr
b%infoa(:) = a%infoa(:)
b%fida = a%fida
b%descra = a%descra
b%m = a%m
b%k = a%k
call psb_nullify_sp(a)
Return
End Subroutine psb_dsp_transfer
! subroutine psb_dspfree(a,info)
! implicit none
! !....Parameters...
src/modules/psb_tools_mod.f90
+11 -2
View File
@@ -313,13 +313,22 @@ Module psb_tools_mod
interface psb_cdcpy
subroutine psb_cdcpy(desc_out, desc_a, info)
subroutine psb_cdcpy(desc_in, desc_out, info)
use psb_descriptor_type
type(psb_desc_type), intent(in) :: desc_in
type(psb_desc_type), intent(out) :: desc_out
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
end subroutine psb_cdcpy
end interface
interface psb_cdtransfer
subroutine psb_cdtransfer(desc_in, desc_out, info)
use psb_descriptor_type
type(psb_desc_type), intent(inout) :: desc_in
type(psb_desc_type), intent(out) :: desc_out
integer, intent(out) :: info
end subroutine psb_cdtransfer
end interface
interface psb_cdfree
src/prec/psb_dasmatbld.f90
+2 -2
View File
@@ -113,7 +113,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
blk%infoa(psb_nnz_) = 0
If (upd == 'F') Then
call psb_cdcpy(desc_p,desc_data,info)
call psb_cdcpy(desc_data,desc_p,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
@@ -154,7 +154,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
blk%infoa(psb_nnz_)=0
if (debug) write(0,*) 'Calling desccpy'
if (upd == 'F') then
call psb_cdcpy(desc_p,desc_data,info)
call psb_cdcpy(desc_data,desc_p,info)
if(info /= 0) then
info=4010
ch_err='psb_cdcpy'
src/prec/psb_dbldaggrmat.f90
+30 -26
View File
@@ -33,7 +33,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dbldaggrmat(a,desc_a,p,info)
subroutine psb_dbldaggrmat(a,desc_a,ac,p,desc_p,info)
use psb_serial_mod
use psb_prec_type
use psb_descriptor_type
@@ -43,10 +43,12 @@ subroutine psb_dbldaggrmat(a,desc_a,p,info)
use psb_error_mod
implicit none
type(psb_dspmat_type), intent(in), target :: a
type(psb_dbase_prec), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target :: a
type(psb_dbase_prec), intent(inout) :: p
type(psb_dspmat_type), intent(out), target :: ac
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_p
integer, intent(out) :: info
logical, parameter :: aggr_dump=.false.
integer ::icontxt,nprow,npcol,me,mycol, err_act
@@ -68,7 +70,7 @@ subroutine psb_dbldaggrmat(a,desc_a,p,info)
call psb_errpush(4010,name,a_err='raw_aggregate')
goto 9999
end if
if (aggr_dump) call psb_csprt(90+me,p%av(ac_),head='% Raw aggregate.')
if (aggr_dump) call psb_csprt(90+me,ac,head='% Raw aggregate.')
case(smth_omg_,smth_biz_)
@@ -114,10 +116,10 @@ contains
& icomm,naggrm1, mtype, i, j, err_act
name='raw_aggregate'
if(psb_get_errstatus().ne.0) return
info=0
info=0
call psb_erractionsave(err_act)
bg => p%av(ac_)
bg => ac
icontxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
@@ -239,7 +241,7 @@ contains
if (p%iprcparm(coarse_mat_) == mat_repl_) then
call psb_cdrep(ntaggr,icontxt,p%desc_data,info)
call psb_cdrep(ntaggr,icontxt,desc_p,info)
nzbr(:) = 0
nzbr(myprow+1) = irs
@@ -288,7 +290,7 @@ contains
else if (p%iprcparm(coarse_mat_) == mat_distr_) then
call psb_cddec(naggr,icontxt,p%desc_data,info)
call psb_cddec(naggr,icontxt,desc_p,info)
call psb_spclone(b,bg,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spclone')
@@ -358,7 +360,7 @@ contains
icontxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
bg => p%av(ac_)
bg => ac
am2 => p%av(sm_pr_t_)
am1 => p%av(sm_pr_)
@@ -715,20 +717,20 @@ contains
i = i + 1
end do
end do
call psb_cdall(ntaggr,ivall,icontxt,p%desc_data,info,flag=1)
call psb_cdall(ntaggr,ivall,icontxt,desc_p,info,flag=1)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
end if
call psb_cdins(nzl,bg%ia1,bg%ia2,p%desc_data,info)
call psb_cdins(nzl,bg%ia1,bg%ia2,desc_p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdins')
goto 9999
end if
call psb_cdasb(p%desc_data,info)
call psb_cdasb(desc_p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb')
goto 9999
@@ -736,23 +738,25 @@ contains
call psb_glob_to_loc(bg%ia1(1:nzl),p%desc_data,info,iact='I')
call psb_glob_to_loc(bg%ia1(1:nzl),desc_p,info,iact='I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psglob_to_loc')
goto 9999
end if
call psb_glob_to_loc(bg%ia2(1:nzl),p%desc_data,info,iact='I')
call psb_glob_to_loc(bg%ia2(1:nzl),desc_p,info,iact='I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psglob_to_loc')
goto 9999
end if
bg%m=p%desc_data%matrix_data(psb_n_row_)
bg%k=p%desc_data%matrix_data(psb_n_col_)
bg%m=desc_p%matrix_data(psb_n_row_)
bg%k=desc_p%matrix_data(psb_n_col_)
bg%fida='COO'
bg%descra='G'
call psb_spfree(b,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_spfree')
@@ -797,13 +801,13 @@ contains
if (np>1) then
call psb_spinfo(psb_nztotreq_,am1,nzl,info)
call psb_glob_to_loc(am1%ia1(1:nzl),p%desc_data,info,'I')
call psb_glob_to_loc(am1%ia1(1:nzl),desc_p,info,'I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc')
goto 9999
end if
endif
am1%k=p%desc_data%matrix_data(psb_n_col_)
am1%k=desc_p%matrix_data(psb_n_col_)
if (np>1) then
call psb_ipcsr2coo(am2,info)
@@ -813,7 +817,7 @@ contains
end if
nzl = am2%infoa(psb_nnz_)
call psb_glob_to_loc(am2%ia1(1:nzl),p%desc_data,info,'I')
call psb_glob_to_loc(am2%ia1(1:nzl),desc_p,info,'I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc')
goto 9999
@@ -825,7 +829,7 @@ contains
goto 9999
end if
end if
am2%m=p%desc_data%matrix_data(psb_n_col_)
am2%m=desc_p%matrix_data(psb_n_col_)
case(mat_repl_)
!
@@ -833,7 +837,7 @@ contains
nzbr(:) = 0
nzbr(myprow+1) = b%infoa(psb_nnz_)
call psb_cdrep(ntaggr,icontxt,p%desc_data,info)
call psb_cdrep(ntaggr,icontxt,desc_p,info)
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1)
nzbg = sum(nzbr)
@@ -887,7 +891,7 @@ contains
call psb_errpush(4010,name,a_err='spclone')
goto 9999
end if
call psb_cddec(naggr,icontxt,p%desc_data,info)
call psb_cddec(naggr,icontxt,desc_p,info)
call psb_spfree(b,info)
if(info /= 0) then
@@ -902,7 +906,7 @@ contains
nzbr(:) = 0
nzbr(myprow+1) = b%infoa(psb_nnz_)
call psb_cdrep(ntaggr,icontxt,p%desc_data,info)
call psb_cdrep(ntaggr,icontxt,desc_p,info)
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1)
src/prec/psb_dilu_bld.f90
+5 -15
View File
@@ -173,24 +173,14 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
if (associated(p%av)) then
if (size(p%av) < bp_ilu_avsz) then
do k=1,size(p%av)
call psb_spfree(p%av(k),info)
end do
deallocate(p%av)
p%av => null()
call psb_errpush(4010,name,a_err='Insufficient av size')
goto 9999
endif
else
call psb_errpush(4010,name,a_err='AV not associated')
goto 9999
endif
if (.not.associated(p%av)) then
allocate(p%av(bp_ilu_avsz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
do k=1,size(p%av)
call psb_nullify_sp(p%av(k))
end do
nrow_a = desc_a%matrix_data(psb_n_row_)
call psb_spinfo(psb_nztotreq_,a,nztota,info)
if(info/=0) then
src/prec/psb_dmlprc_bld.f90
+144 -136
View File
@@ -48,51 +48,101 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
type(psb_dbase_prec), intent(inout) :: p
integer, intent(out) :: info
type(psb_desc_type), pointer :: desc_p
integer :: i, nrg, nzg, err_act,k
character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
type(psb_dspmat_type) :: ac
interface psb_ilu_fct
subroutine psb_dilu_fct(a,l,u,d,info,blck)
use psb_spmat_type
integer, intent(out) :: info
type(psb_dspmat_type),intent(in) :: a
type(psb_dspmat_type),intent(inout) :: l,u
type(psb_dspmat_type),intent(in), optional, target :: blck
real(kind(1.d0)), intent(inout) :: d(:)
end subroutine psb_dilu_fct
subroutine psb_dilu_fct(a,l,u,d,info,blck)
use psb_spmat_type
integer, intent(out) :: info
type(psb_dspmat_type),intent(in) :: a
type(psb_dspmat_type),intent(inout) :: l,u
type(psb_dspmat_type),intent(in), optional, target :: blck
real(kind(1.d0)), intent(inout) :: d(:)
end subroutine psb_dilu_fct
end interface
interface psb_genaggrmap
subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
use psb_spmat_type
use psb_descriptor_type
implicit none
integer, intent(in) :: aggr_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, pointer :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
end subroutine psb_dgenaggrmap
subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
use psb_spmat_type
use psb_descriptor_type
implicit none
integer, intent(in) :: aggr_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, pointer :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
end subroutine psb_dgenaggrmap
end interface
interface psb_bldaggrmat
subroutine psb_dbldaggrmat(a,desc_a,p,info)
use psb_prec_type
use psb_descriptor_type
use psb_spmat_type
type(psb_dspmat_type), intent(in), target :: a
type(psb_dbase_prec), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
end subroutine psb_dbldaggrmat
subroutine psb_dbldaggrmat(a,desc_a,ac,p,desc_p,info)
use psb_prec_type
use psb_descriptor_type
use psb_spmat_type
type(psb_dspmat_type), intent(in), target :: a
type(psb_dbase_prec), intent(inout) :: p
type(psb_dspmat_type), intent(out),target :: ac
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(inout) :: desc_p
integer, intent(out) :: info
end subroutine psb_dbldaggrmat
end interface
interface psb_ilu_bld
subroutine psb_dilu_bld(a,desc_data,p,upd,info)
use psb_serial_mod
use psb_descriptor_type
use psb_prec_type
integer, intent(out) :: info
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type),intent(in) :: desc_data
type(psb_dbase_prec), intent(inout) :: p
character, intent(in) :: upd
end subroutine psb_dilu_bld
end interface
interface psb_slu_bld
subroutine psb_dslu_bld(a,desc_a,p,info)
use psb_serial_mod
use psb_descriptor_type
use psb_prec_type
use psb_const_mod
implicit none
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dbase_prec), intent(inout) :: p
integer, intent(out) :: info
end subroutine psb_dslu_bld
end interface
interface psb_umf_bld
subroutine psb_dumf_bld(a,desc_a,p,info)
use psb_serial_mod
use psb_descriptor_type
use psb_prec_type
use psb_const_mod
implicit none
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dbase_prec), intent(inout) :: p
integer, intent(out) :: info
end subroutine psb_dumf_bld
end interface
integer :: icontxt, nprow, npcol, me, mycol
name='psb_mlprec_bld'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
call psb_nullify_sp(ac)
p%aorig => a
allocate(p%av(smth_avsz),stat=info)
@@ -100,141 +150,99 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
do i=1, smth_avsz
call psb_nullify_sp(p%av(i))
call psb_spall(0,0,p%av(i),1,info)
if(info /= 0) then
info=4010
ch_err='psb_spall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_nullify_sp(p%av(i))
call psb_spall(0,0,p%av(i),1,info)
if(info /= 0) then
info=4010
ch_err='psb_spall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end do
nullify(p%d)
! Currently this is ignored by gen_aggrmap, but it could be
! changed in the future. Need to package nlaggr & mlia in a
! private data structure?
call psb_genaggrmap(p%iprcparm(aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info)
if(info /= 0) then
info=4010
ch_err='psb_gen_aggrmap'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='psb_gen_aggrmap'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_bldaggrmat(a,desc_a,p,info)
nullify(desc_p)
allocate(desc_p)
call psb_nullify_desc(desc_p)
call psb_bldaggrmat(a,desc_a,ac,p,desc_p,info)
if(info /= 0) then
info=4010
ch_err='psb_bld_aggrmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='psb_bld_aggrmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (debug) write(0,*) 'Out from bldaggrmat',desc_p%matrix_data(:)
nrg = p%av(ac_)%m
call psb_spinfo(psb_nztotreq_,p%av(ac_),nzg,info)
call psb_ipcoo2csr(p%av(ac_),info)
if(info /= 0) then
info=4011
ch_err='psb_ipcoo2csr'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(p%d(nrg),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
allocate(p%desc_data)
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
call psb_spreall(p%av(l_pr_),nzg,info)
call psb_spreall(p%av(u_pr_),nzg,info)
call psb_ilu_fct(p%av(ac_),p%av(l_pr_),p%av(u_pr_),p%d,info)
if(info /= 0) then
info=4011
ch_err='psb_ilu_fct'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_ilu_bld(ac,desc_p,p,'F',info)
if(debug) write(0,*)me,': out of psb_ilu_bld'
if(info /= 0) then
info=4010
ch_err='psb_ilu_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(f_slu_)
!!$ call psb_spall(0,0,p%av(l_pr_),1,info)
!!$ call psb_spall(0,0,p%av(u_pr_),1,info)
call psb_ipcsr2coo(p%av(ac_),info)
if(info /= 0) then
info=4011
ch_err='psb_ipcsr2coo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
k=0
do i=1,p%av(ac_)%infoa(psb_nnz_)
if (p%av(ac_)%ia2(i) <= p%av(ac_)%m) then
k = k + 1
p%av(ac_)%aspk(k) = p%av(ac_)%aspk(i)
p%av(ac_)%ia1(k) = p%av(ac_)%ia1(i)
p%av(ac_)%ia2(k) = p%av(ac_)%ia2(i)
end if
end do
p%av(ac_)%infoa(psb_nnz_) = k
call psb_ipcoo2csr(p%av(ac_),info)
call psb_spinfo(psb_nztotreq_,p%av(ac_),nzg,info)
call psb_slu_factor(nrg,nzg,&
& p%av(ac_)%aspk,p%av(ac_)%ia2,p%av(ac_)%ia1,p%iprcparm(slu_ptr_),info)
if(info /= 0) then
info=4011
ch_err='psb_slu_factor'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_slu_bld(ac,desc_p,p,info)
if(debug) write(0,*)me,': out of psb_slu_bld'
if(info /= 0) then
info=4010
ch_err='psb_slu_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case(f_umf_)
!!$ call psb_spall(0,0,p%av(l_pr_),1,info)
!!$ call psb_spall(0,0,p%av(u_pr_),1,info)
call psb_ipcsr2coo(p%av(ac_),info)
if(info /= 0) then
info=4011
ch_err='psb_ipcsr2coo'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
k=0
do i=1,p%av(ac_)%infoa(psb_nnz_)
if (p%av(ac_)%ia2(i) <= p%av(ac_)%m) then
k = k + 1
p%av(ac_)%aspk(k) = p%av(ac_)%aspk(i)
p%av(ac_)%ia1(k) = p%av(ac_)%ia1(i)
p%av(ac_)%ia2(k) = p%av(ac_)%ia2(i)
end if
end do
p%av(ac_)%infoa(psb_nnz_) = k
call psb_ipcoo2csc(p%av(ac_),info)
call psb_spinfo(psb_nztotreq_,p%av(ac_),nzg,info)
call psb_umf_factor(nrg,nzg,&
& p%av(ac_)%aspk,p%av(ac_)%ia1,p%av(ac_)%ia2,&
& p%iprcparm(umf_symptr_),p%iprcparm(umf_numptr_),info)
if(info /= 0) then
info=4011
ch_err='psb_umf_factor'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_umf_bld(ac,desc_p,p,info)
if(debug) write(0,*)me,': out of psb_umf_bld'
if(info /= 0) then
info=4010
ch_err='psb_umf_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case default
write(0,*) 'Invalid fact type for multi level',(p%iprcparm(f_type_))
end select
!
! We have used a separate ac because:
! 1. We want to reuse the same routines psb_ilu_bld etc.
! 2. We do NOT want to pass an argument twice to them
! p%av(ac_) and p
! Hence a separate AC and a TRANSFER function.
!
call psb_sp_transfer(ac,p%av(ac_),info)
call psb_cdfree(desc_p,info)
deallocate(desc_p)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error()
return
call psb_error()
return
end if
Return
src/prec/psb_dprecbld.f90
+16 -11
View File
@@ -111,7 +111,7 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
end interface
! Local scalars
Integer :: err, nnzero, n_row, n_col,I,j,icontxt,&
Integer :: err, nnzero, n_row, n_col,I,j,k,icontxt,&
& me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5)
real(kind(1.d0)),pointer :: gd(:), work(:)
@@ -264,6 +264,12 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
allocate(p%baseprecv(1)%av(bp_ilu_avsz),stat=info)
do k=1,size(p%baseprecv(1)%av)
call psb_nullify_sp(p%baseprecv(1)%av(k))
end do
select case(p%baseprecv(1)%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
@@ -277,7 +283,7 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
end if
case(f_slu_)
p%baseprecv(1)%av => null()
if(debug) write(0,*)me,': calling slu_bld'
call psb_slu_bld(a,desc_a,p%baseprecv(1),info)
if(info /= 0) then
@@ -288,7 +294,6 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
end if
case(f_umf_)
p%baseprecv(1)%av => null()
if(debug) write(0,*)me,': calling umf_bld'
call psb_umf_bld(a,desc_a,p%baseprecv(1),info)
if(info /= 0) then
@@ -326,14 +331,14 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
& pre_smooth_,is_legal_ml_smooth_pos)
call psb_check_def(p%baseprecv(2)%iprcparm(f_type_),'fact',f_ilu_n_,is_legal_ml_fact)
allocate(p%baseprecv(2)%desc_data,stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_nullify_desc(p%baseprecv(2)%desc_data)
!!$ allocate(p%baseprecv(2)%desc_data,stat=info)
!!$ if (info /= 0) then
!!$ call psb_errpush(4010,name,a_err='Allocate')
!!$ goto 9999
!!$ end if
!!$
!!$ call psb_nullify_desc(p%baseprecv(2)%desc_data)
nullify(p%baseprecv(2)%desc_data)
select case(p%baseprecv(2)%iprcparm(f_type_))
case(f_ilu_n_)
call psb_check_def(p%baseprecv(2)%iprcparm(ilu_fill_in_),'Level',0,is_legal_ml_lev)
src/prec/psb_dprecset.f90
+4
View File
@@ -151,6 +151,10 @@ subroutine psb_dprecset(p,ptype,iv,rs,rv,info)
p%baseprecv(2)%iprcparm(p_type_) = bja_
p%baseprecv(2)%iprcparm(restr_) = psb_none_
p%baseprecv(2)%iprcparm(prol_) = psb_none_
p%baseprecv(2)%iprcparm(iren_) = 0
p%baseprecv(2)%iprcparm(n_ovr_) = 0
p%baseprecv(2)%iprcparm(ml_type_) = mult_ml_prec_
p%baseprecv(2)%iprcparm(aggr_alg_) = loc_aggr_
p%baseprecv(2)%iprcparm(smth_kind_) = smth_omg_
src/serial/psb_dcsdp.f90
+40 -32
View File
@@ -105,7 +105,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
info=2040
call psb_errpush(info,name)
goto 9999
end if
end if
if (ifc_<1) then
write(0,*) 'dcsdp90 Error: invalid ifc ',ifc_
info = -4
@@ -117,10 +117,10 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
if(a%fida(1:3)=='CSR') then
call dcsrck(trans,a%m,a%k,a%descra,a%aspk,a%ia1,a%ia2,work,size(work),info)
if(info /= 0) then
info=4010
ch_err='dcsrck'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='dcsrck'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
@@ -154,16 +154,20 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
if (info/=0) then
info=4010
ch_err='dcrcr'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='dcrcr'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
case ('JAD')
!...converting to JAD
!...output matrix may not be big enough
ia1_size=a%infoa(psb_nnz_)
ia2_size=a%m+1
aspk_size=a%infoa(psb_nnz_)
call psb_spreall(b,ia1_size,ia2_size,aspk_size,info)
do
call dcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
@@ -174,7 +178,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
endif
ntry = ntry + 1
if (debug) then
write(0,*) 'On out from dcrjad ',nzr,info
@@ -202,7 +206,7 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
end if
case ('COO')
aspk_size=max(size(a%aspk),a%ia2(a%m+1))
call psb_spreall(b,aspk_size,info)
!!$ write(0,*) 'From DCSDP90:',b%fida,size(b%aspk),info
@@ -212,8 +216,8 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
& size(b%ia2), work, size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrco')
goto 9999
call psb_errpush(4010,name,a_err='dcrco')
goto 9999
end if
end select
@@ -224,18 +228,20 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
case ('CSR')
aspk_size=max(size(a%aspk),a%ia2(a%m+1))
call psb_spreall(b,aspk_size,info)
call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
case ('JAD')
call psb_spall(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info)
if (info /= 0) then
info=2040
@@ -252,10 +258,10 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
& temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, &
& size(temp_a%aspk), size(temp_a%ia1),&
& size(temp_a%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
call psb_errpush(4010,name,a_err='dcocr')
goto 9999
end if
do
@@ -265,8 +271,8 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
& size(b%aspk), size(b%ia1),&
& size(b%ia2), work, size(work), nzr, info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
call psb_errpush(4010,name,a_err='dcrjd')
goto 9999
end if
ntry = ntry + 1
@@ -295,13 +301,15 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
case ('COO')
aspk_size=max(size(a%aspk),a%ia2(a%m+1))
call psb_spreall(b,aspk_size,info)
call dcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,&
& a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,&
& b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),&
& size(b%ia2), work, 2*size(work), info)
if (info/=0) then
call psb_errpush(4010,name,a_err='dcoco')
goto 9999
call psb_errpush(4010,name,a_err='dcoco')
goto 9999
end if
end select
@@ -316,12 +324,12 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
goto 9999
endif
if (ibits(b%infoa(psb_upd_),2,1).eq.0) then
!
! Nothing to be done......
!
info = 8888
call psb_errpush(info,name)
goto 9999
!
! Nothing to be done......
!
info = 8888
call psb_errpush(info,name)
goto 9999
endif
@@ -405,12 +413,12 @@ subroutine psb_dcsdp(a, b,info,ifc,check,trans,unitd)
b%infoa(psb_state_) = psb_spmat_asb_
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error()
return
call psb_error()
return
end if
return
src/tools/Makefile
+2 -1
View File
@@ -4,7 +4,8 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_cdprt.o \
psb_dfree.o psb_dgelp.o psb_dins.o \
psb_cdall.o psb_cdalv.o psb_cdasb.o psb_cdcpy.o \
psb_cddec.o psb_cdfree.o psb_cdins.o psb_cdovr.o \
psb_cdren.o psb_cdrep.o psb_dspalloc.o psb_dspasb.o \
psb_cdren.o psb_cdrep.o psb_cdtransfer.o \
psb_dspalloc.o psb_dspasb.o \
psb_dspcnv.o psb_dspfree.o psb_dspins.o psb_dsprn.o \
psb_glob_to_loc.o psb_ialloc.o psb_iasb.o \
psb_ifree.o psb_iins.o psb_loc_to_glob.o
src/tools/psb_cdcpy.f90
+54 -49
View File
@@ -34,10 +34,10 @@
! Produces a clone of a descriptor.
!
! Parameters:
! desc_in - type(<psb_desc_type>). The communication descriptor to be cloned.
! desc_out - type(<psb_desc_type>). The output communication descriptor.
! desc_a - type(<psb_desc_type>). The communication descriptor to be cloned.
! info - integer. Eventually returns an error code.
subroutine psb_cdcpy(desc_out, desc_a, info)
subroutine psb_cdcpy(desc_in, desc_out, info)
use psb_descriptor_type
use psb_serial_mod
@@ -48,8 +48,8 @@ subroutine psb_cdcpy(desc_out, desc_a, info)
implicit none
!....parameters...
type(psb_desc_type), intent(in) :: desc_in
type(psb_desc_type), intent(out) :: desc_out
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
!locals
@@ -57,18 +57,18 @@ subroutine psb_cdcpy(desc_out, desc_a, info)
& icontxt, isz, dectype, err_act, err
integer :: int_err(5),temp(1)
real(kind(1.d0)) :: real_err(5)
logical, parameter :: debug=.false.
logical, parameter :: debug=.false.,debugprt=.false.
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
if (debug) write(0,*) me,'Entered CDCPY'
if (psb_get_errstatus().ne.0) return
info = 0
call psb_erractionsave(err_act)
name = 'psb_cdcpy'
icontxt=desc_a%matrix_data(psb_ctxt_)
icontxt=desc_in%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (debug) write(0,*) me,'Entered CDCPY'
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
@@ -82,141 +82,146 @@ subroutine psb_cdcpy(desc_out, desc_a, info)
call psb_nullify_desc(desc_out)
if (associated(desc_a%matrix_data)) then
isz = size(desc_a%matrix_data)
if (associated(desc_in%matrix_data)) then
isz = size(desc_in%matrix_data)
! allocate(desc_out%matrix_data(isz),stat=info)
call psb_realloc(isz,desc_out%matrix_data,info)
if(debug) write(0,*) 'cdcpy: m_data',isz,':',desc_a%matrix_data(:)
if(debug) write(0,*) 'cdcpy: m_data',isz,':',desc_in%matrix_data(:)
if (info.ne.0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
desc_out%matrix_data(:) = desc_a%matrix_data(:)
desc_out%matrix_data(:) = desc_in%matrix_data(:)
endif
endif
if (associated(desc_a%halo_index)) then
isz = size(desc_a%halo_index)
if (debug) write(0,*) me,'Done matrix_data '
if (associated(desc_in%halo_index)) then
isz = size(desc_in%halo_index)
! allocate(desc_out%matrix_data(isz),stat=info)
call psb_realloc(isz,desc_out%halo_index,info)
if(debug) write(0,*) 'cdcpy: h_idx',isz,':',desc_a%halo_index(:)
if(debugprt) write(0,*) 'cdcpy: h_idx',isz,':',desc_in%halo_index(:)
if (info.ne.0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
desc_out%halo_index(:) = desc_a%halo_index(:)
desc_out%halo_index(:) = desc_in%halo_index(:)
endif
endif
if (debug) write(0,*) me,'Done halo_index'
if (associated(desc_a%bnd_elem)) then
isz = size(desc_a%bnd_elem)
if (associated(desc_in%bnd_elem)) then
isz = size(desc_in%bnd_elem)
! allocate(desc_out%matrix_data(isz),stat=info)
call psb_realloc(isz,desc_out%bnd_elem,info)
if(debug) write(0,*) 'cdcpy: bnd_elem',isz,':',desc_a%bnd_elem(:)
if(debugprt) write(0,*) 'cdcpy: bnd_elem',isz,':',desc_in%bnd_elem(:)
if (info.ne.0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
desc_out%bnd_elem(:) = desc_a%bnd_elem(:)
desc_out%bnd_elem(:) = desc_in%bnd_elem(:)
endif
endif
if (debug) write(0,*) me,'Done bnd_elem'
if (associated(desc_a%ovrlap_elem)) then
isz = size(desc_a%ovrlap_elem)
if (associated(desc_in%ovrlap_elem)) then
isz = size(desc_in%ovrlap_elem)
! allocate(desc_out%matrix_data(isz),stat=info)
call psb_realloc(isz,desc_out%ovrlap_elem,info)
if(debug) write(0,*) 'cdcpy: ovrlap_elem',isz,':',desc_a%ovrlap_elem(:)
if(debugprt) write(0,*) 'cdcpy: ovrlap_elem',isz,':',desc_in%ovrlap_elem(:)
if (info.ne.0) then
info=4010
char_err='psrealloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
desc_out%ovrlap_elem(:) = desc_a%ovrlap_elem(:)
desc_out%ovrlap_elem(:) = desc_in%ovrlap_elem(:)
endif
endif
if (debug) write(0,*) me,'Done ovrlap_elem'
if (associated(desc_a%ovrlap_index)) then
isz = size(desc_a%ovrlap_index)
if (associated(desc_in%ovrlap_index)) then
isz = size(desc_in%ovrlap_index)
! allocate(desc_out%matrix_data(isz),stat=info)
call psb_realloc(isz,desc_out%ovrlap_index,info)
if(debug) write(0,*) 'cdcpy: ovrlap_index',isz,':',desc_a%ovrlap_index(:)
if(debugprt) write(0,*) 'cdcpy: ovrlap_index',isz,':',desc_in%ovrlap_index(:)
if (info.ne.0) then
info=4010
char_err='psrealloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
desc_out%ovrlap_index(:) = desc_a%ovrlap_index(:)
desc_out%ovrlap_index(:) = desc_in%ovrlap_index(:)
endif
endif
if (debug) write(0,*) me,'Done ovrlap_index'
if (associated(desc_a%loc_to_glob)) then
isz = size(desc_a%loc_to_glob)
if (associated(desc_in%loc_to_glob)) then
isz = size(desc_in%loc_to_glob)
! allocate(desc_out%matrix_data(isz),stat=info)
call psb_realloc(isz,desc_out%loc_to_glob,info)
if(debug) write(0,*) 'cdcpy: loc_to_glob',isz,':',desc_a%loc_to_glob(:)
if(debugprt) write(0,*) 'cdcpy: loc_to_glob',isz,':',desc_in%loc_to_glob(:)
if (info.ne.0) then
info=4010
char_err='psrealloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
desc_out%loc_to_glob(:) = desc_a%loc_to_glob(:)
desc_out%loc_to_glob(:) = desc_in%loc_to_glob(:)
endif
endif
if (debug) write(0,*) me,'Done loc_to_glob'
if (associated(desc_a%glob_to_loc)) then
isz = size(desc_a%glob_to_loc)
if (associated(desc_in%glob_to_loc)) then
isz = size(desc_in%glob_to_loc)
! allocate(desc_out%matrix_data(isz),stat=info)
call psb_realloc(isz,desc_out%glob_to_loc,info)
if(debug) write(0,*) 'cdcpy: glob_to_loc',isz,':',desc_a%glob_to_loc(:)
if(debugprt) write(0,*) 'cdcpy: glob_to_loc',isz,':',desc_in%glob_to_loc(:)
if (info.ne.0) then
info=4010
char_err='psrealloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
desc_out%glob_to_loc(:) = desc_a%glob_to_loc(:)
desc_out%glob_to_loc(:) = desc_in%glob_to_loc(:)
endif
endif
if (debug) write(0,*) me,'Done glob_to_loc'
if (associated(desc_a%lprm)) then
isz = size(desc_a%lprm)
if (associated(desc_in%lprm)) then
isz = size(desc_in%lprm)
! allocate(desc_out%matrix_data(isz),stat=info)
call psb_realloc(isz,desc_out%lprm,info)
if(debug) write(0,*) 'cdcpy: lprm',isz,':',desc_a%lprm(:)
if(debugprt) write(0,*) 'cdcpy: lprm',isz,':',desc_in%lprm(:)
if (info.ne.0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
desc_out%lprm(:) = desc_a%lprm(:)
desc_out%lprm(:) = desc_in%lprm(:)
endif
endif
if (debug) write(0,*) me,'Done lprm'
if (associated(desc_a%idx_space)) then
isz = size(desc_a%idx_space)
if (associated(desc_in%idx_space)) then
isz = size(desc_in%idx_space)
! allocate(desc_out%matrix_data(isz),stat=info)
call psb_realloc(isz,desc_out%idx_space,info)
if(debug) write(0,*) 'cdcpy: idx_space',isz,':',desc_a%idx_space(:)
if(debugprt) write(0,*) 'cdcpy: idx_space',isz,':',desc_in%idx_space(:)
if (info.ne.0) then
info=4010
char_err='psb_realloc'
call psb_errpush(info,name,a_err=char_err)
goto 9999
else
desc_out%idx_space(:) = desc_a%idx_space(:)
desc_out%idx_space(:) = desc_in%idx_space(:)
endif
endif
src/tools/psb_cdovr.f90
+3 -3
View File
@@ -65,10 +65,10 @@ Subroutine psb_cdovr(a,desc_a,novr,desc_ov,info)
!!$ integer mpe_log_get_event_number,mpe_Describe_state,mpe_log_event
interface psb_cdcpy
subroutine psb_cdcpy(desc_out,desc_a,info)
subroutine psb_cdcpy(desc_in,desc_out,info)
use psb_descriptor_type
type(psb_desc_type), intent(in) :: desc_in
type(psb_desc_type), intent(out) :: desc_out
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
end subroutine psb_cdcpy
end interface
@@ -125,7 +125,7 @@ Subroutine psb_cdovr(a,desc_a,novr,desc_ov,info)
! Just copy the input.
!
if (debug) write(0,*) 'Calling desccpy'
call psb_cdcpy(desc_ov,desc_a,info)
call psb_cdcpy(desc_a,desc_ov,info)
if (info.ne.0) then
info=4010
ch_err='psb_cdcpy'
src/tools/psb_cdtransfer.f90
+110
View File
@@ -0,0 +1,110 @@
!!$
!!$ Parallel Sparse BLAS v2.0
!!$ (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari University of Rome Tor Vergata
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the PSBLAS group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: psb_cdtransfer.f90
!
! Subroutine: psb_cdtransfer
! Transfers data and allocation from in to out (just like MOVE_ALLOC).
!
! Parameters:
! desc_in - type(<psb_desc_type>). The communication descriptor to be transferred.
! desc_out - type(<psb_desc_type>). The output communication descriptor.
! info - integer. Eventually returns an error code.
subroutine psb_cdtransfer(desc_in, desc_out, info)
use psb_descriptor_type
use psb_serial_mod
use psb_realloc_mod
use psb_const_mod
use psb_error_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_in
type(psb_desc_type), intent(out) :: desc_out
integer, intent(out) :: info
!locals
integer :: nprow,npcol,me,mypcol,&
& icontxt, isz, dectype, err_act, err
integer :: int_err(5),temp(1)
real(kind(1.d0)) :: real_err(5)
logical, parameter :: debug=.false.,debugprt=.false.
character(len=20) :: name, char_err
if (debug) write(0,*) me,'Entered CDTRANSFER'
if (psb_get_errstatus().ne.0) return
info = 0
call psb_erractionsave(err_act)
name = 'psb_cdtransfer'
icontxt=desc_in%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol)
if (debug) write(0,*) me,'Entered CDTRANSFER'
if (nprow.eq.-1) then
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
endif
call psb_nullify_desc(desc_out)
desc_out%matrix_data => desc_in%matrix_data
desc_out%halo_index => desc_in%halo_index
desc_out%bnd_elem => desc_in%bnd_elem
desc_out%ovrlap_elem => desc_in%ovrlap_elem
desc_out%ovrlap_index => desc_in%ovrlap_index
desc_out%loc_to_glob => desc_in%loc_to_glob
desc_out%glob_to_loc => desc_in%glob_to_loc
desc_out%lprm => desc_in%lprm
desc_out%idx_space => desc_in%idx_space
call psb_nullify_desc(desc_in)
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)
end if
return
end subroutine psb_cdtransfer