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

Merged debug infrastructure, internal docs and html headers.

Browse Source
psblas3-type-indexed
Salvatore Filippone 17 years ago
parent 8eada499ff
commit 1de99a499a
182 changed files with 3187 additions and 2843 deletions
Show Stats Download Patch File Download Diff File

2
Changelog
Unescape Escape View File

@ -1,6 +1,8 @@
Changelog. A lot less detailed than usual, at least for past Changelog. A lot less detailed than usual, at least for past
history. history.
2007/12/21: Merged in debug infrastructure, internal and html docs.
2007/11/14: Fix INTENT(IN) on X vector in preconditioner routines. 2007/11/14: Fix INTENT(IN) on X vector in preconditioner routines.
2007/10/15: Repackaged the sorting routines in a submodule of their 2007/10/15: Repackaged the sorting routines in a submodule of their

4
base/comm/psb_dgather.f90
Unescape Escape View File

@ -38,7 +38,7 @@
! the distributed pieces. ! the distributed pieces.
! locx - real,dimension(:,:). The local piece of the distributed ! locx - real,dimension(:,:). The local piece of the distributed
! matrix to be gathered. ! matrix to be gathered.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Return code.
! iroot - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all
@ -209,7 +209,7 @@ end subroutine psb_dgatherm
! distributed pieces. ! distributed pieces.
! locx - real,dimension(:). The local piece of the ditributed ! locx - real,dimension(:). The local piece of the ditributed
! vector to be gathered. ! vector to be gathered.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Return code.
! root - integer. The process that has to own the ! root - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all

4
base/comm/psb_dhalo.f90
Unescape Escape View File

@ -36,7 +36,7 @@
! !
! Arguments: ! Arguments:
! x - real,dimension(:,:). The local part of the dense matrix. ! x - real,dimension(:,:). The local part of the dense matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! alpha - real(optional). Scale factor. ! alpha - real(optional). Scale factor.
! jx - integer(optional). The starting column of the global matrix. ! jx - integer(optional). The starting column of the global matrix.
@ -252,7 +252,7 @@ end subroutine psb_dhalom
! !
! Arguments: ! Arguments:
! x - real,dimension(:). The local part of the dense vector. ! x - real,dimension(:). The local part of the dense vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! alpha - real(optional). Scale factor. ! alpha - real(optional). Scale factor.
! work - real(optional). Work area. ! work - real(optional). Work area.

4
base/comm/psb_dovrl.f90
Unescape Escape View File

@ -36,7 +36,7 @@
! !
! Arguments: ! Arguments:
! x(:,:) - real The local part of the dense matrix. ! x(:,:) - real The local part of the dense matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix ! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather. ! ik - integer(optional). The number of columns to gather.
@ -254,7 +254,7 @@ end subroutine psb_dovrlm
! !
! Arguments: ! Arguments:
! x(:) - real The local part of the dense vector. ! x(:) - real The local part of the dense vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Return code.
! work - real(optional). A work area. ! work - real(optional). A work area.
! update - integer(optional). Type of update: ! update - integer(optional). Type of update:

7
base/comm/psb_dscatter.F90
Unescape Escape View File

@ -37,10 +37,9 @@
! Arguments: ! Arguments:
! globx - real,dimension(:,:). The global matrix to scatter. ! globx - real,dimension(:,:). The global matrix to scatter.
! locx - real,dimension(:,:). The local piece of the ditributed matrix. ! locx - real,dimension(:,:). The local piece of the ditributed matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix. ! iroot - integer(optional). The process that owns the global matrix. If -1 all
! If -1 all
! the processes have a copy. Default -1. ! the processes have a copy. Default -1.
! !
subroutine psb_dscatterm(globx, locx, desc_a, info, iroot) subroutine psb_dscatterm(globx, locx, desc_a, info, iroot)
@ -267,7 +266,7 @@ end subroutine psb_dscatterm
! Arguments: ! Arguments:
! globx - real,dimension(:). The global vector to scatter. ! globx - real,dimension(:). The global vector to scatter.
! locx - real,dimension(:). The local piece of the ditributed vector. ! locx - real,dimension(:). The local piece of the ditributed vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.

4
base/comm/psb_igather.f90
Unescape Escape View File

@ -38,7 +38,7 @@
! the distributed pieces. ! the distributed pieces.
! locx - integer,dimension(:,:). The local piece of the distributed ! locx - integer,dimension(:,:). The local piece of the distributed
! matrix to be gathered. ! matrix to be gathered.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all
@ -209,7 +209,7 @@ end subroutine psb_igatherm
! distributed pieces. ! distributed pieces.
! locx - integer,dimension(:). The local piece of the ditributed ! locx - integer,dimension(:). The local piece of the ditributed
! vector to be gathered. ! vector to be gathered.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all

4
base/comm/psb_ihalo.f90
Unescape Escape View File

@ -37,7 +37,7 @@
! !
! Arguments: ! Arguments:
! x - integer,dimension(:,:). The local part of the dense matrix. ! x - integer,dimension(:,:). The local part of the dense matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! alpha - real(optional). Scale factor. ! alpha - real(optional). Scale factor.
! jx - integer(optional). The starting column of the global matrix. ! jx - integer(optional). The starting column of the global matrix.
@ -254,7 +254,7 @@ end subroutine psb_ihalom
! !
! Arguments: ! Arguments:
! x - integer,dimension(:). The local part of the dense matrix. ! x - integer,dimension(:). The local part of the dense matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! alpha - real(optional). Scale factor. ! alpha - real(optional). Scale factor.
! jx - integer(optional). The starting column of the global matrix. ! jx - integer(optional). The starting column of the global matrix.

4
base/comm/psb_iscatter.F90
Unescape Escape View File

@ -37,7 +37,7 @@
! Arguments: ! Arguments:
! globx - integer,dimension(:,:). The global matrix to scatter. ! globx - integer,dimension(:,:). The global matrix to scatter.
! locx - integer,dimension(:,:). The local piece of the ditributed matrix. ! locx - integer,dimension(:,:). The local piece of the ditributed matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix. If -1 all ! iroot - integer(optional). The process that owns the global matrix. If -1 all
! the processes have a copy. ! the processes have a copy.
@ -264,7 +264,7 @@ end subroutine psb_iscatterm
! Arguments: ! Arguments:
! globx - integer,dimension(:). The global vector to scatter. ! globx - integer,dimension(:). The global vector to scatter.
! locx - integer,dimension(:). The local piece of the ditributed vector. ! locx - integer,dimension(:). The local piece of the ditributed vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.

4
base/comm/psb_zgather.f90
Unescape Escape View File

@ -38,7 +38,7 @@
! the distributed pieces. ! the distributed pieces.
! locx - cplx,dimension(:,:). The local piece of the distributed ! locx - cplx,dimension(:,:). The local piece of the distributed
! matrix to be gathered. ! matrix to be gathered.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all
@ -211,7 +211,7 @@ end subroutine psb_zgatherm
! the distributed pieces. ! the distributed pieces.
! locx - cplx,dimension(:). The local piece of the distributed ! locx - cplx,dimension(:). The local piece of the distributed
! vector to be gathered. ! vector to be gathered.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer. The process that has to own the ! iroot - integer. The process that has to own the
! global matrix. If -1 all ! global matrix. If -1 all

4
base/comm/psb_zhalo.f90
Unescape Escape View File

@ -36,7 +36,7 @@
! !
! Arguments: ! Arguments:
! x - real,dimension(:,:). The local part of the dense matrix. ! x - real,dimension(:,:). The local part of the dense matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! alpha - complex(optional). Scale factor. ! alpha - complex(optional). Scale factor.
! jx - integer(optional). The starting column of the global matrix. ! jx - integer(optional). The starting column of the global matrix.
@ -251,7 +251,7 @@ end subroutine psb_zhalom
! !
! Arguments: ! Arguments:
! x - real,dimension(:). The local part of the dense vector. ! x - real,dimension(:). The local part of the dense vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! alpha - complex(optional). Scale factor. ! alpha - complex(optional). Scale factor.
! jx - integer(optional). The starting column of the global matrix. ! jx - integer(optional). The starting column of the global matrix.

4
base/comm/psb_zovrl.f90
Unescape Escape View File

@ -36,7 +36,7 @@
! !
! Arguments: ! Arguments:
! x(:,:) - complex The local part of the dense matrix. ! x(:,:) - complex The local part of the dense matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Return code.
! jx - integer(optional). The starting column of the global matrix ! jx - integer(optional). The starting column of the global matrix
! ik - integer(optional). The number of columns to gather. ! ik - integer(optional). The number of columns to gather.
@ -253,7 +253,7 @@ end subroutine psb_zovrlm
! !
! Arguments: ! Arguments:
! x(:) - complex The local part of the dense vector. ! x(:) - complex The local part of the dense vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code. ! info - integer. Return code.
! work - real(optional). A work area. ! work - real(optional). A work area.
! update - integer(optional). Type of update: ! update - integer(optional). Type of update:

4
base/comm/psb_zscatter.F90
Unescape Escape View File

@ -37,7 +37,7 @@
! Arguments: ! Arguments:
! globx - complex,dimension(:,:). The global matrix to scatter. ! globx - complex,dimension(:,:). The global matrix to scatter.
! locx - complex,dimension(:,:). The local piece of the distributed matrix. ! locx - complex,dimension(:,:). The local piece of the distributed matrix.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code. ! info - integer. Error code.
! iroot - integer(optional). The process that owns the global matrix. ! iroot - integer(optional). The process that owns the global matrix.
! If -1 all the processes have a copy. ! If -1 all the processes have a copy.
@ -269,7 +269,7 @@ end subroutine psb_zscatterm
! Arguments: ! Arguments:
! globx - complex,dimension(:). The global vector to scatter. ! globx - complex,dimension(:). The global vector to scatter.
! locx - complex,dimension(:). The local piece of the ditributed vector. ! locx - complex,dimension(:). The local piece of the ditributed vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! iroot - integer(optional). The process that owns the global vector. If -1 all ! iroot - integer(optional). The process that owns the global vector. If -1 all
! the processes have a copy. ! the processes have a copy.

8
base/internals/psi_compute_size.f90
Unescape Escape View File

@ -52,11 +52,13 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info)
integer, allocatable :: counter_recv(:), counter_dl(:) integer, allocatable :: counter_recv(:), counter_dl(:)
! ...parameters ! ...parameters
logical, parameter :: debug=.false. integer :: debug_level, debug_unit
character(len=20) :: name character(len=20) :: name
name='psi_compute_size' name='psi_compute_size'
call psb_get_erraction(err_act) call psb_get_erraction(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = 0 info = 0
ictxt = desc_data(psb_ctxt_) ictxt = desc_data(psb_ctxt_)
@ -113,8 +115,8 @@ subroutine psi_compute_size(desc_data, index_in, dl_lda, info)
! computing max global value of dl_lda ! computing max global value of dl_lda
call psb_amx(ictxt, dl_lda) call psb_amx(ictxt, dl_lda)
if (debug) then if (debug_level>=psb_debug_inner_) then
write(0,*) 'psi_compute_size: ',dl_lda write(debug_unit,*) me,' ',trim(name),': ',dl_lda
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

2
base/internals/psi_crea_bnd_elem.f90
Unescape Escape View File

@ -39,7 +39,7 @@
! !
! Arguments: ! Arguments:
! bndel(:) - integer, allocatable Array containing the output list ! bndel(:) - integer, allocatable Array containing the output list
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! !
subroutine psi_crea_bnd_elem(bndel,desc_a,info) subroutine psi_crea_bnd_elem(bndel,desc_a,info)

22
base/internals/psi_crea_index.f90
Unescape Escape View File

@ -71,12 +71,14 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
! ...parameters... ! ...parameters...
integer, allocatable :: dep_list(:,:), length_dl(:) integer, allocatable :: dep_list(:,:), length_dl(:)
integer,parameter :: root=psb_root_,no_comm=-1 integer,parameter :: root=psb_root_,no_comm=-1
logical,parameter :: debug=.false. integer :: debug_level, debug_unit
character(len=20) :: name character(len=20) :: name
info = 0 info = 0
name='psi_crea_index' name='psi_crea_index'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
@ -99,7 +101,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
! ...extract dependence list (ordered list of identifer process ! ...extract dependence list (ordered list of identifer process
! which every process must communcate with... ! which every process must communcate with...
if (debug) write(*,*) 'crea_halo: calling extract_dep_list' if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': calling extract_dep_list'
mode = 1 mode = 1
call psi_extract_dep_list(desc_a%matrix_data,index_in,& call psi_extract_dep_list(desc_a%matrix_data,index_in,&
@ -109,10 +112,12 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'crea_index: from extract_dep_list',& if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': from extract_dep_list',&
& me,length_dl(0),index_in(1), ':',dep_list(:length_dl(me),me) & me,length_dl(0),index_in(1), ':',dep_list(:length_dl(me),me)
! ...now process root contains dependence list of all processes... ! ...now process root contains dependence list of all processes...
if (debug) write(0,*) 'crea_index: root sorting dep list' if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': root sorting dep list'
call psi_dl_check(dep_list,max(1,dl_lda),np,length_dl) call psi_dl_check(dep_list,max(1,dl_lda),np,length_dl)
@ -123,12 +128,14 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
goto 9999 goto 9999
end if end if
if(debug) write(0,*)'in psi_crea_index calling psi_desc_index',& if(debug_level >= psb_debug_inner_)&
& write(debug_unit,*) me,' ',trim(name),': calling psi_desc_index',&
& size(index_out) & size(index_out)
! Do the actual format conversion. ! Do the actual format conversion.
call psi_desc_index(desc_a,index_in,dep_list(1:,me),& call psi_desc_index(desc_a,index_in,dep_list(1:,me),&
& length_dl(me),nsnd,nrcv, index_out,glob_idx,info) & length_dl(me),nsnd,nrcv, index_out,glob_idx,info)
if(debug) write(0,*)'out of psi_desc_index',& if(debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': out of psi_desc_index',&
& size(index_out) & size(index_out)
nxch = length_dl(me) nxch = length_dl(me)
if(info /= 0) then if(info /= 0) then
@ -137,6 +144,9 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,nxch,nsnd,nrcv,info
end if end if
deallocate(dep_list,length_dl) deallocate(dep_list,length_dl)
if(debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

6
base/internals/psi_crea_ovr_elem.f90
Unescape Escape View File

@ -38,7 +38,7 @@
! !
! Arguments: ! Arguments:
! ovr_elem(:) - integer, allocatable Array containing the output list ! ovr_elem(:) - integer, allocatable Array containing the output list
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! !
subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info) subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info)
@ -84,6 +84,8 @@ subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info)
if (usetree) then if (usetree) then
!
! This is now here just for historical reasons.
! !
! While running through the column indices exchanged with other procs ! While running through the column indices exchanged with other procs
! we have to record them in overlap_elem. We do this by maintaining ! we have to record them in overlap_elem. We do this by maintaining
@ -148,7 +150,7 @@ subroutine psi_crea_ovr_elem(desc_overlap,ovr_elem,info)
else if (.not.usetree) then else if (.not.usetree) then
! Simple alternative.
insize = size(desc_overlap) insize = size(desc_overlap)
insize = max(1,(insize+1)/2) insize = max(1,(insize+1)/2)
allocate(telem(insize,2),stat=info) allocate(telem(insize,2),stat=info)

27
base/internals/psi_desc_index.F90
Unescape Escape View File

@ -131,12 +131,15 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
integer :: ihinsz,ntot,k,err_act,nidx,& integer :: ihinsz,ntot,k,err_act,nidx,&
& idxr, idxs, iszs, iszr, nesd, nerv, icomm & idxr, idxs, iszs, iszr, nesd, nerv, icomm
logical,parameter :: debug=.false., usempi=.true. logical,parameter :: usempi=.true.
character(len=20) :: name integer :: debug_level, debug_unit
character(len=20) :: name
info = 0 info = 0
name='psi_desc_index' name='psi_desc_index'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc) ictxt = psb_cd_get_context(desc)
icomm = psb_cd_get_mpic(desc) icomm = psb_cd_get_mpic(desc)
@ -147,8 +150,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
goto 9999 goto 9999
endif endif
if (debug) then if (debug_level >= psb_debug_inner_) then
write(0,*) me,'start desc_index' write(debug_unit,*) me,' ',trim(name),': start'
call psb_barrier(ictxt) call psb_barrier(ictxt)
endif endif
@ -203,8 +206,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
if ((iszs /= idxs).or.(iszr /= idxr)) then if ((iszs /= idxs).or.(iszr /= idxr)) then
write(0,*) 'strange results?', iszs,idxs,iszr,idxr write(0,*) 'strange results?', iszs,idxs,iszr,idxr
end if end if
if (debug) then if (debug_level >= psb_debug_inner_) then
write(0,*) me,'computed sizes ',iszr,iszs write(debug_unit,*) me,' ',trim(name),': computed sizes ',iszr,iszs
call psb_barrier(ictxt) call psb_barrier(ictxt)
endif endif
@ -223,8 +226,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
goto 9999 goto 9999
end if end if
if (debug) then if (debug_level >= psb_debug_inner_) then
write(0,*) me,'computed allocated workspace ',iszr,iszs write(debug_unit,*) me,' ',trim(name),': computed allocated workspace ',iszr,iszs
call psb_barrier(ictxt) call psb_barrier(ictxt)
endif endif
allocate(sndbuf(iszs),rcvbuf(iszr),stat=info) allocate(sndbuf(iszs),rcvbuf(iszr),stat=info)
@ -264,8 +267,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
i = i + nerv + 1 i = i + nerv + 1
end do end do
if (debug) then if (debug_level >= psb_debug_inner_) then
write(0,*) me,' prepared send buffer ' write(debug_unit,*) me,' ',trim(name),': prepared send buffer '
call psb_barrier(ictxt) call psb_barrier(ictxt)
endif endif
! !
@ -317,8 +320,8 @@ subroutine psi_desc_index(desc,index_in,dep_list,&
goto 9999 goto 9999
end if end if
if (debug) then if (debug_level >= psb_debug_inner_) then
write(0,*) me,'end desc_index' write(debug_unit,*) me,' ',trim(name),': done'
call psb_barrier(ictxt) call psb_barrier(ictxt)
endif endif

11
base/internals/psi_dswapdata.F90
Unescape Escape View File

@ -29,9 +29,9 @@
!!$ !!$
!!$ !!$
! !
! File: psi_Xswapdata.F90 ! File: psi_dswapdata.F90
! !
! Subroutine: psi_Xswapdatam ! Subroutine: psi_dswapdatam
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
@ -68,7 +68,7 @@
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:,:) - X The data area ! y(:,:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
@ -504,9 +504,8 @@ end subroutine psi_dswapdatam
!!$ !!$
!!$ !!$
! !
! File: psi_Xswapdata.F90
! !
! Subroutine: psi_Xswapdatav ! Subroutine: psi_dswapdatav
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
@ -543,7 +542,7 @@ end subroutine psi_dswapdatam
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.

11
base/internals/psi_dswaptran.F90
Unescape Escape View File

@ -29,9 +29,9 @@
!!$ !!$
!!$ !!$
! !
! File: psi_Xswaptran.F90 ! File: psi_dswaptran.F90
! !
! Subroutine: psi_Xswaptranm ! Subroutine: psi_dswaptranm
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -72,7 +72,7 @@
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:,:) - X The data area ! y(:,:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
@ -498,9 +498,8 @@ end subroutine psi_dswaptranm
!!$ !!$
!!$ !!$
! !
! File: psi_Xswaptran.F90
! !
! Subroutine: psi_Xswaptranv ! Subroutine: psi_dswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -541,7 +540,7 @@ end subroutine psi_dswaptranm
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.

31
base/internals/psi_extrct_dl.F90
Unescape Escape View File

@ -141,11 +141,13 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
! .....local scalars... ! .....local scalars...
integer i,me,nprow,pointer_dep_list,proc,j,err_act integer i,me,nprow,pointer_dep_list,proc,j,err_act
integer ictxt, err, icomm integer ictxt, err, icomm
logical, parameter :: debug=.false. integer :: debug_level, debug_unit
character name*20 character name*20
name='psi_extrct_dl' name='psi_extrct_dl'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = 0 info = 0
ictxt = desc_data(psb_ctxt_) ictxt = desc_data(psb_ctxt_)
@ -156,11 +158,13 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
length_dl(i) = 0 length_dl(i) = 0
enddo enddo
i=1 i=1
if (debug) write(0,*) 'extract: info ',info,desc_data(psb_dec_type_) if (debug_level >= psb_debug_inner_)&
& write(debug_unit,*) me,' ',trim(name),': start ',info,desc_data(psb_dec_type_)
pointer_dep_list=1 pointer_dep_list=1
if (psb_is_bld_dec(desc_data(psb_dec_type_))) then if (psb_is_bld_dec(desc_data(psb_dec_type_))) then
do while (desc_str(i) /= -1) do while (desc_str(i) /= -1)
if (debug) write(0,*) me,' extract: looping ',i,& if (debug_level >= psb_debug_inner_)&
& write(debug_unit,*) me,' ',trim(name),' : looping ',i,&
& desc_str(i),desc_str(i+1),desc_str(i+2) & desc_str(i),desc_str(i+1),desc_str(i+2)
! ...with different decomposition type we have different ! ...with different decomposition type we have different
@ -169,7 +173,8 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
! ..if number of element to be exchanged !=0 ! ..if number of element to be exchanged !=0
proc=desc_str(i) proc=desc_str(i)
if ((proc < 0).or.(proc.ge.nprow)) then if ((proc < 0).or.(proc.ge.nprow)) then
if (debug) write(0,*) 'extract error ',i,desc_str(i) if (debug_level >= psb_debug_inner_)&
& write(debug_unit,*) me,' ',trim(name),': error ',i,desc_str(i)
info = 9999 info = 9999
int_err(1) = i int_err(1) = i
int_err(2) = desc_str(i) int_err(2) = desc_str(i)
@ -203,7 +208,8 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
enddo enddo
else if (psb_is_upd_dec(desc_data(psb_dec_type_))) then else if (psb_is_upd_dec(desc_data(psb_dec_type_))) then
do while (desc_str(i) /= -1) do while (desc_str(i) /= -1)
if (debug) write(0,*) 'extract: looping ',i,desc_str(i) if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),': looping ',i,desc_str(i)
! ...with different decomposition type we have different ! ...with different decomposition type we have different
! structure of indices lists............................ ! structure of indices lists............................
@ -240,7 +246,6 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
i=i+desc_str(i+1)+2 i=i+desc_str(i+1)+2
enddo enddo
else else
write(0,*) 'invalid dec_type',desc_data(psb_dec_type_)
info = 2020 info = 2020
goto 9999 goto 9999
endif endif
@ -249,7 +254,8 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
! ... check for errors... ! ... check for errors...
998 continue 998 continue
if (debug) write(0,*) 'extract: info ',info if (debug_level >= psb_debug_inner_)&
& write(debug_unit,*) me,' ',trim(name),': info ',info
err = info err = info
if (err /= 0) goto 9999 if (err /= 0) goto 9999
@ -257,11 +263,18 @@ subroutine psi_extract_dep_list(desc_data,desc_str,dep_list,&
call psb_sum(ictxt,length_dl(0:np)) call psb_sum(ictxt,length_dl(0:np))
call psb_get_mpicomm(ictxt,icomm ) call psb_get_mpicomm(ictxt,icomm )
allocate(itmp(dl_lda),stat=info) allocate(itmp(dl_lda),stat=info)
if (info /= 0) goto 9999 if (info /= 0) then
info=4000
goto 9999
endif
itmp(1:dl_lda) = dep_list(1:dl_lda,me) itmp(1:dl_lda) = dep_list(1:dl_lda,me)
call mpi_allgather(itmp,dl_lda,mpi_integer,& call mpi_allgather(itmp,dl_lda,mpi_integer,&
& dep_list,dl_lda,mpi_integer,icomm,info) & dep_list,dl_lda,mpi_integer,icomm,info)
deallocate(itmp) deallocate(itmp,stat=info)
if (info /= 0) then
info=4000
goto 9999
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

21
base/internals/psi_fnd_owner.f90
Unescape Escape View File

@ -40,7 +40,7 @@
! idx(:) - integer Required indices on the calling process ! idx(:) - integer Required indices on the calling process
! iprc(:) - integer, allocatable Output: process identifiers for the corresponding ! iprc(:) - integer, allocatable Output: process identifiers for the corresponding
! indices ! indices
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! !
subroutine psi_fnd_owner(nv,idx,iprc,desc,info) subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
@ -64,7 +64,6 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
integer :: i,n_row,n_col, err_act,ih,icomm,hsize integer :: i,n_row,n_col, err_act,ih,icomm,hsize
integer :: ictxt,np,me integer :: ictxt,np,me
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name character(len=20) :: name
info = 0 info = 0
@ -92,20 +91,13 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
endif endif
if (.not.(psb_is_ok_desc(desc))) then if (.not.(psb_is_ok_desc(desc))) then
write(0,*) 'Invalid input descriptor in psi_fnd_owner' call psb_errpush(4010,name,a_err='invalid desc')
goto 9999
end if end if
! !
! The basic idea is very simple. ! The basic idea is very simple.
! First we figure out the total number of requests. ! First we figure out the total number of requests.
! Second we build the aggregate list of requests (with psb_amx)
! Third, we figure out locally whether we own the indices (whoever is
! asking for them) and build our part of the reply (we shift process
! indices so that they're 1-based)
! Fourth, we do a psb_amx on the replies so that we have everybody's answers
! Fifth, we extract the answers for our local query, and shift back the
! process indices to 0-based.
Allocate(hidx(np+1),hsz(np),stat=info) Allocate(hidx(np+1),hsz(np),stat=info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate') call psb_errpush(4010,name,a_err='Allocate')
@ -124,12 +116,16 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
call psb_errpush(4010,name,a_err='Allocate') call psb_errpush(4010,name,a_err='Allocate')
goto 9999 goto 9999
end if end if
! Second we build the aggregate list of requests (with psb_amx)
helem(:) = 0 helem(:) = 0
ih = hidx(me+1) ih = hidx(me+1)
do i=1, hsz(me+1) do i=1, hsz(me+1)
helem(ih+i-1) = idx(i) helem(ih+i-1) = idx(i)
end do end do
call psb_amx(ictxt,helem,info) call psb_amx(ictxt,helem,info)
! Third, we figure out locally whether we own the indices (whoever is
! asking for them) and build our part of the reply (we shift process
! indices so that they're 1-based)
call psi_idx_cnv(hsize,helem,desc,info,owned=.true.) call psi_idx_cnv(hsize,helem,desc,info,owned=.true.)
if (info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psi_idx_cnv') call psb_errpush(4010,name,a_err='psi_idx_cnv')
@ -144,8 +140,11 @@ subroutine psi_fnd_owner(nv,idx,iprc,desc,info)
end if end if
end do end do
! Fourth, we do a psb_amx on the replies so that we have everybody's answers
call psb_amx(ictxt,hproc,info) call psb_amx(ictxt,hproc,info)
! Fifth, we extract the answers for our local query, and shift back the
! process indices to 0-based.
if (nv > 0) then if (nv > 0) then
call psb_realloc(nv,iprc,info) call psb_realloc(nv,iprc,info)
ih = hidx(me+1) ih = hidx(me+1)

10
base/internals/psi_idx_cnv.f90
Unescape Escape View File

@ -38,7 +38,7 @@
! Arguments: ! Arguments:
! nv - integer Number of indices required ! nv - integer Number of indices required
! idxin(:) - integer Required indices, overwritten on output. ! idxin(:) - integer Required indices, overwritten on output.
! desc - type(<psb_desc_type>). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! mask(:) - logical, optional Only do the conversion for specific indices. ! mask(:) - logical, optional Only do the conversion for specific indices.
! owned - logical,optional Restrict to local indices, no halo ! owned - logical,optional Restrict to local indices, no halo
@ -61,7 +61,6 @@ subroutine psi_idx_cnv1(nv,idxin,desc,info,mask,owned)
integer :: np, me integer :: np, me
integer :: nrow,ncol, err_act integer :: nrow,ncol, err_act
integer, allocatable :: idxout(:) integer, allocatable :: idxout(:)
logical, parameter :: debug=.false.
integer, parameter :: relocsz=200 integer, parameter :: relocsz=200
character(len=20) :: name character(len=20) :: name
logical, pointer :: mask_(:) logical, pointer :: mask_(:)
@ -183,7 +182,6 @@ end subroutine psi_idx_cnv1
!!$ !!$
!!$ !!$
! !
! File: psi_idx_cnv.f90
! !
! Subroutine: psi_idx_cnv2 ! Subroutine: psi_idx_cnv2
! Converts a bunch of indices from global to local numbering. ! Converts a bunch of indices from global to local numbering.
@ -193,7 +191,7 @@ end subroutine psi_idx_cnv1
! nv - integer Number of indices required ! nv - integer Number of indices required
! idxin(:) - integer Required indices ! idxin(:) - integer Required indices
! idxout(:) - integer Output values, negative for invalid input. ! idxout(:) - integer Output values, negative for invalid input.
! desc - type(<psb_desc_type>). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! mask(:) - logical, optional Only do the conversion for specific indices. ! mask(:) - logical, optional Only do the conversion for specific indices.
! owned - logical,optional Restrict to local indices, no halo ! owned - logical,optional Restrict to local indices, no halo
@ -215,7 +213,6 @@ subroutine psi_idx_cnv2(nv,idxin,idxout,desc,info,mask,owned)
integer :: i,ictxt,mglob, nglob integer :: i,ictxt,mglob, nglob
integer :: np, me integer :: np, me
integer :: nrow,ncol, ip, err_act,lip integer :: nrow,ncol, ip, err_act,lip
logical, parameter :: debug=.false.
integer, parameter :: relocsz=200 integer, parameter :: relocsz=200
character(len=20) :: name character(len=20) :: name
logical, pointer :: mask_(:) logical, pointer :: mask_(:)
@ -405,7 +402,6 @@ end subroutine psi_idx_cnv2
!!$ !!$
!!$ !!$
! !
! File: psi_idx_cnv.f90
! !
! Subroutine: psi_idx_cnvs ! Subroutine: psi_idx_cnvs
! Converts an index from global to local numbering. ! Converts an index from global to local numbering.
@ -414,7 +410,7 @@ end subroutine psi_idx_cnv2
! Arguments: ! Arguments:
! idxin - integer Required index ! idxin - integer Required index
! idxout - integer Output value, negative for invalid input. ! idxout - integer Output value, negative for invalid input.
! desc - type(<psb_desc_type>). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! mask - logical, optional Only do the conversion if true. ! mask - logical, optional Only do the conversion if true.
! owned - logical,optional Restrict to local indices, no halo ! owned - logical,optional Restrict to local indices, no halo

14
base/internals/psi_idx_ins_cnv.f90
Unescape Escape View File

@ -43,7 +43,7 @@
! nv - integer Number of indices required ! nv - integer Number of indices required
! idxin(:) - integer Required indices, overwritten on output ! idxin(:) - integer Required indices, overwritten on output
! output is negative for masked entries ! output is negative for masked entries
! desc - type(<psb_desc_type>). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! mask(:) - logical, optional Only do the conversion for specific indices. ! mask(:) - logical, optional Only do the conversion for specific indices.
! !
@ -64,7 +64,6 @@ subroutine psi_idx_ins_cnv1(nv,idxin,desc,info,mask)
integer :: np, me integer :: np, me
integer :: nrow,ncol, err_act integer :: nrow,ncol, err_act
integer, allocatable :: idxout(:) integer, allocatable :: idxout(:)
logical, parameter :: debug=.false.
integer, parameter :: relocsz=200 integer, parameter :: relocsz=200
character(len=20) :: name character(len=20) :: name
logical, pointer :: mask_(:) logical, pointer :: mask_(:)
@ -179,7 +178,6 @@ end subroutine psi_idx_ins_cnv1
!!$ !!$
!!$ !!$
! !
! File: psi_idx_ins_cnv.f90
! !
! Subroutine: psi_idx_ins_cnv2 ! Subroutine: psi_idx_ins_cnv2
! Converts a bunch of indices from global to local numbering. ! Converts a bunch of indices from global to local numbering.
@ -193,7 +191,7 @@ end subroutine psi_idx_ins_cnv1
! nv - integer Number of indices required ! nv - integer Number of indices required
! idxin(:) - integer Required indices ! idxin(:) - integer Required indices
! idxout(:) - integer Output values (negative for masked entries) ! idxout(:) - integer Output values (negative for masked entries)
! desc - type(<psb_desc_type>). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! mask(:) - logical, optional Only do the conversion for specific indices. ! mask(:) - logical, optional Only do the conversion for specific indices.
! !
@ -214,7 +212,6 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
integer :: i,ictxt,k,mglob, nglob integer :: i,ictxt,k,mglob, nglob
integer :: np, me, isize integer :: np, me, isize
integer :: pnt_halo,nrow,ncol, nh, ip, err_act,lip,nxt integer :: pnt_halo,nrow,ncol, nh, ip, err_act,lip,nxt
logical, parameter :: debug=.false.
integer, parameter :: relocsz=200 integer, parameter :: relocsz=200
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
logical, pointer :: mask_(:) logical, pointer :: mask_(:)
@ -293,7 +290,6 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
if (ncol > isize) then if (ncol > isize) then
nh = ncol + max(nv,relocsz) nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%loc_to_glob,info,pad=-1) call psb_realloc(nh,desc%loc_to_glob,info,pad=-1)
if (debug) write(0,*) 'done realloc ',nh
if (info /= 0) then if (info /= 0) then
info=1 info=1
ch_err='psb_realloc' ch_err='psb_realloc'
@ -346,9 +342,6 @@ subroutine psi_idx_ins_cnv2(nv,idxin,idxout,desc,info,mask)
if (ncol > isize) then if (ncol > isize) then
nh = ncol + max(nv,relocsz) nh = ncol + max(nv,relocsz)
call psb_realloc(nh,desc%loc_to_glob,info,pad=-1) call psb_realloc(nh,desc%loc_to_glob,info,pad=-1)
if (me==0) then
if (debug) write(0,*) 'done realloc ',nh
end if
if (info /= 0) then if (info /= 0) then
info=3 info=3
ch_err='psb_realloc' ch_err='psb_realloc'
@ -437,7 +430,6 @@ end subroutine psi_idx_ins_cnv2
!!$ !!$
!!$ !!$
! !
! File: psi_idx_ins_cnv.f90
! !
! Subroutine: psi_idx_ins_cnvs ! Subroutine: psi_idx_ins_cnvs
! Converts an index from global to local numbering. ! Converts an index from global to local numbering.
@ -450,7 +442,7 @@ end subroutine psi_idx_ins_cnv2
! Arguments: ! Arguments:
! idxin - integer Required index s ! idxin - integer Required index s
! idxout - integer Output value (negative for masked entries) ! idxout - integer Output value (negative for masked entries)
! desc - type(<psb_desc_type>). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! info - integer. return code. ! info - integer. return code.
! mask - logical, optional Only do the conversion for specific indices. ! mask - logical, optional Only do the conversion for specific indices.
! !

11
base/internals/psi_iswapdata.F90
Unescape Escape View File

@ -29,9 +29,9 @@
!!$ !!$
!!$ !!$
! !
! File: psi_Xswapdata.F90 ! File: psi_iswapdata.F90
! !
! Subroutine: psi_Xswapdatam ! Subroutine: psi_iswapdatam
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
@ -68,7 +68,7 @@
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:,:) - X The data area ! y(:,:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
@ -503,9 +503,8 @@ end subroutine psi_iswapdatam
!!$ !!$
!!$ !!$
! !
! File: psi_Xswapdata.F90
! !
! Subroutine: psi_Xswapdatav ! Subroutine: psi_iswapdatav
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
@ -542,7 +541,7 @@ end subroutine psi_iswapdatam
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.

11
base/internals/psi_iswaptran.F90
Unescape Escape View File

@ -29,9 +29,9 @@
!!$ !!$
!!$ !!$
! !
! File: psi_Xswaptran.F90 ! File: psi_iswaptran.F90
! !
! Subroutine: psi_Xswaptranm ! Subroutine: psi_iswaptranm
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -72,7 +72,7 @@
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:,:) - X The data area ! y(:,:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
@ -497,9 +497,8 @@ end subroutine psi_iswaptranm
!!$ !!$
!!$ !!$
! !
! File: psi_Xswaptran.F90
! !
! Subroutine: psi_Xswaptranv ! Subroutine: psi_iswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -540,7 +539,7 @@ end subroutine psi_iswaptranm
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.

3
base/internals/psi_ldsc_pre_halo.f90
Unescape Escape View File

@ -43,7 +43,7 @@
! !
! !
! Arguments: ! Arguments:
! desc - type(<psb_desc_type>). The communication descriptor. ! desc - type(psb_desc_type). The communication descriptor.
! ext_hv - logical Should we work on the halo_index. ! ext_hv - logical Should we work on the halo_index.
! info - integer. return code. ! info - integer. return code.
! !
@ -66,7 +66,6 @@ subroutine psi_ldsc_pre_halo(desc,ext_hv,info)
integer :: i,j,np,me,lhalo,nhalo,& integer :: i,j,np,me,lhalo,nhalo,&
& n_col, err_act, key, ih, nh, idx, nk,icomm & n_col, err_act, key, ih, nh, idx, nk,icomm
integer :: ictxt,n_row integer :: ictxt,n_row
logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
info = 0 info = 0

14
base/internals/psi_sort_dl.f90
Unescape Escape View File

@ -41,20 +41,23 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info)
integer :: np,dep_list(:,:), l_dep_list(:) integer :: np,dep_list(:,:), l_dep_list(:)
integer :: idg, iupd, idgp, iedges, iidx, iich,ndgmx, isz, err_act integer :: idg, iupd, idgp, iedges, iidx, iich,ndgmx, isz, err_act
integer :: i, info integer :: i, info
integer, allocatable :: work(:) integer, allocatable :: work(:)
logical, parameter :: debug=.false. integer :: debug_level, debug_unit
character(len=20) :: name character(len=20) :: name
name='psi_sort_dl' name='psi_sort_dl'
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
info = 0 info = 0
ndgmx = 0 ndgmx = 0
do i=1,np do i=1,np
ndgmx = ndgmx + l_dep_list(i) ndgmx = ndgmx + l_dep_list(i)
if (debug) write(0,*) i,l_dep_list(i) if (debug_level >= psb_debug_inner_)&
& write(debug_unit,*) name,': ',i,l_dep_list(i)
enddo enddo
idg = 1 idg = 1
iupd = idg+np iupd = idg+np
@ -63,7 +66,8 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info)
iidx = iedges + 2*ndgmx iidx = iedges + 2*ndgmx
iich = iidx + ndgmx iich = iidx + ndgmx
isz = iich + ndgmx isz = iich + ndgmx
if (debug)write(0,*) 'psi_sort_dl: ndgmx ',ndgmx,isz if (debug_level >= psb_debug_inner_)&
& write(debug_unit,*) name,': ndgmx ',ndgmx,isz
allocate(work(isz)) allocate(work(isz))
! call srtlist(dep_list, dl_lda, l_dep_list, np, info) ! call srtlist(dep_list, dl_lda, l_dep_list, np, info)

11
base/internals/psi_zswapdata.F90
Unescape Escape View File

@ -29,9 +29,9 @@
!!$ !!$
!!$ !!$
! !
! File: psi_Xswapdata.F90 ! File: psi_zswapdata.F90
! !
! Subroutine: psi_Xswapdatam ! Subroutine: psi_zswapdatam
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
@ -68,7 +68,7 @@
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:,:) - X The data area ! y(:,:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
@ -503,9 +503,8 @@ end subroutine psi_zswapdatam
!!$ !!$
!!$ !!$
! !
! File: psi_Xswapdata.F90
! !
! Subroutine: psi_Xswapdatav ! Subroutine: psi_zswapdatav
! Does the data exchange among processes. Essentially this is doing ! Does the data exchange among processes. Essentially this is doing
! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but ! a variable all-to-all data exchange (ALLTOALLV in MPI parlance), but
! it is capable of pruning empty exchanges, which are very likely in out ! it is capable of pruning empty exchanges, which are very likely in out
@ -542,7 +541,7 @@ end subroutine psi_zswapdatam
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.

11
base/internals/psi_zswaptran.F90
Unescape Escape View File

@ -29,9 +29,9 @@
!!$ !!$
!!$ !!$
! !
! File: psi_Xswaptran.F90 ! File: psi_zswaptran.F90
! !
! Subroutine: psi_Xswaptranm ! Subroutine: psi_zswaptranm
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -72,7 +72,7 @@
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:,:) - X The data area ! y(:,:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.
@ -498,9 +498,8 @@ end subroutine psi_zswaptranm
!!$ !!$
!!$ !!$
! !
! File: psi_Xswaptran.F90
! !
! Subroutine: psi_Xswaptranv ! Subroutine: psi_zswaptranv
! Does the data exchange among processes. This is similar to Xswapdata, but ! Does the data exchange among processes. This is similar to Xswapdata, but
! the list is read "in reverse", i.e. indices that are normally SENT are used ! the list is read "in reverse", i.e. indices that are normally SENT are used
! for the RECEIVE part and vice-versa. This is the basic data exchange operation ! for the RECEIVE part and vice-versa. This is the basic data exchange operation
@ -541,7 +540,7 @@ end subroutine psi_zswaptranm
! n - integer Number of columns in Y ! n - integer Number of columns in Y
! beta - X Choose overwrite or sum. ! beta - X Choose overwrite or sum.
! y(:) - X The data area ! y(:) - X The data area
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! work(:) - X Buffer space. If not sufficient, will do ! work(:) - X Buffer space. If not sufficient, will do
! our own internal allocation. ! our own internal allocation.
! info - integer. return code. ! info - integer. return code.

62
base/modules/psb_desc_type.f90
Unescape Escape View File

@ -29,12 +29,10 @@
!!$ !!$
!!$ !!$
! !
! Module to define desc_a,
! structure for coomunications.
! !
! Typedef: psb_desc_type ! package: psb_descriptor_type
! Defines a communication descriptor ! Defines a communication descriptor
!
module psb_descriptor_type module psb_descriptor_type
use psb_const_mod use psb_const_mod
@ -98,7 +96,23 @@ module psb_descriptor_type
! !
! DESC data structure. ! type: psb_desc_type
!
! Communication Descriptor data structure.
!| type psb_desc_type
!| integer, allocatable :: matrix_data(:)
!| integer, allocatable :: halo_index(:), ext_index(:)
!| integer, allocatable :: bnd_elem(:)
!| integer, allocatable :: ovrlap_index(:)
!| integer, allocatable :: ovrlap_elem(:)
!| integer, allocatable :: loc_to_glob(:)
!| integer, allocatable :: glob_to_loc (:)
!| integer, allocatable :: hashv(:), glb_lc(:,:), ptree(:)
!| integer, allocatable :: lprm(:)
!| integer, allocatable :: idx_space(:)
!| end type psb_desc_type
!
!
! This is the most important data structure: it holds all the data ! This is the most important data structure: it holds all the data
! necessary to organize data exchange. The pattern of communication ! necessary to organize data exchange. The pattern of communication
! among processes depends not only on the allocation of portions of ! among processes depends not only on the allocation of portions of
@ -174,22 +188,22 @@ module psb_descriptor_type
! risk a deadlock. NOTE: This is the format when the state is PSB_ASB_. ! risk a deadlock. NOTE: This is the format when the state is PSB_ASB_.
! See below for BLD. The end-of-list is marked with a -1. ! See below for BLD. The end-of-list is marked with a -1.
! !
! notation stored in explanation !| notation stored in explanation
! --------------- --------------------------- ----------------------------------- !| --------------- --------------------------- -----------------------------------
! process_id index_v(p+proc_id_) identifier of process with which !| process_id index_v(p+proc_id_) identifier of process with which
! data is exchanged. !| data is exchanged.
! n_elements_recv index_v(p+n_elem_recv_) number of elements to receive. !| n_elements_recv index_v(p+n_elem_recv_) number of elements to receive.
! elements_recv index_v(p+elem_recv_+i) indexes of local elements to !| elements_recv index_v(p+elem_recv_+i) indexes of local elements to
! receive. these are stored in the !| receive. these are stored in the
! array from location p+elem_recv_ to !| array from location p+elem_recv_ to
! location p+elem_recv_+ !| location p+elem_recv_+
! index_v(p+n_elem_recv_)-1. !| index_v(p+n_elem_recv_)-1.
! n_elements_send index_v(p+n_elem_send_) number of elements to send. !| n_elements_send index_v(p+n_elem_send_) number of elements to send.
! elements_send index_v(p+elem_send_+i) indexes of local elements to !| elements_send index_v(p+elem_send_+i) indexes of local elements to
! send. these are stored in the !| send. these are stored in the
! array from location p+elem_send_ to !| array from location p+elem_send_ to
! location p+elem_send_+ !| location p+elem_send_+
! index_v(p+n_elem_send_)-1. !| index_v(p+n_elem_send_)-1.
! !
! This organization is valid for both halo and overlap indices; overlap entries ! This organization is valid for both halo and overlap indices; overlap entries
! need to be updated to ensure that a variable at a given global index ! need to be updated to ensure that a variable at a given global index
@ -234,9 +248,7 @@ module psb_descriptor_type
! !
! 10. ovrlap_elem contains a list of overlap indices together with their degree ! 10. ovrlap_elem contains a list of overlap indices together with their degree
! of overlap, i.e. the number of processes "owning" them. ! of overlap, i.e. the number of processes "owning" them.
! ! It is complex, but it does the following:
!
! Yes, it is complex, but it does the following:
! 1. Allows a purely local matrix/stencil buildup phase, requiring only ! 1. Allows a purely local matrix/stencil buildup phase, requiring only
! one synch point at the end (CDASB) ! one synch point at the end (CDASB)
! 2. Takes shortcuts when the problem size is not too large (the default threshold ! 2. Takes shortcuts when the problem size is not too large (the default threshold
@ -248,7 +260,6 @@ module psb_descriptor_type
! !
! !
! !
type psb_desc_type type psb_desc_type
integer, allocatable :: matrix_data(:) integer, allocatable :: matrix_data(:)
integer, allocatable :: halo_index(:), ext_index(:) integer, allocatable :: halo_index(:), ext_index(:)
@ -278,7 +289,6 @@ contains
Type(psb_desc_type), intent(in) :: desc Type(psb_desc_type), intent(in) :: desc
Integer :: psb_cd_sizeof Integer :: psb_cd_sizeof
!locals !locals
logical, parameter :: debug=.false.
integer :: val integer :: val
integer, external :: SizeofPairSearchTree integer, external :: SizeofPairSearchTree

87
base/modules/psb_error_mod.F90
Unescape Escape View File

@ -31,13 +31,19 @@
module psb_error_mod module psb_error_mod
integer, parameter, public :: psb_act_ret_=0, psb_act_abort_=1, psb_no_err_=0 integer, parameter, public :: psb_act_ret_=0, psb_act_abort_=1, psb_no_err_=0
integer, parameter, public :: psb_debug_ext_=1, psb_debug_outer_=2
integer, parameter, public :: psb_debug_comp_=3, psb_debug_inner_=4
integer, parameter, public :: psb_debug_serial_=8, psb_debug_serial_comp_=9
! !
! Error handling ! Error handling
! !
public psb_errpush, psb_error, psb_get_errstatus,& public psb_errpush, psb_error, psb_get_errstatus,&
& psb_get_errverbosity, psb_set_errverbosity,psb_errcomm, & & psb_get_errverbosity, psb_set_errverbosity,psb_errcomm, &
& psb_erractionsave, psb_erractionrestore, & & psb_erractionsave, psb_erractionrestore, &
& psb_get_erraction, psb_set_erraction & psb_get_erraction, psb_set_erraction, &
& psb_get_debug_level, psb_set_debug_level,&
& psb_get_debug_unit, psb_set_debug_unit,&
& psb_get_serial_debug_level, psb_set_serial_debug_level
interface psb_error interface psb_error
module procedure psb_serror module procedure psb_serror
@ -49,29 +55,37 @@ module psb_error_mod
type psb_errstack_node type psb_errstack_node
integer :: err_code=0 ! the error code ! the error code
character(len=20) :: routine='' ! the name of the routine generating the error integer :: err_code=0
integer,dimension(5) :: i_err_data=0 ! array of integer data to complete the error msg ! the name of the routine generating the error
character(len=20) :: routine=''
! array of integer data to complete the error msg
integer,dimension(5) :: i_err_data=0
! real(kind(1.d0))(dim=10) :: r_err_data=0.d0 ! array of real data to complete the error msg ! real(kind(1.d0))(dim=10) :: r_err_data=0.d0 ! array of real data to complete the error msg
! complex(dim=10) :: c_err_data=0.c0 ! array of complex data to complete the error msg ! complex(dim=10) :: c_err_data=0.c0 ! array of complex data to complete the error msg
character(len=40) :: a_err_data='' ! array of character data to complete the error msg ! array of character data to complete the error msg
type(psb_errstack_node), pointer :: next ! pointer to the next element in the stack character(len=40) :: a_err_data=''
! pointer to the next element in the stack
type(psb_errstack_node), pointer :: next
end type psb_errstack_node end type psb_errstack_node
type psb_errstack type psb_errstack
type(psb_errstack_node), pointer :: top => null() ! pointer to the top element of the stack ! pointer to the top element of the stack
integer :: n_elems=0 ! number of entries in the stack type(psb_errstack_node), pointer :: top => null()
! number of entries in the stack
integer :: n_elems=0
end type psb_errstack end type psb_errstack
type(psb_errstack),save :: error_stack ! the PSBLAS-2.0 error stack type(psb_errstack), save :: error_stack ! the PSBLAS-2.0 error stack
integer,save :: error_status=0 ! the error status (maybe not here) integer, save :: error_status=0 ! the error status (maybe not here)
integer,save :: verbosity_level=1 ! the verbosity level (maybe not here) integer, save :: verbosity_level=1 ! the verbosity level (maybe not here)
integer,save :: err_action=1 integer, save :: err_action=1
integer, save :: debug_level=0, debug_unit=0, serial_debug_level=0
contains contains
@ -105,6 +119,49 @@ contains
end subroutine psb_erractionrestore end subroutine psb_erractionrestore
function psb_get_debug_level()
integer :: psb_get_debug_level
psb_get_debug_level = debug_level
end function psb_get_debug_level
subroutine psb_set_debug_level(level)
integer, intent(in) :: level
if (level >= 0) then
debug_level = level
else
debug_level = 0
end if
end subroutine psb_set_debug_level
function psb_get_debug_unit()
integer :: psb_get_debug_unit
psb_get_debug_unit = debug_unit
end function psb_get_debug_unit
subroutine psb_set_debug_unit(unit)
integer, intent(in) :: unit
if (unit >= 0) then
debug_unit = unit
else
debug_unit = 0
end if
end subroutine psb_set_debug_unit
function psb_get_serial_debug_level()
integer :: psb_get_serial_debug_level
psb_get_serial_debug_level = serial_debug_level
end function psb_get_serial_debug_level
subroutine psb_set_serial_debug_level(level)
integer, intent(in) :: level
if (level >= 0) then
serial_debug_level = level
else
serial_debug_level = 0
end if
end subroutine psb_set_serial_debug_level
! checks wether an error has occurred on one of the porecesses in the execution pool ! checks wether an error has occurred on one of the porecesses in the execution pool
subroutine psb_errcomm(ictxt, err) subroutine psb_errcomm(ictxt, err)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
@ -452,10 +509,16 @@ contains
write (0,'("local index is: ",i0," and global index is:",i0)')i_e_d(1:2) write (0,'("local index is: ",i0," and global index is:",i0)')i_e_d(1:2)
case(3110) case(3110)
write (0,'("Before you call this routine, you must assembly sparse matrix")') write (0,'("Before you call this routine, you must assembly sparse matrix")')
case(3111)
write (0,'("Before you call this routine, you must initialize the preconditioner")')
case(3112)
write (0,'("Before you call this routine, you must build the preconditioner")')
case(3111:3999) case(3111:3999)
write(0,'("miscellaneus error. code: ",i0)')err_c write(0,'("miscellaneus error. code: ",i0)')err_c
case(4000) case(4000)
write(0,'("Allocation/deallocation error")') write(0,'("Allocation/deallocation error")')
case(4001)
write(0,'("Internal error: ",a)')a_e_d
case(4010) case(4010)
write (0,'("Error from call to subroutine ",a)')a_e_d write (0,'("Error from call to subroutine ",a)')a_e_d
case(4011) case(4011)

35
base/modules/psb_penv_mod.F90
Unescape Escape View File

@ -72,7 +72,7 @@ module psb_penv_mod
module procedure psb_ibcasts, psb_ibcastv, psb_ibcastm,& module procedure psb_ibcasts, psb_ibcastv, psb_ibcastm,&
& psb_dbcasts, psb_dbcastv, psb_dbcastm,& & psb_dbcasts, psb_dbcastv, psb_dbcastm,&
& psb_zbcasts, psb_zbcastv, psb_zbcastm,& & psb_zbcasts, psb_zbcastv, psb_zbcastm,&
& psb_hbcasts, psb_lbcasts, psb_lbcastv, psb_hbcastv1 & psb_hbcasts, psb_lbcasts, psb_lbcastv
end interface end interface
@ -546,39 +546,6 @@ contains
end subroutine psb_hbcasts end subroutine psb_hbcasts
subroutine psb_hbcastv1(ictxt,dat,root,length)
#ifdef MPI_H
include 'mpif.h'
#endif
#ifdef MPI_MOD
use mpi
#endif
integer, intent(in) :: ictxt
character(len=1), intent(inout) :: dat(:)
integer, intent(in), optional :: root,length
integer :: iam, np, root_,icomm,length_,info
#if !defined(SERIAL_MPI)
if (present(root)) then
root_ = root
else
root_ = psb_root_
endif
if (present(length)) then
length_ = length
else
length_ = size(dat)
endif
call psb_info(ictxt,iam,np)
call psb_get_mpicomm(ictxt,icomm)
call mpi_bcast(dat,length_,MPI_CHARACTER,root_,icomm,info)
#endif
end subroutine psb_hbcastv1
subroutine psb_lbcasts(ictxt,dat,root) subroutine psb_lbcasts(ictxt,dat,root)
#ifdef MPI_H #ifdef MPI_H
include 'mpif.h' include 'mpif.h'

102
base/modules/psb_spmat_type.f90
Unescape Escape View File

@ -28,18 +28,16 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ POSSIBILITY OF SUCH DAMAGE.
!!$ !!$
!!$ !!$
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !
!! Module to define D_SPMAT, structure !! ! package: psb_spmat_type
!! for sparse matrix. !! ! Data structure(s) for sparse matrices
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !
module psb_spmat_type module psb_spmat_type
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_const_mod use psb_const_mod
implicit none implicit none
! Typedef: psb_dspmat_type !
! Contains a sparse matrix
! !
! Queries into spmat%info ! Queries into spmat%info
! !
@ -55,22 +53,40 @@ module psb_spmat_type
integer, parameter :: psb_dupl_=11, psb_upd_=12 integer, parameter :: psb_dupl_=11, psb_upd_=12
integer, parameter :: psb_ifasize_=16 integer, parameter :: psb_ifasize_=16
! !
! Types: psb_dspmat_type, psb_zspmat_type
! !
! Possible matrix states. !| type psb_dspmat_type
!| integer :: m, k ! Row & column size
!| character(len=5) :: fida ! Storage format: CSR,COO etc.
!| character(len=11) :: descra ! Matrix type: encodes general, triang.
!| integer :: infoa(psb_ifasize_) ! Additional integer info
!| real(kind(1.d0)), allocatable :: aspk(:) ! Coefficients
!| integer, allocatable :: ia1(:), ia2(:) ! Row/column indices encoded
!| integer, allocatable :: pl(:), pr(:) ! Row/column permutation
!| end type psb_dspmat_type
!| type psb_zspmat_type
!| integer :: m, k
!| character(len=5) :: fida
!| character(len=11) :: descra
!| integer :: infoa(psb_ifasize_)
!| complex(kind(1.d0)), allocatable :: aspk(:)
!| integer, allocatable :: ia1(:), ia2(:)
!| integer, allocatable :: pl(:), pr(:)
!| end type psb_zspmat_type
! !
! A sparse matrix can move between states according to the ! A sparse matrix can move between states according to the
! following state transition table. ! following state transition table.
! In Out Routine !| In Out Routine
! ---------------------------------- !| ----------------------------------
! Null Build psb_sp_all !| Null Build psb_sp_all
! Build Build psb_coins !| Build Build psb_coins
! Build Assembled psb_spcnv !| Build Assembled psb_spcnv
! Assembled Assembled psb_spcnv !| Assembled Assembled psb_spcnv
! Assembled Update psb_sp_reinit !| Assembled Update psb_sp_reinit
! Update Update psb_coins !| Update Update psb_coins
! Update Assembled psb_spcnv !| Update Assembled psb_spcnv
! * unchanged psb_sp_reall !| * unchanged psb_sp_reall
! Assembled Null psb_sp_free !| Assembled Null psb_sp_free
! !
! Note that psb_spcnv is overloaded in two flavours, ! Note that psb_spcnv is overloaded in two flavours,
! psb_spcnv(a,info) ! psb_spcnv(a,info)
@ -105,35 +121,21 @@ module psb_spmat_type
type psb_dspmat_type type psb_dspmat_type
! Rows & columns
integer :: m, k integer :: m, k
! Identify the representation method. Es: CSR, JAD, ...
character(len=5) :: fida character(len=5) :: fida
! describe some chacteristics of sparse matrix
character(len=11) :: descra character(len=11) :: descra
! Contains some additional informations on sparse matrix
integer :: infoa(psb_ifasize_) integer :: infoa(psb_ifasize_)
! Contains sparse matrix coefficients
real(kind(1.d0)), allocatable :: aspk(:) real(kind(1.d0)), allocatable :: aspk(:)
! Contains indeces that describes sparse matrix structure
integer, allocatable :: ia1(:), ia2(:) integer, allocatable :: ia1(:), ia2(:)
! Permutations matrix
integer, allocatable :: pl(:), pr(:) integer, allocatable :: pl(:), pr(:)
end type psb_dspmat_type end type psb_dspmat_type
type psb_zspmat_type type psb_zspmat_type
! Rows & columns
integer :: m, k integer :: m, k
! Identify the representation method. Es: CSR, JAD, ...
character(len=5) :: fida character(len=5) :: fida
! describe some chacteristics of sparse matrix
character(len=11) :: descra character(len=11) :: descra
! Contains some additional informations on sparse matrix
integer :: infoa(psb_ifasize_) integer :: infoa(psb_ifasize_)
! Contains sparse matrix coefficients
complex(kind(1.d0)), allocatable :: aspk(:) complex(kind(1.d0)), allocatable :: aspk(:)
! Contains indeces that describes sparse matrix structure
integer, allocatable :: ia1(:), ia2(:) integer, allocatable :: ia1(:), ia2(:)
! Permutations matrix
integer, allocatable :: pl(:), pr(:) integer, allocatable :: pl(:), pr(:)
end type psb_zspmat_type end type psb_zspmat_type
@ -637,9 +639,6 @@ contains
Type(psb_dspmat_type), intent(inout) :: B Type(psb_dspmat_type), intent(inout) :: B
Integer, intent(out) :: info Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
info = 0 info = 0
@ -669,11 +668,8 @@ contains
Integer, intent(in) :: field,val Integer, intent(in) :: field,val
Integer, intent(out) :: info Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
info = 0 info = 0
!!$ call psb_realloc(psb_ifasize_,a%infoa,info)
if (info == 0) & if (info == 0) &
& call psb_setifield(val,field,a%infoa,psb_ifasize_,info) & call psb_setifield(val,field,a%infoa,psb_ifasize_,info)
@ -699,7 +695,6 @@ contains
!locals !locals
Integer :: i1, i2, ia Integer :: i1, i2, ia
logical, parameter :: debug=.false.
info = 0 info = 0
call psb_sp_trimsize(a,i1,i2,ia,info) call psb_sp_trimsize(a,i1,i2,ia,info)
@ -718,7 +713,6 @@ contains
Integer, intent(out) :: info Integer, intent(out) :: info
!locals !locals
Integer :: i1, i2, ia Integer :: i1, i2, ia
logical, parameter :: debug=.false.
info = 0 info = 0
call psb_sp_trimsize(a,i1,i2,ia,info) call psb_sp_trimsize(a,i1,i2,ia,info)
@ -739,7 +733,6 @@ contains
!locals !locals
Integer :: nza Integer :: nza
logical, parameter :: debug=.false.
info = 0 info = 0
if (psb_sp_getifld(psb_upd_,a,info) == psb_upd_perm_) then if (psb_sp_getifld(psb_upd_,a,info) == psb_upd_perm_) then
@ -786,7 +779,6 @@ contains
Integer, intent(out) :: info Integer, intent(out) :: info
!locals !locals
logical, parameter :: debug=.false.
integer :: val integer :: val
info = 0 info = 0
@ -813,7 +805,6 @@ contains
Integer :: psb_dspsizeof Integer :: psb_dspsizeof
!locals !locals
logical, parameter :: debug=.false.
integer :: val integer :: val
val = 4*size(a%infoa) val = 4*size(a%infoa)
@ -848,7 +839,6 @@ contains
Type(psb_dspmat_type), intent(inout) :: A Type(psb_dspmat_type), intent(inout) :: A
Integer, intent(out) :: info Integer, intent(out) :: info
!locals !locals
logical, parameter :: debug=.false.
integer :: iret integer :: iret
info = 0 info = 0
@ -902,7 +892,6 @@ contains
logical, intent(in), optional :: clear logical, intent(in), optional :: clear
!locals !locals
logical, parameter :: debug=.false.
logical :: clear_ logical :: clear_
character(len=20) :: name character(len=20) :: name
@ -1078,8 +1067,6 @@ contains
Integer, intent(in) :: ni1,ni2,nz Integer, intent(in) :: ni1,ni2,nz
Integer, intent(inout) :: info Integer, intent(inout) :: info
!locals
logical, parameter :: debug=.false.
info = 0 info = 0
call psb_realloc(nz,a%aspk,info) call psb_realloc(nz,a%aspk,info)
@ -1113,9 +1100,6 @@ contains
Integer, intent(in), optional :: ifc Integer, intent(in), optional :: ifc
integer :: ifc_ integer :: ifc_
!locals
logical, parameter :: debug=.false.
info = 0 info = 0
if (nnz.lt.0) then if (nnz.lt.0) then
info=45 info=45
@ -1154,10 +1138,6 @@ contains
Type(psb_zspmat_type), intent(out) :: B Type(psb_zspmat_type), intent(out) :: B
Integer, intent(out) :: info Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
INFO = 0 INFO = 0
call psb_nullify_sp(b) call psb_nullify_sp(b)
@ -1191,9 +1171,6 @@ contains
Type(psb_zspmat_type), intent(inout) :: B Type(psb_zspmat_type), intent(inout) :: B
Integer, intent(out) :: info Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
info = 0 info = 0
call psb_transfer( a%aspk, b%aspk , info) call psb_transfer( a%aspk, b%aspk , info)
@ -1221,14 +1198,10 @@ contains
Integer, intent(in) :: field,val Integer, intent(in) :: field,val
Integer, intent(out) :: info Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
info = 0 info = 0
!!$ call psb_realloc(psb_ifasize_,a%infoa,info)
if (info == 0) & if (info == 0) &
& call psb_setifield(val,field,a%infoa,psb_ifasize_,info) & call psb_setifield(val,field,a%infoa,psb_ifasize_,info)
@ -1247,7 +1220,6 @@ contains
!locals !locals
Integer :: nza Integer :: nza
logical, parameter :: debug=.false.
info = 0 info = 0
if (psb_sp_getifld(psb_upd_,a,info) == psb_upd_perm_) then if (psb_sp_getifld(psb_upd_,a,info) == psb_upd_perm_) then
@ -1294,7 +1266,6 @@ contains
Integer, intent(out) :: info Integer, intent(out) :: info
!locals !locals
logical, parameter :: debug=.false.
integer :: val integer :: val
info = 0 info = 0
@ -1321,7 +1292,6 @@ contains
Integer :: psb_zspsizeof Integer :: psb_zspsizeof
!locals !locals
logical, parameter :: debug=.false.
integer :: val integer :: val
val = 4*size(a%infoa) val = 4*size(a%infoa)
@ -1357,8 +1327,6 @@ contains
!....Parameters... !....Parameters...
Type(psb_zspmat_type), intent(inout) :: A Type(psb_zspmat_type), intent(inout) :: A
Integer, intent(out) :: info Integer, intent(out) :: info
!locals
logical, parameter :: debug=.false.
info = 0 info = 0

21
base/modules/psi_mod.f90
Unescape Escape View File

@ -316,11 +316,14 @@ contains
integer, allocatable :: idx_out(:) integer, allocatable :: idx_out(:)
! ...parameters ! ...parameters
integer :: debug_level, debug_unit
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name character(len=20) :: name
name='psi_bld_cdesc' name='psi_bld_cdesc'
call psb_get_erraction(err_act) call psb_get_erraction(err_act)
debug_level = psb_get_debug_level()
debug_unit = psb_get_debug_unit()
info = 0 info = 0
ictxt = cdesc%matrix_data(psb_ctxt_) ictxt = cdesc%matrix_data(psb_ctxt_)
@ -334,7 +337,7 @@ contains
! first the halo index ! first the halo index
if (debug) write(0,*) me,'Calling crea_index on halo' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on halo'
call psi_crea_index(cdesc,halo_in, idx_out,.false.,nxch,nsnd,nrcv,info) call psi_crea_index(cdesc,halo_in, idx_out,.false.,nxch,nsnd,nrcv,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_crea_index') call psb_errpush(4010,name,a_err='psi_crea_index')
@ -345,12 +348,12 @@ contains
cdesc%matrix_data(psb_thal_snd_) = nsnd cdesc%matrix_data(psb_thal_snd_) = nsnd
cdesc%matrix_data(psb_thal_rcv_) = nrcv cdesc%matrix_data(psb_thal_rcv_) = nrcv
if (debug) write(0,*) me,'Done crea_index on halo' if (debug_level>0) write(debug_unit,*) me,'Done crea_index on halo'
if (debug) write(0,*) me,'Calling crea_index on ext' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext'
! then ext index ! then ext index
if (debug) write(0,*) me,'Calling crea_index on ext' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ext'
call psi_crea_index(cdesc,ext_in, idx_out,.false.,nxch,nsnd,nrcv,info) call psi_crea_index(cdesc,ext_in, idx_out,.false.,nxch,nsnd,nrcv,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_crea_index') call psb_errpush(4010,name,a_err='psi_crea_index')
@ -361,8 +364,8 @@ contains
cdesc%matrix_data(psb_text_snd_) = nsnd cdesc%matrix_data(psb_text_snd_) = nsnd
cdesc%matrix_data(psb_text_rcv_) = nrcv cdesc%matrix_data(psb_text_rcv_) = nrcv
if (debug) write(0,*) me,'Done crea_index on ext' if (debug_level>0) write(debug_unit,*) me,'Done crea_index on ext'
if (debug) write(0,*) me,'Calling crea_index on ovrlap' if (debug_level>0) write(debug_unit,*) me,'Calling crea_index on ovrlap'
! then the overlap index ! then the overlap index
@ -381,10 +384,10 @@ contains
cdesc%matrix_data(psb_tovr_snd_) = nsnd cdesc%matrix_data(psb_tovr_snd_) = nsnd
cdesc%matrix_data(psb_tovr_rcv_) = nrcv cdesc%matrix_data(psb_tovr_rcv_) = nrcv
if (debug) write(0,*) me,'Calling crea_ovr_elem' if (debug_level>0) write(debug_unit,*) me,'Calling crea_ovr_elem'
! next ovrlap_elem ! next ovrlap_elem
call psi_crea_ovr_elem(cdesc%ovrlap_index,cdesc%ovrlap_elem,info) call psi_crea_ovr_elem(cdesc%ovrlap_index,cdesc%ovrlap_elem,info)
if (debug) write(0,*) me,'Done crea_ovr_elem' if (debug_level>0) write(debug_unit,*) me,'Done crea_ovr_elem'
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_crea_ovr_elem') call psb_errpush(4010,name,a_err='psi_crea_ovr_elem')
goto 9999 goto 9999
@ -398,7 +401,7 @@ contains
call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') call psb_errpush(4010,name,a_err='psi_crea_bnd_elem')
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,'Done crea_bnd_elem' if (debug_level>0) write(debug_unit,*) me,'Done crea_bnd_elem'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

8
base/psblas/psb_damax.f90
Unescape Escape View File

@ -39,7 +39,7 @@
! !
! Arguments: ! Arguments:
! x - real,dimension(:,:). The input vector. ! x - real,dimension(:,:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
@ -166,7 +166,7 @@ end function psb_damax
! !
! Arguments: ! Arguments:
! x - real,dimension(:). The input vector. ! x - real,dimension(:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_damaxv (x,desc_a, info) function psb_damaxv (x,desc_a, info)
@ -288,7 +288,7 @@ end function psb_damaxv
! Arguments: ! Arguments:
! res - real. The result. ! res - real. The result.
! x - real,dimension(:,:). The input vector. ! x - real,dimension(:,:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
@ -410,7 +410,7 @@ end subroutine psb_damaxvs
! Arguments: ! Arguments:
! res - real. The result. ! res - real. The result.
! x - real,dimension(:). The input vector. ! x - real,dimension(:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
subroutine psb_dmamaxs (res,x,desc_a, info,jx) subroutine psb_dmamaxs (res,x,desc_a, info,jx)

6
base/psblas/psb_dasum.f90
Unescape Escape View File

@ -39,7 +39,7 @@
! !
! Arguments: ! Arguments:
! x - real,dimension(:,:). The input vector. ! x - real,dimension(:,:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
@ -184,7 +184,7 @@ end function psb_dasum
! !
! Arguments: ! Arguments:
! x - real,dimension(:). The input vector. ! x - real,dimension(:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_dasumv (x,desc_a, info) function psb_dasumv (x,desc_a, info)
@ -322,7 +322,7 @@ end function psb_dasumv
! Arguments: ! Arguments:
! res - real. The result. ! res - real. The result.
! x - real,dimension(:). The input vector. ! x - real,dimension(:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !

5
base/psblas/psb_daxpby.f90
Unescape Escape View File

@ -44,7 +44,7 @@
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! beta - real. The scalar used to multiply each component of sub( Y ). ! beta - real. The scalar used to multiply each component of sub( Y ).
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y - real,dimension(:,:). The input vector containing the entries of sub( Y ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset for sub( X ). ! jx - integer(optional). The column offset for sub( X ).
! jy - integer(optional). The column offset for sub( Y ). ! jy - integer(optional). The column offset for sub( Y ).
@ -199,7 +199,7 @@ end subroutine psb_daxpby
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! beta - real. The scalar used to multiply each component of Y. ! beta - real. The scalar used to multiply each component of Y.
! y - real,dimension(:). The input vector containing the entries of Y. ! y - real,dimension(:). The input vector containing the entries of Y.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info) subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info)
@ -220,7 +220,6 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info)
integer :: ictxt, np, me,& integer :: ictxt, np, me,&
& err_act, iix, jjx, ix, iy, m, iiy, jjy & err_act, iix, jjx, ix, iy, m, iiy, jjy
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='psb_dgeaxpby' name='psb_dgeaxpby'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return

8
base/psblas/psb_ddot.f90
Unescape Escape View File

@ -42,7 +42,7 @@
! Arguments: ! Arguments:
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y - real,dimension(:,:). The input vector containing the entries of sub( Y ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset for sub( X ). ! jx - integer(optional). The column offset for sub( X ).
! jy - integer(optional). The column offset for sub( Y ). ! jy - integer(optional). The column offset for sub( Y ).
@ -199,7 +199,7 @@ end function psb_ddot
! Arguments: ! Arguments:
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! y - real,dimension(:). The input vector containing the entries of Y. ! y - real,dimension(:). The input vector containing the entries of Y.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_ddotv(x, y,desc_a, info) function psb_ddotv(x, y,desc_a, info)
@ -337,7 +337,7 @@ end function psb_ddotv
! res - real. The result. ! res - real. The result.
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! y - real,dimension(:). The input vector containing the entries of Y. ! y - real,dimension(:). The input vector containing the entries of Y.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
subroutine psb_ddotvs(res, x, y,desc_a, info) subroutine psb_ddotvs(res, x, y,desc_a, info)
@ -478,7 +478,7 @@ end subroutine psb_ddotvs
! res - real. The result. ! res - real. The result.
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y - real,dimension(:,:). The input vector containing the entries of sub( Y ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
subroutine psb_dmdots(res, x, y, desc_a, info) subroutine psb_dmdots(res, x, y, desc_a, info)

6
base/psblas/psb_dnrm2.f90
Unescape Escape View File

@ -39,7 +39,7 @@
! !
! Arguments: ! Arguments:
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset for sub( X ). ! jx - integer(optional). The column offset for sub( X ).
! !
@ -178,7 +178,7 @@ end function psb_dnrm2
! !
! Arguments: ! Arguments:
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_dnrm2v(x, desc_a, info) function psb_dnrm2v(x, desc_a, info)
@ -313,7 +313,7 @@ end function psb_dnrm2v
! Arguments: ! Arguments:
! res - real. The result. ! res - real. The result.
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
subroutine psb_dnrm2vs(res, x, desc_a, info) subroutine psb_dnrm2vs(res, x, desc_a, info)

4
base/psblas/psb_dnrmi.f90
Unescape Escape View File

@ -36,8 +36,8 @@
! normi := max(abs(sum(A(i,j)))) ! normi := max(abs(sum(A(i,j))))
! !
! Arguments: ! Arguments:
! a - type(<psb_dspmat_type>). The sparse matrix containing A. ! a - type(psb_dspmat_type). The sparse matrix containing A.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_dnrmi(a,desc_a,info) function psb_dnrmi(a,desc_a,info)

40
base/psblas/psb_dspmm.f90
Unescape Escape View File

@ -64,11 +64,11 @@
! !
! Arguments: ! Arguments:
! alpha - real. The scalar alpha. ! alpha - real. The scalar alpha.
! a - type(<psb_dspmat_type>). The sparse matrix containing A. ! a - type(psb_dspmat_type). The sparse matrix containing A.
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! beta - real. The scalar beta. ! beta - real. The scalar beta.
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y - real,dimension(:,:). The input vector containing the entries of sub( Y ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! trans - character(optional). Whether A or A'. If not present 'N' is assumed. ! trans - character(optional). Whether A or A'. If not present 'N' is assumed.
! k - integer(optional). The number of right-hand sides. ! k - integer(optional). The number of right-hand sides.
@ -404,11 +404,11 @@ end subroutine psb_dspmm
! !
! Arguments: ! Arguments:
! alpha - real. The scalar alpha. ! alpha - real. The scalar alpha.
! a - type(<psb_dspmat_type>). The sparse matrix containing A. ! a - type(psb_dspmat_type). The sparse matrix containing A.
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! beta - real. The scalar beta. ! beta - real. The scalar beta.
! y - real,dimension(:. The input vector containing the entries of Y. ! y - real,dimension(:. The input vector containing the entries of Y.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! trans - character(optional). Whether A or A'. If not present 'N' is assumed. ! trans - character(optional). Whether A or A'. If not present 'N' is assumed.
! work - real,dimension(:)(optional). Working area. ! work - real,dimension(:)(optional). Working area.
@ -449,15 +449,16 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
character :: itrans character :: itrans
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw logical :: aliw
logical, parameter :: debug=.false. integer :: debug_level, debug_unit
name='psb_dspmv' name='psb_dspmv'
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt=psb_cd_get_context(desc_a) ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (np == -1) then if (np == -1) then
info = 2010 info = 2010
@ -509,7 +510,7 @@ subroutine psb_dspmv(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
! write(0,*)'---->>>',work(1)
if (present(work)) then if (present(work)) then
if (size(work) >= liwork) then if (size(work) >= liwork) then
aliw =.false. aliw =.false.
@ -520,7 +521,6 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
aliw=.true. aliw=.true.
end if end if
aliw=.true.
if (aliw) then if (aliw) then
allocate(iwork(liwork),stat=info) allocate(iwork(liwork),stat=info)
if(info /= 0) then if(info /= 0) then
@ -533,7 +533,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
iwork => work iwork => work
endif endif
if (debug) write(0,*) me,name,' Allocated work ', info if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', info
! checking for matrix correctness ! checking for matrix correctness
call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja)
if(info /= 0) then if(info /= 0) then
@ -543,7 +544,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,name,' Checkmat ', info if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Checkmat ', info
if (itrans == 'N') then if (itrans == 'N') then
! Matrix is not transposed ! Matrix is not transposed
if((ja /= ix).or.(ia /= iy)) then if((ja /= ix).or.(ia /= iy)) then
@ -624,10 +626,12 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
yp => y(iiy:lldy) yp => y(iiy:lldy)
yp(nrow+1:ncol)=dzero yp(nrow+1:ncol)=dzero
if (debug) write(0,*) me,name,' checkvect ', info if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' checkvect ', info
! local Matrix-vector product ! local Matrix-vector product
call psb_csmm(alpha,a,xp,beta,yp,info,trans=itrans) call psb_csmm(alpha,a,xp,beta,yp,info,trans=itrans)
if (debug) write(0,*) me,name,' csmm ', info if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' csmm ', info
if(info /= 0) then if(info /= 0) then
info = 4010 info = 4010
ch_err='dcsmm' ch_err='dcsmm'
@ -638,7 +642,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
if(idoswap /= 0)& if(idoswap /= 0)&
& call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
& done,yp,desc_a,iwork,info) & done,yp,desc_a,iwork,info)
if (debug) write(0,*) me,name,' swaptran ', info if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' swaptran ', info
if(info /= 0) then if(info /= 0) then
info = 4010 info = 4010
ch_err='PSI_dSwapTran' ch_err='PSI_dSwapTran'
@ -649,7 +654,8 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
end if end if
if (aliw) deallocate(iwork,stat=info) if (aliw) deallocate(iwork,stat=info)
if (debug) write(0,*) me,name,' deallocat ',aliw, info if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= 0) then if(info /= 0) then
info = 4010 info = 4010
ch_err='Deallocate iwork' ch_err='Deallocate iwork'
@ -660,8 +666,10 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
nullify(iwork) nullify(iwork)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (debug) call psb_barrier(ictxt) if (debug_level >= psb_debug_comp_) then
if (debug) write(0,*) me,name,' Returning ' call psb_barrier(ictxt)
write(debug_unit,*) me,' ',trim(name),' Returning '
endif
return return
9999 continue 9999 continue

8
base/psblas/psb_dspsm.f90
Unescape Escape View File

@ -56,11 +56,11 @@
! !
! Arguments: ! Arguments:
! alpha - real. The scalar alpha. ! alpha - real. The scalar alpha.
! a - type(<psb_dspmat_type>). The sparse matrix containing A. ! a - type(psb_dspmat_type). The sparse matrix containing A.
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! beta - real. The scalar beta. ! beta - real. The scalar beta.
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y - real,dimension(:,:). The input vector containing the entries of sub( Y ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! trans - character(optional). Whether A or A'. If not present 'N' is assumed. ! trans - character(optional). Whether A or A'. If not present 'N' is assumed.
! unitd - character(optional). Specify some type of operation with the diagonal matrix D. ! unitd - character(optional). Specify some type of operation with the diagonal matrix D.
@ -366,11 +366,11 @@ end subroutine psb_dspsm
! !
! Arguments: ! Arguments:
! alpha - real. The scalar alpha. ! alpha - real. The scalar alpha.
! a - type(<psb_dspmat_type>). The sparse matrix containing A. ! a - type(psb_dspmat_type). The sparse matrix containing A.
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! beta - real. The scalar beta. ! beta - real. The scalar beta.
! y - real,dimension(:). The input vector containing the entries of Y. ! y - real,dimension(:). The input vector containing the entries of Y.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! trans - character(optional). Whether A or A'. If not present 'N' is assumed. ! trans - character(optional). Whether A or A'. If not present 'N' is assumed.
! unitd - character(optional). Specify some type of operation with the diagonal matrix D. ! unitd - character(optional). Specify some type of operation with the diagonal matrix D.

14
base/psblas/psb_zamax.f90
Unescape Escape View File

@ -28,9 +28,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ POSSIBILITY OF SUCH DAMAGE.
!!$ !!$
!!$ !!$
! File: psb_damax.f90 ! File: psb_zamax.f90
! !
! Function: psb_damax ! Function: psb_zamax
! Searches the absolute max of X. ! Searches the absolute max of X.
! !
! normi := max(abs(sub(X)(i)) ! normi := max(abs(sub(X)(i))
@ -38,8 +38,8 @@
! where sub( X ) denotes X(1:N,JX:). ! where sub( X ) denotes X(1:N,JX:).
! !
! Arguments: ! Arguments:
! x - real,dimension(:,:). The input vector. ! x - complex,dimension(:,:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
@ -169,7 +169,7 @@ end function psb_zamax
! !
! Arguments: ! Arguments:
! x - real,dimension(:). The input vector. ! x - real,dimension(:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_zamaxv (x,desc_a, info) function psb_zamaxv (x,desc_a, info)
@ -296,7 +296,7 @@ end function psb_zamaxv
! Arguments: ! Arguments:
! res - real. The result. ! res - real. The result.
! x - real,dimension(:,:). The input vector. ! x - real,dimension(:,:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
@ -422,7 +422,7 @@ end subroutine psb_zamaxvs
! Arguments: ! Arguments:
! res - real. The result. ! res - real. The result.
! x - real,dimension(:). The input vector. ! x - real,dimension(:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
subroutine psb_zmamaxs (res,x,desc_a, info,jx) subroutine psb_zmamaxs (res,x,desc_a, info,jx)

6
base/psblas/psb_zasum.f90
Unescape Escape View File

@ -39,7 +39,7 @@
! !
! Arguments: ! Arguments:
! x - real,dimension(:,:). The input vector. ! x - real,dimension(:,:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
@ -189,7 +189,7 @@ end function psb_zasum
! !
! Arguments: ! Arguments:
! x - real,dimension(:). The input vector. ! x - real,dimension(:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_zasumv (x,desc_a, info) function psb_zasumv (x,desc_a, info)
@ -333,7 +333,7 @@ end function psb_zasumv
! Arguments: ! Arguments:
! res - real. The result. ! res - real. The result.
! x - real,dimension(:). The input vector. ! x - real,dimension(:). The input vector.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !

35
base/psblas/psb_zaxpby.f90
Unescape Escape View File

@ -28,9 +28,9 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ POSSIBILITY OF SUCH DAMAGE.
!!$ !!$
!!$ !!$
! File: psb_daxpby.f90 ! File: psb_zaxpby.f90
! !
! Subroutine: psb_daxpby ! Subroutine: psb_zaxpby
! Adds one distributed matrix to another, ! Adds one distributed matrix to another,
! !
! sub( Y ) := beta * sub( Y ) + alpha * sub( X ) ! sub( Y ) := beta * sub( Y ) + alpha * sub( X )
@ -40,14 +40,14 @@
! sub( Y ) denotes Y(:,JY). ! sub( Y ) denotes Y(:,JY).
! !
! Arguments: ! Arguments:
! alpha - real. The scalar used to multiply each component of sub( X ). ! alpha - complex,input The scalar used to multiply each component of X
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x(:,:) - complex,input The input vector containing the entries of X
! beta - real. The scalar used to multiply each component of sub( Y ). ! beta - real,input The scalar used to multiply each component of Y
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y(:,:) - real,inout The input vector Y
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type) The communication descriptor.
! info - integer. Return code ! info - integer Return code
! jx - integer(optional). The column offset for sub( X ). ! jx - integer(optional) The column offset for X
! jy - integer(optional). The column offset for sub( Y ). ! jy - integer(optional) The column offset for Y
! !
subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy) subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
use psb_descriptor_type use psb_descriptor_type
@ -188,18 +188,19 @@ end subroutine psb_zaxpby
!!$ !!$
!!$ !!$
! !
! Subroutine: psb_dgeaxpbyv ! Subroutine: psb_zgeaxpbyv
! Adds one distributed matrix to another, ! Adds one distributed matrix to another,
! !
! Y := beta * Y + alpha * X ! Y := beta * Y + alpha * X
! !
! Arguments: ! Arguments:
! alpha - real. The scalar used to multiply each component of X. ! alpha - complex,input The scalar used to multiply each component of X
! x - real,dimension(:). The input vector containing the entries of X. ! x(:) - complex,input The input vector containing the entries of X
! beta - real. The scalar used to multiply each component of Y. ! beta - real,input The scalar used to multiply each component of Y
! y - real,dimension(:). The input vector containing the entries of Y. ! y(:) - real,inout The input vector Y
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type) The communication descriptor.
! info - integer. Return code ! info - integer Return code
!
! !
subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info) subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info)
use psb_descriptor_type use psb_descriptor_type

8
base/psblas/psb_zdot.f90
Unescape Escape View File

@ -42,7 +42,7 @@
! Arguments: ! Arguments:
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y - real,dimension(:,:). The input vector containing the entries of sub( Y ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset for sub( X ). ! jx - integer(optional). The column offset for sub( X ).
! jy - integer(optional). The column offset for sub( Y ). ! jy - integer(optional). The column offset for sub( Y ).
@ -198,7 +198,7 @@ end function psb_zdot
! Arguments: ! Arguments:
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! y - real,dimension(:). The input vector containing the entries of Y. ! y - real,dimension(:). The input vector containing the entries of Y.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_zdotv(x, y,desc_a, info) function psb_zdotv(x, y,desc_a, info)
@ -336,7 +336,7 @@ end function psb_zdotv
! res - real. The result. ! res - real. The result.
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! y - real,dimension(:). The input vector containing the entries of Y. ! y - real,dimension(:). The input vector containing the entries of Y.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
subroutine psb_zdotvs(res, x, y,desc_a, info) subroutine psb_zdotvs(res, x, y,desc_a, info)
@ -476,7 +476,7 @@ end subroutine psb_zdotvs
! res - real. The result. ! res - real. The result.
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y - real,dimension(:,:). The input vector containing the entries of sub( Y ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
subroutine psb_zmdots(res, x, y, desc_a, info) subroutine psb_zmdots(res, x, y, desc_a, info)

6
base/psblas/psb_znrm2.f90
Unescape Escape View File

@ -39,7 +39,7 @@
! !
! Arguments: ! Arguments:
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! jx - integer(optional). The column offset for sub( X ). ! jx - integer(optional). The column offset for sub( X ).
! !
@ -177,7 +177,7 @@ end function psb_znrm2
! !
! Arguments: ! Arguments:
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_znrm2v(x, desc_a, info) function psb_znrm2v(x, desc_a, info)
@ -312,7 +312,7 @@ end function psb_znrm2v
! Arguments: ! Arguments:
! res - real. The result. ! res - real. The result.
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
subroutine psb_znrm2vs(res, x, desc_a, info) subroutine psb_znrm2vs(res, x, desc_a, info)

4
base/psblas/psb_znrmi.f90
Unescape Escape View File

@ -36,8 +36,8 @@
! normi := max(abs(sum(A(i,j)))) ! normi := max(abs(sum(A(i,j))))
! !
! Arguments: ! Arguments:
! a - type(<psb_dspmat_type>). The sparse matrix containing A. ! a - type(psb_dspmat_type). The sparse matrix containing A.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! !
function psb_znrmi(a,desc_a,info) function psb_znrmi(a,desc_a,info)

261
base/psblas/psb_zspmm.f90
Unescape Escape View File

@ -64,11 +64,11 @@
! !
! Arguments: ! Arguments:
! alpha - real. The scalar alpha. ! alpha - real. The scalar alpha.
! a - type(<psb_zspmat_type>). The sparse matrix containing A. ! a - type(psb_zspmat_type). The sparse matrix containing A.
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! beta - real. The scalar beta. ! beta - real. The scalar beta.
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y - real,dimension(:,:). The input vector containing the entries of sub( Y ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! trans - character(optional). Whether A or A'. If not present 'N' is assumed. ! trans - character(optional). Whether A or A'. If not present 'N' is assumed.
! k - integer(optional). The number of right-hand sides. ! k - integer(optional). The number of right-hand sides.
@ -398,11 +398,11 @@ end subroutine psb_zspmm
! !
! Arguments: ! Arguments:
! alpha - real. The scalar alpha. ! alpha - real. The scalar alpha.
! a - type(<psb_zspmat_type>). The sparse matrix containing A. ! a - type(psb_zspmat_type). The sparse matrix containing A.
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! beta - real. The scalar beta. ! beta - real. The scalar beta.
! y - real,dimension(:. The input vector containing the entries of Y. ! y - real,dimension(:. The input vector containing the entries of Y.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! trans - character(optional). Whether A or A'. If not present 'N' is assumed. ! trans - character(optional). Whether A or A'. If not present 'N' is assumed.
! work - real,dimension(:)(optional). Working area. ! work - real,dimension(:)(optional). Working area.
@ -443,11 +443,14 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,&
character :: itrans character :: itrans
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw logical :: aliw
integer :: debug_level, debug_unit
name='psb_zspmv' name='psb_zspmv'
if(psb_get_errstatus() /= 0) return if(psb_get_errstatus() /= 0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt=psb_cd_get_context(desc_a) ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
@ -467,9 +470,9 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,&
ib = 1 ib = 1
if (present(doswap)) then if (present(doswap)) then
idoswap = doswap idoswap = doswap
else else
idoswap = 1 idoswap = 1
endif endif
if (present(trans)) then if (present(trans)) then
@ -481,7 +484,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,&
goto 9999 goto 9999
end if end if
else else
itrans = 'N' itrans = 'N'
endif endif
m = psb_cd_get_global_rows(desc_a) m = psb_cd_get_global_rows(desc_a)
@ -496,18 +499,17 @@ subroutine psb_zspmv(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
! write(0,*)'---->>>',work(1)
if (present(work)) then if (present(work)) then
if (size(work) >= liwork) then if (size(work) >= liwork) then
aliw =.false. aliw =.false.
else else
aliw=.true. aliw=.true.
endif endif
else else
aliw=.true. aliw=.true.
end if end if
aliw=.true.
if (aliw) then if (aliw) then
allocate(iwork(liwork),stat=info) allocate(iwork(liwork),stat=info)
if(info /= 0) then if(info /= 0) then
@ -517,136 +519,153 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,&
goto 9999 goto 9999
end if end if
else else
iwork => work iwork => work
endif endif
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Allocated work ', info
! checking for matrix correctness ! checking for matrix correctness
call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja) call psb_chkmat(m,n,ia,ja,desc_a,info,iia,jja)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_chkmat' ch_err='psb_chkmat'
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_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' Checkmat ', info
if (itrans == 'N') then if (itrans == 'N') then
! Matrix is not transposed ! Matrix is not transposed
if((ja /= ix).or.(ia /= iy)) then if((ja /= ix).or.(ia /= iy)) then
! this case is not yet implemented ! this case is not yet implemented
info = 3030 info = 3030
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! checking for vectors correctness ! checking for vectors correctness
call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx) call psb_chkvect(n,ik,size(x),ix,jx,desc_a,info,iix,jjx)
if (info == 0) & if (info == 0) &
& call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy) & call psb_chkvect(m,ik,size(y),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_chkvect' ch_err='psb_chkvect'
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((iix /= 1).or.(iiy /= 1)) then if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented ! this case is not yet implemented
info = 3040 info = 3040
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (idoswap == 0) then if (idoswap == 0) then
x(nrow+1:ncol)=zzero x(nrow+1:ncol)=zzero
else else
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& zzero,x,desc_a,iwork,info,data=psb_comm_halo_) & zzero,x,desc_a,iwork,info,data=psb_comm_halo_)
end if end if
! local Matrix-vector product ! local Matrix-vector product
call psb_csmm(alpha,a,x(iix:lldx),beta,y(iiy:lldy),info) call psb_csmm(alpha,a,x(iix:lldx),beta,y(iiy:lldy),info)
if(info /= 0) then if(info /= 0) then
info = 4011 info = 4011
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
else else
! Matrix is transposed ! Matrix is transposed
if((ja /= iy).or.(ia /= ix)) then if((ja /= iy).or.(ia /= ix)) then
! this case is not yet implemented ! this case is not yet implemented
info = 3030 info = 3030
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if(desc_a%ovrlap_elem(1) /= -1) then if(desc_a%ovrlap_elem(1) /= -1) then
info = 3070 info = 3070
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
! checking for vectors correctness ! checking for vectors correctness
call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx) call psb_chkvect(m,ik,size(x),ix,jx,desc_a,info,iix,jjx)
if (info == 0)& if (info == 0)&
& call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy) & call psb_chkvect(n,ik,size(y),iy,jy,desc_a,info,iiy,jjy)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_chkvect' ch_err='psb_chkvect'
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((iix /= 1).or.(iiy /= 1)) then if((iix /= 1).or.(iiy /= 1)) then
! this case is not yet implemented ! this case is not yet implemented
info = 3040 info = 3040
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
xp => x(iix:lldx) xp => x(iix:lldx)
yp => y(iiy:lldy) yp => y(iiy:lldy)
yp(nrow+1:ncol)=zzero yp(nrow+1:ncol)=zzero
if (debug_level >= psb_debug_comp_) &
! local Matrix-vector product & write(debug_unit,*) me,' ',trim(name),' checkvect ', info
call psb_csmm(alpha,a,xp,beta,yp,info,trans=itrans) ! local Matrix-vector product
call psb_csmm(alpha,a,xp,beta,yp,info,trans=itrans)
if(info /= 0) then
info = 4010 if(info /= 0) then
ch_err='dcsmm' info = 4010
call psb_errpush(info,name,a_err=ch_err) ch_err='zcsmm'
goto 9999 call psb_errpush(info,name,a_err=ch_err)
end if goto 9999
end if
if(idoswap /= 0)&
& call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),& if(idoswap /= 0)&
& zone,yp,desc_a,iwork,info) & call psi_swaptran(ior(psb_swap_send_,psb_swap_recv_),&
if(info /= 0) then & zone,yp,desc_a,iwork,info)
info = 4010 if (debug_level >= psb_debug_comp_) &
ch_err='PSI_dSwapTran' & write(debug_unit,*) me,' ',trim(name),' swaptran ', info
call psb_errpush(info,name,a_err=ch_err) if(info /= 0) then
goto 9999 info = 4010
end if ch_err='PSI_dSwapTran'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if end if
if(aliw) deallocate(iwork) if (aliw) deallocate(iwork,stat=info)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' deallocat ',aliw, info
if(info /= 0) then
info = 4010
ch_err='Deallocate iwork'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
nullify(iwork) nullify(iwork)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (debug_level >= psb_debug_comp_) then
call psb_barrier(ictxt)
write(debug_unit,*) me,' ',trim(name),' Returning '
endif
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error(ictxt) call psb_error(ictxt)
return return
end if end if
return return
end subroutine psb_zspmv end subroutine psb_zspmv

8
base/psblas/psb_zspsm.f90
Unescape Escape View File

@ -56,11 +56,11 @@
! !
! Arguments: ! Arguments:
! alpha - real. The scalar alpha. ! alpha - real. The scalar alpha.
! a - type(<psb_zspmat_type>). The sparse matrix containing A. ! a - type(psb_zspmat_type). The sparse matrix containing A.
! x - real,dimension(:,:). The input vector containing the entries of sub( X ). ! x - real,dimension(:,:). The input vector containing the entries of sub( X ).
! beta - real. The scalar beta. ! beta - real. The scalar beta.
! y - real,dimension(:,:). The input vector containing the entries of sub( Y ). ! y - real,dimension(:,:). The input vector containing the entries of sub( Y ).
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! trans - character(optional). Whether A or A'. If not present 'N' is assumed. ! trans - character(optional). Whether A or A'. If not present 'N' is assumed.
! unitd - character(optional). Specify some type of operation with the diagonal matrix D. ! unitd - character(optional). Specify some type of operation with the diagonal matrix D.
@ -369,11 +369,11 @@ end subroutine psb_zspsm
! !
! Arguments: ! Arguments:
! alpha - real. The scalar alpha. ! alpha - real. The scalar alpha.
! a - type(<psb_zspmat_type>). The sparse matrix containing A. ! a - type(psb_zspmat_type). The sparse matrix containing A.
! x - real,dimension(:). The input vector containing the entries of X. ! x - real,dimension(:). The input vector containing the entries of X.
! beta - real. The scalar beta. ! beta - real. The scalar beta.
! y - real,dimension(:). The input vector containing the entries of Y. ! y - real,dimension(:). The input vector containing the entries of Y.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code ! info - integer. Return code
! trans - character(optional). Whether A or A'. If not present 'N' is assumed. ! trans - character(optional). Whether A or A'. If not present 'N' is assumed.
! unitd - character(optional). Specify some type of operation with the diagonal matrix D. ! unitd - character(optional). Specify some type of operation with the diagonal matrix D.

2
base/serial/aux/dasr.f90
Unescape Escape View File

@ -69,7 +69,6 @@ subroutine dasr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -194,7 +193,6 @@ subroutine dasr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/dasrx.f90
Unescape Escape View File

@ -81,7 +81,6 @@ subroutine dasrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -220,7 +219,6 @@ subroutine dasrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/dsr.f90
Unescape Escape View File

@ -69,7 +69,6 @@ subroutine dsr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -194,7 +193,6 @@ subroutine dsr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/dsrx.f90
Unescape Escape View File

@ -81,7 +81,6 @@ subroutine dsrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -221,7 +220,6 @@ subroutine dsrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/iasr.f90
Unescape Escape View File

@ -69,7 +69,6 @@ subroutine iasr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -194,7 +193,6 @@ subroutine iasr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/iasrx.f90
Unescape Escape View File

@ -81,7 +81,6 @@ subroutine iasrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -220,7 +219,6 @@ subroutine iasrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

1
base/serial/aux/imsru.f90
Unescape Escape View File

@ -42,7 +42,6 @@ subroutine imsru(n,x,idir,nout)
nout = 0 nout = 0
if (n<0) then if (n<0) then
!!$ write(0,*) 'Error: IMSR: N<0'
return return
endif endif

2
base/serial/aux/isr.f90
Unescape Escape View File

@ -69,7 +69,6 @@ subroutine isr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -194,7 +193,6 @@ subroutine isr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/isrx.f90
Unescape Escape View File

@ -80,7 +80,6 @@ subroutine isrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -221,7 +220,6 @@ subroutine isrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/zalsr.f90
Unescape Escape View File

@ -70,7 +70,6 @@ subroutine zalsr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -195,7 +194,6 @@ subroutine zalsr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/zalsrx.f90
Unescape Escape View File

@ -82,7 +82,6 @@ subroutine zalsrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -223,7 +222,6 @@ subroutine zalsrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/zasr.f90
Unescape Escape View File

@ -70,7 +70,6 @@ subroutine zasr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -195,7 +194,6 @@ subroutine zasr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/zasrx.f90
Unescape Escape View File

@ -82,7 +82,6 @@ subroutine zasrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -223,7 +222,6 @@ subroutine zasrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/zlsr.f90
Unescape Escape View File

@ -70,7 +70,6 @@ subroutine zlsr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -195,7 +194,6 @@ subroutine zlsr(n,x,dir)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/aux/zlsrx.f90
Unescape Escape View File

@ -82,7 +82,6 @@ subroutine zlsrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location
@ -223,7 +222,6 @@ subroutine zlsrx(n,x,indx,dir,flag)
ilx = istack(1,istp) ilx = istack(1,istp)
iux = istack(2,istp) iux = istack(2,istp)
istp = istp - 1 istp = istp - 1
!$$$ write(0,*) 'Debug 1: ',ilx,iux
! !
! Choose a pivot with median-of-three heuristics, leave it ! Choose a pivot with median-of-three heuristics, leave it
! in the LPIV location ! in the LPIV location

2
base/serial/coo/Makefile
Unescape Escape View File

@ -3,7 +3,7 @@ include ../../../Make.inc
# #
# The object files # The object files
# #
FOBJS = dcooprt.o dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o dcoorws.o\ FOBJS = dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o dcoorws.o\
zcoomm.o zcoomv.o zcoonrmi.o zcoorws.o zcoosm.o zcoosv.o zcoomm.o zcoomv.o zcoonrmi.o zcoorws.o zcoosm.o zcoosv.o

80
base/serial/coo/dcooprt.f
Unescape Escape View File

@ -1,80 +0,0 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
c
c What if a wrong DESCRA is passed?
c
c
SUBROUTINE DCOOPRT(M,N,DESCRA,AR,IA,JA,INFOA,TITLE,IOUT)
C
C
C .. Scalar Arguments ..
INTEGER M, N, IOUT
C .. Array Arguments ..
DOUBLE PRECISION AR(*)
INTEGER IA(*), JA(*),INFOA(*)
CHARACTER DESCRA*11, TITLE*(*)
C .. Local Scalars ..
INTEGER J
C .. External Subroutines ..
C
C
if ((descra(1:1).eq.'g').or.(descra(1:1).eq.'G')) then
write(iout,fmt=998)
else if ((descra(1:1).eq.'s').or.(descra(1:1).eq.'S')) then
write(iout,fmt=997)
else
write(iout,fmt=998)
endif
nnzero = infoa(1)
write(iout,fmt=992)
write(iout,fmt=996)
write(iout,fmt=996) title
write(iout,fmt=995) 'Number of rows: ',m
write(iout,fmt=995) 'Number of columns: ',n
write(iout,fmt=995) 'Nonzero entries: ',nnzero
write(iout,fmt=996)
write(iout,fmt=992)
write(iout,*) m,n,nnzero
998 format('%%MatrixMarket matrix coordinate real general')
997 format('%%MatrixMarket matrix coordinate real symmetric')
992 format('%======================================== ')
996 format('% ',a)
995 format('% ',a,i9,a,i9,a,i9)
do j=1,nnzero
write(iout,fmt=994) ia(j),ja(j),ar(j)
994 format(i6,1x,i6,1x,e16.8)
enddo
RETURN
END

12
base/serial/coo/dcoosm.f
Unescape Escape View File

@ -30,9 +30,8 @@ C
C C
SUBROUTINE DCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA, SUBROUTINE DCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA,
* B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR)
use psb_error_mod
IMPLICIT NONE IMPLICIT NONE
LOGICAL DEBUG
PARAMETER (DEBUG=.FALSE.)
DOUBLE PRECISION ALPHA, BETA DOUBLE PRECISION ALPHA, BETA
INTEGER LDB, LDC, LWORK, M, N, IERROR INTEGER LDB, LDC, LWORK, M, N, IERROR
CHARACTER UNITD, TRANST CHARACTER UNITD, TRANST
@ -43,18 +42,21 @@ C
CHARACTER DIAG, UPLO CHARACTER DIAG, UPLO
INTRINSIC DBLE, IDINT INTRINSIC DBLE, IDINT
CHARACTER*20 NAME CHARACTER*20 NAME
integer :: debug_level, debug_unit
NAME = 'DCOOSM\0' NAME = 'ZCOOSM\0'
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then
IERROR=5 IERROR=5
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999 GOTO 9999
ENDIF ENDIF
if (debug) write(*,*) 'DCOOSM ',m if (debug_level >= psb_debug_serial_comp_)
if (debug) write(*,*) 'DCOOSM ',m,ierror + write(debug_unit,*) trim(name),':' ,m,ierror
UPLO = '?' UPLO = '?'
IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U'

274
base/serial/coo/dcoosv.f
Unescape Escape View File

@ -34,10 +34,9 @@ C "right" place, i.e. the last in its row for Lower and the first
C for Upper. C for Upper.
C C
SUBROUTINE DCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR) SUBROUTINE DCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR)
use psb_error_mod
DOUBLE PRECISION ZERO DOUBLE PRECISION ZERO
PARAMETER (ZERO=0.0D0) PARAMETER (ZERO=0.0D0)
LOGICAL DEBUG
PARAMETER (DEBUG=.FALSE.)
INTEGER N,IERROR INTEGER N,IERROR
CHARACTER DIAG, TRANS, UPLO CHARACTER DIAG, TRANS, UPLO
DOUBLE PRECISION AS(*), B(*), X(*) DOUBLE PRECISION AS(*), B(*), X(*)
@ -45,120 +44,129 @@ C
DOUBLE PRECISION ACC DOUBLE PRECISION ACC
INTEGER I, J, K, NNZ, II INTEGER I, J, K, NNZ, II
LOGICAL LOW, TRA, UNI LOGICAL LOW, TRA, UNI
if (debug) write(*,*) 'DCOOSV ',n integer :: debug_level, debug_unit
if (debug) write(*,*) 'DCOOSV ',n,nnz,diag,trans,uplo character(len=20) :: name='dcoosv'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
UNI = (DIAG.EQ.'U') UNI = (DIAG.EQ.'U')
TRA = (TRANS.EQ.'T') TRA = (TRANS.EQ.'T')
LOW = (UPLO.EQ.'L') LOW = (UPLO.EQ.'L')
NNZ = INFOA(1) NNZ = INFOA(1)
if (debug) write(*,*) 'DCOOSV ',n,nnz,uni,tra,low,ia(1),ja(1)
IERROR = 0 IERROR = 0
if (debug) write(*,*) 'DCOOSV ierror ',ierror if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),':',n,nnz,diag,trans,uplo
IF ( .NOT. TRA) THEN IF ( .NOT. TRA) THEN
if (debug) write(*,*) 'DCOOSV NOT TRA' if (debug_level>=psb_debug_serial_comp_)
IF (LOW) THEN + write(debug_unit,*) trim(name),': NOT TRA'
if (debug) write(*,*) 'DCOOSV LOW' IF (LOW) THEN
IF ( .NOT. UNI) THEN if (debug_level>=psb_debug_serial_comp_)
if (debug) write(*,*) 'DCOOSV NOT UNI' + write(debug_unit,*) trim(name),': LOW'
I = 1 IF ( .NOT. UNI) THEN
J = I if (debug_level>=psb_debug_serial_comp_)
DO WHILE (I.LE.NNZ) + write(debug_unit,*) trim(name),': NOT UNI'
I = 1
J = I
DO WHILE (I.LE.NNZ)
DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I)))
J = J+1
ENDDO
ACC = ZERO
IR = IA(I)
DO K = I, J-2
JC = JA(K)
ACC = ACC + AS(K)*X(JC)
ENDDO
X(IR) = (B(IR)-ACC)/AS(J-1)
I = J
ENDDO
ELSE IF (UNI) THEN
C
C Bug warning: if UNI, some rows might be empty
C
I = 1
if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': UNILOW ',
+ i,n,nnz,uni,tra,low
DO II = 1, N
DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II))
I = I + 1
ENDDO
ACC = ZERO
IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN
J = I + 1
DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I)))
J = J+1 J = J+1
ENDDO ENDDO
ACC = ZERO DO K = I, J-1
IR = IA(I)
DO K = I, J-2
JC = JA(K) JC = JA(K)
ACC = ACC + AS(K)*X(JC) ACC = ACC + AS(K)*X(JC)
ENDDO ENDDO
X(IR) = (B(IR)-ACC)/AS(J-1) ELSE
I = J J = I
ENDDO ENDIF
X(II) = (B(II)-ACC)
I = J
ENDDO
ELSE IF (UNI) THEN END IF
C
C Bug warning: if UNI, some rows might be empty
C
I = 1
if (debug) write(*,*) 'DCOOSV UNILOW ',
+ i,n,nnz,uni,tra,low
DO II = 1, N
if (debug) write(*,*) 'Loop1 COOSV',i,j,ii,x(ii),b(ii)
DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II))
I = I + 1
c$$$ if (debug) write(*,*) 'Loop2 COOSV',i,ia(i),ii
ENDDO
ACC = ZERO
IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN
J = I + 1
DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I)))
J = J+1
ENDDO
DO K = I, J-1
JC = JA(K)
ACC = ACC + AS(K)*X(JC)
ENDDO
ELSE
J = I
ENDIF
X(II) = (B(II)-ACC)
if (debug) write(*,*) 'Loop COOSV',i,j,ii,x(ii),b(ii)
I = J
ENDDO
END IF ELSE IF ( .NOT. LOW) THEN
if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': NOT LOW'
IF ( .NOT. UNI) THEN
if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': NOT UNI'
I = NNZ
J = NNZ
DO WHILE (I.GT.0)
DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I)))
J = J-1
ENDDO
ACC = ZERO
IR = IA(I)
DO K = I, J+2,-1
JC = JA(K)
ACC = ACC + AS(K)*X(JC)
ENDDO
X(IR) = (B(IR)-ACC)/AS(J+1)
I = J
ENDDO
ELSE IF ( .NOT. LOW) THEN ELSE IF (UNI) THEN
if (debug) write(*,*) 'DCOOSV NOT LOW' if (debug_level>=psb_debug_serial_comp_)
IF ( .NOT. UNI) THEN + write(debug_unit,*) trim(name),': UNI'
if (debug) write(*,*) 'DCOOSV NOT UNI' I = NNZ
I = NNZ DO II = N,1,-1
J = NNZ DO WHILE ((I.GT.0).AND.(IA(I).GT.II))
DO WHILE (I.GT.0) I = I -1
ENDDO
ACC = ZERO
IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN
J = I - 1
DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I)))
J = J-1 J = J-1
ENDDO ENDDO
ACC = ZERO DO K = I, J+1, -1
IR = IA(I)
DO K = I, J+2,-1
JC = JA(K) JC = JA(K)
ACC = ACC + AS(K)*X(JC) ACC = ACC + AS(K)*X(JC)
ENDDO ENDDO
X(IR) = (B(IR)-ACC)/AS(J+1) ELSE
I = J J = I
ENDDO ENDIF
X(II) = (B(II)-ACC)
ELSE IF (UNI) THEN I = J
if (debug) write(*,*) 'DCOOSV UNI' ENDDO
I = NNZ
DO II = N,1,-1
DO WHILE ((I.GT.0).AND.(IA(I).GT.II))
I = I -1
ENDDO
ACC = ZERO
IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN
J = I - 1
DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I)))
J = J-1
ENDDO
DO K = I, J+1, -1
JC = JA(K)
ACC = ACC + AS(K)*X(JC)
ENDDO
ELSE
J = I
ENDIF
X(II) = (B(II)-ACC)
if (debug) write(*,*) 'Loop COOSV',i,j,ii,x(ii),b(ii)
I = J
ENDDO
END IF END IF
END IF END IF
ELSE IF (TRA) THEN ELSE IF (TRA) THEN
if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': TRA'
IERROR = 3010 IERROR = 3010
return return
CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
@ -166,48 +174,48 @@ C
C TBF C TBF
C C
CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
DO 180 I = 1, N DO 180 I = 1, N
X(I) = B(I) X(I) = B(I)
180 CONTINUE 180 CONTINUE
IF (LOW) THEN IF (LOW) THEN
IF ( .NOT. UNI) THEN IF ( .NOT. UNI) THEN
DO 220 I = N, 1, -1 DO 220 I = N, 1, -1
X(I) = X(I)/AS(IA(I+1)-1) X(I) = X(I)/AS(IA(I+1)-1)
ACC = X(I) ACC = X(I)
DO 200 J = IA(I), IA(I+1) - 2 DO 200 J = IA(I), IA(I+1) - 2
K = JA(J) K = JA(J)
X(K) = X(K) - AS(J)*ACC X(K) = X(K) - AS(J)*ACC
200 CONTINUE 200 CONTINUE
220 CONTINUE 220 CONTINUE
ELSE IF (UNI) THEN ELSE IF (UNI) THEN
DO 260 I = N, 1, -1 DO 260 I = N, 1, -1
ACC = X(I) ACC = X(I)
DO 240 J = IA(I), IA(I+1) - 1 DO 240 J = IA(I), IA(I+1) - 1
K = JA(J) K = JA(J)
X(K) = X(K) - AS(J)*ACC X(K) = X(K) - AS(J)*ACC
240 CONTINUE 240 CONTINUE
260 CONTINUE 260 CONTINUE
END IF END IF
ELSE IF ( .NOT. LOW) THEN ELSE IF ( .NOT. LOW) THEN
IF ( .NOT. UNI) THEN IF ( .NOT. UNI) THEN
DO 300 I = 1, N DO 300 I = 1, N
X(I) = X(I)/AS(IA(I)) X(I) = X(I)/AS(IA(I))
ACC = X(I) ACC = X(I)
DO 280 J = IA(I) + 1, IA(I+1) - 1 DO 280 J = IA(I) + 1, IA(I+1) - 1
K = JA(J) K = JA(J)
X(K) = X(K) - AS(J)*ACC X(K) = X(K) - AS(J)*ACC
280 CONTINUE 280 CONTINUE
300 CONTINUE 300 CONTINUE
ELSE IF (UNI) THEN ELSE IF (UNI) THEN
DO 340 I = 1, N DO 340 I = 1, N
ACC = X(I) ACC = X(I)
DO 320 J = IA(I), IA(I+1) - 1 DO 320 J = IA(I), IA(I+1) - 1
K = JA(J) K = JA(J)
X(K) = X(K) - AS(J)*ACC X(K) = X(K) - AS(J)*ACC
320 CONTINUE 320 CONTINUE
340 CONTINUE 340 CONTINUE
END IF END IF
END IF END IF
END IF END IF
RETURN RETURN
END END

29
base/serial/coo/zcoomm.f
Unescape Escape View File

@ -1,3 +1,32 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
c c
c What if a wrong DESCRA is passed? c What if a wrong DESCRA is passed?
c c

29
base/serial/coo/zcoomv.f
Unescape Escape View File

@ -1,3 +1,32 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
*********************************************************************** ***********************************************************************
* ZCOOMV. Prolog to be updated. * * ZCOOMV. Prolog to be updated. *
* * * *

29
base/serial/coo/zcoonrmi.f
Unescape Escape View File

@ -1,3 +1,32 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C ... Compute Infinity norm for sparse matrix in CSR Format ... C ... Compute Infinity norm for sparse matrix in CSR Format ...
DOUBLE PRECISION FUNCTION ZCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, DOUBLE PRECISION FUNCTION ZCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2,
+ INFOA,IERROR) + INFOA,IERROR)

29
base/serial/coo/zcoorws.f
Unescape Escape View File

@ -1,3 +1,32 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
SUBROUTINE ZCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, SUBROUTINE ZCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2,
& INFOA,ROWSUM,IERROR) & INFOA,ROWSUM,IERROR)
IMPLICIT NONE IMPLICIT NONE

86
base/serial/coo/zcoosm.f
Unescape Escape View File

@ -1,36 +1,77 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
SUBROUTINE ZCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA, SUBROUTINE ZCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA,
* B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR)
LOGICAL DEBUG use psb_error_mod
PARAMETER (DEBUG=.FALSE.) IMPLICIT NONE
COMPLEX*16 ALPHA, BETA COMPLEX*16 ALPHA, BETA
INTEGER LDB, LDC, LWORK, M, N, IERROR INTEGER LDB, LDC, LWORK, M, N, IERROR
CHARACTER UNITD, TRANST CHARACTER UNITD, TRANST
COMPLEX*16 A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) COMPLEX*16 A(*), B(LDB,*), C(LDC,*), D(*), WORK(*)
INTEGER IA(*), JA(*), INFOA(*) INTEGER IA(*), JA(*), INFOA(*), INT_VAL(5)
CHARACTER DESCRA*11 CHARACTER DESCRA*11
INTEGER I, K INTEGER I, K, ERR_ACT
CHARACTER DIAG, UPLO CHARACTER DIAG, UPLO
EXTERNAL XERBLA INTRINSIC DBLE, IDINT
CHARACTER*20 NAME
integer :: debug_level, debug_unit
NAME = 'DCOOSM\0'
IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then
call xerbla('DCSSM ',9) IERROR=5
RETURN CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF ENDIF
if (debug) write(*,*) 'ZCOOSM ',m if (debug_level >= psb_debug_serial_comp_)
if (debug) write(*,*) 'ZCOOSM ',m,ierror + write(debug_unit,*) trim(name),':' ,m,ierror
UPLO = '?' UPLO = '?'
IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U'
IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L'
IF (UPLO.EQ.'?') THEN IF (UPLO.EQ.'?') THEN
CALL XERBLA('ZCSSM ',10) IERROR=5
RETURN CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
END IF END IF
IF (DESCRA(3:3).EQ.'N') DIAG = 'N' IF (DESCRA(3:3).EQ.'N') DIAG = 'N'
IF (DESCRA(3:3).EQ.'U') DIAG = 'U' IF (DESCRA(3:3).EQ.'U') DIAG = 'U'
IF(UNITD.EQ.'B') THEN IF(UNITD.EQ.'B') THEN
CALL XERBLA('ZCSSM ',11) IERROR=5
RETURN CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
ENDIF ENDIF
IF (UNITD.EQ.'R') THEN IF (UNITD.EQ.'R') THEN
DO 40 I = 1, N DO 40 I = 1, N
@ -44,6 +85,12 @@
CALL ZCOOSV(UPLO,TRANST,DIAG,M,A,IA,JA,INFOA, CALL ZCOOSV(UPLO,TRANST,DIAG,M,A,IA,JA,INFOA,
+ B(1,I),C(1,I),IERROR) + B(1,I),C(1,I),IERROR)
60 CONTINUE 60 CONTINUE
IF(IERROR.NE.0) THEN
INT_VAL(1)=IERROR
CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL)
GOTO 9999
END IF
IF (UNITD.EQ.'L') THEN IF (UNITD.EQ.'L') THEN
DO 45 I = 1, N DO 45 I = 1, N
DO 25 K = 1, M DO 25 K = 1, M
@ -51,5 +98,16 @@
25 CONTINUE 25 CONTINUE
45 CONTINUE 45 CONTINUE
END IF END IF
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
RETURN
9999 CONTINUE
CALL FCPSB_ERRACTIONRESTORE(ERR_ACT)
IF ( ERR_ACT .NE. 0 ) THEN
CALL FCPSB_SERROR()
RETURN
ENDIF
RETURN RETURN
END END

303
base/serial/coo/zcoosv.f
Unescape Escape View File

@ -1,13 +1,41 @@
C C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
C Assumption: the triangular matrix has the diagonal element in the C Assumption: the triangular matrix has the diagonal element in the
C "right" place, i.e. the last in its row for Lower and the first C "right" place, i.e. the last in its row for Lower and the first
C for Upper. C for Upper.
C C
SUBROUTINE ZCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR) SUBROUTINE ZCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR)
use psb_error_mod
COMPLEX*16 ZERO COMPLEX*16 ZERO
PARAMETER (ZERO=(0.0D0,0.0D0)) PARAMETER (ZERO=(0.0D0,0.0D0))
LOGICAL DEBUG
PARAMETER (DEBUG=.FALSE.)
INTEGER N,IERROR INTEGER N,IERROR
CHARACTER DIAG, TRANS, UPLO CHARACTER DIAG, TRANS, UPLO
COMPLEX*16 AS(*), B(*), X(*) COMPLEX*16 AS(*), B(*), X(*)
@ -15,120 +43,129 @@ C
COMPLEX*16 ACC COMPLEX*16 ACC
INTEGER I, J, K, NNZ, II, JJ INTEGER I, J, K, NNZ, II, JJ
LOGICAL LOW, TRA, UNI LOGICAL LOW, TRA, UNI
if (debug) write(*,*) 'ZCOOSV ',n integer :: debug_level, debug_unit
if (debug) write(*,*) 'ZCOOSV ',n,nnz,diag,trans,uplo character(len=20) :: name='zcoosv'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
UNI = (DIAG.EQ.'U') UNI = (DIAG.EQ.'U')
TRA = (TRANS.EQ.'T') TRA = (TRANS.EQ.'T')
LOW = (UPLO.EQ.'L') LOW = (UPLO.EQ.'L')
NNZ = INFOA(1) NNZ = INFOA(1)
if (debug) write(*,*) 'ZCOOSV ',n,nnz,uni,tra,low,ia(1),ja(1)
IERROR = 0 IERROR = 0
if (debug) write(*,*) 'ZCOOSV ierror ',ierror if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),':',n,nnz,diag,trans,uplo
IF ( .NOT. TRA) THEN IF ( .NOT. TRA) THEN
if (debug) write(*,*) 'ZCOOSV NOT TRA' if (debug_level>=psb_debug_serial_comp_)
IF (LOW) THEN + write(debug_unit,*) trim(name),': NOT TRA'
if (debug) write(*,*) 'ZCOOSV LOW' IF (LOW) THEN
IF ( .NOT. UNI) THEN if (debug_level>=psb_debug_serial_comp_)
if (debug) write(*,*) 'ZCOOSV NOT UNI' + write(debug_unit,*) trim(name),': LOW'
I = 1 IF ( .NOT. UNI) THEN
J = I if (debug_level>=psb_debug_serial_comp_)
DO WHILE (I.LE.NNZ) + write(debug_unit,*) trim(name),': NOT UNI'
I = 1
J = I
DO WHILE (I.LE.NNZ)
DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I)))
J = J+1
ENDDO
ACC = ZERO
IR = IA(I)
DO K = I, J-2
JC = JA(K)
ACC = ACC + AS(K)*X(JC)
ENDDO
X(IR) = (B(IR)-ACC)/AS(J-1)
I = J
ENDDO
ELSE IF (UNI) THEN
C
C Bug warning: if UNI, some rows might be empty
C
I = 1
if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': UNILOW ',
+ i,n,nnz,uni,tra,low
DO II = 1, N
DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II))
I = I + 1
ENDDO
ACC = ZERO
IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN
J = I + 1
DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I)))
J = J+1 J = J+1
ENDDO ENDDO
ACC = ZERO DO K = I, J-1
IR = IA(I)
DO K = I, J-2
JC = JA(K) JC = JA(K)
ACC = ACC + AS(K)*X(JC) ACC = ACC + AS(K)*X(JC)
ENDDO ENDDO
X(IR) = (B(IR)-ACC)/AS(J-1) ELSE
I = J J = I
ENDDO ENDIF
X(II) = (B(II)-ACC)
I = J
ENDDO
ELSE IF (UNI) THEN END IF
C
C Bug warning: if UNI, some rows might be empty
C
I = 1
if (debug) write(*,*) 'ZCOOSV UNILOW ',
+ i,n,nnz,uni,tra,low
DO II = 1, N
if (debug) write(*,*) 'Loop1 COOSV',i,j,ii,x(ii),b(ii)
DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II))
I = I + 1
c$$$ if (debug) write(*,*) 'Loop2 COOSV',i,ia(i),ii
ENDDO
ACC = ZERO
IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN
J = I + 1
DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I)))
J = J+1
ENDDO
DO K = I, J-1
JC = JA(K)
ACC = ACC + AS(K)*X(JC)
ENDDO
ELSE
J = I
ENDIF
X(II) = (B(II)-ACC)
if (debug) write(*,*) 'Loop COOSV',i,j,ii,x(ii),b(ii)
I = J
ENDDO
END IF ELSE IF ( .NOT. LOW) THEN
if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': NOT LOW'
IF ( .NOT. UNI) THEN
if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': NOT UNI'
I = NNZ
J = NNZ
DO WHILE (I.GT.0)
DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I)))
J = J-1
ENDDO
ACC = ZERO
IR = IA(I)
DO K = I, J+2,-1
JC = JA(K)
ACC = ACC + AS(K)*X(JC)
ENDDO
X(IR) = (B(IR)-ACC)/AS(J+1)
I = J
ENDDO
ELSE IF ( .NOT. LOW) THEN ELSE IF (UNI) THEN
if (debug) write(*,*) 'ZCOOSV NOT LOW' if (debug_level>=psb_debug_serial_comp_)
IF ( .NOT. UNI) THEN + write(debug_unit,*) trim(name),': UNI'
if (debug) write(*,*) 'ZCOOSV NOT UNI' I = NNZ
I = NNZ DO II = N,1,-1
J = NNZ DO WHILE ((I.GT.0).AND.(IA(I).GT.II))
DO WHILE (I.GT.0) I = I -1
ENDDO
ACC = ZERO
IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN
J = I - 1
DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I)))
J = J-1 J = J-1
ENDDO ENDDO
ACC = ZERO DO K = I, J+1, -1
IR = IA(I)
DO K = I, J+2,-1
JC = JA(K) JC = JA(K)
ACC = ACC + AS(K)*X(JC) ACC = ACC + AS(K)*X(JC)
ENDDO ENDDO
X(IR) = (B(IR)-ACC)/AS(J+1) ELSE
I = J J = I
ENDDO ENDIF
X(II) = (B(II)-ACC)
ELSE IF (UNI) THEN I = J
if (debug) write(*,*) 'ZCOOSV UNI' ENDDO
I = NNZ
DO II = N,1,-1
DO WHILE ((I.GT.0).AND.(IA(I).GT.II))
I = I -1
ENDDO
ACC = ZERO
IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN
J = I - 1
DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I)))
J = J-1
ENDDO
DO K = I, J+1, -1
JC = JA(K)
ACC = ACC + AS(K)*X(JC)
ENDDO
ELSE
J = I
ENDIF
X(II) = (B(II)-ACC)
if (debug) write(*,*) 'Loop COOSV',i,j,ii,x(ii),b(ii)
I = J
ENDDO
END IF END IF
END IF END IF
ELSE IF (TRA) THEN ELSE IF (TRA) THEN
if (debug_level>=psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': TRA'
IERROR = 3010 IERROR = 3010
return return
CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
@ -136,48 +173,48 @@ C
C TBF C TBF
C C
CCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCC
DO 180 I = 1, N DO 180 I = 1, N
X(I) = B(I) X(I) = B(I)
180 CONTINUE 180 CONTINUE
IF (LOW) THEN IF (LOW) THEN
IF ( .NOT. UNI) THEN IF ( .NOT. UNI) THEN
DO 220 I = N, 1, -1 DO 220 I = N, 1, -1
X(I) = X(I)/AS(IA(I+1)-1) X(I) = X(I)/AS(IA(I+1)-1)
ACC = X(I) ACC = X(I)
DO 200 J = IA(I), IA(I+1) - 2 DO 200 J = IA(I), IA(I+1) - 2
K = JA(J) K = JA(J)
X(K) = X(K) - AS(J)*ACC X(K) = X(K) - AS(J)*ACC
200 CONTINUE 200 CONTINUE
220 CONTINUE 220 CONTINUE
ELSE IF (UNI) THEN ELSE IF (UNI) THEN
DO 260 I = N, 1, -1 DO 260 I = N, 1, -1
ACC = X(I) ACC = X(I)
DO 240 J = IA(I), IA(I+1) - 1 DO 240 J = IA(I), IA(I+1) - 1
K = JA(J) K = JA(J)
X(K) = X(K) - AS(J)*ACC X(K) = X(K) - AS(J)*ACC
240 CONTINUE 240 CONTINUE
260 CONTINUE 260 CONTINUE
END IF END IF
ELSE IF ( .NOT. LOW) THEN ELSE IF ( .NOT. LOW) THEN
IF ( .NOT. UNI) THEN IF ( .NOT. UNI) THEN
DO 300 I = 1, N DO 300 I = 1, N
X(I) = X(I)/AS(IA(I)) X(I) = X(I)/AS(IA(I))
ACC = X(I) ACC = X(I)
DO 280 J = IA(I) + 1, IA(I+1) - 1 DO 280 J = IA(I) + 1, IA(I+1) - 1
K = JA(J) K = JA(J)
X(K) = X(K) - AS(J)*ACC X(K) = X(K) - AS(J)*ACC
280 CONTINUE 280 CONTINUE
300 CONTINUE 300 CONTINUE
ELSE IF (UNI) THEN ELSE IF (UNI) THEN
DO 340 I = 1, N DO 340 I = 1, N
ACC = X(I) ACC = X(I)
DO 320 J = IA(I), IA(I+1) - 1 DO 320 J = IA(I), IA(I+1) - 1
K = JA(J) K = JA(J)
X(K) = X(K) - AS(J)*ACC X(K) = X(K) - AS(J)*ACC
320 CONTINUE 320 CONTINUE
340 CONTINUE 340 CONTINUE
END IF END IF
END IF END IF
END IF END IF
RETURN RETURN
END END

2
base/serial/csr/Makefile
Unescape Escape View File

@ -5,7 +5,7 @@ include ../../../Make.inc
# #
FOBJS = dcsrck.o dcsrmm.o dcsrsm.o dcsrmv.o dcsrsv.o dcrnrmi.o \ FOBJS = dcsrck.o dcsrmm.o dcsrsm.o dcsrmv.o dcsrsv.o dcrnrmi.o \
dcsrprt.o dcsrmv4.o dcsrmv2.o dcsrmv3.o dcsrrws.o\ dcsrmv4.o dcsrmv2.o dcsrmv3.o dcsrrws.o\
zcrnrmi.o zcsrmm.o zcsrrws.o zcsrsm.o zsrmv.o zsrsv.o zcsrck.o zcrnrmi.o zcsrmm.o zcsrrws.o zcsrsm.o zsrmv.o zsrsv.o zcsrck.o
OBJS=$(FOBJS) OBJS=$(FOBJS)

84
base/serial/csr/dcsrprt.f
Unescape Escape View File

@ -1,84 +0,0 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
c
c What if a wrong DESCRA is passed?
c
c
*
*
SUBROUTINE DCSRPRT(M,N,DESCRA,AR,JA,IA,TITLE,IOUT)
C
C
C .. Scalar Arguments ..
INTEGER M, N, IOUT
C .. Array Arguments ..
DOUBLE PRECISION AR(*)
INTEGER IA(*), JA(*)
CHARACTER DESCRA*11, TITLE*(*)
C .. Local Scalars ..
INTEGER I, J, nnzero
C .. External Subroutines ..
C
C
if ((descra(1:1).eq.'g').or.(descra(1:1).eq.'G')) then
write(iout,fmt=998)
else if ((descra(1:1).eq.'s').or.(descra(1:1).eq.'S')) then
write(iout,fmt=997)
else
write(iout,fmt=998)
endif
nnzero = ia(m+1) -1
write(iout,fmt=992)
write(iout,fmt=996)
write(iout,fmt=996) title
write(iout,fmt=995) 'Number of rows: ',m
write(iout,fmt=995) 'Number of columns: ',n
write(iout,fmt=995) 'Nonzero entries: ',nnzero
write(iout,fmt=996)
write(iout,fmt=992)
write(iout,*) m,n,nnzero
998 format('%%MatrixMarket matrix coordinate real general')
997 format('%%MatrixMarket matrix coordinate real symmetric')
992 format('%======================================== ')
996 format('% ',a)
995 format('% ',a,i9,a,i9,a,i9)
do i=1, m
do j=ia(i),ia(i+1)-1
write(iout,fmt=994) i,ja(j),ar(j)
994 format(i6,1x,i6,1x,e16.8)
enddo
enddo
RETURN
END

9
base/serial/csr/dcsrsm.f
Unescape Escape View File

@ -38,8 +38,6 @@ C
CHARACTER DESCRA*11 CHARACTER DESCRA*11
INTEGER I, K INTEGER I, K
CHARACTER DIAG, UPLO CHARACTER DIAG, UPLO
LOGICAL DEBUG
PARAMETER (DEBUG=.FALSE.)
C .. Local Arrays .. C .. Local Arrays ..
CHARACTER*20 NAME CHARACTER*20 NAME
INTEGER INT_VAL(5), err_Act INTEGER INT_VAL(5), err_Act
@ -97,13 +95,6 @@ C .. Local Arrays ..
GOTO 9999 GOTO 9999
END IF END IF
if (debug) then
write(0,*) 'Check from DCSRSM'
do k=1,m
write(0,*) k, b(k,1),c(k,1)
enddo
endif
IF (UNITD.EQ.'L') THEN IF (UNITD.EQ.'L') THEN
DO 45 I = 1, N DO 45 I = 1, N
DO 25 K = 1, M DO 25 K = 1, M

29
base/serial/csr/zcrnrmi.f
Unescape Escape View File

@ -1,3 +1,32 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
DOUBLE PRECISION FUNCTION ZCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, DOUBLE PRECISION FUNCTION ZCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2,
& INFOA,IERROR) & INFOA,IERROR)
IMPLICIT NONE IMPLICIT NONE

29
base/serial/csr/zcsrmm.f
Unescape Escape View File

@ -1,4 +1,33 @@
C C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
C
C SUBROUTINE ZCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, C SUBROUTINE ZCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR,
C * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK) C * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK)
C C

29
base/serial/csr/zcsrrws.f
Unescape Escape View File

@ -1,3 +1,32 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
SUBROUTINE ZCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, SUBROUTINE ZCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2,
& INFOA,ROWSUM,IERROR) & INFOA,ROWSUM,IERROR)
IMPLICIT NONE IMPLICIT NONE

29
base/serial/csr/zsrmv.f
Unescape Escape View File

@ -1,3 +1,32 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
*********************************************************************** ***********************************************************************
* ZSRMV modified for SPARKER * * ZSRMV modified for SPARKER *
* * * *

29
base/serial/csr/zsrsv.f
Unescape Escape View File

@ -1,3 +1,32 @@
C
C Parallel Sparse BLAS v2.0
C (C) Copyright 2006 Salvatore Filippone University of Rome Tor Vergata
C Alfredo Buttari University of Rome Tor Vergata
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions
C are met:
C 1. Redistributions of source code must retain the above copyright
C notice, this list of conditions and the following disclaimer.
C 2. Redistributions in binary form must reproduce the above copyright
C notice, this list of conditions, and the following disclaimer in the
C documentation and/or other materials provided with the distribution.
C 3. The name of the PSBLAS group or the names of its contributors may
C not be used to endorse or promote products derived from this
C software without specific written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
C POSSIBILITY OF SUCH DAMAGE.
C
SUBROUTINE ZSRSV (UPLO,TRANS,DIAG,N,AS,JA,IA,B,X) SUBROUTINE ZSRSV (UPLO,TRANS,DIAG,N,AS,JA,IA,B,X)
COMPLEX*16 ZERO COMPLEX*16 ZERO
PARAMETER (ZERO = (0.0D0, 0.0D0)) PARAMETER (ZERO = (0.0D0, 0.0D0))

31
base/serial/dp/dcoco.f
Unescape Escape View File

@ -33,7 +33,7 @@ c
subroutine dcoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info, subroutine dcoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info,
* p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n,
* lia2n,aux,laux,ierror) * lia2n,aux,laux,ierror)
use psb_error_mod
use psb_const_mod use psb_const_mod
use psb_spmat_type use psb_spmat_type
use psb_string_mod use psb_string_mod
@ -55,8 +55,7 @@ c .. local scalars ..
integer elem_in, elem_out integer elem_in, elem_out
logical scale logical scale
integer max_nnzero integer max_nnzero
logical debug integer :: debug_level, debug_unit
parameter (debug=.false.)
c .. local arrays .. c .. local arrays ..
character*20 name character*20 name
integer int_val(5) integer int_val(5)
@ -69,9 +68,11 @@ c .. external subroutines ..
c .. executable statements .. c .. executable statements ..
c c
name = 'dcoco\0' name = 'dcoco'
ierror = 0 ierror = 0
call fcpsb_erractionsave(err_act) call fcpsb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
@ -81,8 +82,8 @@ c
p2(1) = 0 p2(1) = 0
call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror) call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror)
if (debug) then if (debug_level >= psb_debug_serial_) then
write(*,*) 'on entry to dcoco: nnz laux ', write(debug_unit,*) trim(name),': on entry nnz laux ',
+ nnz,laux,larn,lia1n,lia2n + nnz,laux,larn,lia1n,lia2n
endif endif
if (laux.lt.nnz+2) then if (laux.lt.nnz+2) then
@ -119,14 +120,16 @@ c
c c
c sort COO data structure c sort COO data structure
c c
if (debug) write(*,*)'first sort',nnz if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': first sort',nnz
do k=1, nnz do k=1, nnz
arn(k) = ar(k) arn(k) = ar(k)
ia1n(k) = ia1(k) ia1n(k) = ia1(k)
ia2n(k) = ia2(k) ia2n(k) = ia2(k)
enddo enddo
if (debug) write(*,*)'second sort' if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': second sort'
if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1)) if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1))
+ .and.(laux.ge.2*(2+nnz))) then + .and.(laux.ge.2*(2+nnz))) then
@ -145,7 +148,9 @@ c
ia2n(ip1+psb_nnzt_) = nnz ia2n(ip1+psb_nnzt_) = nnz
ia2n(ip1+psb_nnz_) = 0 ia2n(ip1+psb_nnz_) = 0
ia2n(ip1+psb_ichk_) = nnz+check_flag ia2n(ip1+psb_ichk_) = nnz+check_flag
if (debug) write(0,*) 'build check :',ia2n(ip1+psb_nnzt_) if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': build check :',ia2n(ip1+psb_nnzt_)
c .... order with key ia1n ... c .... order with key ia1n ...
call msort_up(nnz,ia1n,aux,iret) call msort_up(nnz,ia1n,aux,iret)
@ -183,7 +188,7 @@ c ... error, there are duplicated elements ...
c ... insert only the first duplicated element ... c ... insert only the first duplicated element ...
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... add the duplicated element ... c ... sum the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in) arn(elem_out) = arn(elem_out) + arn(elem_in)
ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out
end if end if
@ -230,7 +235,7 @@ c ... error, there are duplicated elements ...
else if (check_flag.eq.psb_dupl_ovwrt_) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the first duplicated element ... c ... insert only the first duplicated element ...
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... add the duplicated element ... c ... sum the duplicated element ...
arn(elem_out) = arn(elem_out) + arn(elem_in) arn(elem_out) = arn(elem_out) + arn(elem_in)
end if end if
else else
@ -244,7 +249,9 @@ c ... add the duplicated element ...
infon(psb_nnz_) = elem_out infon(psb_nnz_) = elem_out
infon(psb_srtd_) = psb_isrtdcoo_ infon(psb_srtd_) = psb_isrtdcoo_
if (debug) write(*,*)'done rebuild COO',infon(1) if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': done rebuild COO',infon(1)
else if (toupper(descra(1:1)).eq.'S' .and. else if (toupper(descra(1:1)).eq.'S' .and.
+ toupper(descra(2:2)).eq.'U') then + toupper(descra(2:2)).eq.'U') then

90
base/serial/dp/dcocr.f
Unescape Escape View File

@ -36,6 +36,7 @@ C
* LIAN2,AUX,LAUX,IERROR) * LIAN2,AUX,LAUX,IERROR)
use psb_const_mod use psb_const_mod
use psb_error_mod
use psb_spmat_type use psb_spmat_type
use psb_string_mod use psb_string_mod
IMPLICIT NONE IMPLICIT NONE
@ -57,12 +58,11 @@ C .. Local Scalars ..
integer elem, elem_csr,regen_flag integer elem, elem_csr,regen_flag
logical scale logical scale
integer max_nnzero integer max_nnzero
logical debug
parameter (debug=.false.)
integer, allocatable :: itmp(:) integer, allocatable :: itmp(:)
c .. local arrays .. c .. local arrays ..
character*20 name character*20 name
integer int_val(5) integer int_val(5)
integer :: debug_level, debug_unit
c c
C ...Common variables... C ...Common variables...
@ -72,9 +72,11 @@ C .. External Subroutines ..
C .. Executable Statements .. C .. Executable Statements ..
C C
NAME = 'DCOCR\0' NAME = 'DCOCR'
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
@ -84,10 +86,9 @@ C
SCALE = (toupper(UNITD).EQ.'L') ! meaningless SCALE = (toupper(UNITD).EQ.'L') ! meaningless
P1(1) = 0 P1(1) = 0
P2(1) = 0 P2(1) = 0
nnz = info(1) nnz = info(1)
if (debug) then if (debug_level >= psb_debug_serial_) then
write(0,*) 'On entry to DCOCR: NNZ LAUX ', write(debug_unit,*) trim(name),': On entry NNZ LAUX ',
+ nnz,laux,larn,lian1,lian2 + nnz,laux,larn,lian1,lian2
endif endif
IF (LAUX.LT.NNZ+2) THEN IF (LAUX.LT.NNZ+2) THEN
@ -139,10 +140,9 @@ C
C C
C Sort COO data structure C Sort COO data structure
C C
if (debug) write(0,*)'First sort',nnz if (debug_level >= psb_debug_serial_)
c$$$ write(0,*) 'DCOCR Sizes ',lian2,((m+1)+nnz+psb_ireg_flgs_+1), + write(debug_unit,*) trim(name),': First sort',nnz
c$$$ + m+1,nnz,psb_ireg_flgs_,
c$$$ + laux,2*(2+nnz)
if ((regen_flag==psb_upd_perm_).and. if ((regen_flag==psb_upd_perm_).and.
+ (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) + (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
+ .and.(laux.ge.2*(2+nnz))) then + .and.(laux.ge.2*(2+nnz))) then
@ -162,17 +162,22 @@ c
ian2(ip1+psb_nnz_) = 0 ian2(ip1+psb_nnz_) = 0
ian2(ip1+psb_ichk_) = nnz+check_flag ian2(ip1+psb_ichk_) = nnz+check_flag
if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_) if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Build check :',ian2(ip1+psb_nnzt_)
C .... Order with key IA ... C .... Order with key IA ...
call msort_up(nnz,itmp,aux,iret) call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call reordvn3(nnz,arn,itmp,ian1,aux(ipx),aux) if (iret.eq.0) call reordvn3(nnz,arn,itmp,ian1,aux(ipx),aux)
if (debug) then if (debug_level >= psb_debug_serial_) then
do i=1, nnz-1 do i=1, nnz-1
if (itmp(i).gt.itmp(i+1)) then if (itmp(i).gt.itmp(i+1)) then
write(0,*) 'Sorting error:',i,itmp(i),itmp(i+1) write(debug_unit,*) trim(name),
+ 'Sorting error:',i,itmp(i),itmp(i+1)
endif endif
enddo enddo
write(0,*) 'nnz :',m,nnz,itmp(nnz),ian1(nnz) write(debug_unit,*) trim(name),
+ 'nnz :',m,nnz,itmp(nnz),ian1(nnz)
endif endif
C .... Order with key JA ... C .... Order with key JA ...
@ -200,7 +205,10 @@ c ... Insert first element ...
do row = 1, itmp(1) do row = 1, itmp(1)
ian2(row) = 1 ian2(row) = 1
enddo enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem) ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem) arn(elem_csr) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
@ -233,14 +241,10 @@ c ... error, there are duplicated elements ...
c ... insert only the last duplicated element ... c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem) arn(elem_csr-1) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
if (debug) write(0,*) 'duplicated overwrite perm ',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
if (debug) write(0,*) 'duplicated add perm ',
+ elem_csr-1,elem
end if end if
endif endif
elem = elem + 1 elem = elem + 1
@ -280,7 +284,10 @@ C ... Insert first element ...
do row = 1, itmp(1) do row = 1, itmp(1)
ian2(row) = 1 ian2(row) = 1
enddo enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem) ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem) arn(elem_csr) = arn(elem)
elem = elem+1 elem = elem+1
@ -309,13 +316,9 @@ c ... error, there are duplicated elements ...
else if (check_flag.eq.psb_dupl_ovwrt_) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ... c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem) arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if end if
endif endif
elem = elem + 1 elem = elem + 1
@ -324,13 +327,9 @@ c ... sum the duplicated element ...
enddo enddo
endif endif
if (debug) write(0,*)'Done Rebuild CSR', if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': Done Rebuild CSR',
+ ian2(m+1),ia(elem) + ian2(m+1),ia(elem)
c$$$ if (debug) then
c$$$ do i=ian2(m+1), nnz
c$$$ write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
c$$$ enddo
c$$$ endif
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN + toupper(DESCRA(2:2)).EQ.'U') THEN
@ -342,7 +341,6 @@ c$$$ endif
else if (toupper(DESCRA(1:1)).EQ.'T' .AND. else if (toupper(DESCRA(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN + toupper(DESCRA(2:2)).EQ.'U') THEN
call msort_up(nnz,itmp,aux,iret) call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux) if (iret.eq.0) call reordvn(nnz,arn,itmp,ian1,aux)
C .... Order with key JA ... C .... Order with key JA ...
@ -371,7 +369,10 @@ C ... Insert first element ...
do row = 1, itmp(1) do row = 1, itmp(1)
ian2(row) = 1 ian2(row) = 1
enddo enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem) ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem) arn(elem_csr) = arn(elem)
elem = elem+1 elem = elem+1
@ -400,13 +401,9 @@ c ... error, there are duplicated elements ...
else if (check_flag.eq.psb_dupl_ovwrt_) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ... c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem) arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if end if
endif endif
elem = elem + 1 elem = elem + 1
@ -436,8 +433,6 @@ C .... Order with key JA ...
i = j i = j
enddo enddo
C ... Construct CSR Representation... C ... Construct CSR Representation...
elem = 1 elem = 1
elem_csr = 1 elem_csr = 1
@ -445,7 +440,10 @@ C ... Insert first element ...
do row = 1, itmp(1) do row = 1, itmp(1)
ian2(row) = 1 ian2(row) = 1
enddo enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem) ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem) arn(elem_csr) = arn(elem)
elem = elem+1 elem = elem+1
@ -474,13 +472,9 @@ c ... error, there are duplicated elements ...
else if (check_flag.eq.psb_dupl_ovwrt_) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ... c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem) arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if end if
endif endif
elem = elem + 1 elem = elem + 1
@ -488,13 +482,9 @@ c ... sum the duplicated element ...
ian2(row+1) = elem_csr ian2(row+1) = elem_csr
enddo enddo
if (debug) write(0,*)'Done Rebuild CSR', if (debug_level >= psb_debug_serial_)
+ ian2(m+1),ia(elem) + write(debug_unit,*) trim(name),': Done Rebuild CSR',
if (debug) then + ian2(m+1),ia(elem)
do i=ian2(m+1), nnz
write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
enddo
endif
end if end if

18
base/serial/dp/dcrco.f
Unescape Escape View File

@ -35,6 +35,7 @@ C
use psb_const_mod use psb_const_mod
use psb_spmat_type use psb_spmat_type
use psb_string_mod use psb_string_mod
use psb_error_mod
IMPLICIT NONE IMPLICIT NONE
C C
@ -54,23 +55,27 @@ C .. Local Scalars ..
c .. Local Arrays .. c .. Local Arrays ..
CHARACTER*20 NAME CHARACTER*20 NAME
INTEGER INT_VAL(5) INTEGER INT_VAL(5)
logical, parameter :: debug=.false. integer :: debug_level, debug_unit
C .. External Subroutines .. C .. External Subroutines ..
EXTERNAL MAX_NNZERO EXTERNAL MAX_NNZERO
C .. Executable Statements .. C .. Executable Statements ..
C C
NAME = 'DCRCO\0' NAME = 'DCRCO'
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
IF (toupper(TRANS).EQ.'N') THEN IF (toupper(TRANS).EQ.'N') THEN
SCALE = (toupper(UNITD).EQ.'L') ! meaningless SCALE = (toupper(UNITD).EQ.'L') ! meaningless
IP1(1) = 0 IP1(1) = 0
IP2(1) = 0 IP2(1) = 0
NNZ = IA2(M+1)-1 NNZ = IA2(M+1)-1
if (debug) write(0,*) 'CRCO: ',m,n,nnz,' : ', if (debug_level >= psb_debug_serial_)
+ descra,' : ',descrn + write(debug_unit,*) trim(name),': entry',m,n,nnz,
+ ' : ',descra,' : ',descrn
IF (LARN.LT.NNZ) THEN IF (LARN.LT.NNZ) THEN
IERROR = 60 IERROR = 60
INT_VAL(1) = 18 INT_VAL(1) = 18
@ -106,7 +111,10 @@ C ... Construct COO Representation...
ENDDO ENDDO
ENDDO ENDDO
INFON(psb_nnz_) = elem INFON(psb_nnz_) = elem
if (debug) write(0,*) 'CRCO endloop',m,elem
if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': endloop',m,elem
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN + toupper(DESCRA(2:2)).EQ.'U') THEN

12
base/serial/dp/dcrcr.f
Unescape Escape View File

@ -188,18 +188,20 @@ C .. Intrinsic Functions ..
C .. Executable Statements .. C .. Executable Statements ..
C C
EXIT=.FALSE. EXIT=.FALSE.
NAME = 'DCOCO\0' NAME = 'DCRCR'
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
C C
C Check for argument errors C Check for argument errors
C C
idescra=toupper(descra) idescra=toupper(descra)
IF(((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. IF (((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR.
& idescra(1:1) .EQ. 'A') .AND. (toupper(unitd) .NE. 'B')) .OR. & idescra(1:1) .EQ. 'A') .AND. (toupper(unitd) .NE. 'B'))
+ .OR.
& (.NOT.((idescra(3:3).EQ.'N').OR.(idescra(3:3).EQ.'L').OR. & (.NOT.((idescra(3:3).EQ.'N').OR.(idescra(3:3).EQ.'L').OR.
+ (idescra(3:3).EQ.'U'))) .OR. + (idescra(3:3).EQ.'U')))
+ toupper(TRANS).NE.'N') THEN + .OR.
+ toupper(TRANS).NE.'N') THEN
IERROR = 20 IERROR = 20
ENDIF ENDIF
IF(LAN.LT.(IA2(M+1)-1)) THEN IF(LAN.LT.(IA2(M+1)-1)) THEN

2
base/serial/dp/dcrjd.f
Unescape Escape View File

@ -78,8 +78,6 @@ C .. Local Scalars ..
INTEGER IOFF, ISTROW, NJA, NZ, PIA, INTEGER IOFF, ISTROW, NJA, NZ, PIA,
+ PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT + PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT
LOGICAL SCALE LOGICAL SCALE
logical debug
parameter (debug=.false.)
CHARACTER UPLO CHARACTER UPLO
INTEGER MAX_NNZERO INTEGER MAX_NNZERO
c .. Local Arrays .. c .. Local Arrays ..

3
base/serial/dp/djadrp1.f
Unescape Escape View File

@ -114,8 +114,6 @@ C .. Local Scalars ..
INTEGER I, K, IPG, ERR_ACT INTEGER I, K, IPG, ERR_ACT
C .. Intrinsic Functions .. C .. Intrinsic Functions ..
INTRINSIC DBLE INTRINSIC DBLE
LOGICAL DEBUG
PARAMETER (DEBUG=.FALSE.)
C .. Local Arrays .. C .. Local Arrays ..
CHARACTER*20 NAME CHARACTER*20 NAME
INTEGER INT_VAL(5) INTEGER INT_VAL(5)
@ -127,7 +125,6 @@ C
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
IF(toupper(TRANS).EQ.'N') THEN IF(toupper(TRANS).EQ.'N') THEN
IF (DEBUG) WRITE(0,*)'DJADRP1:',NG
DO IPG = 1, NG DO IPG = 1, NG
DO K = IA(2,IPG), IA(3,IPG)-1 DO K = IA(2,IPG), IA(3,IPG)-1
DO I = JA(K), JA(K+1) - 1 DO I = JA(K), JA(K+1) - 1

11
base/serial/dp/djdco.f
Unescape Escape View File

@ -32,6 +32,7 @@ C
* IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N, * IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N,
* LIA2N,AUX,LAUX,IERROR) * LIA2N,AUX,LAUX,IERROR)
use psb_const_mod use psb_const_mod
use psb_error_mod
IMPLICIT NONE IMPLICIT NONE
C C
C .. Scalar Arguments .. C .. Scalar Arguments ..
@ -45,21 +46,23 @@ C .. Array Arguments ..
CHARACTER DESCRA*11, DESCRN*11 CHARACTER DESCRA*11, DESCRN*11
C .. Local Scalars .. C .. Local Scalars ..
INTEGER PIA, PJA, PNG, ERR_ACT INTEGER PIA, PJA, PNG, ERR_ACT
logical debug integer :: debug_level, debug_unit
parameter (debug=.false.)
c .. Local Arrays .. c .. Local Arrays ..
CHARACTER*20 NAME CHARACTER*20 NAME
INTEGER INT_VAL(5) INTEGER INT_VAL(5)
NAME = 'DJDCO\0' NAME = 'DJDCO'
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
PNG = IA2(1) PNG = IA2(1)
PIA = IA2(2) PIA = IA2(2)
PJA = IA2(3) PJA = IA2(3)
if(debug) write(*,*) 'On entry to DJDCO: NNZ LAUX ', if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': On entry NNZ LAUX ',
+ info(1),laux,larn,lia1n,lia2n + info(1),laux,larn,lia1n,lia2n
CALL DJDCOX(TRANS,M,N,DESCRA,AR,IA2(PIA),IA2(PJA), CALL DJDCOX(TRANS,M,N,DESCRA,AR,IA2(PIA),IA2(PJA),

12
base/serial/dp/djdcox.f
Unescape Escape View File

@ -38,6 +38,7 @@ C
use psb_const_mod use psb_const_mod
use psb_string_mod use psb_string_mod
use psb_error_mod
IMPLICIT NONE IMPLICIT NONE
C C
@ -54,8 +55,7 @@ C .. Local Scalars ..
INTEGER IPX, IPG, NNZ, K, ROW, INTEGER IPX, IPG, NNZ, K, ROW,
* I, J, NZL, IRET, ERR_ACT * I, J, NZL, IRET, ERR_ACT
LOGICAL SCALE LOGICAL SCALE
logical debug integer :: debug_level, debug_unit
parameter (debug=.false.)
c .. Local Arrays .. c .. Local Arrays ..
CHARACTER*20 NAME CHARACTER*20 NAME
INTEGER INT_VAL(5) INTEGER INT_VAL(5)
@ -63,9 +63,11 @@ c .. Local Arrays ..
C C
C .. Executable Statements .. C .. Executable Statements ..
C C
NAME = 'DJDCOX\0' NAME = 'DJDCOX'
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
IF (toupper(TRANS).EQ.'N') THEN IF (toupper(TRANS).EQ.'N') THEN
C SCALE = (UNITD.EQ.'L') ! meaningless C SCALE = (UNITD.EQ.'L') ! meaningless
@ -80,8 +82,8 @@ C SCALE = (UNITD.EQ.'L') ! meaningless
NNZ = JA(IA(2,NG+1)-1 +1)-1 NNZ = JA(IA(2,NG+1)-1 +1)-1
if (debug) then if (debug_level >= psb_debug_serial_) then
write(0,*) 'On entry to DJDCOX: NNZ LAUX ', write(debug_unit,*) trim(name),': On entry NNZ LAUX ',
+ nnz,laux,larn,lia1n,lia2n + nnz,laux,larn,lia1n,lia2n
endif endif
IF (LAUX.LT.NNZ+2) THEN IF (LAUX.LT.NNZ+2) THEN

16
base/serial/dp/dvtfg.f
Unescape Escape View File

@ -34,6 +34,7 @@ C
SUBROUTINE DVTFG (UPLO,M,JA,IA,NG,IPA,IPAT,KLEN,IWORK1,IWORK2, SUBROUTINE DVTFG (UPLO,M,JA,IA,NG,IPA,IPAT,KLEN,IWORK1,IWORK2,
* IWORK3) * IWORK3)
use psb_string_mod use psb_string_mod
use psb_error_mod
implicit none implicit none
C .. Scalar Arguments .. C .. Scalar Arguments ..
INTEGER M, NG INTEGER M, NG
@ -45,10 +46,12 @@ C .. Local Scalars ..
INTEGER I, J, L, L0, L1, LEV, NP, iret INTEGER I, J, L, L0, L1, LEV, NP, iret
C .. Intrinsic Functions .. C .. Intrinsic Functions ..
INTRINSIC MAX INTRINSIC MAX
logical debug integer :: debug_level, debug_unit
parameter (debug=.false.) character(len=20) :: name='DVTFG'
C .. Executable Statements .. C .. Executable Statements ..
C C
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
NG = 0 NG = 0
C C
C CHECK ON THE NUMBERS OF THE ELEMENTS OF THE MATRIX C CHECK ON THE NUMBERS OF THE ELEMENTS OF THE MATRIX
@ -152,7 +155,9 @@ C
DO 260 L = 1, L1 DO 260 L = 1, L1
IPA(L) = IWORK3(L) IPA(L) = IWORK3(L)
260 CONTINUE 260 CONTINUE
if (debug) write(0,*) 'DVTFG: Group ',1,':',(ipa(l),l=1,l1) if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Group ',1,':',(ipa(l),l=1,l1)
DO 360 LEV = 2, NG DO 360 LEV = 2, NG
C C
C LOOP ON GROUPS C LOOP ON GROUPS
@ -177,8 +182,9 @@ C
IPA(L0+L) = IWORK3(L0+L) IPA(L0+L) = IWORK3(L0+L)
320 CONTINUE 320 CONTINUE
ENDIF ENDIF
if (debug) write(0,*) 'DVTFG: Group ',lev, if (debug_level >= psb_debug_serial_)
+ ':',(ipa(l0+l),l=1,l1) + write(debug_unit,*) trim(name),
+ ': Group ',lev,':',(ipa(l0+l),l=1,l1)
360 CONTINUE 360 CONTINUE
C C
C IPAT = IPA-1 C IPAT = IPA-1

26
base/serial/dp/zcoco.f
Unescape Escape View File

@ -33,7 +33,7 @@ c
subroutine zcoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info, subroutine zcoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info,
* p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n,
* lia2n,aux,laux,ierror) * lia2n,aux,laux,ierror)
use psb_error_mod
use psb_const_mod use psb_const_mod
use psb_spmat_type use psb_spmat_type
use psb_string_mod use psb_string_mod
@ -55,8 +55,7 @@ c .. local scalars ..
integer elem_in, elem_out integer elem_in, elem_out
logical scale logical scale
integer max_nnzero integer max_nnzero
logical debug integer :: debug_level, debug_unit
parameter (debug=.false.)
c .. local arrays .. c .. local arrays ..
character*20 name character*20 name
integer int_val(5) integer int_val(5)
@ -72,16 +71,19 @@ c
name = 'zcoco' name = 'zcoco'
ierror = 0 ierror = 0
call fcpsb_erractionsave(err_act) call fcpsb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
if (toupper(trans).eq.'N') then if (toupper(trans).eq.'N') then
scale = (toupper(unitd).eq.'L') ! meaningless scale = (toupper(unitd).eq.'L') ! meaningless
p1(1) = 0 p1(1) = 0
p2(1) = 0 p2(1) = 0
call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror) call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror)
if (debug) then if (debug_level >= psb_debug_serial_) then
write(*,*) 'on entry to dcoco: nnz laux ', write(debug_unit,*) trim(name),': on entry nnz laux ',
+ nnz,laux,larn,lia1n,lia2n + nnz,laux,larn,lia1n,lia2n
endif endif
if (laux.lt.nnz+2) then if (laux.lt.nnz+2) then
@ -118,14 +120,16 @@ c
c c
c sort COO data structure c sort COO data structure
c c
if (debug) write(*,*)'first sort',nnz if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': first sort',nnz
do k=1, nnz do k=1, nnz
arn(k) = ar(k) arn(k) = ar(k)
ia1n(k) = ia1(k) ia1n(k) = ia1(k)
ia2n(k) = ia2(k) ia2n(k) = ia2(k)
enddo enddo
if (debug) write(*,*)'second sort' if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': second sort'
if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1)) if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1))
+ .and.(laux.ge.2*(2+nnz))) then + .and.(laux.ge.2*(2+nnz))) then
@ -144,7 +148,9 @@ c
ia2n(ip1+psb_nnzt_) = nnz ia2n(ip1+psb_nnzt_) = nnz
ia2n(ip1+psb_nnz_) = 0 ia2n(ip1+psb_nnz_) = 0
ia2n(ip1+psb_ichk_) = nnz+check_flag ia2n(ip1+psb_ichk_) = nnz+check_flag
if (debug) write(0,*) 'build check :',ia2n(ip1+psb_nnzt_) if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': build check :',ia2n(ip1+psb_nnzt_)
c .... order with key ia1n ... c .... order with key ia1n ...
call msort_up(nnz,ia1n,aux,iret) call msort_up(nnz,ia1n,aux,iret)
@ -244,7 +250,9 @@ c ... sum the duplicated element ...
infon(psb_nnz_) = elem_out infon(psb_nnz_) = elem_out
infon(psb_srtd_) = psb_isrtdcoo_ infon(psb_srtd_) = psb_isrtdcoo_
if (debug) write(*,*)'done rebuild COO',infon(1) if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': done rebuild COO',infon(1)
else if (toupper(descra(1:1)).eq.'S' .and. else if (toupper(descra(1:1)).eq.'S' .and.
+ toupper(descra(2:2)).eq.'U') then + toupper(descra(2:2)).eq.'U') then

100
base/serial/dp/zcocr.f
Unescape Escape View File

@ -36,6 +36,7 @@ C
* LIAN2,AUX,LAUX,IERROR) * LIAN2,AUX,LAUX,IERROR)
use psb_const_mod use psb_const_mod
use psb_error_mod
use psb_spmat_type use psb_spmat_type
use psb_string_mod use psb_string_mod
IMPLICIT NONE IMPLICIT NONE
@ -56,13 +57,12 @@ C .. Local Scalars ..
integer ipx, ip1, ip2, check_flag, err_act integer ipx, ip1, ip2, check_flag, err_act
integer elem, elem_csr,regen_flag integer elem, elem_csr,regen_flag
logical scale logical scale
integer max_nnzero integer max_nnzero
logical debug
parameter (debug=.false.)
integer, allocatable :: itmp(:) integer, allocatable :: itmp(:)
c .. local arrays .. c .. local arrays ..
character*20 name character*20 name
integer int_val(5) integer int_val(5)
integer :: debug_level, debug_unit
C C
C ...Common variables... C ...Common variables...
@ -71,10 +71,11 @@ C .. External Subroutines ..
EXTERNAL MAX_NNZERO EXTERNAL MAX_NNZERO
C .. Executable Statements .. C .. Executable Statements ..
C C
NAME = 'ZCOCR'
NAME = 'ZCOCR\0'
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror)
call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror)
@ -84,10 +85,9 @@ C
SCALE = (toupper(UNITD).EQ.'L') ! meaningless SCALE = (toupper(UNITD).EQ.'L') ! meaningless
P1(1) = 0 P1(1) = 0
P2(1) = 0 P2(1) = 0
nnz = info(1) nnz = info(1)
if (debug) then if (debug_level >= psb_debug_serial_) then
write(0,*) 'On entry to ZCOCR: NNZ LAUX ', write(debug_unit,*) trim(name),': On entry NNZ LAUX ',
+ nnz,laux,larn,lian1,lian2 + nnz,laux,larn,lian1,lian2
endif endif
IF (LAUX.LT.NNZ+2) THEN IF (LAUX.LT.NNZ+2) THEN
@ -131,15 +131,17 @@ C
ian1(k) = ja(k) ian1(k) = ja(k)
itmp(k) = ia(k) itmp(k) = ia(k)
enddo enddo
! Mark as unavailable by default.
infon(psb_upd_pnt_) = 0
IF (toupper(descra(1:1)).EQ.'G') THEN IF (toupper(descra(1:1)).EQ.'G') THEN
C C
C Sort COO data structure C Sort COO data structure
C C
if (debug) write(0,*)'First sort',nnz if (debug_level >= psb_debug_serial_)
c$$$ write(0,*) 'ZCOCR Sizes ',lian2,((m+1)+nnz+psb_ireg_flgs_+1), + write(debug_unit,*) trim(name),': First sort',nnz
c$$$ + m+1,nnz,psb_ireg_flgs_,
c$$$ + laux,2*(2+nnz)
if ((regen_flag==psb_upd_perm_).and. if ((regen_flag==psb_upd_perm_).and.
+ (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) + (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1))
+ .and.(laux.ge.2*(2+nnz))) then + .and.(laux.ge.2*(2+nnz))) then
@ -159,24 +161,23 @@ c
ian2(ip1+psb_nnz_) = 0 ian2(ip1+psb_nnz_) = 0
ian2(ip1+psb_ichk_) = nnz+check_flag ian2(ip1+psb_ichk_) = nnz+check_flag
c$$$ write(0,*)'ZCOCR Check: ',ip2,ian2(ip1+psb_iflag_), if (debug_level >= psb_debug_serial_)
c$$$ + ian2(ip1+psb_nnzt_), ian2(ip1+psb_nnz_), + write(debug_unit,*) trim(name),
c$$$ + ian2(ip1+psb_ichk_) + ': Build check :',ian2(ip1+psb_nnzt_)
c$$$ + ip1,ip2,nnz,ian2(ip1+nnzt_)
if (debug) write(0,*) 'Build check :',ian2(ip1+psb_nnzt_)
C .... Order with key IA ... C .... Order with key IA ...
call msort_up(nnz,itmp,aux,iret) call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) if (iret.eq.0)
+ call zreordvn3(nnz,arn,itmp,ian1,aux(ipx),aux) + call zreordvn3(nnz,arn,itmp,ian1,aux(ipx),aux)
if (debug) then if (debug_level >= psb_debug_serial_) then
do i=1, nnz-1 do i=1, nnz-1
if (itmp(i).gt.itmp(i+1)) then if (itmp(i).gt.itmp(i+1)) then
write(0,*) 'Sorting error:',i,itmp(i),itmp(i+1) write(debug_unit,*) trim(name),
+ 'Sorting error:',i,itmp(i),itmp(i+1)
endif endif
enddo enddo
write(0,*) 'nnz :',m,nnz,itmp(nnz),ian1(nnz) write(debug_unit,*) trim(name),
+ 'nnz :',m,nnz,itmp(nnz),ian1(nnz)
endif endif
C .... Order with key JA ... C .... Order with key JA ...
@ -204,7 +205,10 @@ c ... Insert first element ...
do row = 1, itmp(1) do row = 1, itmp(1)
ian2(row) = 1 ian2(row) = 1
enddo enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem) ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem) arn(elem_csr) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr ian2(ip2+aux(ipx+elem-1)-1) = elem_csr
@ -237,14 +241,10 @@ c ... error, there are duplicated elements ...
c ... insert only the last duplicated element ... c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem) arn(elem_csr-1) = arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
if (debug) write(0,*) 'duplicated overwrite perm ',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1
if (debug) write(0,*) 'duplicated add perm ',
+ elem_csr-1,elem
end if end if
endif endif
elem = elem + 1 elem = elem + 1
@ -284,7 +284,10 @@ C ... Insert first element ...
do row = 1, itmp(1) do row = 1, itmp(1)
ian2(row) = 1 ian2(row) = 1
enddo enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem) ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem) arn(elem_csr) = arn(elem)
elem = elem+1 elem = elem+1
@ -313,13 +316,9 @@ c ... error, there are duplicated elements ...
else if (check_flag.eq.psb_dupl_ovwrt_) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ... c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem) arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if end if
endif endif
elem = elem + 1 elem = elem + 1
@ -328,13 +327,9 @@ c ... sum the duplicated element ...
enddo enddo
endif endif
if (debug) write(0,*)'Done Rebuild CSR', if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': Done Rebuild CSR',
+ ian2(m+1),ia(elem) + ian2(m+1),ia(elem)
c$$$ if (debug) then
c$$$ do i=ian2(m+1), nnz
c$$$ write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
c$$$ enddo
c$$$ endif
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN + toupper(DESCRA(2:2)).EQ.'U') THEN
@ -346,7 +341,6 @@ c$$$ endif
else if (toupper(DESCRA(1:1)).EQ.'T' .AND. else if (toupper(DESCRA(1:1)).EQ.'T' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN + toupper(DESCRA(2:2)).EQ.'U') THEN
call msort_up(nnz,itmp,aux,iret) call msort_up(nnz,itmp,aux,iret)
if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux) if (iret.eq.0) call zreordvn(nnz,arn,itmp,ian1,aux)
C .... Order with key JA ... C .... Order with key JA ...
@ -375,7 +369,10 @@ C ... Insert first element ...
do row = 1, itmp(1) do row = 1, itmp(1)
ian2(row) = 1 ian2(row) = 1
enddo enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem) ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem) arn(elem_csr) = arn(elem)
elem = elem+1 elem = elem+1
@ -404,13 +401,9 @@ c ... error, there are duplicated elements ...
else if (check_flag.eq.psb_dupl_ovwrt_) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ... c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem) arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if end if
endif endif
elem = elem + 1 elem = elem + 1
@ -440,8 +433,6 @@ C .... Order with key JA ...
i = j i = j
enddo enddo
C ... Construct CSR Representation... C ... Construct CSR Representation...
elem = 1 elem = 1
elem_csr = 1 elem_csr = 1
@ -449,7 +440,10 @@ C ... Insert first element ...
do row = 1, itmp(1) do row = 1, itmp(1)
ian2(row) = 1 ian2(row) = 1
enddo enddo
if (debug) write(0,*)'Rebuild CSR',ia(1),elem_csr if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),
+ ': Rebuild CSR',ia(1),elem_csr
ian1(elem_csr) = ian1(elem) ian1(elem_csr) = ian1(elem)
arn(elem_csr) = arn(elem) arn(elem_csr) = arn(elem)
elem = elem+1 elem = elem+1
@ -478,13 +472,9 @@ c ... error, there are duplicated elements ...
else if (check_flag.eq.psb_dupl_ovwrt_) then else if (check_flag.eq.psb_dupl_ovwrt_) then
c ... insert only the last duplicated element ... c ... insert only the last duplicated element ...
arn(elem_csr-1) = arn(elem) arn(elem_csr-1) = arn(elem)
if (debug) write(0,*) 'Duplicated overwrite srch',
+ elem_csr-1,elem
else if (check_flag.eq.psb_dupl_add_) then else if (check_flag.eq.psb_dupl_add_) then
c ... sum the duplicated element ... c ... sum the duplicated element ...
arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) arn(elem_csr-1) = arn(elem_csr-1) + arn(elem)
if (debug) write(0,*) 'Duplicated add srch',
+ elem_csr-1,elem
end if end if
endif endif
elem = elem + 1 elem = elem + 1
@ -492,13 +482,9 @@ c ... sum the duplicated element ...
ian2(row+1) = elem_csr ian2(row+1) = elem_csr
enddo enddo
if (debug) write(0,*)'Done Rebuild CSR', if (debug_level >= psb_debug_serial_)
+ ian2(m+1),ia(elem) + write(debug_unit,*) trim(name),': Done Rebuild CSR',
if (debug) then + ian2(m+1),ia(elem)
do i=ian2(m+1), nnz
write(0,*) 'Overflow check :',ia(i),ja(i),ar(i)
enddo
endif
end if end if

20
base/serial/dp/zcrco.f
Unescape Escape View File

@ -35,6 +35,7 @@ C
use psb_const_mod use psb_const_mod
use psb_spmat_type use psb_spmat_type
use psb_string_mod use psb_string_mod
use psb_error_mod
IMPLICIT NONE IMPLICIT NONE
C C
@ -54,21 +55,27 @@ C .. Local Scalars ..
c .. Local Arrays .. c .. Local Arrays ..
CHARACTER*20 NAME CHARACTER*20 NAME
INTEGER INT_VAL(5) INTEGER INT_VAL(5)
integer :: debug_level, debug_unit
C .. External Subroutines .. C .. External Subroutines ..
EXTERNAL MAX_NNZERO EXTERNAL MAX_NNZERO
C .. Executable Statements .. C .. Executable Statements ..
C C
NAME = 'ZCRCO\0' NAME = 'ZCRCO'
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
IF (toupper(TRANS).EQ.'N') THEN IF (toupper(TRANS).EQ.'N') THEN
SCALE = (toupper(UNITD).EQ.'L') ! meaningless SCALE = (toupper(UNITD).EQ.'L') ! meaningless
IP1(1) = 0 IP1(1) = 0
IP2(1) = 0 IP2(1) = 0
NNZ = IA2(M+1)-1 NNZ = IA2(M+1)-1
if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': entry',m,n,nnz,
+ ' : ',descra,' : ',descrn
IF (LARN.LT.NNZ) THEN IF (LARN.LT.NNZ) THEN
IERROR = 60 IERROR = 60
INT_VAL(1) = 18 INT_VAL(1) = 18
@ -93,17 +100,20 @@ C
IF (toupper(DESCRA(1:1)).EQ.'G') THEN IF (toupper(DESCRA(1:1)).EQ.'G') THEN
C ... Construct COO Representation... C ... Construct COO Representation...
ELEM = 1 ELEM = 0
DO ROW = 1, M DO ROW = 1, M
DO J = IA2(ROW), IA2(ROW+1)-1 DO J = IA2(ROW), IA2(ROW+1)-1
ELEM = ELEM + 1
IAN1(ELEM) = ROW IAN1(ELEM) = ROW
IAN2(ELEM) = IA1(J) IAN2(ELEM) = IA1(J)
ARN(ELEM) = AR(J) ARN(ELEM) = AR(J)
ELEM = ELEM + 1
ENDDO ENDDO
ENDDO ENDDO
INFON(psb_nnz_) = IA2(M+1)-1 INFON(psb_nnz_) = elem
if (debug_level >= psb_debug_serial_)
+ write(debug_unit,*) trim(name),': endloop',m,elem
ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND. ELSE IF (toupper(DESCRA(1:1)).EQ.'S' .AND.
+ toupper(DESCRA(2:2)).EQ.'U') THEN + toupper(DESCRA(2:2)).EQ.'U') THEN

2
base/serial/dp/zcrcr.f
Unescape Escape View File

@ -188,7 +188,7 @@ C .. Intrinsic Functions ..
C .. Executable Statements .. C .. Executable Statements ..
C C
EXIT=.FALSE. EXIT=.FALSE.
NAME = 'DCOCO\0' NAME = 'ZCRCR'
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
C C

2
base/serial/dp/zcrjd.f
Unescape Escape View File

@ -78,8 +78,6 @@ C .. Local Scalars ..
INTEGER IOFF, ISTROW, NJA, NZ, PIA, INTEGER IOFF, ISTROW, NJA, NZ, PIA,
+ PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT + PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT
LOGICAL SCALE LOGICAL SCALE
logical debug
parameter (debug=.false.)
CHARACTER UPLO CHARACTER UPLO
INTEGER MAX_NNZERO INTEGER MAX_NNZERO
c .. Local Arrays .. c .. Local Arrays ..

2
base/serial/f77/Makefile
Unescape Escape View File

@ -4,7 +4,7 @@ include ../../../Make.inc
# The object files # The object files
# #
FOBJS = daxpby.o dcsmm.o dcsnmi.o dcsrp.o dcssm.o \ FOBJS = daxpby.o dcsmm.o dcsnmi.o dcsrp.o dcssm.o \
dgelp.o dlpupd.o dswmm.o dswprt.o \ dgelp.o dlpupd.o dswmm.o \
dswsm.o smmp.o dcsrws.o \ dswsm.o smmp.o dcsrws.o \
zcsnmi.o zaxpby.o zcsmm.o zcssm.o zswmm.o zswsm.o\ zcsnmi.o zaxpby.o zcsmm.o zcssm.o zswmm.o zswsm.o\
zcsrws.o zgelp.o zlpupd.o zcsrws.o zgelp.o zlpupd.o

14
base/serial/f77/dcsrp.f
Unescape Escape View File

@ -118,6 +118,7 @@ C
C C
SUBROUTINE DCSRP(TRANS,M,N,FIDA,DESCRA,IA1,IA2,INFOA, SUBROUTINE DCSRP(TRANS,M,N,FIDA,DESCRA,IA1,IA2,INFOA,
+ P,WORK,LWORK,IERROR) + P,WORK,LWORK,IERROR)
use psb_error_mod
IMPLICIT NONE IMPLICIT NONE
C .. Scalar Arguments .. C .. Scalar Arguments ..
INTEGER LWORK, M, N, IERROR INTEGER LWORK, M, N, IERROR
@ -130,9 +131,7 @@ C .. Array Arguments ..
CHARACTER DESCRA*11, FIDA*5 CHARACTER DESCRA*11, FIDA*5
C .. External Subroutines .. C .. External Subroutines ..
EXTERNAL DCSRRP EXTERNAL DCSRRP
logical debug integer :: debug_level, debug_unit
parameter (debug=.false.)
CHARACTER*20 NAME CHARACTER*20 NAME
C C
C .. Executable Statements .. C .. Executable Statements ..
@ -140,7 +139,9 @@ C
C C
C Check on M, N, TRANS C Check on M, N, TRANS
C C
NAME = 'DCSRP\0' NAME = 'DCSRP'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
IERROR = 0 IERROR = 0
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
@ -167,14 +168,15 @@ C
C C
C Switching on FIDA C Switching on FIDA
C C
c$$$ write(0,*) 'DCSRP FORMAT: ',fida
IF (FIDA(1:3).EQ.'CSR') THEN IF (FIDA(1:3).EQ.'CSR') THEN
C C
C Permuting CSR structure C Permuting CSR structure
C C
CALL DCSRRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK) CALL DCSRRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK)
ELSE IF (FIDA(1:3).EQ.'JAD') THEN ELSE IF (FIDA(1:3).EQ.'JAD') THEN
if (debug) write(0,*) 'Calling djadrp',m,p(1),lwork if (debug_level >= psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),
+ ': Calling djadrp',m,p(1),lwork
CALL DJADRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK) CALL DJADRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK)
ELSE ELSE
C C

27
base/serial/f77/dcssm.f
Unescape Escape View File

@ -196,6 +196,7 @@ C
+ PL,FIDT,DESCRT,T,IT1,IT2,INFOT,PR, + PL,FIDT,DESCRT,T,IT1,IT2,INFOT,PR,
+ B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR)
C .. Scalar Arguments .. C .. Scalar Arguments ..
use psb_error_mod
IMPLICIT NONE IMPLICIT NONE
DOUBLE PRECISION ALPHA, BETA DOUBLE PRECISION ALPHA, BETA
INTEGER N, LDB, LDC, M, LWORK, IERROR INTEGER N, LDB, LDC, M, LWORK, IERROR
@ -211,11 +212,11 @@ C .. Local Scalars ..
C .. Local Array.. C .. Local Array..
INTEGER INT_VAL(5) INTEGER INT_VAL(5)
CHARACTER*30 STRINGS(2) CHARACTER*30 STRINGS(2)
CHARACTER NAME*30 CHARACTER NAME*20
integer :: debug_level, debug_unit
C .. Parameters .. C .. Parameters ..
PARAMETER (ZERO=0.D0) PARAMETER (ZERO=0.D0)
LOGICAL DEBUG
PARAMETER (DEBUG=.FALSE.)
C .. External Subroutines .. C .. External Subroutines ..
EXTERNAL DSWSM, DLPUPD EXTERNAL DSWSM, DLPUPD
C .. Intrinsic Functions .. C .. Intrinsic Functions ..
@ -225,10 +226,12 @@ C
C Check for argument errors C Check for argument errors
C C
IERROR = 0 IERROR = 0
NAME = 'DCSSM\0' NAME = 'DCSSM'
CALL FCPSB_ERRACTIONSAVE(ERR_ACT) CALL FCPSB_ERRACTIONSAVE(ERR_ACT)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
IF (M.LT.0) THEN IF (M.LT.0) THEN
IERROR = 10 IERROR = 10
INT_VAL(1) = 2 INT_VAL(1) = 2
INT_VAL(2) = M INT_VAL(2) = M
@ -299,6 +302,9 @@ C
C C
C Both right and left permutations required C Both right and left permutations required
C C
if (debug_level >= psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': RP LP ',m,n,ierror
CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M) CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M)
CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2,
& INFOT,WORK,M,ZERO,WORK(P),M,WORK(P+LWORKB),LWORK,IERROR) & INFOT,WORK,M,ZERO,WORK(P),M,WORK(P+LWORKB),LWORK,IERROR)
@ -314,7 +320,9 @@ C
C C
C Only right permutation required C Only right permutation required
C C
c$$$ write(0,*) 'DCSSM: RP' if (debug_level >= psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': RP NLP ',m,n,ierror
CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M) CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M)
CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2,
& INFOT,WORK,M,ZERO,C,LDC,WORK(P),LWORK,IERROR) & INFOT,WORK,M,ZERO,C,LDC,WORK(P),LWORK,IERROR)
@ -330,7 +338,8 @@ c$$$ write(0,*) 'DCSSM: RP'
C C
C Only left permutation required C Only left permutation required
C C
c$$$ write(0,*) 'DCSSM: LP' if (debug_level >= psb_debug_serial_comp_)
+ write(debug_unit,*) trim(name),': NRP LP ',m,n,ierror
CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2,
& INFOT,B,LDB,BETA,WORK,M,WORK(P),LWORK,IERROR) & INFOT,B,LDB,BETA,WORK,M,WORK(P),LWORK,IERROR)
LWORKS = IDINT(WORK(P)) LWORKS = IDINT(WORK(P))
@ -345,8 +354,8 @@ c$$$ write(0,*) 'DCSSM: LP'
C C
C Only triangular systems solver required C Only triangular systems solver required
C C
if (debug) write(*,*) 'DCSSM ',m,n if (debug_level >= psb_debug_serial_comp_)
if (debug) write(*,*) 'DCSSM ',m,n,ierror + write(debug_unit,*) trim(name),': NRP NLP ',m,n,ierror
CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2,
& INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR)
LWORKS = IDINT(WORK(1)) LWORKS = IDINT(WORK(1))

Some files were not shown because too many files have changed in this diff Show More

Write Preview
Loading…
Cancel
Save