fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Folded in a bunch of fixes coming from testing on IBM SP. A few

Browse Source 
wrinkles are still out there.
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent 2c21b017b3
commit 0b428f4c7d
26 changed files with 436 additions and 343 deletions
Show Stats Download Patch File Download Diff File

3
Changelog
Unescape Escape View File

@ -1,6 +1,9 @@
Changelog. A lot less detailed than usual, at least for past Changelog. A lot less detailed than usual, at least for past
history. history.
2006/04/21: A bunch of fixes related to various scratch spmat(s) initialization
problems that were revealed while testing on SP5.
2006/04/18: Changed interface to spasb and csdp: better handling of 2006/04/18: Changed interface to spasb and csdp: better handling of
regeneration. To be tested further for sophisticated uses. regeneration. To be tested further for sophisticated uses.

8
README
Unescape Escape View File

@ -19,8 +19,8 @@ Make.inc file; we have tested with AIX XLF, Intel ifc/Linux, Lahey
F95/Linux, Nag f95/Linux, GNU Fortran/Linux. If you succeed in compiling with F95/Linux, Nag f95/Linux, GNU Fortran/Linux. If you succeed in compiling with
other compiler/operating systems please let us know. other compiler/operating systems please let us know.
IBM SP2. IBM SP.
The library has been tested on an IBM SP2 with XLC and XLF The library has been tested on an IBM SP2, SP4 and SP5, with XLC and XLF
compilers, and a version of the BLACS based on MPI. compilers, and a version of the BLACS based on MPI.
The rather baroque setting The rather baroque setting
F90=xlf90 -qsuffix=f=f90 F90=xlf90 -qsuffix=f=f90
@ -117,8 +117,8 @@ Credits for version 2.0:
Salvatore Filippone Salvatore Filippone
Alfredo Buttari Alfredo Buttari
The MPcube preconditioners contained in directory src/prec were The multilevel parallel preconditioners contained in directory
developed with the contribution of: src/prec were developed with the contribution of:
Pasqua D'Ambra Pasqua D'Ambra
Daniela Di Serafino Daniela Di Serafino

16
src/modules/psb_psblas_mod.f90
Unescape Escape View File

@ -348,7 +348,7 @@ module psb_psblas_mod
real(kind(1.d0)), intent(in) :: alpha, beta real(kind(1.d0)), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans character, optional, intent(in) :: trans
real(kind(1.d0)), optional, intent(inout) :: work(:) real(kind(1.d0)), optional, intent(inout),target :: work(:)
integer, optional, intent(in) :: k, jx, jy,doswap integer, optional, intent(in) :: k, jx, jy,doswap
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_dspmm end subroutine psb_dspmm
@ -362,7 +362,7 @@ module psb_psblas_mod
real(kind(1.d0)), intent(in) :: alpha, beta real(kind(1.d0)), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans character, optional, intent(in) :: trans
real(kind(1.d0)), optional, intent(inout) :: work(:) real(kind(1.d0)), optional, intent(inout),target :: work(:)
integer, optional, intent(in) :: doswap integer, optional, intent(in) :: doswap
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_dspmv end subroutine psb_dspmv
@ -376,7 +376,7 @@ module psb_psblas_mod
complex(kind(1.d0)), intent(in) :: alpha, beta complex(kind(1.d0)), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans character, optional, intent(in) :: trans
complex(kind(1.d0)), optional, intent(inout) :: work(:) complex(kind(1.d0)), optional, intent(inout),target :: work(:)
integer, optional, intent(in) :: k, jx, jy,doswap integer, optional, intent(in) :: k, jx, jy,doswap
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_zspmm end subroutine psb_zspmm
@ -390,7 +390,7 @@ module psb_psblas_mod
complex(kind(1.d0)), intent(in) :: alpha, beta complex(kind(1.d0)), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans character, optional, intent(in) :: trans
complex(kind(1.d0)), optional, intent(inout) :: work(:) complex(kind(1.d0)), optional, intent(inout),target :: work(:)
integer, optional, intent(in) :: doswap integer, optional, intent(in) :: doswap
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_zspmv end subroutine psb_zspmv
@ -410,7 +410,7 @@ module psb_psblas_mod
character, optional, intent(in) :: trans, unit character, optional, intent(in) :: trans, unit
integer, optional, intent(in) :: n, jx, jy integer, optional, intent(in) :: n, jx, jy
integer, optional, intent(in) :: choice integer, optional, intent(in) :: choice
real(kind(1.d0)), optional, intent(in) :: work(:), diag(:) real(kind(1.d0)), optional, intent(inout),target :: work(:), diag(:)
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_dspsm end subroutine psb_dspsm
subroutine psb_dspsv(alpha, t, x, beta, y,& subroutine psb_dspsv(alpha, t, x, beta, y,&
@ -425,7 +425,7 @@ module psb_psblas_mod
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans, unit character, optional, intent(in) :: trans, unit
integer, optional, intent(in) :: choice integer, optional, intent(in) :: choice
real(kind(1.d0)), optional, intent(in) :: work(:), diag(:) real(kind(1.d0)), optional, intent(inout),target :: work(:), diag(:)
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_dspsv end subroutine psb_dspsv
subroutine psb_zspsm(alpha, t, x, beta, y,& subroutine psb_zspsm(alpha, t, x, beta, y,&
@ -441,7 +441,7 @@ module psb_psblas_mod
character, optional, intent(in) :: trans, unit character, optional, intent(in) :: trans, unit
integer, optional, intent(in) :: n, jx, jy integer, optional, intent(in) :: n, jx, jy
integer, optional, intent(in) :: choice integer, optional, intent(in) :: choice
complex(kind(1.d0)), optional, intent(in) :: work(:), diag(:) complex(kind(1.d0)), optional, intent(inout),target :: work(:), diag(:)
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_zspsm end subroutine psb_zspsm
subroutine psb_zspsv(alpha, t, x, beta, y,& subroutine psb_zspsv(alpha, t, x, beta, y,&
@ -456,7 +456,7 @@ module psb_psblas_mod
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans, unit character, optional, intent(in) :: trans, unit
integer, optional, intent(in) :: choice integer, optional, intent(in) :: choice
complex(kind(1.d0)), optional, intent(in) :: work(:), diag(:) complex(kind(1.d0)), optional, intent(inout),target :: work(:), diag(:)
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_zspsv end subroutine psb_zspsv
end interface end interface

12
src/modules/psb_realloc_mod.f90
Unescape Escape View File

@ -61,13 +61,15 @@ Contains
Integer,Pointer :: tmp(:) Integer,Pointer :: tmp(:)
Integer :: dim, err_act, err,i Integer :: dim, err_act, err,i
character(len=20) :: name character(len=20) :: name
logical, parameter :: debug=.false.
name='psb_dreallocate1i' name='psb_dreallocate1i'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
if (associated(rrax)) then if (debug) write(0,*) 'reallocate I',len
if (associated(rrax)) then a
dim=size(rrax) dim=size(rrax)
If (dim /= len) Then If (dim /= len) Then
Allocate(tmp(len),stat=info) Allocate(tmp(len),stat=info)
@ -137,9 +139,12 @@ Contains
Real(kind(1.d0)),Pointer :: tmp(:) Real(kind(1.d0)),Pointer :: tmp(:)
Integer :: dim,err_act,err,i, m Integer :: dim,err_act,err,i, m
character(len=20) :: name character(len=20) :: name
logical, parameter :: debug=.false.
name='psb_dreallocate1d' name='psb_dreallocate1d'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = 0
if (debug) write(0,*) 'reallocate D',len
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax) dim=size(rrax)
@ -210,9 +215,12 @@ Contains
complex(kind(1.d0)),Pointer :: tmp(:) complex(kind(1.d0)),Pointer :: tmp(:)
Integer :: dim,err_act,err,i, m Integer :: dim,err_act,err,i, m
character(len=20) :: name character(len=20) :: name
logical, parameter :: debug=.false.
name='psb_dreallocate1z' name='psb_dreallocate1z'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = 0
if (debug) write(0,*) 'reallocate Z',len
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax) dim=size(rrax)
@ -286,6 +294,7 @@ Contains
name='psb_dreallocated2' name='psb_dreallocated2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = 0
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax,1) dim=size(rrax,1)
@ -357,6 +366,7 @@ Contains
name='psb_dreallocatez2' name='psb_dreallocatez2'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = 0
if (associated(rrax)) then if (associated(rrax)) then
dim=size(rrax,1) dim=size(rrax,1)

55
src/modules/psb_spmat_type.f90
Unescape Escape View File

@ -98,7 +98,7 @@ module psb_spmat_type
interface psb_sp_reall interface psb_sp_reall
module procedure psb_dspreallocate, psb_dspreall3, & module procedure psb_dspreallocate, psb_dspreall3, &
& psb_zspreallocate, psb_zspreall3 & psb_zspreall3, psb_zspreallocate
end interface end interface
interface psb_sp_all interface psb_sp_all
@ -757,6 +757,32 @@ contains
End Subroutine psb_zspall3 End Subroutine psb_zspall3
subroutine psb_zspreall3(a, ni1,ni2,nz,info)
implicit none
!....Parameters...
Type(psb_zspmat_type), intent(inout) :: A
Integer, intent(in) :: ni1,ni2,nz
Integer, intent(inout) :: info
!locals
logical, parameter :: debug=.false.
info = 0
call psb_realloc(nz,a%aspk,info)
if (info /= 0) return
call psb_realloc(ni2,a%ia2,info)
if (info /= 0) return
call psb_realloc(ni1,a%ia1,info)
if (info /= 0) return
call psb_realloc(max(1,a%m),a%pl,info)
if (info /= 0) return
call psb_realloc(max(1,a%k),a%pr,info)
if (info /= 0) return
Return
End Subroutine psb_zspreall3
subroutine psb_zspreallocate(a, nnz,info,ifc) subroutine psb_zspreallocate(a, nnz,info,ifc)
implicit none implicit none
@ -807,33 +833,6 @@ contains
End Subroutine psb_zspreallocate End Subroutine psb_zspreallocate
subroutine psb_zspreall3(a, ni1,ni2,nd,info)
implicit none
!....Parameters...
Type(psb_zspmat_type), intent(inout) :: A
Integer, intent(in) :: ni1,ni2,nd
Integer, intent(inout) :: info
!locals
logical, parameter :: debug=.false.
info = 0
call psb_realloc(nd,a%aspk,info)
if (info /= 0) return
call psb_realloc(ni2,a%ia2,info)
if (info /= 0) return
call psb_realloc(ni1,a%ia1,info)
if (info /= 0) return
call psb_realloc(max(1,a%m),a%pl,info)
if (info /= 0) return
call psb_realloc(max(1,a%k),a%pr,info)
if (info /= 0) return
Return
End Subroutine psb_zspreall3
subroutine psb_zspclone(a, b,info) subroutine psb_zspclone(a, b,info)
implicit none implicit none
!....Parameters... !....Parameters...

6
src/prec/psb_dasmatbld.f90
Unescape Escape View File

@ -102,6 +102,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! Block Jacobi. Copy the descriptor, just in case we want to ! Block Jacobi. Copy the descriptor, just in case we want to
! do the renumbering. ! do the renumbering.
! !
If(debug) Write(0,*)' asmatbld calling allocate '
call psb_sp_all(0,0,blk,1,info) call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -111,9 +112,10 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if end if
blk%fida = 'COO' blk%fida = 'COO'
blk%infoa(psb_nnz_) = 0 blk%infoa(psb_nnz_) = 0
If(debug) Write(0,*)' asmatbld done spallocate'
If (upd == 'F') Then If (upd == 'F') Then
call psb_cdcpy(desc_data,desc_p,info) call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy'
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_cdcpy' ch_err='psb_cdcpy'
@ -143,6 +145,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! !
! This is really just Block Jacobi..... ! This is really just Block Jacobi.....
! !
If(debug) Write(0,*)' asmatbld calling allocate novr=0'
call psb_sp_all(0,0,blk,1,info) call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -155,6 +158,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
if (debug) write(0,*) 'Calling desccpy' if (debug) write(0,*) 'Calling desccpy'
if (upd == 'F') then if (upd == 'F') then
call psb_cdcpy(desc_data,desc_p,info) call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy'
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_cdcpy' ch_err='psb_cdcpy'

1
src/prec/psb_dbaseprc_bld.f90
Unescape Escape View File

@ -223,6 +223,7 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
case(f_umf_) case(f_umf_)
if(debug) write(0,*)me,': calling umf_bld' if(debug) write(0,*)me,': calling umf_bld'
call psb_umf_bld(a,desc_a,p,info) call psb_umf_bld(a,desc_a,p,info)
if(debug) write(0,*)me,': Done umf_bld ',info
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='umf_bld' ch_err='umf_bld'

35
src/prec/psb_dbldaggrmat.f90
Unescape Escape View File

@ -64,7 +64,7 @@ subroutine psb_dbldaggrmat(a,desc_a,ac,p,desc_p,info)
select case (p%iprcparm(smth_kind_)) select case (p%iprcparm(smth_kind_))
case (no_smth_) case (no_smth_)
call raw_aggregate(info) call raw_aggregate(info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='raw_aggregate') call psb_errpush(4010,name,a_err='raw_aggregate')
@ -120,6 +120,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
bg => ac bg => ac
call psb_nullify_sp(b)
icontxt = desc_a%matrix_data(psb_ctxt_) icontxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol) call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
@ -347,7 +348,7 @@ contains
type(psb_dspmat_type) :: am3,am4 type(psb_dspmat_type) :: am3,am4
logical :: ml_global_nmb logical :: ml_global_nmb
logical, parameter :: test_dump=.false. logical, parameter :: test_dump=.false.,debug=.false.
integer, parameter :: ncmax=16 integer, parameter :: ncmax=16
real(kind(1.d0)) :: omega, anorm, tmp, dg real(kind(1.d0)) :: omega, anorm, tmp, dg
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -362,6 +363,9 @@ contains
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol) call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
bg => ac bg => ac
call psb_nullify_sp(b)
call psb_nullify_sp(am3)
call psb_nullify_sp(am4)
am2 => p%av(sm_pr_t_) am2 => p%av(sm_pr_t_)
am1 => p%av(sm_pr_) am1 => p%av(sm_pr_)
@ -441,7 +445,15 @@ contains
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call psb_sp_all(am4,ncol,info) am4%fida='COO'
am4%m=ncol
if (ml_global_nmb) then
am4%k=ntaggr
call psb_sp_all(ncol,ntaggr,am4,ncol,info)
else
am4%k=naggr
call psb_sp_all(ncol,naggr,am4,ncol,info)
endif
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='spall') call psb_errpush(4010,name,a_err='spall')
goto 9999 goto 9999
@ -462,14 +474,6 @@ contains
end do end do
am4%infoa(psb_nnz_) = nrow am4%infoa(psb_nnz_) = nrow
endif endif
am4%fida='COO'
am4%m=ncol
if (ml_global_nmb) then
am4%k=ntaggr
else
am4%k=naggr
endif
if (test_dump) call & if (test_dump) call &
@ -560,6 +564,7 @@ contains
if (test_dump) call psb_csprt(40+me,am3,head='% (I-wDA)',ivr=desc_a%loc_to_glob,& if (test_dump) call psb_csprt(40+me,am3,head='% (I-wDA)',ivr=desc_a%loc_to_glob,&
& ivc=desc_a%loc_to_glob) & ivc=desc_a%loc_to_glob)
if (debug) write(0,*) me,'Done gather, going for SYMBMM 1'
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
@ -570,6 +575,7 @@ contains
call psb_symbmm(am3,am4,am1) call psb_symbmm(am3,am4,am1)
call psb_numbmm(am3,am4,am1) call psb_numbmm(am3,am4,am1)
if (debug) write(0,*) me,'Done NUMBMM 1'
call psb_sp_free(am4,info) call psb_sp_free(am4,info)
if(info /= 0) then if(info /= 0) then
@ -615,6 +621,7 @@ contains
call psb_symbmm(a,am1,am3) call psb_symbmm(a,am1,am3)
call psb_numbmm(a,am1,am3) call psb_numbmm(a,am1,am3)
if (debug) write(0,*) me,'Done NUMBMM 2'
if (p%iprcparm(smth_kind_) == smth_omg_) then if (p%iprcparm(smth_kind_) == smth_omg_) then
call psb_transp(am1,am2,fmt='COO') call psb_transp(am1,am2,fmt='COO')
@ -638,6 +645,7 @@ contains
else else
call psb_transp(am1,am2) call psb_transp(am1,am2)
endif endif
if (debug) write(0,*) me,'starting sphalo/ rwxtd'
if (p%iprcparm(smth_kind_) == smth_omg_) then if (p%iprcparm(smth_kind_) == smth_omg_) then
! am2 = ((i-wDA)Ptilde)^T ! am2 = ((i-wDA)Ptilde)^T
@ -667,8 +675,11 @@ contains
end if end if
endif endif
if (debug) write(0,*) me,'starting symbmm 3'
call psb_symbmm(am2,am3,b) call psb_symbmm(am2,am3,b)
if (debug) write(0,*) me,'starting numbmm 3'
call psb_numbmm(am2,am3,b) call psb_numbmm(am2,am3,b)
if (debug) write(0,*) me,'Done NUMBMM 3'
!!$ if (aggr_dump) call csprt(50+me,am1,head='% Operator PTrans.') !!$ if (aggr_dump) call csprt(50+me,am1,head='% Operator PTrans.')
call psb_sp_free(am3,info) call psb_sp_free(am3,info)
@ -731,6 +742,7 @@ contains
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,'Created aux descr. distr.'
call psb_cdasb(desc_p,info) call psb_cdasb(desc_p,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb') call psb_errpush(4010,name,a_err='psb_cdasb')
@ -738,6 +750,7 @@ contains
end if end if
if (debug) write(0,*) me,'Asmbld aux descr. distr.'
call psb_glob_to_loc(bg%ia1(1:nzl),desc_p,info,iact='I') call psb_glob_to_loc(bg%ia1(1:nzl),desc_p,info,iact='I')
if(info /= 0) then if(info /= 0) then

2
src/prec/psb_dilu_bld.f90
Unescape Escape View File

@ -157,6 +157,8 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
call psb_nullify_sp(blck) call psb_nullify_sp(blck)
call psb_nullify_sp(atmp)
t1= mpi_wtime() t1= mpi_wtime()
if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)

6
src/prec/psb_dilu_fct.f90
Unescape Escape View File

@ -151,7 +151,7 @@ contains
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
call psb_nullify_sp(trw)
trw%m=0 trw%m=0
trw%k=0 trw%k=0
if(debug) write(0,*)'LUINT Allocating TRW' if(debug) write(0,*)'LUINT Allocating TRW'
@ -300,7 +300,7 @@ contains
! !
info = 2 info = 2
int_err(1) = i int_err(1) = i
write(ch_err,'(g20.10)'),dia write(ch_err,'(g20.10)') dia
call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
goto 9999 goto 9999
else else
@ -439,7 +439,7 @@ contains
! Pivot too small: unstable factorization ! Pivot too small: unstable factorization
! !
int_err(1) = i int_err(1) = i
write(ch_err,'(g20.10)'),dia write(ch_err,'(g20.10)') dia
info = 2 info = 2
call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
goto 9999 goto 9999

2
src/prec/psb_dmlprc_bld.f90
Unescape Escape View File

@ -150,6 +150,7 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
nullify(desc_p) nullify(desc_p)
allocate(desc_p) allocate(desc_p)
call psb_nullify_desc(desc_p) call psb_nullify_desc(desc_p)
@ -165,6 +166,7 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
call psb_baseprc_bld(ac,desc_p,p,info) call psb_baseprc_bld(ac,desc_p,p,info)
if (debug) write(0,*) 'Out from basaeprcbld',info
! !
! We have used a separate ac because: ! We have used a separate ac because:

139
src/prec/psb_dslu_bld.f90
Unescape Escape View File

@ -68,7 +68,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
integer, intent(out) :: info integer, intent(out) :: info
character(len=5), optional :: outfmt character(len=5), optional :: outfmt
end Subroutine psb_dasmatbld end Subroutine psb_dasmatbld
end interface end interface
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
@ -82,120 +82,121 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
fmt = 'COO' fmt = 'COO'
call psb_nullify_sp(blck) call psb_nullify_sp(blck)
call psb_nullify_sp(atmp) call psb_nullify_sp(atmp)
atmp%fida='COO' atmp%fida='COO'
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Calling csdp' write(0,*) me, 'SPLUBLD: Calling csdp'
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_dcsdp(a,atmp,info) call psb_dcsdp(a,atmp,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_dcsdp' ch_err='psb_dcsdp'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
nza = atmp%infoa(psb_nnz_) nza = atmp%infoa(psb_nnz_)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=fmt) & blck,desc_a,upd,p%desc_data,info,outfmt=fmt)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_asmatbld' ch_err='psb_asmatbld'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
nzb = blck%infoa(psb_nnz_) nzb = blck%infoa(psb_nnz_)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
if (nzb > 0 ) then if (nzb > 0 ) then
if (size(atmp%aspk)<nza+nzb) then if (size(atmp%aspk)<nza+nzb) then
call psb_sp_reall(atmp,nza+nzb,info) call psb_sp_reall(atmp,nza+nzb,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_sp_reall' ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
endif endif
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
do j=1,nzb do j=1,nzb
atmp%aspk(nza+j) = blck%aspk(j) atmp%aspk(nza+j) = blck%aspk(j)
atmp%ia1(nza+j) = blck%ia1(j) atmp%ia1(nza+j) = blck%ia1(j)
atmp%ia2(nza+j) = blck%ia2(j) atmp%ia2(nza+j) = blck%ia2(j)
end do end do
atmp%infoa(psb_nnz_) = nza+nzb atmp%infoa(psb_nnz_) = nza+nzb
atmp%m = atmp%m + blck%m atmp%m = atmp%m + blck%m
atmp%k = max(a%k,blck%k) atmp%k = max(a%k,blck%k)
else else
atmp%infoa(psb_nnz_) = nza atmp%infoa(psb_nnz_) = nza
atmp%m = a%m atmp%m = a%m
atmp%k = a%k atmp%k = a%k
endif endif
i=0 i=0
do j=1, atmp%infoa(psb_nnz_) do j=1, atmp%infoa(psb_nnz_)
if (atmp%ia2(j) <= atmp%m) then if (atmp%ia2(j) <= atmp%m) then
i = i + 1 i = i + 1
atmp%aspk(i) = atmp%aspk(j) atmp%aspk(i) = atmp%aspk(j)
atmp%ia1(i) = atmp%ia1(j) atmp%ia1(i) = atmp%ia1(j)
atmp%ia2(i) = atmp%ia2(j) atmp%ia2(i) = atmp%ia2(j)
endif endif
enddo enddo
atmp%infoa(psb_nnz_) = i atmp%infoa(psb_nnz_) = i
call psb_ipcoo2csr(atmp,info) call psb_ipcoo2csr(atmp,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_ipcoo2csr' ch_err='psb_ipcoo2csr'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call psb_spinfo(psb_nztotreq_,atmp,nzt,info) call psb_spinfo(psb_nztotreq_,atmp,nzt,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_spinfo' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (Debug) then if (Debug) then
write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,& write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,&
& atmp%k,p%desc_data%matrix_data(psb_n_row_) & atmp%k,p%desc_data%matrix_data(psb_n_row_)
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_dslu_factor(atmp%m,nzt,& call psb_dslu_factor(atmp%m,nzt,&
& atmp%aspk,atmp%ia2,atmp%ia1,p%iprcparm(slu_ptr_),info) & atmp%aspk,atmp%ia2,atmp%ia1,p%iprcparm(slu_ptr_),info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_slu_fact' ch_err='psb_slu_fact'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_) write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_)
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_sp_free(blck,info) call psb_sp_free(blck,info)
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_sp_free' ch_err='psb_sp_free'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -204,8 +205,8 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error() call psb_error()
return return
end if end if
return return

1
src/prec/psb_dumf_bld.f90
Unescape Escape View File

@ -82,6 +82,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
fmt = 'COO' fmt = 'COO'
call psb_nullify_sp(blck) call psb_nullify_sp(blck)
call psb_nullify_sp(atmp) call psb_nullify_sp(atmp)
atmp%fida='COO' atmp%fida='COO'
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Calling csdp' write(0,*) me, 'UMFBLD: Calling csdp'

6
src/prec/psb_zasmatbld.f90
Unescape Escape View File

@ -102,6 +102,7 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! Block Jacobi. Copy the descriptor, just in case we want to ! Block Jacobi. Copy the descriptor, just in case we want to
! do the renumbering. ! do the renumbering.
! !
If(debug) Write(0,*)' asmatbld calling allocate '
call psb_sp_all(0,0,blk,1,info) call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -111,9 +112,10 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if end if
blk%fida = 'COO' blk%fida = 'COO'
blk%infoa(psb_nnz_) = 0 blk%infoa(psb_nnz_) = 0
If(debug) Write(0,*)' asmatbld done spallocate'
If (upd == 'F') Then If (upd == 'F') Then
call psb_cdcpy(desc_data,desc_p,info) call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy'
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_cdcpy' ch_err='psb_cdcpy'
@ -143,6 +145,7 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! !
! This is really just Block Jacobi..... ! This is really just Block Jacobi.....
! !
If(debug) Write(0,*)' asmatbld calling allocate novr=0'
call psb_sp_all(0,0,blk,1,info) call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -155,6 +158,7 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
if (debug) write(0,*) 'Calling desccpy' if (debug) write(0,*) 'Calling desccpy'
if (upd == 'F') then if (upd == 'F') then
call psb_cdcpy(desc_data,desc_p,info) call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy'
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_cdcpy' ch_err='psb_cdcpy'

4
src/prec/psb_zbaseprc_bld.f90
Unescape Escape View File

@ -194,13 +194,14 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
& f_ilu_n_,is_legal_ml_fact) & f_ilu_n_,is_legal_ml_fact)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD' if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) call blacs_barrier(icontxt,'All')
select case(p%iprcparm(f_type_)) select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_) case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info) call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld' if(debug) write(0,*)me,': out of psb_ilu_bld'
if (debug) call blacs_barrier(icontxt,'All')
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_ilu_bld' ch_err='psb_ilu_bld'
@ -222,6 +223,7 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
case(f_umf_) case(f_umf_)
if(debug) write(0,*)me,': calling umf_bld' if(debug) write(0,*)me,': calling umf_bld'
call psb_umf_bld(a,desc_a,p,info) call psb_umf_bld(a,desc_a,p,info)
if(debug) write(0,*)me,': Done umf_bld ',info
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='umf_bld' ch_err='umf_bld'

33
src/prec/psb_zbldaggrmat.f90
Unescape Escape View File

@ -64,7 +64,7 @@ subroutine psb_zbldaggrmat(a,desc_a,ac,p,desc_p,info)
select case (p%iprcparm(smth_kind_)) select case (p%iprcparm(smth_kind_))
case (no_smth_) case (no_smth_)
call raw_aggregate(info) call raw_aggregate(info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='raw_aggregate') call psb_errpush(4010,name,a_err='raw_aggregate')
@ -120,6 +120,7 @@ contains
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
bg => ac bg => ac
call psb_nullify_sp(b)
icontxt = desc_a%matrix_data(psb_ctxt_) icontxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol) call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
@ -362,6 +363,9 @@ contains
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol) call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
bg => ac bg => ac
call psb_nullify_sp(b)
call psb_nullify_sp(am3)
call psb_nullify_sp(am4)
am2 => p%av(sm_pr_t_) am2 => p%av(sm_pr_t_)
am1 => p%av(sm_pr_) am1 => p%av(sm_pr_)
@ -441,7 +445,15 @@ contains
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call psb_sp_all(am4,ncol,info) am4%fida='COO'
am4%m=ncol
if (ml_global_nmb) then
am4%k=ntaggr
call psb_sp_all(ncol,ntaggr,am4,ncol,info)
else
am4%k=naggr
call psb_sp_all(ncol,naggr,am4,ncol,info)
endif
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='spall') call psb_errpush(4010,name,a_err='spall')
goto 9999 goto 9999
@ -462,14 +474,6 @@ contains
end do end do
am4%infoa(psb_nnz_) = nrow am4%infoa(psb_nnz_) = nrow
endif endif
am4%fida='COO'
am4%m=ncol
if (ml_global_nmb) then
am4%k=ntaggr
else
am4%k=naggr
endif
if (test_dump) call & if (test_dump) call &
@ -560,6 +564,7 @@ contains
if (test_dump) call psb_csprt(40+me,am3,head='% (I-wDA)',ivr=desc_a%loc_to_glob,& if (test_dump) call psb_csprt(40+me,am3,head='% (I-wDA)',ivr=desc_a%loc_to_glob,&
& ivc=desc_a%loc_to_glob) & ivc=desc_a%loc_to_glob)
if (debug) write(0,*) me,'Done gather, going for SYMBMM 1'
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
@ -570,6 +575,7 @@ contains
call psb_symbmm(am3,am4,am1) call psb_symbmm(am3,am4,am1)
call psb_numbmm(am3,am4,am1) call psb_numbmm(am3,am4,am1)
if (debug) write(0,*) me,'Done NUMBMM 1'
call psb_sp_free(am4,info) call psb_sp_free(am4,info)
if(info /= 0) then if(info /= 0) then
@ -615,6 +621,7 @@ contains
call psb_symbmm(a,am1,am3) call psb_symbmm(a,am1,am3)
call psb_numbmm(a,am1,am3) call psb_numbmm(a,am1,am3)
if (debug) write(0,*) me,'Done NUMBMM 2'
if (p%iprcparm(smth_kind_) == smth_omg_) then if (p%iprcparm(smth_kind_) == smth_omg_) then
call psb_transp(am1,am2,fmt='COO') call psb_transp(am1,am2,fmt='COO')
@ -638,6 +645,7 @@ contains
else else
call psb_transp(am1,am2) call psb_transp(am1,am2)
endif endif
if (debug) write(0,*) me,'starting sphalo/ rwxtd'
if (p%iprcparm(smth_kind_) == smth_omg_) then if (p%iprcparm(smth_kind_) == smth_omg_) then
! am2 = ((i-wDA)Ptilde)^T ! am2 = ((i-wDA)Ptilde)^T
@ -667,8 +675,11 @@ contains
end if end if
endif endif
if (debug) write(0,*) me,'starting symbmm 3'
call psb_symbmm(am2,am3,b) call psb_symbmm(am2,am3,b)
if (debug) write(0,*) me,'starting numbmm 3'
call psb_numbmm(am2,am3,b) call psb_numbmm(am2,am3,b)
if (debug) write(0,*) me,'Done NUMBMM 3'
!!$ if (aggr_dump) call csprt(50+me,am1,head='% Operator PTrans.') !!$ if (aggr_dump) call csprt(50+me,am1,head='% Operator PTrans.')
call psb_sp_free(am3,info) call psb_sp_free(am3,info)
@ -731,6 +742,7 @@ contains
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,'Created aux descr. distr.'
call psb_cdasb(desc_p,info) call psb_cdasb(desc_p,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb') call psb_errpush(4010,name,a_err='psb_cdasb')
@ -738,6 +750,7 @@ contains
end if end if
if (debug) write(0,*) me,'Asmbld aux descr. distr.'
call psb_glob_to_loc(bg%ia1(1:nzl),desc_p,info,iact='I') call psb_glob_to_loc(bg%ia1(1:nzl),desc_p,info,iact='I')
if(info /= 0) then if(info /= 0) then

14
src/prec/psb_zilu_bld.f90
Unescape Escape View File

@ -156,9 +156,12 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
icontxt=desc_a%matrix_data(psb_ctxt_) icontxt=desc_a%matrix_data(psb_ctxt_)
call psb_nullify_sp(blck) call psb_nullify_sp(blck)
call psb_nullify_sp(atmp)
t1= mpi_wtime() t1= mpi_wtime()
if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
if (debug) call blacs_barrier(icontxt,'All')
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info) & blck,desc_a,upd,p%desc_data,info)
if(info/=0) then if(info/=0) then
@ -168,7 +171,8 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
goto 9999 goto 9999
end if end if
t2= mpi_wtime() t2= mpi_wtime()
if(debug) write(0,*)me,': out of psb_asmatbld' if (debug) write(0,*)me,': out of psb_asmatbld'
if (debug) call blacs_barrier(icontxt,'All')
if (associated(p%av)) then if (associated(p%av)) then
if (size(p%av) < bp_ilu_avsz) then if (size(p%av) < bp_ilu_avsz) then
@ -188,6 +192,9 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*)me,': out spinfo',nztota
if (debug) call blacs_barrier(icontxt,'All')
n_col = desc_a%matrix_data(psb_n_col_) n_col = desc_a%matrix_data(psb_n_col_)
nhalo = n_col-nrow_a nhalo = n_col-nrow_a
n_row = p%desc_data%matrix_data(psb_n_row_) n_row = p%desc_data%matrix_data(psb_n_row_)
@ -197,7 +204,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
p%av(u_pr_)%m = n_row p%av(u_pr_)%m = n_row
p%av(u_pr_)%k = n_row p%av(u_pr_)%k = n_row
call psb_sp_all(n_row,n_row,p%av(l_pr_),nztota+lovr,info) call psb_sp_all(n_row,n_row,p%av(l_pr_),nztota+lovr,info)
call psb_sp_all(n_row,n_row,p%av(u_pr_),nztota+lovr,info) if (info == 0) call psb_sp_all(n_row,n_row,p%av(u_pr_),nztota+lovr,info)
if(info/=0) then if(info/=0) then
info=4010 info=4010
ch_err='psb_sp_all' ch_err='psb_sp_all'
@ -303,7 +310,8 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
endif endif
t5= mpi_wtime() t5= mpi_wtime()
if (debug) write(0,*) me,' Going for dilu_fct' if (debug) write(0,*) me,' Going for ilu_fct'
if (debug) call blacs_barrier(icontxt,'All')
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck) call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
if(info/=0) then if(info/=0) then
info=4010 info=4010

6
src/prec/psb_zilu_fct.f90
Unescape Escape View File

@ -149,7 +149,7 @@ contains
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
call psb_nullify_sp(trw)
trw%m=0 trw%m=0
trw%k=0 trw%k=0
if(debug) write(0,*)'LUINT Allocating TRW' if(debug) write(0,*)'LUINT Allocating TRW'
@ -298,7 +298,7 @@ contains
! !
info = 2 info = 2
int_err(1) = i int_err(1) = i
write(ch_err,'(g20.10)'),abs(dia) write(ch_err,'(g20.10)') abs(dia)
call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
goto 9999 goto 9999
else else
@ -437,7 +437,7 @@ contains
! Pivot too small: unstable factorization ! Pivot too small: unstable factorization
! !
int_err(1) = i int_err(1) = i
write(ch_err,'(g20.10)'),abs(dia) write(ch_err,'(g20.10)') abs(dia)
info = 2 info = 2
call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
goto 9999 goto 9999

2
src/prec/psb_zmlprc_bld.f90
Unescape Escape View File

@ -150,6 +150,7 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
nullify(desc_p) nullify(desc_p)
allocate(desc_p) allocate(desc_p)
call psb_nullify_desc(desc_p) call psb_nullify_desc(desc_p)
@ -165,6 +166,7 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info)
call psb_baseprc_bld(ac,desc_p,p,info) call psb_baseprc_bld(ac,desc_p,p,info)
if (debug) write(0,*) 'Out from basaeprcbld',info
! !
! We have used a separate ac because: ! We have used a separate ac because:

139
src/prec/psb_zslu_bld.f90
Unescape Escape View File

@ -68,7 +68,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
integer, intent(out) :: info integer, intent(out) :: info
character(len=5), optional :: outfmt character(len=5), optional :: outfmt
end Subroutine psb_zasmatbld end Subroutine psb_zasmatbld
end interface end interface
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
@ -82,120 +82,121 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
fmt = 'COO' fmt = 'COO'
call psb_nullify_sp(blck) call psb_nullify_sp(blck)
call psb_nullify_sp(atmp) call psb_nullify_sp(atmp)
atmp%fida='COO' atmp%fida='COO'
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Calling csdp' write(0,*) me, 'SPLUBLD: Calling csdp'
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_zcsdp(a,atmp,info) call psb_zcsdp(a,atmp,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_zcsdp' ch_err='psb_zcsdp'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
nza = atmp%infoa(psb_nnz_) nza = atmp%infoa(psb_nnz_)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=fmt) & blck,desc_a,upd,p%desc_data,info,outfmt=fmt)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_asmatbld' ch_err='psb_asmatbld'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
nzb = blck%infoa(psb_nnz_) nzb = blck%infoa(psb_nnz_)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
if (nzb > 0 ) then if (nzb > 0 ) then
if (size(atmp%aspk)<nza+nzb) then if (size(atmp%aspk)<nza+nzb) then
call psb_sp_reall(atmp,nza+nzb,info) call psb_sp_reall(atmp,nza+nzb,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_sp_reall' ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
endif endif
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
do j=1,nzb do j=1,nzb
atmp%aspk(nza+j) = blck%aspk(j) atmp%aspk(nza+j) = blck%aspk(j)
atmp%ia1(nza+j) = blck%ia1(j) atmp%ia1(nza+j) = blck%ia1(j)
atmp%ia2(nza+j) = blck%ia2(j) atmp%ia2(nza+j) = blck%ia2(j)
end do end do
atmp%infoa(psb_nnz_) = nza+nzb atmp%infoa(psb_nnz_) = nza+nzb
atmp%m = atmp%m + blck%m atmp%m = atmp%m + blck%m
atmp%k = max(a%k,blck%k) atmp%k = max(a%k,blck%k)
else else
atmp%infoa(psb_nnz_) = nza atmp%infoa(psb_nnz_) = nza
atmp%m = a%m atmp%m = a%m
atmp%k = a%k atmp%k = a%k
endif endif
i=0 i=0
do j=1, atmp%infoa(psb_nnz_) do j=1, atmp%infoa(psb_nnz_)
if (atmp%ia2(j) <= atmp%m) then if (atmp%ia2(j) <= atmp%m) then
i = i + 1 i = i + 1
atmp%aspk(i) = atmp%aspk(j) atmp%aspk(i) = atmp%aspk(j)
atmp%ia1(i) = atmp%ia1(j) atmp%ia1(i) = atmp%ia1(j)
atmp%ia2(i) = atmp%ia2(j) atmp%ia2(i) = atmp%ia2(j)
endif endif
enddo enddo
atmp%infoa(psb_nnz_) = i atmp%infoa(psb_nnz_) = i
call psb_ipcoo2csr(atmp,info) call psb_ipcoo2csr(atmp,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_ipcoo2csr' ch_err='psb_ipcoo2csr'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call psb_spinfo(psb_nztotreq_,atmp,nzt,info) call psb_spinfo(psb_nztotreq_,atmp,nzt,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_spinfo' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (Debug) then if (Debug) then
write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,& write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,&
& atmp%k,p%desc_data%matrix_data(psb_n_row_) & atmp%k,p%desc_data%matrix_data(psb_n_row_)
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_zslu_factor(atmp%m,nzt,& call psb_zslu_factor(atmp%m,nzt,&
& atmp%aspk,atmp%ia2,atmp%ia1,p%iprcparm(slu_ptr_),info) & atmp%aspk,atmp%ia2,atmp%ia1,p%iprcparm(slu_ptr_),info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_slu_fact' ch_err='psb_slu_fact'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_) write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_)
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_sp_free(blck,info) call psb_sp_free(blck,info)
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_sp_free' ch_err='psb_sp_free'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -204,8 +205,8 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error() call psb_error()
return return
end if end if
return return

139
src/prec/psb_zumf_bld.f90
Unescape Escape View File

@ -69,7 +69,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
integer, intent(out) :: info integer, intent(out) :: info
character(len=5), optional :: outfmt character(len=5), optional :: outfmt
end Subroutine psb_zasmatbld end Subroutine psb_zasmatbld
end interface end interface
info=0 info=0
name='psb_umf_bld' name='psb_umf_bld'
@ -82,97 +82,98 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
fmt = 'COO' fmt = 'COO'
call psb_nullify_sp(blck) call psb_nullify_sp(blck)
call psb_nullify_sp(atmp) call psb_nullify_sp(atmp)
atmp%fida='COO' atmp%fida='COO'
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Calling csdp' write(0,*) me, 'UMFBLD: Calling csdp'
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_zcsdp(a,atmp,info) call psb_zcsdp(a,atmp,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_zcsdp' ch_err='psb_zcsdp'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call psb_spinfo(psb_nztotreq_,atmp,nza,info) call psb_spinfo(psb_nztotreq_,atmp,nza,info)
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=fmt) & blck,desc_a,upd,p%desc_data,info,outfmt=fmt)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_asmatbld' ch_err='psb_asmatbld'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call psb_spinfo(psb_nztotreq_,blck,nzb,info) call psb_spinfo(psb_nztotreq_,blck,nzb,info)
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done asmatbld',info,nzb,blck%fida write(0,*) me, 'UMFBLD: Done asmatbld',info,nzb,blck%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
if (nzb > 0 ) then if (nzb > 0 ) then
if (size(atmp%aspk)<nza+nzb) then if (size(atmp%aspk)<nza+nzb) then
call psb_sp_reall(atmp,nza+nzb,info) call psb_sp_reall(atmp,nza+nzb,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_sp_reall' ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
endif endif
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done realloc',info,nza+nzb,atmp%fida write(0,*) me, 'UMFBLD: Done realloc',info,nza+nzb,atmp%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
do j=1,nzb do j=1,nzb
atmp%aspk(nza+j) = blck%aspk(j) atmp%aspk(nza+j) = blck%aspk(j)
atmp%ia1(nza+j) = blck%ia1(j) atmp%ia1(nza+j) = blck%ia1(j)
atmp%ia2(nza+j) = blck%ia2(j) atmp%ia2(nza+j) = blck%ia2(j)
end do end do
atmp%infoa(psb_nnz_) = nza+nzb atmp%infoa(psb_nnz_) = nza+nzb
atmp%m = atmp%m + blck%m atmp%m = atmp%m + blck%m
atmp%k = max(a%k,blck%k) atmp%k = max(a%k,blck%k)
else else
atmp%infoa(psb_nnz_) = nza atmp%infoa(psb_nnz_) = nza
atmp%m = a%m atmp%m = a%m
atmp%k = a%k atmp%k = a%k
endif endif
i=0 i=0
do j=1, atmp%infoa(psb_nnz_) do j=1, atmp%infoa(psb_nnz_)
if (atmp%ia2(j) <= atmp%m) then if (atmp%ia2(j) <= atmp%m) then
i = i + 1 i = i + 1
atmp%aspk(i) = atmp%aspk(j) atmp%aspk(i) = atmp%aspk(j)
atmp%ia1(i) = atmp%ia1(j) atmp%ia1(i) = atmp%ia1(j)
atmp%ia2(i) = atmp%ia2(j) atmp%ia2(i) = atmp%ia2(j)
endif endif
enddo enddo
atmp%infoa(psb_nnz_) = i atmp%infoa(psb_nnz_) = i
call psb_ipcoo2csc(atmp,info) call psb_ipcoo2csc(atmp,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_ipcoo2csc' ch_err='psb_ipcoo2csc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call psb_spinfo(psb_nztotreq_,atmp,nzt,info) call psb_spinfo(psb_nztotreq_,atmp,nzt,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_spinfo' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (Debug) then if (Debug) then
write(0,*) me,'Calling psb_umf_factor ',nzt,atmp%m,& write(0,*) me,'Calling psb_umf_factor ',nzt,atmp%m,&
& atmp%k,p%desc_data%matrix_data(psb_n_row_) & atmp%k,p%desc_data%matrix_data(psb_n_row_)
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_zumf_factor(atmp%m,nzt,& call psb_zumf_factor(atmp%m,nzt,&
@ -180,23 +181,23 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
& p%iprcparm(umf_symptr_),p%iprcparm(umf_numptr_),info) & p%iprcparm(umf_symptr_),p%iprcparm(umf_numptr_),info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_umf_fact' ch_err='psb_umf_fact'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done umf_Factor',info,p%iprcparm(umf_numptr_) write(0,*) me, 'UMFBLD: Done umf_Factor',info,p%iprcparm(umf_numptr_)
call blacs_barrier(icontxt,'All') call blacs_barrier(icontxt,'All')
endif endif
call psb_sp_free(blck,info) call psb_sp_free(blck,info)
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_sp_free' ch_err='psb_sp_free'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -205,8 +206,8 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error() call psb_error()
return return
end if end if
return return

68
src/psblas/psb_dspmm.f90
Unescape Escape View File

@ -96,7 +96,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
real(kind(1.d0)), optional, pointer :: work(:) real(kind(1.d0)), optional, target :: work(:)
character, intent(in), optional :: trans character, intent(in), optional :: trans
integer, intent(in), optional :: k, jx, jy,doswap integer, intent(in), optional :: k, jx, jy,doswap
@ -109,6 +109,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
real(kind(1.d0)),pointer :: tmpx(:), xp(:,:), yp(:,:), iwork(:) real(kind(1.d0)),pointer :: tmpx(:), xp(:,:), yp(:,:), iwork(:)
character :: itrans character :: itrans
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw
name='psb_dspmm' name='psb_dspmm'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -187,26 +188,28 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
liwork= 2*ncol liwork= 2*ncol
if (a%pr(1) /= 0) liwork = liwork + n * ik if (a%pr(1) /= 0) liwork = liwork + n * ik
if (a%pl(1) /= 0) liwork = liwork + m * ik if (a%pl(1) /= 0) liwork = liwork + m * ik
if (present(work)) then if (present(work)) then
if(size(work).lt.liwork) then if (size(work) >= liwork) then
call psb_realloc(liwork,work,info) aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
end if
iwork => work
else else
call psb_realloc(liwork,iwork,info) iwork => work
if(info.ne.0) then endif
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
iwork(1)=dzero iwork(1)=dzero
! checking for matrix correctness ! checking for matrix correctness
@ -342,7 +345,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
end if end if
if(.not.present(work)) deallocate(iwork) if(aliw) deallocate(iwork)
nullify(iwork) nullify(iwork)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -433,7 +436,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
real(kind(1.d0)), optional, pointer :: work(:) real(kind(1.d0)), optional, target :: work(:)
character, intent(in), optional :: trans character, intent(in), optional :: trans
integer, intent(in), optional :: doswap integer, intent(in), optional :: doswap
@ -446,6 +449,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
real(kind(1.d0)),pointer :: tmpx(:), iwork(:), xp(:), yp(:) real(kind(1.d0)),pointer :: tmpx(:), iwork(:), xp(:), yp(:)
character :: itrans character :: itrans
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw
name='psb_dspmv' name='psb_dspmv'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -505,16 +509,24 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
lldx = size(x) lldx = size(x)
lldy = size(y) lldy = size(y)
iwork => null()
! check for presence/size of a work area ! check for presence/size of a work area
liwork= 2*ncol liwork= 2*ncol
if (a%pr(1) /= 0) liwork = liwork + n * ik if (a%pr(1) /= 0) liwork = liwork + n * ik
if (a%pl(1) /= 0) liwork = liwork + m * ik if (a%pl(1) /= 0) liwork = liwork + m * ik
! write(0,*)'---->>>',work(1) ! write(0,*)'---->>>',work(1)
if (present(work)) then if (present(work)) then
if(size(work).ge.liwork) then if (size(work) >= liwork) then
iwork => work aliw =.false.
liwork=size(work)
else else
aliw=.true.
endif
else
aliw=.true.
end if
aliw=.true.
if (aliw) then
call psb_realloc(liwork,iwork,info) call psb_realloc(liwork,iwork,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
@ -522,16 +534,10 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
end if
else else
call psb_realloc(liwork,iwork,info) iwork => work
if(info.ne.0) then endif
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
! checking for matrix correctness ! checking for matrix correctness
call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja) call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja)
@ -644,9 +650,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
end if end if
if(.not.present(work)) then if(aliw) deallocate(iwork)
deallocate(iwork)
end if
nullify(iwork) nullify(iwork)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

68
src/psblas/psb_dspsm.f90
Unescape Escape View File

@ -91,7 +91,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
real(kind(1.d0)), intent(in), optional, target :: d(:) real(kind(1.d0)), intent(in), optional, target :: d(:)
real(kind(1.d0)), optional, pointer :: work(:) real(kind(1.d0)), optional, target :: work(:)
character, intent(in), optional :: trans, unitd character, intent(in), optional :: trans, unitd
integer, intent(in), optional :: choice integer, intent(in), optional :: choice
integer, intent(in), optional :: k, jx, jy integer, intent(in), optional :: k, jx, jy
@ -107,6 +107,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
real(kind(1.d0)),pointer :: iwork(:), xp(:,:), yp(:,:), id(:) real(kind(1.d0)),pointer :: iwork(:), xp(:,:), yp(:,:), id(:)
character :: itrans character :: itrans
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw
name='psb_dspsm' name='psb_dspsm'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -195,29 +196,32 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
end if end if
! check for presence/size of a work area ! check for presence/size of a work area
iwork => null()
liwork= 2*ncol liwork= 2*ncol
if (a%pr(1) /= 0) llwork = liwork + m * ik if (a%pr(1) /= 0) llwork = liwork + m * ik
if (a%pl(1) /= 0) llwork = llwork + m * ik if (a%pl(1) /= 0) llwork = llwork + m * ik
if (present(work)) then if (present(work)) then
if(size(work).lt.liwork) then if (size(work) >= liwork) then
call psb_realloc(liwork,work,info) aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
if (aliw) then
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
end if
iwork => work
else else
call psb_realloc(liwork,iwork,info) iwork => work
if(info.ne.0) then endif
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
iwork(1)=0.d0 iwork(1)=0.d0
if(present(d)) then if(present(d)) then
@ -302,7 +306,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
end select end select
end if end if
if(.not.present(work)) deallocate(iwork) if(aliw) deallocate(iwork)
if(.not.present(d)) deallocate(id) if(.not.present(d)) deallocate(id)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -398,7 +402,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
real(kind(1.d0)), intent(in), optional, target :: d(:) real(kind(1.d0)), intent(in), optional, target :: d(:)
real(kind(1.d0)), optional, pointer :: work(:) real(kind(1.d0)), optional, target :: work(:)
character, intent(in), optional :: trans, unitd character, intent(in), optional :: trans, unitd
integer, intent(in), optional :: choice integer, intent(in), optional :: choice
@ -413,6 +417,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
real(kind(1.d0)),pointer :: iwork(:), xp(:), yp(:), id(:) real(kind(1.d0)),pointer :: iwork(:), xp(:), yp(:), id(:)
character :: itrans character :: itrans
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw
name='psb_dspsv' name='psb_dspsv'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -484,30 +489,35 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
goto 9999 goto 9999
end if end if
iwork => null()
! check for presence/size of a work area ! check for presence/size of a work area
liwork= 2*ncol liwork= 2*ncol
if (a%pr(1) /= 0) llwork = liwork + m * ik if (a%pr(1) /= 0) llwork = liwork + m * ik
if (a%pl(1) /= 0) llwork = llwork + m * ik if (a%pl(1) /= 0) llwork = llwork + m * ik
if (present(work)) then if (present(work)) then
if(size(work).lt.liwork) then if (size(work) >= liwork) then
call psb_realloc(liwork,work,info) aliw =.false.
else
aliw=.true.
endif
else
aliw=.true.
end if
aliw=.true.
if (aliw) then
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
end if
iwork => work
else else
call psb_realloc(liwork,iwork,info) iwork => work
if(info.ne.0) then endif
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
iwork(1)=0.d0 iwork(1)=0.d0
if (present(d)) then if (present(d)) then
@ -591,7 +601,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
end select end select
end if end if
if(.not.present(work)) deallocate(iwork) if (aliw) deallocate(iwork)
if(.not.present(d)) deallocate(id) if(.not.present(d)) deallocate(id)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

1
src/tools/psb_dcdovrbld.f90
Unescape Escape View File

@ -96,6 +96,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
icontxt = desc_a%matrix_data(psb_ctxt_) icontxt = desc_a%matrix_data(psb_ctxt_)
!!$ call blacs_barrier(icontxt,'All') !!$ call blacs_barrier(icontxt,'All')
Call blacs_gridinfo(icontxt,np,npcol,myrow,mycol) Call blacs_gridinfo(icontxt,np,npcol,myrow,mycol)
call psb_nullify_sp(blk)
Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
tl = 0.0 tl = 0.0

2
test/Fileread/Makefile
Unescape Escape View File

@ -50,6 +50,8 @@ zhb2mm: $(ZH2MOBJS)
zmm2hb: $(ZM2HOBJS) zmm2hb: $(ZM2HOBJS)
$(MPF90) -o zmm2hb $(ZM2HOBJS) $(PSBLAS_LIB) $(BLACS) $(MPF90) -o zmm2hb $(ZM2HOBJS) $(PSBLAS_LIB) $(BLACS)
srctst: srctst.o
$(MPF90) -o srctst srctst.o $(PSBLAS_LIB) $(BLACS)
.f90.o: .f90.o:
$(MPF90) $(F90COPT) $(INCDIRS) -c $< $(MPF90) $(F90COPT) $(INCDIRS) -c $<

9
test/Fileread/df_sample.f90
Unescape Escape View File

@ -248,6 +248,15 @@ program df_sample
call psb_precset(pre,'asm',iv=(/novr,halo_,none_/)) call psb_precset(pre,'asm',iv=(/novr,halo_,none_/))
case(rash_) case(rash_)
call psb_precset(pre,'asm',iv=(/novr,nohalo_,none_/)) call psb_precset(pre,'asm',iv=(/novr,nohalo_,none_/))
case(7)
call psb_precset(pre,'asm',iv=(/ml,halo_,none_/))
call psb_precset(pre,'ml',&
& iv=(/mult_ml_prec_,loc_aggr_,smth_omg_,mat_distr_,post_smooth_,1,f_ilu_n_,4/))
case(8)
call psb_precset(pre,'asm',iv=(/ml,halo_,none_/))
call psb_precset(pre,'ml',&
& iv=(/mult_ml_prec_,loc_aggr_,smth_omg_,mat_distr_,post_smooth_,1,f_umf_,4/))
case default case default
call psb_precset(pre,'ilu') call psb_precset(pre,'ilu')
end select end select

Write Preview
Loading…
Cancel
Save