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

Fixes for environment routines: take away traces of BLACS except from psb_penv_mod.f90.

Browse Source
psblas3-type-indexed
Salvatore Filippone 20 years ago
parent 44df8d6b19
commit c0b8a0758a
33 changed files with 4640 additions and 738 deletions
Show Stats Download Patch File Download Diff File

18
docs/pdf/toolsrout.tex
Unescape Escape View File

@ -1032,7 +1032,7 @@ Type, rank and size must agree on all processes.
\subroutine{psb\_sum}{Global sum} \subroutine{psb\_sum}{Global sum}
\syntax{call psb\_sum}{ictxt, dat, dst} \syntax{call psb\_sum}{ictxt, dat, root}
This subroutine implements a sum reduction operation based on the This subroutine implements a sum reduction operation based on the
underlying communication library. underlying communication library.
@ -1049,11 +1049,11 @@ Type:{\bf required}.\\
Specified as: an integer, real or complex variable, which may be a Specified as: an integer, real or complex variable, which may be a
scalar, or a rank 1 or 2 array. \ scalar, or a rank 1 or 2 array. \
Type, rank and size must agree on all processes. Type, rank and size must agree on all processes.
\item[dst] Process to hold the final sum, or $-1$ to make it available \item[root] Process to hold the final sum, or $-1$ to make it available
on all processes.\\ on all processes.\\
Scope:{\bf global}.\\ Scope:{\bf global}.\\
Type:{\bf optional}.\\ Type:{\bf optional}.\\
Specified as: an integer value $-1<= dst <= np-1$, default -1. \ Specified as: an integer value $-1<= root <= np-1$, default -1. \
\end{description} \end{description}
@ -1069,7 +1069,7 @@ Type, rank and size must agree on all processes.
\subroutine{psb\_amx}{Global maximum absolute value} \subroutine{psb\_amx}{Global maximum absolute value}
\syntax{call psb\_amx}{ictxt, dat, dst} \syntax{call psb\_amx}{ictxt, dat, root}
This subroutine implements a maximum absolute value reduction This subroutine implements a maximum absolute value reduction
operation based on the underlying communication library. operation based on the underlying communication library.
@ -1086,11 +1086,11 @@ Type:{\bf required}.\\
Specified as: an integer, real or complex variable, which may be a Specified as: an integer, real or complex variable, which may be a
scalar, or a rank 1 or 2 array. \ scalar, or a rank 1 or 2 array. \
Type, rank and size must agree on all processes. Type, rank and size must agree on all processes.
\item[dst] Process to hold the final sum, or $-1$ to make it available \item[root] Process to hold the final sum, or $-1$ to make it available
on all processes.\\ on all processes.\\
Scope:{\bf global}.\\ Scope:{\bf global}.\\
Type:{\bf optional}.\\ Type:{\bf optional}.\\
Specified as: an integer value $-1<= dst <= np-1$, default -1. \\ Specified as: an integer value $-1<= root <= np-1$, default -1. \\
\end{description} \end{description}
@ -1106,7 +1106,7 @@ Type, rank and size must agree on all processes.
\subroutine{psb\_amn}{Global minimum absolute value} \subroutine{psb\_amn}{Global minimum absolute value}
\syntax{call psb\_amn}{ictxt, dat, dst} \syntax{call psb\_amn}{ictxt, dat, root}
This subroutine implements a minimum absolute value reduction This subroutine implements a minimum absolute value reduction
operation based on the underlying communication library. operation based on the underlying communication library.
@ -1123,11 +1123,11 @@ Type:{\bf required}.\\
Specified as: an integer, real or complex variable, which may be a Specified as: an integer, real or complex variable, which may be a
scalar, or a rank 1 or 2 array. \ scalar, or a rank 1 or 2 array. \
Type, rank and size must agree on all processes. Type, rank and size must agree on all processes.
\item[dst] Process to hold the final sum, or $-1$ to make it available \item[root] Process to hold the final sum, or $-1$ to make it available
on all processes.\\ on all processes.\\
Scope:{\bf global}.\\ Scope:{\bf global}.\\
Type:{\bf optional}.\\ Type:{\bf optional}.\\
Specified as: an integer value $-1<= dst <= np-1$, default -1. \\ Specified as: an integer value $-1<= root <= np-1$, default -1. \\
\end{description} \end{description}

21
src/comm/psb_dgather.f90
Unescape Escape View File

@ -51,6 +51,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: locx(:,:) real(kind(1.d0)), intent(in) :: locx(:,:)
@ -146,11 +147,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
k = maxk k = maxk
end if end if
if (myrow == iiroot) then call psb_bcast(ictxt,k,root=iiroot)
call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else
call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -186,7 +183,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
end do end do
end do end do
call dgsum2d(ictxt,'a',' ',m,k,globx(1,jglobx),size(globx,1),root,mycol) call psb_sum(ictxt,globx(1:m,jglobx:jglobx+k-1),root=root)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -255,6 +252,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: locx(:) real(kind(1.d0)), intent(in) :: locx(:)
@ -279,7 +277,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
ictxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -303,7 +301,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
root = -1 root = -1
end if end if
if (root==-1) then if (root==-1) then
root=0 iiroot=0
endif endif
jglobx=1 jglobx=1
@ -328,11 +326,6 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
k = 1 k = 1
if (myrow == root) then
call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else
call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, root, 0)
end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -366,7 +359,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
i=i+2 i=i+2
end do end do
call dgsum2d(ictxt,'a',' ',m,k,globx,size(globx),root,mycol) call psb_sum(ictxt,globx(1:m),root=root)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

24
src/comm/psb_zgather.f90
Unescape Escape View File

@ -51,7 +51,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,&
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
complex(kind(1.d0)), intent(in) :: locx(:,:) complex(kind(1.d0)), intent(in) :: locx(:,:)
@ -147,11 +147,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,&
k = maxk k = maxk
end if end if
if (myrow == iiroot) then call psb_bcast(ictxt,k,root=iiroot)
call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else
call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -187,7 +183,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,&
end do end do
end do end do
call gsum2d(ictxt,'a',globx(:,jglobx),rrt=root) call psb_sum(ictxt,globx(1:m,jglobx:jglobx+k-1),root=root)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -256,7 +252,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
complex(kind(1.d0)), intent(in) :: locx(:) complex(kind(1.d0)), intent(in) :: locx(:)
@ -281,7 +277,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
ictxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -304,9 +300,6 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
else else
root = -1 root = -1
end if end if
if (root==-1) then
root=0
endif
jglobx=1 jglobx=1
if (present(iiglobx)) then if (present(iiglobx)) then
@ -330,11 +323,6 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
k = 1 k = 1
if (myrow == root) then
call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else
call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, root, 0)
end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -368,7 +356,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
i=i+2 i=i+2
end do end do
call dgsum2d(ictxt,'a',' ',m,k,globx,size(globx),root,mycol) call psb_sum(ictxt,globx(1:m),root=root)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

11
src/internals/psi_compute_size.f90
Unescape Escape View File

@ -28,11 +28,11 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ POSSIBILITY OF SUCH DAMAGE.
!!$ !!$
!!$ !!$
subroutine psi_compute_size(desc_data,& subroutine psi_compute_size(desc_data, index_in, dl_lda, info)
& index_in, dl_lda, info)
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
! ....scalars parameters.... ! ....scalars parameters....
@ -40,7 +40,7 @@ subroutine psi_compute_size(desc_data,&
! .....array parameters.... ! .....array parameters....
integer :: desc_data(:), index_in(:) integer :: desc_data(:), index_in(:)
! ....local scalars.... ! ....local scalars....
integer :: i,npcol,nprow,mycol,myrow,proc,counter, max_index integer :: i,npcol,nprow,mycol,myrow,proc, max_index
integer :: ictxt, err, err_act, np integer :: ictxt, err, err_act, np
! ...local array... ! ...local array...
integer :: exch(2) integer :: exch(2)
@ -57,7 +57,7 @@ subroutine psi_compute_size(desc_data,&
info = 0 info = 0
ictxt = desc_data(psb_ctxt_) ictxt = desc_data(psb_ctxt_)
call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol) call psb_info(ictxt,myrow,nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -113,8 +113,7 @@ subroutine psi_compute_size(desc_data,&
enddo enddo
! computing max global value of dl_lda ! computing max global value of dl_lda
call igamx2d(ictxt, psb_all_, psb_topdef_, 1, ione, dl_lda, & call psb_amx(ictxt, dl_lda)
&1, counter, counter, -ione ,-ione,-ione)
if (debug) then if (debug) then
write(0,*) 'psi_compute_size: ',dl_lda write(0,*) 'psi_compute_size: ',dl_lda

35
src/internals/psi_extrct_dl.f
Unescape Escape View File

@ -118,7 +118,7 @@ c must communicate with. this list with its order is extracted from
c desc_str list. c desc_str list.
c length_dl integer array(0:np) c length_dl integer array(0:np)
c length_dl(i) is the length of dep_list(*,i) list c length_dl(i) is the length of dep_list(*,i) list
use psb_penv_mod
implicit none implicit none
include 'psb_const.fh' include 'psb_const.fh'
include 'mpif.h' include 'mpif.h'
@ -146,7 +146,7 @@ c .....local scalars...
ictxt = desc_data(psb_ctxt_) ictxt = desc_data(psb_ctxt_)
call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) call psb_info(ictxt,me,nprow)
do i=0,np do i=0,np
length_dl(i) = 0 length_dl(i) = 0
enddo enddo
@ -244,13 +244,10 @@ c ... check for errors...
998 continue 998 continue
if (debug) write(0,*) 'extract: info ',info if (debug) write(0,*) 'extract: info ',info
err = info err = info
c$$$ call igamx2d(ictxt, all, topdef, ione, ione, err, ione,
c$$$ + i, i, -ione ,-ione,-ione)
if (err.ne.0) goto 9999 if (err.ne.0) goto 9999
if (.true.) then call psb_sum(ictxt,length_dl(0:np))
call igsum2d(ictxt,'all',' ',np+1,1,length_dl,np+1,-1,-1)
call blacs_get(ictxt,10,icomm ) call blacs_get(ictxt,10,icomm )
allocate(itmp(dl_lda),stat=info) allocate(itmp(dl_lda),stat=info)
if (info /= 0) goto 9999 if (info /= 0) goto 9999
@ -259,32 +256,6 @@ c$$$ + i, i, -ione ,-ione,-ione)
+ dep_list,dl_lda,mpi_integer,icomm,info) + dep_list,dl_lda,mpi_integer,icomm,info)
deallocate(itmp) deallocate(itmp)
else
if (me.eq.psb_root_) then
do proc=0,np-1
if (proc.ne.psb_root_) then
if (debug) write(0,*) 'receiving from: ',proc
c ...receive from proc length of its dependence list....
call igerv2d(ictxt,1,1,length_dl(proc),1,
+ proc,mycol)
c ...receive from proc its dependence list....
call igerv2d(ictxt,length_dl(proc),1,
+ dep_list(1,proc),length_dl(proc),proc,mycol)
endif
enddo
else if (me.ne.psb_root_) then
c ...send to root dependence list length.....
if (debug) write(0,*) 'sending to: ',me,psb_root_
call igesd2d(ictxt,1,1,length_dl(me),1,psb_root_,mycol)
if (debug) write(0,*) 'sending to: ',me,psb_root_
c ...send to root dependence list....
call igesd2d(ictxt,length_dl(me),1,dep_list(1,me),
+ length_dl(me),psb_root_,mycol)
endif
end if end if
return return

4
src/modules/Makefile
Unescape Escape View File

@ -2,7 +2,7 @@ include ../../Make.inc
MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \ MODULES = psb_realloc_mod.o psb_string_mod.o psb_spmat_type.o \
psb_desc_type.o psb_spsb_mod.o \ psb_desc_type.o psb_spsb_mod.o \
psb_blacs_mod.o psb_serial_mod.o psb_tools_mod.o \ psb_penv_mod.o psb_serial_mod.o psb_tools_mod.o \
psb_prec_type.o psb_error_mod.o psb_prec_mod.o \ psb_prec_type.o psb_error_mod.o psb_prec_mod.o \
psb_methd_mod.o psb_const_mod.o \ psb_methd_mod.o psb_const_mod.o \
psb_comm_mod.o psb_psblas_mod.o psi_mod.o \ psb_comm_mod.o psb_psblas_mod.o psi_mod.o \
@ -17,7 +17,7 @@ psb_realloc_mod.o : psb_error_mod.o
psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o psb_spmat_type.o : psb_realloc_mod.o psb_const_mod.o
psb_error_mod.o: psb_const_mod.o psb_error_mod.o: psb_const_mod.o
psb_const_mod.f90: psb_const.fh psb_const_mod.f90: psb_const.fh
psb_blacs_mod.o : psb_const_mod.o psb_error_mod.o psb_penv_mod.o : psb_const_mod.o psb_error_mod.o
lib: $(MODULES) $(OBJS) lib: $(MODULES) $(OBJS)
$(AR) $(LIBDIR)/$(LIBNAME) $(MODULES) $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(MODULES) $(OBJS)

2
src/modules/psb_all_mod.f90
Unescape Escape View File

@ -35,7 +35,7 @@ module psb_all_mod
use psb_prec_mod use psb_prec_mod
use psb_methd_mod use psb_methd_mod
use psb_serial_mod use psb_serial_mod
use psb_blacs_mod use psb_penv_mod
use psb_comm_mod use psb_comm_mod
use psb_error_mod use psb_error_mod
use psb_psblas_mod use psb_psblas_mod

414
src/modules/psb_blacs_mod.f90
Unescape Escape View File

@ -416,551 +416,551 @@ contains
end subroutine psb_zbcastm end subroutine psb_zbcastm
subroutine psb_iamxs(ictxt,dat,rt,ia) subroutine psb_iamxs(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
integer, intent(inout) :: dat integer, intent(inout) :: dat
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia integer, intent(inout), optional :: ia
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
call gamx2d(ictxt,'A',dat,ria=ia,rrt=rt_) call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_)
else else
call gamx2d(ictxt,'A',dat,rrt=rt_) call gamx2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_iamxs end subroutine psb_iamxs
subroutine psb_iamxv(ictxt,dat,rt,ia) subroutine psb_iamxv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:) integer, intent(inout) :: dat(:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:) integer, intent(inout), optional :: ia(:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:) integer, allocatable :: cia(:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia))) allocate(cia(size(ia)))
call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamx2d(ictxt,'A',dat,rrt=rt_) call gamx2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_iamxv end subroutine psb_iamxv
subroutine psb_iamxm(ictxt,dat,rt,ia) subroutine psb_iamxm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:,:) integer, intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:) integer, intent(inout), optional :: ia(:,:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:,:) integer, allocatable :: cia(:,:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia,1),size(ia,2))) allocate(cia(size(ia,1),size(ia,2)))
call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamx2d(ictxt,'A',dat,rrt=rt_) call gamx2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_iamxm end subroutine psb_iamxm
subroutine psb_damxs(ictxt,dat,rt,ia) subroutine psb_damxs(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat real(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia integer, intent(inout), optional :: ia
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
call gamx2d(ictxt,'A',dat,ria=ia,rrt=rt_) call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_)
else else
call gamx2d(ictxt,'A',dat,rrt=rt_) call gamx2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_damxs end subroutine psb_damxs
subroutine psb_damxv(ictxt,dat,rt,ia) subroutine psb_damxv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:) real(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:) integer, intent(inout), optional :: ia(:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:) integer, allocatable :: cia(:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia))) allocate(cia(size(ia)))
call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamx2d(ictxt,'A',dat,rrt=rt_) call gamx2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_damxv end subroutine psb_damxv
subroutine psb_damxm(ictxt,dat,rt,ia) subroutine psb_damxm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:,:) real(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:) integer, intent(inout), optional :: ia(:,:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:,:) integer, allocatable :: cia(:,:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia,1),size(ia,2))) allocate(cia(size(ia,1),size(ia,2)))
call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamx2d(ictxt,'A',dat,rrt=rt_) call gamx2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_damxm end subroutine psb_damxm
subroutine psb_zamxs(ictxt,dat,rt,ia) subroutine psb_zamxs(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat complex(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia integer, intent(inout), optional :: ia
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
call gamx2d(ictxt,'A',dat,ria=ia,rrt=rt_) call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_)
else else
call gamx2d(ictxt,'A',dat,rrt=rt_) call gamx2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_zamxs end subroutine psb_zamxs
subroutine psb_zamxv(ictxt,dat,rt,ia) subroutine psb_zamxv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:) complex(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:) integer, intent(inout), optional :: ia(:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:) integer, allocatable :: cia(:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia))) allocate(cia(size(ia)))
call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamx2d(ictxt,'A',dat,rrt=rt_) call gamx2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_zamxv end subroutine psb_zamxv
subroutine psb_zamxm(ictxt,dat,rt,ia) subroutine psb_zamxm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:,:) complex(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:) integer, intent(inout), optional :: ia(:,:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:,:) integer, allocatable :: cia(:,:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia,1),size(ia,2))) allocate(cia(size(ia,1),size(ia,2)))
call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamx2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamx2d(ictxt,'A',dat,rrt=rt_) call gamx2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_zamxm end subroutine psb_zamxm
subroutine psb_iamns(ictxt,dat,rt,ia) subroutine psb_iamns(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
integer, intent(inout) :: dat integer, intent(inout) :: dat
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia integer, intent(inout), optional :: ia
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
call gamn2d(ictxt,'A',dat,ria=ia,rrt=rt_) call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_)
else else
call gamn2d(ictxt,'A',dat,rrt=rt_) call gamn2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_iamns end subroutine psb_iamns
subroutine psb_iamnv(ictxt,dat,rt,ia) subroutine psb_iamnv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:) integer, intent(inout) :: dat(:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:) integer, intent(inout), optional :: ia(:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:) integer, allocatable :: cia(:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia))) allocate(cia(size(ia)))
call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamn2d(ictxt,'A',dat,rrt=rt_) call gamn2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_iamnv end subroutine psb_iamnv
subroutine psb_iamnm(ictxt,dat,rt,ia) subroutine psb_iamnm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:,:) integer, intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:) integer, intent(inout), optional :: ia(:,:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:,:) integer, allocatable :: cia(:,:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia,1),size(ia,2))) allocate(cia(size(ia,1),size(ia,2)))
call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamn2d(ictxt,'A',dat,rrt=rt_) call gamn2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_iamnm end subroutine psb_iamnm
subroutine psb_damns(ictxt,dat,rt,ia) subroutine psb_damns(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat real(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia integer, intent(inout), optional :: ia
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
call gamn2d(ictxt,'A',dat,ria=ia,rrt=rt_) call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_)
else else
call gamn2d(ictxt,'A',dat,rrt=rt_) call gamn2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_damns end subroutine psb_damns
subroutine psb_damnv(ictxt,dat,rt,ia) subroutine psb_damnv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:) real(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:) integer, intent(inout), optional :: ia(:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:) integer, allocatable :: cia(:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia))) allocate(cia(size(ia)))
call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamn2d(ictxt,'A',dat,rrt=rt_) call gamn2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_damnv end subroutine psb_damnv
subroutine psb_damnm(ictxt,dat,rt,ia) subroutine psb_damnm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:,:) real(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:) integer, intent(inout), optional :: ia(:,:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:,:) integer, allocatable :: cia(:,:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia,1),size(ia,2))) allocate(cia(size(ia,1),size(ia,2)))
call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamn2d(ictxt,'A',dat,rrt=rt_) call gamn2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_damnm end subroutine psb_damnm
subroutine psb_zamns(ictxt,dat,rt,ia) subroutine psb_zamns(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat complex(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia integer, intent(inout), optional :: ia
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
call gamn2d(ictxt,'A',dat,ria=ia,rrt=rt_) call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_)
else else
call gamn2d(ictxt,'A',dat,rrt=rt_) call gamn2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_zamns end subroutine psb_zamns
subroutine psb_zamnv(ictxt,dat,rt,ia) subroutine psb_zamnv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:) complex(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:) integer, intent(inout), optional :: ia(:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:) integer, allocatable :: cia(:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia))) allocate(cia(size(ia)))
call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamn2d(ictxt,'A',dat,rrt=rt_) call gamn2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_zamnv end subroutine psb_zamnv
subroutine psb_zamnm(ictxt,dat,rt,ia) subroutine psb_zamnm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:,:) complex(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:) integer, intent(inout), optional :: ia(:,:)
integer :: rt_ integer :: root_
integer, allocatable :: cia(:,:) integer, allocatable :: cia(:,:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
if (present(ia)) then if (present(ia)) then
allocate(cia(size(ia,1),size(ia,2))) allocate(cia(size(ia,1),size(ia,2)))
call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=rt_) call gamn2d(ictxt,'A',dat,ria=ia,cia=cia,rrt=root_)
else else
call gamn2d(ictxt,'A',dat,rrt=rt_) call gamn2d(ictxt,'A',dat,rrt=root_)
endif endif
end subroutine psb_zamnm end subroutine psb_zamnm
subroutine psb_isums(ictxt,dat,rt) subroutine psb_isums(ictxt,dat,root)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
integer, intent(inout) :: dat integer, intent(inout) :: dat
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
call gsum2d(ictxt,'A',dat,rrt=rt_) call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_isums end subroutine psb_isums
subroutine psb_isumv(ictxt,dat,rt) subroutine psb_isumv(ictxt,dat,root)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:) integer, intent(inout) :: dat(:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
call gsum2d(ictxt,'A',dat,rrt=rt_) call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_isumv end subroutine psb_isumv
subroutine psb_isumm(ictxt,dat,rt) subroutine psb_isumm(ictxt,dat,root)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:,:) integer, intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
call gsum2d(ictxt,'A',dat,rrt=rt_) call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_isumm end subroutine psb_isumm
subroutine psb_dsums(ictxt,dat,rt) subroutine psb_dsums(ictxt,dat,root)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat real(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
call gsum2d(ictxt,'A',dat,rrt=rt_) call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_dsums end subroutine psb_dsums
subroutine psb_dsumv(ictxt,dat,rt) subroutine psb_dsumv(ictxt,dat,root)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:) real(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
call gsum2d(ictxt,'A',dat,rrt=rt_) call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_dsumv end subroutine psb_dsumv
subroutine psb_dsumm(ictxt,dat,rt) subroutine psb_dsumm(ictxt,dat,root)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:,:) real(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
call gsum2d(ictxt,'A',dat,rrt=rt_) call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_dsumm end subroutine psb_dsumm
subroutine psb_zsums(ictxt,dat,rt) subroutine psb_zsums(ictxt,dat,root)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat complex(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
call gsum2d(ictxt,'A',dat,rrt=rt_) call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_zsums end subroutine psb_zsums
subroutine psb_zsumv(ictxt,dat,rt) subroutine psb_zsumv(ictxt,dat,root)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:) complex(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer :: rt_ integer :: root_
integer, allocatable :: cia(:) integer, allocatable :: cia(:)
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
call gsum2d(ictxt,'A',dat,rrt=rt_) call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_zsumv end subroutine psb_zsumv
subroutine psb_zsumm(ictxt,dat,rt) subroutine psb_zsumm(ictxt,dat,root)
integer, intent(in) :: ictxt integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:,:) complex(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt integer, intent(in), optional :: root
integer :: rt_ integer :: root_
if (present(rt)) then if (present(root)) then
rt_ = rt root_ = root
else else
rt_ = -1 root_ = -1
endif endif
call gsum2d(ictxt,'A',dat,rrt=rt_) call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_zsumm end subroutine psb_zsumm

2
src/modules/psb_error_mod.f90
Unescape Escape View File

@ -109,7 +109,7 @@ contains
integer, intent(inout):: err integer, intent(inout):: err
integer :: temp(2) integer :: temp(2)
integer, parameter :: ione=1 integer, parameter :: ione=1
! Cannot use psb_amx or otherwise we have a recursion in module usage
call igamx2d(ictxt, 'A', ' ', ione, ione, err, ione,& call igamx2d(ictxt, 'A', ' ', ione, ione, err, ione,&
&temp ,temp,-ione ,-ione,-ione) &temp ,temp,-ione ,-ione,-ione)
end subroutine psb_errcomm end subroutine psb_errcomm

3899
src/modules/psb_penv.f90
View File

File diff suppressed because it is too large Load Diff

2
src/modules/psb_sparse_mod.f90
Unescape Escape View File

@ -29,7 +29,7 @@
!!$ !!$
!!$ !!$
module psb_sparse_mod module psb_sparse_mod
use psb_blacs_mod use psb_penv_mod
use psb_descriptor_type use psb_descriptor_type
use psb_prec_type use psb_prec_type
use psb_serial_mod use psb_serial_mod

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

@ -36,6 +36,7 @@
!!$ !!$
subroutine psb_dbldaggrmat(a,desc_a,ac,p,desc_p,info) subroutine psb_dbldaggrmat(a,desc_a,ac,p,desc_p,info)
use psb_serial_mod use psb_serial_mod
use psb_penv_mod
use psb_prec_type use psb_prec_type
use psb_descriptor_type use psb_descriptor_type
use psb_spmat_type use psb_spmat_type
@ -105,6 +106,7 @@ contains
use psb_const_mod use psb_const_mod
use psb_psblas_mod use psb_psblas_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
include 'mpif.h' include 'mpif.h'
@ -248,7 +250,7 @@ contains
nzbr(:) = 0 nzbr(:) = 0
nzbr(myprow+1) = irs nzbr(myprow+1) = irs
call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1) call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr) nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info) call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) then if(info /= 0) then
@ -327,7 +329,7 @@ contains
call psb_errpush(4010,name,a_err='psb_ipcoo2csr') call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
goto 9999 goto 9999
end if end if
call igsum2d(icontxt,'All',' ',1,1,k,1,-1,-1) call psb_sum(ictxt,k)
if (k == 0) then if (k == 0) then
! If the off diagonal part is emtpy, there's no point ! If the off diagonal part is emtpy, there's no point
@ -380,6 +382,7 @@ contains
use psb_comm_mod use psb_comm_mod
use psb_tools_mod use psb_tools_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
include 'mpif.h' include 'mpif.h'
@ -390,7 +393,7 @@ contains
integer, pointer :: nzbr(:), idisp(:), ivall(:) integer, pointer :: nzbr(:), idisp(:), ivall(:)
integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,& integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,&
& naggr, np, myprow, mypcol, nprows, npcols,& & naggr, np, myprow, mypcol, nprows, npcols,&
& icomm, naggrm1,naggrp1,mtype,i,j,err_act,k,nzl,itemp(1),jtemp(1) & icomm, naggrm1,naggrp1,mtype,i,j,err_act,k,nzl
type(psb_dspmat_type), pointer :: am1,am2 type(psb_dspmat_type), pointer :: am1,am2
type(psb_dspmat_type) :: am3,am4 type(psb_dspmat_type) :: am3,am4
logical :: ml_global_nmb logical :: ml_global_nmb
@ -568,7 +571,7 @@ contains
anorm = max(anorm,tmp/dg) anorm = max(anorm,tmp/dg)
enddo enddo
call dgamx2d(ictxt,'All',' ',1,1,anorm,1,itemp,jtemp,-1,-1,-1) call psb_amx(ictxt,anorm)
else else
anorm = psb_spnrmi(am3,desc_a,info) anorm = psb_spnrmi(am3,desc_a,info)
endif endif
@ -850,7 +853,7 @@ contains
call psb_errpush(4010,name,a_err='psb_ipcoo2csr') call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
goto 9999 goto 9999
end if end if
call igsum2d(ictxt,'All',' ',1,1,k,1,-1,-1) call psb_sum(ictxt,k)
if (k == 0) then if (k == 0) then
! If the off diagonal part is emtpy, there's no point ! If the off diagonal part is emtpy, there's no point
@ -900,7 +903,7 @@ contains
call psb_cdrep(ntaggr,ictxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1) call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr) nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info) call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) goto 9999 if(info /= 0) goto 9999
@ -970,7 +973,7 @@ contains
call psb_cdrep(ntaggr,ictxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1) call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr) nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info) call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) then if(info /= 0) then

5
src/prec/psb_dgenaggrmap.f90
Unescape Escape View File

@ -39,6 +39,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
@ -66,7 +67,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! change in the future. ! change in the future.
! !
ictxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(ictxt,nprow,npcol,me,mycol) call psb_info(ictxt,me,nprow)
nrow = desc_a%matrix_data(psb_n_row_) nrow = desc_a%matrix_data(psb_n_row_)
ncol = desc_a%matrix_data(psb_n_col_) ncol = desc_a%matrix_data(psb_n_col_)
@ -279,7 +280,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nlaggr(:) = 0 nlaggr(:) = 0
nlaggr(me+1) = naggr nlaggr(me+1) = naggr
call igsum2d(ictxt,'All',' ',nprow,1,nlaggr,nprow,-1,-1) call psb_sum(ictxt,nlaggr(1:nprow))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

10
src/prec/psb_dmlprc_aply.f90
Unescape Escape View File

@ -44,7 +44,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
use psb_descriptor_type use psb_descriptor_type
use psb_prec_type use psb_prec_type
use psb_psblas_mod use psb_psblas_mod
use psb_blacs_mod use psb_penv_mod
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
implicit none implicit none
@ -161,7 +161,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if end if
if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then
call gsum2d(ictxt,'All',t2l(1:nrg)) call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
& baseprecv(2)%iprcparm(coarse_mat_) & baseprecv(2)%iprcparm(coarse_mat_)
@ -264,7 +264,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if end if
if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then
call gsum2d(ictxt,'All',t2l(1:nrg)) call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
& baseprecv(2)%iprcparm(coarse_mat_) & baseprecv(2)%iprcparm(coarse_mat_)
@ -367,7 +367,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if end if
if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then
call gsum2d(ictxt,'All',t2l(1:nrg)) call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
& baseprecv(2)%iprcparm(coarse_mat_) & baseprecv(2)%iprcparm(coarse_mat_)
@ -458,7 +458,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then
call gsum2d(ictxt,'All',t2l(1:nrg)) call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
& baseprecv(2)%iprcparm(coarse_mat_) & baseprecv(2)%iprcparm(coarse_mat_)

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

@ -42,6 +42,7 @@ subroutine psb_zbldaggrmat(a,desc_a,ac,p,desc_p,info)
use psb_tools_mod use psb_tools_mod
use psb_psblas_mod use psb_psblas_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
type(psb_zspmat_type), intent(in), target :: a type(psb_zspmat_type), intent(in), target :: a
@ -105,6 +106,7 @@ contains
use psb_const_mod use psb_const_mod
use psb_psblas_mod use psb_psblas_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
include 'mpif.h' include 'mpif.h'
@ -114,7 +116,7 @@ contains
integer, pointer :: nzbr(:), idisp(:) integer, pointer :: nzbr(:), idisp(:)
integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,& integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,&
& naggr, np, myprow, mypcol, nprows, npcols,nzt,irs,jl,nzl,nlr,& & naggr, np, myprow, mypcol, nprows, npcols,nzt,irs,jl,nzl,nlr,&
& icomm,naggrm1, mtype, i, j, err_act & icomm,naggrm1, mtype, i, j, k, err_act
name='raw_aggregate' name='raw_aggregate'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
@ -248,7 +250,7 @@ contains
nzbr(:) = 0 nzbr(:) = 0
nzbr(myprow+1) = irs nzbr(myprow+1) = irs
call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1) call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr) nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info) call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) then if(info /= 0) then
@ -279,11 +281,6 @@ contains
bg%infoa(psb_nnz_) = nzbg bg%infoa(psb_nnz_) = nzbg
bg%fida='COO' bg%fida='COO'
bg%descra='G' bg%descra='G'
call psb_fixcoo(bg,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='fixcoo')
goto 9999
end if
call psb_sp_free(b,info) call psb_sp_free(b,info)
if(info /= 0) then if(info /= 0) then
@ -305,11 +302,62 @@ contains
goto 9999 goto 9999
end if end if
!if(.not.associated(p%av(ap_nd_)%aspk)) p%iprcparm(jac_sweeps_) = 1
!------------------------------------------------------------------
! Split BG=M+N N off-diagonal part
call psb_sp_all(bg%m,bg%k,p%av(ap_nd_),nzl,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_all')
goto 9999
end if
if(.not.associated(p%av(ap_nd_)%aspk)) write(0,*) '.not.associated(p%av(ap_nd_)%ia1)'
if(.not.associated(p%av(ap_nd_)%ia1)) write(0,*) '.not.associated(p%av(ap_nd_)%ia1)'
!write(0,*) 'ok line 238'
k=0
do i=1,nzl
if (bg%ia2(i)>bg%m) then
k = k + 1
p%av(ap_nd_)%aspk(k) = bg%aspk(i)
p%av(ap_nd_)%ia1(k) = bg%ia1(i)
p%av(ap_nd_)%ia2(k) = bg%ia2(i)
endif
enddo
p%av(ap_nd_)%infoa(psb_nnz_) = k
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
goto 9999
end if
call psb_sum(ictxt,k)
if (k == 0) then
! If the off diagonal part is emtpy, there's no point
! in doing multiple Jacobi sweeps. This is certain
! to happen when running on a single processor.
p%iprcparm(jac_sweeps_) = 1
end if
!write(0,*) 'operations in bldaggrmat are ok !'
!------------------------------------------------------------------
call psb_ipcoo2csr(p%av(ap_nd_),info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='ipcoo2csr')
goto 9999
end if
else else
write(0,*) 'Unknown p%iprcparm(coarse_mat) in aggregate_sp',p%iprcparm(coarse_mat_) write(0,*) 'Unknown p%iprcparm(coarse_mat) in aggregate_sp',p%iprcparm(coarse_mat_)
end if end if
call psb_ipcoo2csr(bg,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='ipcoo2csr')
goto 9999
end if
deallocate(nzbr,idisp) deallocate(nzbr,idisp)
@ -334,6 +382,7 @@ contains
use psb_comm_mod use psb_comm_mod
use psb_tools_mod use psb_tools_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
include 'mpif.h' include 'mpif.h'
@ -344,7 +393,7 @@ contains
integer, pointer :: nzbr(:), idisp(:), ivall(:) integer, pointer :: nzbr(:), idisp(:), ivall(:)
integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,& integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,&
& naggr, np, myprow, mypcol, nprows, npcols,& & naggr, np, myprow, mypcol, nprows, npcols,&
& icomm, naggrm1,naggrp1,mtype,i,j,err_act,k,nzl,itemp(1),jtemp(1) & icomm, naggrm1,naggrp1,mtype,i,j,err_act,k,nzl
type(psb_zspmat_type), pointer :: am1,am2 type(psb_zspmat_type), pointer :: am1,am2
type(psb_zspmat_type) :: am3,am4 type(psb_zspmat_type) :: am3,am4
logical :: ml_global_nmb logical :: ml_global_nmb
@ -522,7 +571,7 @@ contains
anorm = max(anorm,tmp/dg) anorm = max(anorm,tmp/dg)
enddo enddo
call dgamx2d(ictxt,'All',' ',1,1,anorm,1,itemp,jtemp,-1,-1,-1) call psb_amx(ictxt,anorm)
else else
anorm = psb_spnrmi(am3,desc_a,info) anorm = psb_spnrmi(am3,desc_a,info)
endif endif
@ -804,7 +853,7 @@ contains
call psb_errpush(4010,name,a_err='psb_ipcoo2csr') call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
goto 9999 goto 9999
end if end if
call igsum2d(ictxt,'All',' ',1,1,k,1,-1,-1) call psb_sum(ictxt,k)
if (k == 0) then if (k == 0) then
! If the off diagonal part is emtpy, there's no point ! If the off diagonal part is emtpy, there's no point
@ -854,7 +903,7 @@ contains
call psb_cdrep(ntaggr,ictxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1) call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr) nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info) call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) goto 9999 if(info /= 0) goto 9999
@ -924,7 +973,7 @@ contains
call psb_cdrep(ntaggr,ictxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1) call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr) nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info) call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) then if(info /= 0) then

3
src/prec/psb_zgenaggrmap.f90
Unescape Escape View File

@ -39,6 +39,7 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
@ -279,7 +280,7 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nlaggr(:) = 0 nlaggr(:) = 0
nlaggr(me+1) = naggr nlaggr(me+1) = naggr
call igsum2d(ictxt,'All',' ',nprow,1,nlaggr,nprow,-1,-1) call psb_sum(ictxt,nlaggr(1:nprow))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

10
src/prec/psb_zmlprc_aply.f90
Unescape Escape View File

@ -44,7 +44,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
use psb_descriptor_type use psb_descriptor_type
use psb_prec_type use psb_prec_type
use psb_psblas_mod use psb_psblas_mod
use psb_blacs_mod use psb_penv_mod
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
implicit none implicit none
@ -161,7 +161,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if end if
if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then
call gsum2d(ictxt,'All',t2l(1:nrg)) call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
& baseprecv(2)%iprcparm(coarse_mat_) & baseprecv(2)%iprcparm(coarse_mat_)
@ -264,7 +264,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if end if
if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then
call gsum2d(ictxt,'All',t2l(1:nrg)) call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
& baseprecv(2)%iprcparm(coarse_mat_) & baseprecv(2)%iprcparm(coarse_mat_)
@ -367,7 +367,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if end if
if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then
call gsum2d(ictxt,'All',t2l(1:nrg)) call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
& baseprecv(2)%iprcparm(coarse_mat_) & baseprecv(2)%iprcparm(coarse_mat_)
@ -458,7 +458,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then if (baseprecv(2)%iprcparm(coarse_mat_)==mat_repl_) Then
call gsum2d(ictxt,'All',t2l(1:nrg)) call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',& write(0,*) 'Unknown value for baseprecv(2)%iprcparm(coarse_mat_) ',&
& baseprecv(2)%iprcparm(coarse_mat_) & baseprecv(2)%iprcparm(coarse_mat_)

33
src/psblas/psb_damax.f90
Unescape Escape View File

@ -44,7 +44,7 @@
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
function psb_damax (x,desc_a, info, jx) function psb_damax (x,desc_a, info, jx)
use psb_blacs_mod use psb_penv_mod
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
@ -59,7 +59,7 @@ function psb_damax (x,desc_a, info, jx)
! locals ! locals
integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, m, i, k, imax, idamax & err_act, n, iix, jjx, ix, ijx, m, i, k, imax, idamax
real(kind(1.d0)) :: amax real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -73,7 +73,7 @@ function psb_damax (x,desc_a, info, jx)
ictxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -115,8 +115,7 @@ function psb_damax (x,desc_a, info, jx)
end if end if
! compute global max ! compute global max
call dgamx2d(ictxt, 'A', ' ', ione, ione, amax, ione,& call psb_amx(ictxt, amax)
&temp ,temp,-ione ,-ione,-ione)
psb_damax=amax psb_damax=amax
@ -177,7 +176,7 @@ end function psb_damax
! info - integer. Eventually returns an error code. ! info - integer. Eventually returns an error code.
! !
function psb_damaxv (x,desc_a, info) function psb_damaxv (x,desc_a, info)
use psb_blacs_mod use psb_penv_mod
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
@ -191,7 +190,7 @@ function psb_damaxv (x,desc_a, info)
! locals ! locals
integer :: int_err(5), err, ictxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), err, ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, jx, temp(2), ix, ijx, m, imax, idamax & err_act, n, iix, jjx, jx, ix, ijx, m, imax, idamax
real(kind(1.d0)) :: amax real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -205,7 +204,7 @@ function psb_damaxv (x,desc_a, info)
ictxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -243,7 +242,7 @@ function psb_damaxv (x,desc_a, info)
end if end if
! compute global max ! compute global max
call gamx2d(ictxt, 'A', amax) call psb_amx(ictxt, amax)
psb_damaxv=amax psb_damaxv=amax
@ -306,7 +305,7 @@ end function psb_damaxv
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
subroutine psb_damaxvs (res,x,desc_a, info) subroutine psb_damaxvs (res,x,desc_a, info)
use psb_blacs_mod use psb_penv_mod
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
@ -320,7 +319,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
! locals ! locals
integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, m, imax, idamax & err_act, n, iix, jjx, ix, ijx, m, imax, idamax
real(kind(1.d0)) :: amax real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -334,7 +333,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
ictxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -372,7 +371,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
end if end if
! compute global max ! compute global max
call gamx2d(ictxt, 'A', amax) call psb_amx(ictxt, amax)
res = amax res = amax
@ -433,7 +432,7 @@ end subroutine psb_damaxvs
! info - integer. Eventually returns an error code. ! info - integer. Eventually returns an error code.
! !
subroutine psb_dmamaxs (res,x,desc_a, info,jx) subroutine psb_dmamaxs (res,x,desc_a, info,jx)
use psb_blacs_mod use psb_penv_mod
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
@ -448,7 +447,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
! locals ! locals
integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ix, temp(2), ijx, m, imax, i, k, idamax & err_act, n, iix, jjx, ix, ijx, m, imax, i, k, idamax
real(kind(1.d0)) :: amax real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -462,7 +461,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
ictxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -507,7 +506,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
end if end if
! compute global max ! compute global max
call gamx2d(ictxt, 'A', res(1:k)) call psb_amx(ictxt, res(1:k))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

18
src/psblas/psb_dasum.f90
Unescape Escape View File

@ -49,7 +49,7 @@ function psb_dasum (x,desc_a, info, jx)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:,:) real(kind(1.d0)), intent(in) :: x(:,:)
@ -125,12 +125,12 @@ function psb_dasum (x,desc_a, info, jx)
end do end do
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -199,7 +199,7 @@ function psb_dasumv (x,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:) real(kind(1.d0)), intent(in) :: x(:)
@ -270,12 +270,12 @@ function psb_dasumv (x,desc_a, info)
end do end do
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -344,7 +344,7 @@ subroutine psb_dasumvs (res,x,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:) real(kind(1.d0)), intent(in) :: x(:)
@ -415,12 +415,12 @@ subroutine psb_dasumvs (res,x,desc_a, info)
end do end do
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A',asum) call psb_sum(ictxt,asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
end if end if
else else
asum=0.d0 asum=0.d0

16
src/psblas/psb_ddot.f90
Unescape Escape View File

@ -51,6 +51,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:,:), y(:,:) real(kind(1.d0)), intent(in) :: x(:,:), y(:,:)
@ -145,8 +146,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
end if end if
! compute global sum ! compute global sum
call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,& call psb_sum(ictxt, dot_local)
& ione, mone ,mycol)
psb_ddot = dot_local psb_ddot = dot_local
@ -211,6 +211,7 @@ function psb_ddotv(x, y,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:), y(:) real(kind(1.d0)), intent(in) :: x(:), y(:)
@ -288,8 +289,7 @@ function psb_ddotv(x, y,desc_a, info)
end if end if
! compute global sum ! compute global sum
call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,& call psb_sum(ictxt, dot_local)
& ione, mone ,mycol)
psb_ddotv = dot_local psb_ddotv = dot_local
@ -354,6 +354,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:), y(:) real(kind(1.d0)), intent(in) :: x(:), y(:)
@ -429,8 +430,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
end if end if
! compute global sum ! compute global sum
call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,& call psb_sum(ictxt, dot_local)
& ione, mone ,mycol)
res = dot_local res = dot_local
@ -500,6 +500,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
real(kind(1.d0)), intent(in) :: x(:,:), y(:,:) real(kind(1.d0)), intent(in) :: x(:,:), y(:,:)
@ -587,8 +588,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
end if end if
! compute global sum ! compute global sum
call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,& call psb_sum(ictxt, dot_local(1:k))
& ione, mone ,mycol)
res(1:k) = dot_local(1:k) res(1:k) = dot_local(1:k)

10
src/psblas/psb_dnrmi.f90
Unescape Escape View File

@ -45,6 +45,7 @@ function psb_dnrmi(a,desc_a,info)
use psb_serial_mod use psb_serial_mod
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
@ -54,7 +55,7 @@ function psb_dnrmi(a,desc_a,info)
! locals ! locals
integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iia, jja, ia, ja, temp(2), mdim, ndim, m & err_act, n, iia, jja, ia, ja, mdim, ndim, m
real(kind(1.d0)) :: nrmi, dcsnmi real(kind(1.d0)) :: nrmi, dcsnmi
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -66,7 +67,7 @@ function psb_dnrmi(a,desc_a,info)
ictxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -111,12 +112,11 @@ function psb_dnrmi(a,desc_a,info)
goto 9999 goto 9999
end if end if
! compute global max
call dgamx2d(ictxt, 'A', ' ', ione, ione, nrmi, ione,&
&temp ,temp,-ione ,-ione,-ione)
else else
nrmi = 0.d0 nrmi = 0.d0
end if end if
! compute global max
call psb_amx(ictxt, nrmi)
psb_dnrmi = nrmi psb_dnrmi = nrmi

16
src/psblas/psb_zamax.f90
Unescape Escape View File

@ -44,7 +44,7 @@
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
function psb_zamax (x,desc_a, info, jx) function psb_zamax (x,desc_a, info, jx)
use psb_blacs_mod use psb_penv_mod
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
@ -118,7 +118,7 @@ function psb_zamax (x,desc_a, info, jx)
end if end if
! compute global max ! compute global max
call gamx2d(ictxt, 'A', amax) call psb_amx(ictxt, amax)
psb_zamax=amax psb_zamax=amax
@ -179,7 +179,7 @@ end function psb_zamax
! info - integer. Eventually returns an error code. ! info - integer. Eventually returns an error code.
! !
function psb_zamaxv (x,desc_a, info) function psb_zamaxv (x,desc_a, info)
use psb_blacs_mod use psb_penv_mod
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
@ -250,7 +250,7 @@ function psb_zamaxv (x,desc_a, info)
end if end if
! compute global max ! compute global max
call gamx2d(ictxt, 'A', amax) call psb_amx(ictxt, amax)
psb_zamaxv=amax psb_zamaxv=amax
@ -313,7 +313,7 @@ end function psb_zamaxv
! jx - integer(optional). The column offset. ! jx - integer(optional). The column offset.
! !
subroutine psb_zamaxvs (res,x,desc_a, info) subroutine psb_zamaxvs (res,x,desc_a, info)
use psb_blacs_mod use psb_penv_mod
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
@ -384,7 +384,7 @@ subroutine psb_zamaxvs (res,x,desc_a, info)
end if end if
! compute global max ! compute global max
call gamx2d(ictxt, 'A', amax) call psb_amx(ictxt, amax)
res = amax res = amax
@ -445,7 +445,7 @@ end subroutine psb_zamaxvs
! info - integer. Eventually returns an error code. ! info - integer. Eventually returns an error code.
! !
subroutine psb_zmamaxs (res,x,desc_a, info,jx) subroutine psb_zmamaxs (res,x,desc_a, info,jx)
use psb_blacs_mod use psb_penv_mod
use psb_serial_mod use psb_serial_mod
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
@ -524,7 +524,7 @@ subroutine psb_zmamaxs (res,x,desc_a, info,jx)
end if end if
! compute global max ! compute global max
call gamx2d(ictxt, 'A', res(1:k)) call psb_amx(ictxt, res(1:k))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

18
src/psblas/psb_zasum.f90
Unescape Escape View File

@ -49,7 +49,7 @@ function psb_zasum (x,desc_a, info, jx)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
complex(kind(1.d0)), intent(in) :: x(:,:) complex(kind(1.d0)), intent(in) :: x(:,:)
@ -130,12 +130,12 @@ function psb_zasum (x,desc_a, info, jx)
end do end do
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -204,7 +204,7 @@ function psb_zasumv (x,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
complex(kind(1.d0)), intent(in) :: x(:) complex(kind(1.d0)), intent(in) :: x(:)
@ -280,12 +280,12 @@ function psb_zasumv (x,desc_a, info)
end do end do
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -354,7 +354,7 @@ subroutine psb_zasumvs (res,x,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
complex(kind(1.d0)), intent(in) :: x(:) complex(kind(1.d0)), intent(in) :: x(:)
@ -430,12 +430,12 @@ subroutine psb_zasumvs (res,x,desc_a, info)
end do end do
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A',asum) call psb_sum(ictxt,asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', asum) call psb_sum(ictxt, asum)
end if end if
else else
asum=0.d0 asum=0.d0

16
src/psblas/psb_zdot.f90
Unescape Escape View File

@ -51,7 +51,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
complex(kind(1.d0)), intent(in) :: x(:,:), y(:,:) complex(kind(1.d0)), intent(in) :: x(:,:), y(:,:)
@ -146,7 +146,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy)
end if end if
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', dot_local) call psb_sum(ictxt, dot_local)
psb_zdot = dot_local psb_zdot = dot_local
@ -211,7 +211,7 @@ function psb_zdotv(x, y,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
complex(kind(1.d0)), intent(in) :: x(:), y(:) complex(kind(1.d0)), intent(in) :: x(:), y(:)
@ -289,7 +289,7 @@ function psb_zdotv(x, y,desc_a, info)
end if end if
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', dot_local) call psb_sum(ictxt, dot_local)
psb_zdotv = dot_local psb_zdotv = dot_local
@ -354,7 +354,7 @@ subroutine psb_zdotvs(res, x, y,desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
complex(kind(1.d0)), intent(in) :: x(:), y(:) complex(kind(1.d0)), intent(in) :: x(:), y(:)
@ -430,7 +430,7 @@ subroutine psb_zdotvs(res, x, y,desc_a, info)
end if end if
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', dot_local) call psb_sum(ictxt, dot_local)
res = dot_local res = dot_local
@ -500,7 +500,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
complex(kind(1.d0)), intent(in) :: x(:,:), y(:,:) complex(kind(1.d0)), intent(in) :: x(:,:), y(:,:)
@ -588,7 +588,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info)
end if end if
! compute global sum ! compute global sum
call gsum2d(ictxt, 'A', dot_local(1:k)) call psb_sum(ictxt, dot_local(1:k))
res(1:k) = dot_local(1:k) res(1:k) = dot_local(1:k)

10
src/psblas/psb_znrmi.f90
Unescape Escape View File

@ -45,7 +45,7 @@ function psb_znrmi(a,desc_a,info)
use psb_serial_mod use psb_serial_mod
use psb_check_mod use psb_check_mod
use psb_error_mod use psb_error_mod
use psb_blacs_mod use psb_penv_mod
implicit none implicit none
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
@ -67,7 +67,7 @@ function psb_znrmi(a,desc_a,info)
ictxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -111,13 +111,13 @@ function psb_znrmi(a,desc_a,info)
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
! compute global max
call gamx2d(ictxt, 'A', nrmi)
else else
nrmi = 0.d0 nrmi = 0.d0
end if end if
! compute global max
call psb_amx(ictxt, nrmi)
psb_znrmi = nrmi psb_znrmi = nrmi
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

8
src/tools/psb_cdasb.f90
Unescape Escape View File

@ -42,6 +42,7 @@ subroutine psb_cdasb(desc_a,info)
use psb_const_mod use psb_const_mod
use psi_mod use psi_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
!...Parameters.... !...Parameters....
@ -55,7 +56,7 @@ subroutine psb_cdasb(desc_a,info)
integer :: i,err,nprow,npcol,me,mypcol,& integer :: i,err,nprow,npcol,me,mypcol,&
& lovrlap,lhalo,nhalo,novrlap,max_size,max_halo,n_col,ldesc_halo,& & lovrlap,lhalo,nhalo,novrlap,max_size,max_halo,n_col,ldesc_halo,&
& ldesc_ovrlap, dectype, err_act & ldesc_ovrlap, dectype, err_act
integer :: ictxt,temp(1),n_row integer :: ictxt,n_row
logical, parameter :: debug=.false., debugwrt=.false. logical, parameter :: debug=.false., debugwrt=.false.
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
@ -71,7 +72,7 @@ subroutine psb_cdasb(desc_a,info)
n_col = desc_a%matrix_data(psb_n_col_) n_col = desc_a%matrix_data(psb_n_col_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) call psb_info(ictxt, me, nprow)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -134,8 +135,7 @@ subroutine psb_cdasb(desc_a,info)
itemp(1) = max_size itemp(1) = max_size
itemp(2) = max_halo itemp(2) = max_halo
call igamx2d(ictxt, psb_all_, psb_topdef_, itwo, ione, itemp,& call psb_amx(ictxt, itemp(1:2))
& itwo,temp ,temp,-ione ,-ione,-ione)
max_size = itemp(1) max_size = itemp(1)
max_halo = itemp(2) max_halo = itemp(2)

5
src/tools/psb_cddec.f90
Unescape Escape View File

@ -107,6 +107,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info)
use psb_serial_mod use psb_serial_mod
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit None implicit None
!....Parameters... !....Parameters...
Integer, intent(in) :: nloc,ictxt Integer, intent(in) :: nloc,ictxt
@ -129,7 +130,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info)
err=0 err=0
name = 'psb_cddec' name = 'psb_cddec'
call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) call psb_info(ictxt, me, nprow)
if (debug) write(*,*) 'psb_cdalll: ',nprow,npcol,me,mypcol if (debug) write(*,*) 'psb_cdalll: ',nprow,npcol,me,mypcol
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (npcol /= 1) then if (npcol /= 1) then
@ -163,7 +164,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info)
nlv(:) = 0 nlv(:) = 0
nlv(me) = nloc nlv(me) = nloc
call igsum2d(ictxt,'All',' ',nprow,1,nlv,nprow,-1,-1) call psb_sum(ictxt,nlv(1:nprow))
m = sum(nlv) m = sum(nlv)

8
src/tools/psb_cdren.f90
Unescape Escape View File

@ -43,6 +43,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
use psb_descriptor_type use psb_descriptor_type
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
use psb_penv_mod
implicit none implicit none
interface isaperm interface isaperm
@ -60,7 +61,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
!....locals.... !....locals....
integer :: i,j,err,nprow,npcol,myrow,mycol, n_col, kh, nh integer :: i,j,err,nprow,npcol,myrow,mycol, n_col, kh, nh
integer :: dectype integer :: dectype
integer :: ictxt,temp(1),n_row, int_err(5), err_act integer :: ictxt,n_row, int_err(5), err_act
real(kind(1.d0)) :: time(10), mpi_wtime, real_err(6) real(kind(1.d0)) :: time(10), mpi_wtime, real_err(6)
external mpi_wtime external mpi_wtime
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
@ -79,7 +80,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
n_col = desc_a%matrix_data(psb_n_col_) n_col = desc_a%matrix_data(psb_n_col_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol) call psb_info(ictxt, myrow, nprow)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -213,8 +214,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
time(4) = mpi_wtime() time(4) = mpi_wtime()
time(4) = time(4) - time(3) time(4) = time(4) - time(3)
if (debug) then if (debug) then
call dgamx2d(ictxt, psb_all_, psb_topdef_, ione, ione, time(4),& call psb_amx(ictxt, time(4))
& ione,temp ,temp,-ione ,-ione,-ione)
write (*, *) ' comm structs assembly: ', time(4)*1.d-3 write (*, *) ' comm structs assembly: ', time(4)*1.d-3
end if end if

8
src/tools/psb_dcsrp.f90
Unescape Escape View File

@ -44,6 +44,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_serial_mod use psb_serial_mod
use psb_const_mod use psb_const_mod
use psb_penv_mod
! implicit none ! implicit none
interface dcsrp interface dcsrp
@ -82,7 +83,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info)
& mypcol ,ierror ,n_col,l_dcsdp, iout, ipsize & mypcol ,ierror ,n_col,l_dcsdp, iout, ipsize
integer :: dectype integer :: dectype
real(kind(1.d0)), pointer :: work_dcsdp(:) real(kind(1.d0)), pointer :: work_dcsdp(:)
integer :: ictxt,temp(1),n_row,err_act integer :: ictxt,n_row,err_act
character(len=20) :: name, char_err character(len=20) :: name, char_err
real(kind(1.d0)) :: time(10), mpi_wtime real(kind(1.d0)) :: time(10), mpi_wtime
@ -102,7 +103,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info)
name = 'psd_csrp' name = 'psd_csrp'
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) call psb_info(ictxt, me, nprow)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -180,8 +181,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info)
time(4) = mpi_wtime() time(4) = mpi_wtime()
time(4) = time(4) - time(3) time(4) = time(4) - time(3)
if (debug) then if (debug) then
call dgamx2d(ictxt, all, topdef, ione, ione, time(4),& call psb_amx(ictxt, time(4))
& ione,temp ,temp,-ione ,-ione,-ione)
write (*, *) ' comm structs assembly: ', time(4)*1.d-3 write (*, *) ' comm structs assembly: ', time(4)*1.d-3
end if end if

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

@ -81,7 +81,6 @@ Subroutine psb_dsprn(a, desc_a,info,clear)
goto 9999 goto 9999
endif endif
if (debug) write(*,*) 'got through igamx2d '
if (psb_is_bld_dec(desc_a%matrix_data(psb_dec_type_))) then if (psb_is_bld_dec(desc_a%matrix_data(psb_dec_type_))) then
! Should do nothing, we are called redundantly ! Should do nothing, we are called redundantly

10
src/tools/psb_zcsrp.f90
Unescape Escape View File

@ -44,6 +44,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
use psb_descriptor_type use psb_descriptor_type
use psb_serial_mod use psb_serial_mod
use psb_const_mod use psb_const_mod
use psb_penv_mod
! implicit none ! implicit none
interface interface
@ -56,7 +57,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
integer, intent(in) :: p(*) integer, intent(in) :: p(*)
integer, intent(inout) :: ia1(*), ia2(*), infoa(*) integer, intent(inout) :: ia1(*), ia2(*), infoa(*)
character, intent(in) :: fida*5, descra*11 character, intent(in) :: fida*5, descra*11
end subroutine dcsrp end subroutine zcsrp
end interface end interface
@ -81,7 +82,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
& mypcol ,ierror ,n_col,l_dcsdp, iout, ipsize & mypcol ,ierror ,n_col,l_dcsdp, iout, ipsize
integer :: dectype integer :: dectype
real(kind(1.d0)), pointer :: work_dcsdp(:) real(kind(1.d0)), pointer :: work_dcsdp(:)
integer :: ictxt,temp(1),n_row,err_act integer :: ictxt,n_row,err_act
character(len=20) :: name, char_err character(len=20) :: name, char_err
real(kind(1.d0)) :: time(10), mpi_wtime real(kind(1.d0)) :: time(10), mpi_wtime
@ -101,7 +102,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
name = 'psd_csrp' name = 'psd_csrp'
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol) call psb_info(ictxt, me, nprow)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -179,8 +180,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
time(4) = mpi_wtime() time(4) = mpi_wtime()
time(4) = time(4) - time(3) time(4) = time(4) - time(3)
if (debug) then if (debug) then
call dgamx2d(ictxt, all, topdef, ione, ione, time(4),& call psb_amx(ictxt, time(4))
& ione,temp ,temp,-ione ,-ione,-ione)
write (*, *) ' comm structs assembly: ', time(4)*1.d-3 write (*, *) ' comm structs assembly: ', time(4)*1.d-3
end if end if

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

@ -80,7 +80,6 @@ Subroutine psb_zsprn(a, desc_a,info,clear)
goto 9999 goto 9999
endif endif
if (debug) write(*,*) 'got through igamx2d '
if (psb_is_bld_dec(desc_a%matrix_data(psb_dec_type_))) then if (psb_is_bld_dec(desc_a%matrix_data(psb_dec_type_))) then
! Should do nothing, we are called redundantly ! Should do nothing, we are called redundantly

32
test/Fileread/read_mat.f90
Unescape Escape View File

@ -90,13 +90,13 @@ contains
else else
root = 0 root = 0
end if end if
call blacs_gridinfo(ictxt, nprow, npcol, myprow, mypcol) call psb_info(ictxt, myprow, nprow)
if (myprow == root) then if (myprow == root) then
write(*, '("Reading matrix...")') ! open input file write(*, '("Reading matrix...")') ! open input file
call mm_mat_read(a,info,infile,filename) call mm_mat_read(a,info,infile,filename)
if (info /= 0) then if (info /= 0) then
write(0,*) 'Error return from MM_MAT_READ ',info write(0,*) 'Error return from MM_MAT_READ ',info
call blacs_abort(ictxt, 1) ! Unexpected End of File call psb_abort(ictxt) ! Unexpected End of File
endif endif
end if end if
return return
@ -123,7 +123,7 @@ contains
else else
root = 0 root = 0
end if end if
call blacs_gridinfo(ictxt, nprow, npcol, myprow, mypcol) call psb_info(ictxt, myprow, nprow)
if (myprow == root) then if (myprow == root) then
write(*, '("Reading rhs...")') ! open input file write(*, '("Reading rhs...")') ! open input file
open(infile,file=filename, status='old', err=901, action="read") open(infile,file=filename, status='old', err=901, action="read")
@ -131,7 +131,7 @@ contains
write(0,*)'obj fmt',object, fmt write(0,*)'obj fmt',object, fmt
if ( (object .ne. 'matrix').or.(fmt.ne.'array')) then if ( (object .ne. 'matrix').or.(fmt.ne.'array')) then
write(0,*) 'read_rhs: input file type not yet supported' write(0,*) 'read_rhs: input file type not yet supported'
call blacs_abort(ictxt, 1) call psb_abort(ictxt)
end if end if
do do
@ -148,7 +148,7 @@ contains
else else
write(0,*) 'read_rhs: rhs type not yet supported' write(0,*) 'read_rhs: rhs type not yet supported'
call blacs_abort(ictxt, 1) call psb_abort(ictxt)
end if ! read right hand sides end if ! read right hand sides
write(*,*) 'end read_rhs' write(*,*) 'end read_rhs'
end if end if
@ -156,12 +156,12 @@ contains
! open failed ! open failed
901 write(0,*) 'read_rhs: could not open file ',& 901 write(0,*) 'read_rhs: could not open file ',&
& infile,' for input' & infile,' for input'
call blacs_abort(ictxt, 1) ! unexpected end of file call psb_abort(ictxt) ! unexpected end of file
902 write(0,*) 'read_rhs: unexpected end of file ',infile,& 902 write(0,*) 'read_rhs: unexpected end of file ',infile,&
& ' during input' & ' during input'
call blacs_abort(ictxt, 1) ! allocation failed call psb_abort(ictxt) ! allocation failed
993 write(0,*) 'read_rhs: memory allocation failure' 993 write(0,*) 'read_rhs: memory allocation failure'
call blacs_abort(ictxt, 1) call psb_abort(ictxt)
end subroutine dread_rhs end subroutine dread_rhs
@ -181,13 +181,13 @@ contains
else else
root = 0 root = 0
end if end if
call blacs_gridinfo(ictxt, nprow, npcol, myprow, mypcol) call psb_info(ictxt, myprow, nprow)
if (myprow == root) then if (myprow == root) then
write(*, '("Reading matrix...")') ! open input file write(*, '("Reading matrix...")') ! open input file
call mm_mat_read(a,info,infile,filename) call mm_mat_read(a,info,infile,filename)
if (info /= 0) then if (info /= 0) then
write(0,*) 'Error return from MM_MAT_READ ',info write(0,*) 'Error return from MM_MAT_READ ',info
call blacs_abort(ictxt, 1) ! Unexpected End of File call psb_abort(ictxt) ! Unexpected End of File
endif endif
end if end if
return return
@ -214,7 +214,7 @@ contains
else else
root = 0 root = 0
end if end if
call blacs_gridinfo(ictxt, nprow, npcol, myprow, mypcol) call psb_info(ictxt, myprow, nprow)
if (myprow == root) then if (myprow == root) then
write(*, '("Reading rhs...")') ! open input file write(*, '("Reading rhs...")') ! open input file
open(infile,file=filename, status='old', err=901, action="read") open(infile,file=filename, status='old', err=901, action="read")
@ -222,7 +222,7 @@ contains
!!$ write(0,*)'obj fmt',object, fmt !!$ write(0,*)'obj fmt',object, fmt
if ( (object .ne. 'matrix').or.(fmt.ne.'array')) then if ( (object .ne. 'matrix').or.(fmt.ne.'array')) then
write(0,*) 'read_rhs: input file type not yet supported' write(0,*) 'read_rhs: input file type not yet supported'
call blacs_abort(ictxt, 1) call psb_abort(ictxt)
end if end if
do do
@ -239,7 +239,7 @@ contains
else else
write(0,*) 'read_rhs: rhs type not yet supported' write(0,*) 'read_rhs: rhs type not yet supported'
call blacs_abort(ictxt, 1) call psb_abort(ictxt)
end if ! read right hand sides end if ! read right hand sides
write(*,*) 'end read_rhs' write(*,*) 'end read_rhs'
end if end if
@ -247,12 +247,12 @@ contains
! open failed ! open failed
901 write(0,*) 'read_rhs: could not open file ',& 901 write(0,*) 'read_rhs: could not open file ',&
& infile,' for input' & infile,' for input'
call blacs_abort(ictxt, 1) ! unexpected end of file call psb_abort(ictxt) ! unexpected end of file
902 write(0,*) 'read_rhs: unexpected end of file ',infile,& 902 write(0,*) 'read_rhs: unexpected end of file ',infile,&
& ' during input' & ' during input'
call blacs_abort(ictxt, 1) ! allocation failed call psb_abort(ictxt) ! allocation failed
993 write(0,*) 'read_rhs: memory allocation failure' 993 write(0,*) 'read_rhs: memory allocation failure'
call blacs_abort(ictxt, 1) call psb_abort(ictxt)
end subroutine zread_rhs end subroutine zread_rhs

Write Preview
Loading…
Cancel
Save