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
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
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
other compiler/operating systems please let us know.
IBM SP2.
The library has been tested on an IBM SP2 with XLC and XLF
IBM SP.
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.
The rather baroque setting
F90=xlf90 -qsuffix=f=f90
@ -117,8 +117,8 @@ Credits for version 2.0:
Salvatore Filippone
Alfredo Buttari
The MPcube preconditioners contained in directory src/prec were
developed with the contribution of:
The multilevel parallel preconditioners contained in directory
src/prec were developed with the contribution of:
Pasqua D'Ambra
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
type(psb_desc_type), intent(in) :: desc_a
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, intent(out) :: info
end subroutine psb_dspmm
@ -362,7 +362,7 @@ module psb_psblas_mod
real(kind(1.d0)), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
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, intent(out) :: info
end subroutine psb_dspmv
@ -376,7 +376,7 @@ module psb_psblas_mod
complex(kind(1.d0)), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
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, intent(out) :: info
end subroutine psb_zspmm
@ -390,7 +390,7 @@ module psb_psblas_mod
complex(kind(1.d0)), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
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, intent(out) :: info
end subroutine psb_zspmv
@ -410,7 +410,7 @@ module psb_psblas_mod
character, optional, intent(in) :: trans, unit
integer, optional, intent(in) :: n, jx, jy
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
end subroutine psb_dspsm
subroutine psb_dspsv(alpha, t, x, beta, y,&
@ -425,7 +425,7 @@ module psb_psblas_mod
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans, unit
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
end subroutine psb_dspsv
subroutine psb_zspsm(alpha, t, x, beta, y,&
@ -441,7 +441,7 @@ module psb_psblas_mod
character, optional, intent(in) :: trans, unit
integer, optional, intent(in) :: n, jx, jy
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
end subroutine psb_zspsm
subroutine psb_zspsv(alpha, t, x, beta, y,&
@ -456,7 +456,7 @@ module psb_psblas_mod
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans, unit
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
end subroutine psb_zspsv
end interface

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

@ -61,13 +61,15 @@ Contains
Integer,Pointer :: tmp(:)
Integer :: dim, err_act, err,i
character(len=20) :: name
logical, parameter :: debug=.false.
name='psb_dreallocate1i'
call psb_erractionsave(err_act)
if(psb_get_errstatus().ne.0) return
info=0
if (associated(rrax)) then
if (debug) write(0,*) 'reallocate I',len
if (associated(rrax)) then a
dim=size(rrax)
If (dim /= len) Then
Allocate(tmp(len),stat=info)
@ -137,9 +139,12 @@ Contains
Real(kind(1.d0)),Pointer :: tmp(:)
Integer :: dim,err_act,err,i, m
character(len=20) :: name
logical, parameter :: debug=.false.
name='psb_dreallocate1d'
call psb_erractionsave(err_act)
info = 0
if (debug) write(0,*) 'reallocate D',len
if (associated(rrax)) then
dim=size(rrax)
@ -210,9 +215,12 @@ Contains
complex(kind(1.d0)),Pointer :: tmp(:)
Integer :: dim,err_act,err,i, m
character(len=20) :: name
logical, parameter :: debug=.false.
name='psb_dreallocate1z'
call psb_erractionsave(err_act)
info = 0
if (debug) write(0,*) 'reallocate Z',len
if (associated(rrax)) then
dim=size(rrax)
@ -286,6 +294,7 @@ Contains
name='psb_dreallocated2'
call psb_erractionsave(err_act)
info = 0
if (associated(rrax)) then
dim=size(rrax,1)
@ -357,6 +366,7 @@ Contains
name='psb_dreallocatez2'
call psb_erractionsave(err_act)
info = 0
if (associated(rrax)) then
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
module procedure psb_dspreallocate, psb_dspreall3, &
& psb_zspreallocate, psb_zspreall3
& psb_zspreall3, psb_zspreallocate
end interface
interface psb_sp_all
@ -757,6 +757,32 @@ contains
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)
implicit none
@ -807,33 +833,6 @@ contains
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)
implicit none
!....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
! do the renumbering.
!
If(debug) Write(0,*)' asmatbld calling allocate '
call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then
info=4010
@ -111,9 +112,10 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if
blk%fida = 'COO'
blk%infoa(psb_nnz_) = 0
If(debug) Write(0,*)' asmatbld done spallocate'
If (upd == 'F') Then
call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy'
if(info /= 0) then
info=4010
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.....
!
If(debug) Write(0,*)' asmatbld calling allocate novr=0'
call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then
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 (upd == 'F') then
call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy'
if(info /= 0) then
info=4010
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_)
if(debug) write(0,*)me,': calling umf_bld'
call psb_umf_bld(a,desc_a,p,info)
if(debug) write(0,*)me,': Done umf_bld ',info
if(info /= 0) then
info=4010
ch_err='umf_bld'

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

@ -120,6 +120,7 @@ contains
call psb_erractionsave(err_act)
bg => ac
call psb_nullify_sp(b)
icontxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
@ -347,7 +348,7 @@ contains
type(psb_dspmat_type) :: am3,am4
logical :: ml_global_nmb
logical, parameter :: test_dump=.false.
logical, parameter :: test_dump=.false.,debug=.false.
integer, parameter :: ncmax=16
real(kind(1.d0)) :: omega, anorm, tmp, dg
character(len=20) :: name, ch_err
@ -362,6 +363,9 @@ contains
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
bg => ac
call psb_nullify_sp(b)
call psb_nullify_sp(am3)
call psb_nullify_sp(am4)
am2 => p%av(sm_pr_t_)
am1 => p%av(sm_pr_)
@ -441,7 +445,15 @@ contains
! 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
call psb_errpush(4010,name,a_err='spall')
goto 9999
@ -462,14 +474,6 @@ contains
end do
am4%infoa(psb_nnz_) = nrow
endif
am4%fida='COO'
am4%m=ncol
if (ml_global_nmb) then
am4%k=ntaggr
else
am4%k=naggr
endif
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,&
& ivc=desc_a%loc_to_glob)
if (debug) write(0,*) me,'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
@ -570,6 +575,7 @@ contains
call psb_symbmm(am3,am4,am1)
call psb_numbmm(am3,am4,am1)
if (debug) write(0,*) me,'Done NUMBMM 1'
call psb_sp_free(am4,info)
if(info /= 0) then
@ -615,6 +621,7 @@ contains
call psb_symbmm(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
call psb_transp(am1,am2,fmt='COO')
@ -638,6 +645,7 @@ contains
else
call psb_transp(am1,am2)
endif
if (debug) write(0,*) me,'starting sphalo/ rwxtd'
if (p%iprcparm(smth_kind_) == smth_omg_) then
! am2 = ((i-wDA)Ptilde)^T
@ -667,8 +675,11 @@ contains
end if
endif
if (debug) write(0,*) me,'starting symbmm 3'
call psb_symbmm(am2,am3,b)
if (debug) write(0,*) me,'starting numbmm 3'
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.')
call psb_sp_free(am3,info)
@ -731,6 +742,7 @@ contains
goto 9999
end if
if (debug) write(0,*) me,'Created aux descr. distr.'
call psb_cdasb(desc_p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb')
@ -738,6 +750,7 @@ contains
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')
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_)
call psb_nullify_sp(blck)
call psb_nullify_sp(atmp)
t1= mpi_wtime()
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
info=0
call psb_erractionsave(err_act)
call psb_nullify_sp(trw)
trw%m=0
trw%k=0
if(debug) write(0,*)'LUINT Allocating TRW'
@ -300,7 +300,7 @@ contains
!
info = 2
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)
goto 9999
else
@ -439,7 +439,7 @@ contains
! Pivot too small: unstable factorization
!
int_err(1) = i
write(ch_err,'(g20.10)'),dia
write(ch_err,'(g20.10)') dia
info = 2
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
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
end if
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
nullify(desc_p)
allocate(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)
if (debug) write(0,*) 'Out from basaeprcbld',info
!
! We have used a separate ac because:

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

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

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'
call psb_nullify_sp(blck)
call psb_nullify_sp(atmp)
atmp%fida='COO'
if (Debug) then
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
! do the renumbering.
!
If(debug) Write(0,*)' asmatbld calling allocate '
call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then
info=4010
@ -111,9 +112,10 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if
blk%fida = 'COO'
blk%infoa(psb_nnz_) = 0
If(debug) Write(0,*)' asmatbld done spallocate'
If (upd == 'F') Then
call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy'
if(info /= 0) then
info=4010
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.....
!
If(debug) Write(0,*)' asmatbld calling allocate novr=0'
call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then
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 (upd == 'F') then
call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy'
if(info /= 0) then
info=4010
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)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) call blacs_barrier(icontxt,'All')
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld'
if (debug) call blacs_barrier(icontxt,'All')
if(info /= 0) then
info=4010
ch_err='psb_ilu_bld'
@ -222,6 +223,7 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
case(f_umf_)
if(debug) write(0,*)me,': calling umf_bld'
call psb_umf_bld(a,desc_a,p,info)
if(debug) write(0,*)me,': Done umf_bld ',info
if(info /= 0) then
info=4010
ch_err='umf_bld'

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

@ -120,6 +120,7 @@ contains
call psb_erractionsave(err_act)
bg => ac
call psb_nullify_sp(b)
icontxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
@ -362,6 +363,9 @@ contains
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol)
bg => ac
call psb_nullify_sp(b)
call psb_nullify_sp(am3)
call psb_nullify_sp(am4)
am2 => p%av(sm_pr_t_)
am1 => p%av(sm_pr_)
@ -441,7 +445,15 @@ contains
! 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
call psb_errpush(4010,name,a_err='spall')
goto 9999
@ -462,14 +474,6 @@ contains
end do
am4%infoa(psb_nnz_) = nrow
endif
am4%fida='COO'
am4%m=ncol
if (ml_global_nmb) then
am4%k=ntaggr
else
am4%k=naggr
endif
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,&
& ivc=desc_a%loc_to_glob)
if (debug) write(0,*) me,'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
@ -570,6 +575,7 @@ contains
call psb_symbmm(am3,am4,am1)
call psb_numbmm(am3,am4,am1)
if (debug) write(0,*) me,'Done NUMBMM 1'
call psb_sp_free(am4,info)
if(info /= 0) then
@ -615,6 +621,7 @@ contains
call psb_symbmm(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
call psb_transp(am1,am2,fmt='COO')
@ -638,6 +645,7 @@ contains
else
call psb_transp(am1,am2)
endif
if (debug) write(0,*) me,'starting sphalo/ rwxtd'
if (p%iprcparm(smth_kind_) == smth_omg_) then
! am2 = ((i-wDA)Ptilde)^T
@ -667,8 +675,11 @@ contains
end if
endif
if (debug) write(0,*) me,'starting symbmm 3'
call psb_symbmm(am2,am3,b)
if (debug) write(0,*) me,'starting numbmm 3'
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.')
call psb_sp_free(am3,info)
@ -731,6 +742,7 @@ contains
goto 9999
end if
if (debug) write(0,*) me,'Created aux descr. distr.'
call psb_cdasb(desc_p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb')
@ -738,6 +750,7 @@ contains
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')
if(info /= 0) then

12
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_)
call psb_nullify_sp(blck)
call psb_nullify_sp(atmp)
t1= mpi_wtime()
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,&
& blck,desc_a,upd,p%desc_data,info)
if(info/=0) then
@ -169,6 +172,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
end if
t2= mpi_wtime()
if (debug) write(0,*)me,': out of psb_asmatbld'
if (debug) call blacs_barrier(icontxt,'All')
if (associated(p%av)) 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)
goto 9999
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_)
nhalo = n_col-nrow_a
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_)%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(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
info=4010
ch_err='psb_sp_all'
@ -303,7 +310,8 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
endif
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)
if(info/=0) then
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
info=0
call psb_erractionsave(err_act)
call psb_nullify_sp(trw)
trw%m=0
trw%k=0
if(debug) write(0,*)'LUINT Allocating TRW'
@ -298,7 +298,7 @@ contains
!
info = 2
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)
goto 9999
else
@ -437,7 +437,7 @@ contains
! Pivot too small: unstable factorization
!
int_err(1) = i
write(ch_err,'(g20.10)'),abs(dia)
write(ch_err,'(g20.10)') abs(dia)
info = 2
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
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
end if
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
nullify(desc_p)
allocate(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)
if (debug) write(0,*) 'Out from basaeprcbld',info
!
! We have used a separate ac because:

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

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

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

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

54
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_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
real(kind(1.d0)), optional, pointer :: work(:)
real(kind(1.d0)), optional, target :: work(:)
character, intent(in), optional :: trans
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(:)
character :: itrans
character(len=20) :: name, ch_err
logical :: aliw
name='psb_dspmm'
if(psb_get_errstatus().ne.0) return
@ -188,17 +189,16 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
if (a%pr(1) /= 0) liwork = liwork + n * ik
if (a%pl(1) /= 0) liwork = liwork + m * ik
if (present(work)) then
if(size(work).lt.liwork) then
call psb_realloc(liwork,work,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
iwork => work
else
aliw=.true.
end if
if (aliw) then
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
@ -206,7 +206,10 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
iwork(1)=dzero
! checking for matrix correctness
@ -342,7 +345,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
end if
if(.not.present(work)) deallocate(iwork)
if(aliw) deallocate(iwork)
nullify(iwork)
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_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
real(kind(1.d0)), optional, pointer :: work(:)
real(kind(1.d0)), optional, target :: work(:)
character, intent(in), optional :: trans
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(:)
character :: itrans
character(len=20) :: name, ch_err
logical :: aliw
name='psb_dspmv'
if(psb_get_errstatus().ne.0) return
@ -505,25 +509,24 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
lldx = size(x)
lldy = size(y)
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (a%pr(1) /= 0) liwork = liwork + n * ik
if (a%pl(1) /= 0) liwork = liwork + m * ik
! write(0,*)'---->>>',work(1)
if (present(work)) then
if(size(work).ge.liwork) then
iwork => work
liwork=size(work)
if (size(work) >= liwork) then
aliw =.false.
else
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
aliw=.true.
endif
else
aliw=.true.
end if
aliw=.true.
if (aliw) then
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
@ -531,8 +534,11 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
! checking for matrix correctness
call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja)
if(info.ne.0) then
@ -644,9 +650,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
end if
if(.not.present(work)) then
deallocate(iwork)
end if
if(aliw) deallocate(iwork)
nullify(iwork)
call psb_erractionrestore(err_act)

54
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
integer, intent(out) :: info
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
integer, intent(in), optional :: choice
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(:)
character :: itrans
character(len=20) :: name, ch_err
logical :: aliw
name='psb_dspsm'
if(psb_get_errstatus().ne.0) return
@ -195,21 +196,21 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
end if
! check for presence/size of a work area
iwork => null()
liwork= 2*ncol
if (a%pr(1) /= 0) llwork = liwork + m * ik
if (a%pl(1) /= 0) llwork = llwork + m * ik
if (present(work)) then
if(size(work).lt.liwork) then
call psb_realloc(liwork,work,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
iwork => work
else
aliw=.true.
end if
if (aliw) then
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
@ -217,7 +218,10 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
iwork(1)=0.d0
if(present(d)) then
@ -302,7 +306,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
end select
end if
if(.not.present(work)) deallocate(iwork)
if(aliw) deallocate(iwork)
if(.not.present(d)) deallocate(id)
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
integer, intent(out) :: info
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
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(:)
character :: itrans
character(len=20) :: name, ch_err
logical :: aliw
name='psb_dspsv'
if(psb_get_errstatus().ne.0) return
@ -484,22 +489,24 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
goto 9999
end if
iwork => null()
! check for presence/size of a work area
liwork= 2*ncol
if (a%pr(1) /= 0) llwork = liwork + m * ik
if (a%pl(1) /= 0) llwork = llwork + m * ik
if (present(work)) then
if(size(work).lt.liwork) then
call psb_realloc(liwork,work,info)
if(info.ne.0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (size(work) >= liwork) then
aliw =.false.
else
aliw=.true.
endif
iwork => work
else
aliw=.true.
end if
aliw=.true.
if (aliw) then
call psb_realloc(liwork,iwork,info)
if(info.ne.0) then
info=4010
@ -507,7 +514,10 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
iwork => work
endif
iwork(1)=0.d0
if (present(d)) then
@ -591,7 +601,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
end select
end if
if(.not.present(work)) deallocate(iwork)
if (aliw) deallocate(iwork)
if(.not.present(d)) deallocate(id)
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_)
!!$ call blacs_barrier(icontxt,'All')
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)
tl = 0.0

2
test/Fileread/Makefile
Unescape Escape View File

@ -50,6 +50,8 @@ zhb2mm: $(ZH2MOBJS)
zmm2hb: $(ZM2HOBJS)
$(MPF90) -o zmm2hb $(ZM2HOBJS) $(PSBLAS_LIB) $(BLACS)
srctst: srctst.o
$(MPF90) -o srctst srctst.o $(PSBLAS_LIB) $(BLACS)
.f90.o:
$(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_/))
case(rash_)
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
call psb_precset(pre,'ilu')
end select

Write Preview
Loading…
Cancel
Save