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 19 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}
\syntax{call psb\_sum}{ictxt, dat, dst}
\syntax{call psb\_sum}{ictxt, dat, root}
This subroutine implements a sum reduction operation based on the
underlying communication library.
@ -1049,11 +1049,11 @@ Type:{\bf required}.\\
Specified as: an integer, real or complex variable, which may be a
scalar, or a rank 1 or 2 array. \
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.\\
Scope:{\bf global}.\\
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}
@ -1069,7 +1069,7 @@ Type, rank and size must agree on all processes.
\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
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
scalar, or a rank 1 or 2 array. \
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.\\
Scope:{\bf global}.\\
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}
@ -1106,7 +1106,7 @@ Type, rank and size must agree on all processes.
\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
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
scalar, or a rank 1 or 2 array. \
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.\\
Scope:{\bf global}.\\
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}

115
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_check_mod
use psb_error_mod
use psb_penv_mod
implicit none
real(kind(1.d0)), intent(in) :: locx(:,:)
@ -88,42 +89,42 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
endif
if (present(iroot)) then
root = iroot
if((root.lt.-1).or.(root.gt.nprow)) then
info=30
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
root = iroot
if((root.lt.-1).or.(root.gt.nprow)) then
info=30
int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
else
root = -1
root = -1
end if
if (root==-1) then
iiroot=0
iiroot=0
endif
if (present(iiglobx)) then
iglobx = iiglobx
iglobx = iiglobx
else
iglobx = 1
iglobx = 1
end if
if (present(ijglobx)) then
jglobx = ijglobx
jglobx = ijglobx
else
jglobx = 1
jglobx = 1
end if
if (present(iilocx)) then
ilocx = iilocx
ilocx = iilocx
else
ilocx = 1
ilocx = 1
end if
if (present(ijlocx)) then
jlocx = ijlocx
jlocx = ijlocx
else
jlocx = 1
jlocx = 1
end if
lda_globx = size(globx,1)
@ -131,62 +132,58 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
m = desc_a%matrix_data(psb_m_)
n = desc_a%matrix_data(psb_n_)
lock=size(locx,2)-jlocx+1
globk=size(globx,2)-jglobx+1
maxk=min(lock,globk)
if(present(ik)) then
if(ik.gt.maxk) then
k=maxk
else
k=ik
end if
if(ik.gt.maxk) then
k=maxk
else
k=ik
end if
else
k = maxk
k = maxk
end if
if (myrow == iiroot) then
call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else
call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if
call psb_bcast(ictxt,k,root=iiroot)
! there should be a global check on k here!!!
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a%matrix_data,info)
call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a%matrix_data,info,ilx,jlx)
if(info.ne.0) then
info=4010
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((ilx.ne.1).or.(iglobx.ne.1)) then
info=3040
call psb_errpush(info,name)
goto 9999
info=3040
call psb_errpush(info,name)
goto 9999
end if
globx(:,:)=0.d0
do j=1,k
do i=1,desc_a%matrix_data(psb_n_row_)
idx = desc_a%loc_to_glob(i)
globx(idx,jglobx+j-1) = locx(i,jlx+j-1)
end do
! adjust overlapped elements
i=0
do while (desc_a%ovrlap_elem(i).ne.-1)
idx=desc_a%ovrlap_elem(i+psb_ovrlp_elem_)
idx=desc_a%loc_to_glob(idx)
globx(idx,jglobx+j-1) = globx(idx,jglobx+j-1)/desc_a%ovrlap_elem(i+psb_n_dom_ovr_)
i=i+2
end do
do i=1,desc_a%matrix_data(psb_n_row_)
idx = desc_a%loc_to_glob(i)
globx(idx,jglobx+j-1) = locx(i,jlx+j-1)
end do
! adjust overlapped elements
i=0
do while (desc_a%ovrlap_elem(i).ne.-1)
idx=desc_a%ovrlap_elem(i+psb_ovrlp_elem_)
idx=desc_a%loc_to_glob(idx)
globx(idx,jglobx+j-1) = globx(idx,jglobx+j-1)/desc_a%ovrlap_elem(i+psb_n_dom_ovr_)
i=i+2
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)
return
@ -195,8 +192,8 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(ictxt)
return
call psb_error(ictxt)
return
end if
return
@ -255,6 +252,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_penv_mod
implicit none
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_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
@ -303,7 +301,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
root = -1
end if
if (root==-1) then
root=0
iiroot=0
endif
jglobx=1
@ -328,11 +326,6 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
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!!!
@ -366,7 +359,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
i=i+2
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)
return

26
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_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
complex(kind(1.d0)), intent(in) :: locx(:,:)
@ -147,11 +147,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,&
k = maxk
end if
if (myrow == iiroot) then
call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else
call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if
call psb_bcast(ictxt,k,root=iiroot)
! 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
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)
return
@ -256,7 +252,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
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_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
@ -304,9 +300,6 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
else
root = -1
end if
if (root==-1) then
root=0
endif
jglobx=1
if (present(iiglobx)) then
@ -330,11 +323,6 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
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!!!
@ -368,8 +356,8 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
i=i+2
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)
return

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

@ -28,11 +28,11 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psi_compute_size(desc_data,&
& index_in, dl_lda, info)
subroutine psi_compute_size(desc_data, index_in, dl_lda, info)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
! ....scalars parameters....
@ -40,7 +40,7 @@ subroutine psi_compute_size(desc_data,&
! .....array parameters....
integer :: desc_data(:), index_in(:)
! ....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
! ...local array...
integer :: exch(2)
@ -57,16 +57,16 @@ subroutine psi_compute_size(desc_data,&
info = 0
ictxt = desc_data(psb_ctxt_)
call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
call psb_info(ictxt,myrow,nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
goto 9999
info = 2010
call psb_errpush(info,name)
goto 9999
else if (npcol /= 1) then
info = 2030
int_err(1) = npcol
call psb_errpush(info,name)
goto 9999
info = 2030
int_err(1) = npcol
call psb_errpush(info,name)
goto 9999
endif
np=nprow
@ -78,28 +78,28 @@ subroutine psi_compute_size(desc_data,&
! ..initialize counters...
do i=0,np-1
counter_recv(i)=0
counter_dl(i)=0
counter_recv(i)=0
counter_dl(i)=0
enddo
! ....verify local correctness of halo_in....
i=1
do while (index_in(i).ne.-1)
proc=index_in(i)
if ((proc.gt.np-1).or.(proc.lt.0)) then
info = 115
int_err(1) = 11
int_err(2) = proc
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
counter_dl(proc)=1
! ..update no of elements to receive from proc proc..
counter_recv(proc)=counter_recv(proc)+&
& index_in(i+1)
i=i+index_in(i+1)+2
proc=index_in(i)
if ((proc.gt.np-1).or.(proc.lt.0)) then
info = 115
int_err(1) = 11
int_err(2) = proc
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
counter_dl(proc)=1
! ..update no of elements to receive from proc proc..
counter_recv(proc)=counter_recv(proc)+&
& index_in(i+1)
i=i+index_in(i+1)+2
enddo
! ...computing max_halo: max halo points to be received from
@ -108,16 +108,15 @@ subroutine psi_compute_size(desc_data,&
dl_lda=0
do i=0,np-1
if (counter_recv(i).gt.max_index) max_index = counter_recv(i)
if (counter_dl(i).eq.1) dl_lda = dl_lda+1
if (counter_recv(i).gt.max_index) max_index = counter_recv(i)
if (counter_dl(i).eq.1) dl_lda = dl_lda+1
enddo
! computing max global value of dl_lda
call igamx2d(ictxt, psb_all_, psb_topdef_, 1, ione, dl_lda, &
&1, counter, counter, -ione ,-ione,-ione)
call psb_amx(ictxt, dl_lda)
if (debug) then
write(0,*) 'psi_compute_size: ',dl_lda
write(0,*) 'psi_compute_size: ',dl_lda
endif
call psb_erractionrestore(err_act)
@ -126,8 +125,8 @@ subroutine psi_compute_size(desc_data,&
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(ictxt)
return
call psb_error(ictxt)
return
end if
return

53
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 length_dl integer array(0:np)
c length_dl(i) is the length of dep_list(*,i) list
use psb_penv_mod
implicit none
include 'psb_const.fh'
include 'mpif.h'
@ -146,13 +146,13 @@ c .....local scalars...
ictxt = desc_data(psb_ctxt_)
call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
call psb_info(ictxt,me,nprow)
do i=0,np
length_dl(i) = 0
enddo
i=1
if (debug) write(0,*) 'extract: info ',info,
+ desc_data(psb_dec_type_)
+ desc_data(psb_dec_type_)
pointer_dep_list=1
if (desc_data(psb_dec_type_).eq.psb_desc_bld_) then
do while (desc_str(i).ne.-1)
@ -244,47 +244,18 @@ c ... check for errors...
998 continue
if (debug) write(0,*) 'extract: info ',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 (.true.) then
call igsum2d(ictxt,'all',' ',np+1,1,length_dl,np+1,-1,-1)
call blacs_get(ictxt,10,icomm )
allocate(itmp(dl_lda),stat=info)
if (info /= 0) goto 9999
itmp(1:dl_lda) = dep_list(1:dl_lda,me)
call mpi_allgather(itmp,dl_lda,mpi_integer,
+ dep_list,dl_lda,mpi_integer,icomm,info)
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)
call psb_sum(ictxt,length_dl(0:np))
call blacs_get(ictxt,10,icomm )
allocate(itmp(dl_lda),stat=info)
if (info /= 0) goto 9999
itmp(1:dl_lda) = dep_list(1:dl_lda,me)
call mpi_allgather(itmp,dl_lda,mpi_integer,
+ dep_list,dl_lda,mpi_integer,icomm,info)
deallocate(itmp)
endif
end if
return
@ -292,7 +263,7 @@ c ...send to root dependence list....
9999 continue
call fcpsb_errpush(info,name,int_err)
if(err_act.eq.act_abort) then
call fcpsb_perror(ictxt)
call fcpsb_perror(ictxt)
endif
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 \
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_methd_mod.o psb_const_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_error_mod.o: psb_const_mod.o
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)
$(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_methd_mod
use psb_serial_mod
use psb_blacs_mod
use psb_penv_mod
use psb_comm_mod
use psb_error_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
subroutine psb_iamxs(ictxt,dat,rt,ia)
subroutine psb_iamxs(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia
integer :: rt_
integer :: root_
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
call gamx2d(ictxt,'A',dat,ria=ia,rrt=rt_)
call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_)
else
call gamx2d(ictxt,'A',dat,rrt=rt_)
call gamx2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_iamxs
subroutine psb_iamxv(ictxt,dat,rt,ia)
subroutine psb_iamxv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamx2d(ictxt,'A',dat,rrt=rt_)
call gamx2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_iamxv
subroutine psb_iamxm(ictxt,dat,rt,ia)
subroutine psb_iamxm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:,:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamx2d(ictxt,'A',dat,rrt=rt_)
call gamx2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_iamxm
subroutine psb_damxs(ictxt,dat,rt,ia)
subroutine psb_damxs(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia
integer :: rt_
integer :: root_
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
call gamx2d(ictxt,'A',dat,ria=ia,rrt=rt_)
call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_)
else
call gamx2d(ictxt,'A',dat,rrt=rt_)
call gamx2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_damxs
subroutine psb_damxv(ictxt,dat,rt,ia)
subroutine psb_damxv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamx2d(ictxt,'A',dat,rrt=rt_)
call gamx2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_damxv
subroutine psb_damxm(ictxt,dat,rt,ia)
subroutine psb_damxm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:,:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamx2d(ictxt,'A',dat,rrt=rt_)
call gamx2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_damxm
subroutine psb_zamxs(ictxt,dat,rt,ia)
subroutine psb_zamxs(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia
integer :: rt_
integer :: root_
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
call gamx2d(ictxt,'A',dat,ria=ia,rrt=rt_)
call gamx2d(ictxt,'A',dat,ria=ia,rrt=root_)
else
call gamx2d(ictxt,'A',dat,rrt=rt_)
call gamx2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_zamxs
subroutine psb_zamxv(ictxt,dat,rt,ia)
subroutine psb_zamxv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamx2d(ictxt,'A',dat,rrt=rt_)
call gamx2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_zamxv
subroutine psb_zamxm(ictxt,dat,rt,ia)
subroutine psb_zamxm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:,:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamx2d(ictxt,'A',dat,rrt=rt_)
call gamx2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_zamxm
subroutine psb_iamns(ictxt,dat,rt,ia)
subroutine psb_iamns(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia
integer :: rt_
integer :: root_
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
call gamn2d(ictxt,'A',dat,ria=ia,rrt=rt_)
call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_)
else
call gamn2d(ictxt,'A',dat,rrt=rt_)
call gamn2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_iamns
subroutine psb_iamnv(ictxt,dat,rt,ia)
subroutine psb_iamnv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamn2d(ictxt,'A',dat,rrt=rt_)
call gamn2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_iamnv
subroutine psb_iamnm(ictxt,dat,rt,ia)
subroutine psb_iamnm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:,:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamn2d(ictxt,'A',dat,rrt=rt_)
call gamn2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_iamnm
subroutine psb_damns(ictxt,dat,rt,ia)
subroutine psb_damns(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia
integer :: rt_
integer :: root_
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
call gamn2d(ictxt,'A',dat,ria=ia,rrt=rt_)
call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_)
else
call gamn2d(ictxt,'A',dat,rrt=rt_)
call gamn2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_damns
subroutine psb_damnv(ictxt,dat,rt,ia)
subroutine psb_damnv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamn2d(ictxt,'A',dat,rrt=rt_)
call gamn2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_damnv
subroutine psb_damnm(ictxt,dat,rt,ia)
subroutine psb_damnm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
real(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:,:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamn2d(ictxt,'A',dat,rrt=rt_)
call gamn2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_damnm
subroutine psb_zamns(ictxt,dat,rt,ia)
subroutine psb_zamns(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia
integer :: rt_
integer :: root_
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
call gamn2d(ictxt,'A',dat,ria=ia,rrt=rt_)
call gamn2d(ictxt,'A',dat,ria=ia,rrt=root_)
else
call gamn2d(ictxt,'A',dat,rrt=rt_)
call gamn2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_zamns
subroutine psb_zamnv(ictxt,dat,rt,ia)
subroutine psb_zamnv(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamn2d(ictxt,'A',dat,rrt=rt_)
call gamn2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_zamnv
subroutine psb_zamnm(ictxt,dat,rt,ia)
subroutine psb_zamnm(ictxt,dat,root,ia)
integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer, intent(inout), optional :: ia(:,:)
integer :: rt_
integer :: root_
integer, allocatable :: cia(:,:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
if (present(ia)) then
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
call gamn2d(ictxt,'A',dat,rrt=rt_)
call gamn2d(ictxt,'A',dat,rrt=root_)
endif
end subroutine psb_zamnm
subroutine psb_isums(ictxt,dat,rt)
subroutine psb_isums(ictxt,dat,root)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer :: rt_
integer :: root_
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
call gsum2d(ictxt,'A',dat,rrt=rt_)
call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_isums
subroutine psb_isumv(ictxt,dat,rt)
subroutine psb_isumv(ictxt,dat,root)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer :: rt_
integer :: root_
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
call gsum2d(ictxt,'A',dat,rrt=rt_)
call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_isumv
subroutine psb_isumm(ictxt,dat,rt)
subroutine psb_isumm(ictxt,dat,root)
integer, intent(in) :: ictxt
integer, intent(inout) :: dat(:,:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer :: rt_
integer :: root_
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
call gsum2d(ictxt,'A',dat,rrt=rt_)
call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_isumm
subroutine psb_dsums(ictxt,dat,rt)
subroutine psb_dsums(ictxt,dat,root)
integer, intent(in) :: ictxt
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
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
call gsum2d(ictxt,'A',dat,rrt=rt_)
call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_dsums
subroutine psb_dsumv(ictxt,dat,rt)
subroutine psb_dsumv(ictxt,dat,root)
integer, intent(in) :: ictxt
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
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
call gsum2d(ictxt,'A',dat,rrt=rt_)
call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_dsumv
subroutine psb_dsumm(ictxt,dat,rt)
subroutine psb_dsumm(ictxt,dat,root)
integer, intent(in) :: ictxt
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
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
call gsum2d(ictxt,'A',dat,rrt=rt_)
call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_dsumm
subroutine psb_zsums(ictxt,dat,rt)
subroutine psb_zsums(ictxt,dat,root)
integer, intent(in) :: ictxt
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
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
call gsum2d(ictxt,'A',dat,rrt=rt_)
call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_zsums
subroutine psb_zsumv(ictxt,dat,rt)
subroutine psb_zsumv(ictxt,dat,root)
integer, intent(in) :: ictxt
complex(kind(1.d0)), intent(inout) :: dat(:)
integer, intent(in), optional :: rt
integer, intent(in), optional :: root
integer :: rt_
integer :: root_
integer, allocatable :: cia(:)
if (present(rt)) then
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
call gsum2d(ictxt,'A',dat,rrt=rt_)
call gsum2d(ictxt,'A',dat,rrt=root_)
end subroutine psb_zsumv
subroutine psb_zsumm(ictxt,dat,rt)
subroutine psb_zsumm(ictxt,dat,root)
integer, intent(in) :: ictxt
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
rt_ = rt
if (present(root)) then
root_ = root
else
rt_ = -1
root_ = -1
endif
call gsum2d(ictxt,'A',dat,rrt=rt_)
call gsum2d(ictxt,'A',dat,rrt=root_)
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 :: temp(2)
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,&
&temp ,temp,-ione ,-ione,-ione)
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
use psb_blacs_mod
use psb_penv_mod
use psb_descriptor_type
use psb_prec_type
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)
use psb_serial_mod
use psb_penv_mod
use psb_prec_type
use psb_descriptor_type
use psb_spmat_type
@ -105,6 +106,7 @@ contains
use psb_const_mod
use psb_psblas_mod
use psb_error_mod
use psb_penv_mod
implicit none
include 'mpif.h'
@ -248,7 +250,7 @@ contains
nzbr(:) = 0
nzbr(myprow+1) = irs
call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) then
@ -327,7 +329,7 @@ contains
call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
goto 9999
end if
call igsum2d(icontxt,'All',' ',1,1,k,1,-1,-1)
call psb_sum(ictxt,k)
if (k == 0) then
! If the off diagonal part is emtpy, there's no point
@ -380,6 +382,7 @@ contains
use psb_comm_mod
use psb_tools_mod
use psb_error_mod
use psb_penv_mod
implicit none
include 'mpif.h'
@ -390,7 +393,7 @@ contains
integer, pointer :: nzbr(:), idisp(:), ivall(:)
integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,&
& 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) :: am3,am4
logical :: ml_global_nmb
@ -568,7 +571,7 @@ contains
anorm = max(anorm,tmp/dg)
enddo
call dgamx2d(ictxt,'All',' ',1,1,anorm,1,itemp,jtemp,-1,-1,-1)
call psb_amx(ictxt,anorm)
else
anorm = psb_spnrmi(am3,desc_a,info)
endif
@ -850,7 +853,7 @@ contains
call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
goto 9999
end if
call igsum2d(ictxt,'All',' ',1,1,k,1,-1,-1)
call psb_sum(ictxt,k)
if (k == 0) then
! 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 igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) goto 9999
@ -970,7 +973,7 @@ contains
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)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) then

277
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_descriptor_type
use psb_error_mod
use psb_penv_mod
implicit none
integer, intent(in) :: aggr_type
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.
!
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_)
ncol = desc_a%matrix_data(psb_n_col_)
@ -74,13 +75,13 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nr = a%m
allocate(ilaggr(nr),neigh(nr),stat=info)
if(info.ne.0) then
info=4000
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4000
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do i=1, nr
ilaggr(i) = -(nr+1)
ilaggr(i) = -(nr+1)
end do
! Note: -(nr+1) Untouched as yet
! -i 1<=i<=nr Adjacent to aggregate i
@ -93,56 +94,56 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
naggr = 0
nlp = 0
do
icnt = 0
do i=1, nr
if (ilaggr(i) == -(nr+1)) then
!
! 1. Untouched nodes are marked >0 together
! with their neighbours
!
icnt = icnt + 1
naggr = naggr + 1
ilaggr(i) = naggr
icnt = 0
do i=1, nr
if (ilaggr(i) == -(nr+1)) then
!
! 1. Untouched nodes are marked >0 together
! with their neighbours
!
icnt = icnt + 1
naggr = naggr + 1
ilaggr(i) = naggr
call psb_neigh(a,i,neigh,n_ne,info,lev=one)
if (info/=0) then
info=4010
ch_err='psb_neigh'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do k=1, n_ne
j = neigh(k)
if ((1<=j).and.(j<=nr)) then
ilaggr(j) = naggr
call psb_neigh(a,i,neigh,n_ne,info,lev=one)
if (info/=0) then
info=4010
ch_err='psb_neigh'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do k=1, n_ne
j = neigh(k)
if ((1<=j).and.(j<=nr)) then
ilaggr(j) = naggr
!!$ if (ilaggr(j) < 0) ilaggr(j) = naggr
!!$ if (ilaggr(j) == -(nr+1)) ilaggr(j) = naggr
endif
enddo
!
! 2. Untouched neighbours of these nodes are marked <0.
!
call psb_neigh(a,i,neigh,n_ne,info,lev=two)
if (info/=0) then
info=4010
ch_err='psb_neigh'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
enddo
!
! 2. Untouched neighbours of these nodes are marked <0.
!
call psb_neigh(a,i,neigh,n_ne,info,lev=two)
if (info/=0) then
info=4010
ch_err='psb_neigh'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do n = 1, n_ne
m = neigh(n)
if ((1<=m).and.(m<=nr)) then
if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr
endif
enddo
endif
enddo
nlp = nlp + 1
if (icnt == 0) exit
do n = 1, n_ne
m = neigh(n)
if ((1<=m).and.(m<=nr)) then
if (ilaggr(m) == -(nr+1)) ilaggr(m) = -naggr
endif
enddo
endif
enddo
nlp = nlp + 1
if (icnt == 0) exit
enddo
if (debug) then
write(0,*) 'Check 1:',count(ilaggr == -(nr+1)),(a%ia1(i),i=a%ia2(1),a%ia2(2)-1)
write(0,*) 'Check 1:',count(ilaggr == -(nr+1)),(a%ia1(i),i=a%ia2(1),a%ia2(2)-1)
end if
!
@ -150,136 +151,136 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
!
allocate(ils(naggr+10),stat=info)
if(info.ne.0) then
info=4000
call psb_errpush(info,name)
goto 9999
info=4000
call psb_errpush(info,name)
goto 9999
end if
do i=1, size(ils)
ils(i) = 0
ils(i) = 0
end do
do i=1, nr
n = ilaggr(i)
if (n>0) then
if (n>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 1 ? ',n,naggr
else
ils(n) = ils(n) + 1
end if
n = ilaggr(i)
if (n>0) then
if (n>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 1 ? ',n,naggr
else
ils(n) = ils(n) + 1
end if
end if
end if
end do
if (debug) then
write(0,*) 'Phase 1: number of aggregates ',naggr
write(0,*) 'Phase 1: nodes aggregated ',sum(ils)
write(0,*) 'Phase 1: number of aggregates ',naggr
write(0,*) 'Phase 1: nodes aggregated ',sum(ils)
end if
recovery=.false.
do i=1, nr
if (ilaggr(i) < 0) then
!
! Now some silly rule to break ties:
! Group with smallest adjacent aggregate.
!
isz = nr+1
ia = -1
if (ilaggr(i) < 0) then
!
! Now some silly rule to break ties:
! Group with smallest adjacent aggregate.
!
isz = nr+1
ia = -1
call psb_neigh(a,i,neigh,n_ne,info,lev=one)
if (info/=0) then
info=4010
ch_err='psb_neigh'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call psb_neigh(a,i,neigh,n_ne,info,lev=one)
if (info/=0) then
info=4010
ch_err='psb_neigh'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do j=1, n_ne
k = neigh(j)
if ((1<=k).and.(k<=nr)) then
n = ilaggr(k)
if (n>0) then
if (n>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 2? ',n,naggr
end if
do j=1, n_ne
k = neigh(j)
if ((1<=k).and.(k<=nr)) then
n = ilaggr(k)
if (n>0) then
if (n>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 2? ',n,naggr
end if
if (ils(n) < isz) then
ia = n
isz = ils(n)
endif
endif
endif
enddo
if (ia == -1) then
if (ilaggr(i) > -(nr+1)) then
ilaggr(i) = abs(ilaggr(i))
if (ilaggr(I)>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 3? ',ilaggr(i),naggr
end if
ils(ilaggr(i)) = ils(ilaggr(i)) + 1
!
! This might happen if the pattern is non symmetric.
! Need a better handling.
!
recovery = .true.
else
write(0,*) 'Unrecoverable error !!',ilaggr(i), nr
endif
if (ils(n) < isz) then
ia = n
isz = ils(n)
endif
endif
endif
enddo
if (ia == -1) then
if (ilaggr(i) > -(nr+1)) then
ilaggr(i) = abs(ilaggr(i))
if (ilaggr(I)>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 3? ',ilaggr(i),naggr
end if
ils(ilaggr(i)) = ils(ilaggr(i)) + 1
!
! This might happen if the pattern is non symmetric.
! Need a better handling.
!
recovery = .true.
else
ilaggr(i) = ia
if (ia>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 4? ',ia,naggr
end if
ils(ia) = ils(ia) + 1
write(0,*) 'Unrecoverable error !!',ilaggr(i), nr
endif
end if
else
ilaggr(i) = ia
if (ia>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 4? ',ia,naggr
end if
ils(ia) = ils(ia) + 1
endif
end if
enddo
if (recovery) then
write(0,*) 'Had to recover from strange situation in loc_aggregate.'
write(0,*) 'Perhaps an unsymmetric pattern?'
write(0,*) 'Had to recover from strange situation in loc_aggregate.'
write(0,*) 'Perhaps an unsymmetric pattern?'
endif
if (debug) then
write(0,*) 'Phase 2: number of aggregates ',naggr
write(0,*) 'Phase 2: nodes aggregated ',sum(ils)
do i=1, naggr
write(*,*) 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i)
enddo
write(*,*) maxval(ils(1:naggr))
write(*,*) 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops'
write(0,*) 'Phase 2: number of aggregates ',naggr
write(0,*) 'Phase 2: nodes aggregated ',sum(ils)
do i=1, naggr
write(*,*) 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i)
enddo
write(*,*) maxval(ils(1:naggr))
write(*,*) 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops'
end if
!!$ write(0,*) 'desc_a loc_aggr 4 : ', desc_a%matrix_data(m_)
if (count(ilaggr<0) >0) then
write(0,*) 'Fatal error: some leftovers!!!'
write(0,*) 'Fatal error: some leftovers!!!'
endif
deallocate(ils,neigh,stat=info)
if (info/=0) then
info=4000
call psb_errpush(info,name)
goto 9999
info=4000
call psb_errpush(info,name)
goto 9999
end if
if (nrow /= size(ilaggr)) then
write(0,*) 'SOmething wrong ilaggr ',nrow,size(ilaggr)
write(0,*) 'SOmething wrong ilaggr ',nrow,size(ilaggr)
endif
call psb_realloc(ncol,ilaggr,info)
if (info/=0) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
allocate(nlaggr(nprow),stat=info)
if (info/=0) then
info=4000
call psb_errpush(info,name)
goto 9999
info=4000
call psb_errpush(info,name)
goto 9999
end if
nlaggr(:) = 0
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)
return
@ -287,8 +288,8 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error()
return
call psb_error()
return
end if
return

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_prec_type
use psb_psblas_mod
use psb_blacs_mod
use psb_penv_mod
use psb_const_mod
use psb_error_mod
implicit none
@ -161,7 +161,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if
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
write(0,*) 'Unknown value for 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
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
write(0,*) 'Unknown value for 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
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
write(0,*) 'Unknown value for 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
call gsum2d(ictxt,'All',t2l(1:nrg))
call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for 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_psblas_mod
use psb_error_mod
use psb_penv_mod
implicit none
type(psb_zspmat_type), intent(in), target :: a
@ -105,6 +106,7 @@ contains
use psb_const_mod
use psb_psblas_mod
use psb_error_mod
use psb_penv_mod
implicit none
include 'mpif.h'
@ -114,7 +116,7 @@ contains
integer, pointer :: nzbr(:), idisp(:)
integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,&
& 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'
if(psb_get_errstatus().ne.0) return
info=0
@ -248,7 +250,7 @@ contains
nzbr(:) = 0
nzbr(myprow+1) = irs
call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) then
@ -279,11 +281,6 @@ contains
bg%infoa(psb_nnz_) = nzbg
bg%fida='COO'
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)
if(info /= 0) then
@ -305,11 +302,62 @@ contains
goto 9999
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
write(0,*) 'Unknown p%iprcparm(coarse_mat) in aggregate_sp',p%iprcparm(coarse_mat_)
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)
@ -334,6 +382,7 @@ contains
use psb_comm_mod
use psb_tools_mod
use psb_error_mod
use psb_penv_mod
implicit none
include 'mpif.h'
@ -344,7 +393,7 @@ contains
integer, pointer :: nzbr(:), idisp(:), ivall(:)
integer :: ictxt, nrow, nglob, ncol, ntaggr, nzbg, ip, ndx,&
& 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) :: am3,am4
logical :: ml_global_nmb
@ -522,7 +571,7 @@ contains
anorm = max(anorm,tmp/dg)
enddo
call dgamx2d(ictxt,'All',' ',1,1,anorm,1,itemp,jtemp,-1,-1,-1)
call psb_amx(ictxt,anorm)
else
anorm = psb_spnrmi(am3,desc_a,info)
endif
@ -804,7 +853,7 @@ contains
call psb_errpush(4010,name,a_err='psb_ipcoo2csr')
goto 9999
end if
call igsum2d(ictxt,'All',' ',1,1,k,1,-1,-1)
call psb_sum(ictxt,k)
if (k == 0) then
! 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 igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
call psb_sum(ictxt,nzbr(1:np))
nzbg = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
if(info /= 0) goto 9999
@ -924,7 +973,7 @@ contains
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)
call psb_sp_all(ntaggr,ntaggr,bg,nzbg,info)
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_descriptor_type
use psb_error_mod
use psb_penv_mod
implicit none
integer, intent(in) :: aggr_type
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(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)
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_prec_type
use psb_psblas_mod
use psb_blacs_mod
use psb_penv_mod
use psb_const_mod
use psb_error_mod
implicit none
@ -161,7 +161,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
end if
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
write(0,*) 'Unknown value for 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
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
write(0,*) 'Unknown value for 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
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
write(0,*) 'Unknown value for 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
call gsum2d(ictxt,'All',t2l(1:nrg))
call psb_sum(ictxt,t2l(1:nrg))
else if (baseprecv(2)%iprcparm(coarse_mat_) /= mat_distr_) Then
write(0,*) 'Unknown value for 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.
!
function psb_damax (x,desc_a, info, jx)
use psb_blacs_mod
use psb_penv_mod
use psb_serial_mod
use psb_descriptor_type
use psb_check_mod
@ -59,7 +59,7 @@ function psb_damax (x,desc_a, info, jx)
! locals
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
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_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
@ -115,8 +115,7 @@ function psb_damax (x,desc_a, info, jx)
end if
! compute global max
call dgamx2d(ictxt, 'A', ' ', ione, ione, amax, ione,&
&temp ,temp,-ione ,-ione,-ione)
call psb_amx(ictxt, amax)
psb_damax=amax
@ -177,7 +176,7 @@ end function psb_damax
! info - integer. Eventually returns an error code.
!
function psb_damaxv (x,desc_a, info)
use psb_blacs_mod
use psb_penv_mod
use psb_serial_mod
use psb_descriptor_type
use psb_check_mod
@ -191,7 +190,7 @@ function psb_damaxv (x,desc_a, info)
! locals
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
character(len=20) :: name, ch_err
@ -205,7 +204,7 @@ function psb_damaxv (x,desc_a, info)
ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
@ -243,7 +242,7 @@ function psb_damaxv (x,desc_a, info)
end if
! compute global max
call gamx2d(ictxt, 'A', amax)
call psb_amx(ictxt, amax)
psb_damaxv=amax
@ -306,7 +305,7 @@ end function psb_damaxv
! jx - integer(optional). The column offset.
!
subroutine psb_damaxvs (res,x,desc_a, info)
use psb_blacs_mod
use psb_penv_mod
use psb_serial_mod
use psb_descriptor_type
use psb_check_mod
@ -320,7 +319,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
! locals
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
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_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
@ -372,7 +371,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
end if
! compute global max
call gamx2d(ictxt, 'A', amax)
call psb_amx(ictxt, amax)
res = amax
@ -433,7 +432,7 @@ end subroutine psb_damaxvs
! info - integer. Eventually returns an error code.
!
subroutine psb_dmamaxs (res,x,desc_a, info,jx)
use psb_blacs_mod
use psb_penv_mod
use psb_serial_mod
use psb_descriptor_type
use psb_check_mod
@ -448,7 +447,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
! locals
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
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_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
@ -507,7 +506,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
end if
! compute global max
call gamx2d(ictxt, 'A', res(1:k))
call psb_amx(ictxt, res(1:k))
call psb_erractionrestore(err_act)
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_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
real(kind(1.d0)), intent(in) :: x(:,:)
@ -125,12 +125,12 @@ function psb_dasum (x,desc_a, info, jx)
end do
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
else
asum=0.d0
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
end if
else
asum=0.d0
@ -199,7 +199,7 @@ function psb_dasumv (x,desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
real(kind(1.d0)), intent(in) :: x(:)
@ -270,12 +270,12 @@ function psb_dasumv (x,desc_a, info)
end do
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
else
asum=0.d0
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
end if
else
asum=0.d0
@ -344,7 +344,7 @@ subroutine psb_dasumvs (res,x,desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
real(kind(1.d0)), intent(in) :: x(:)
@ -415,12 +415,12 @@ subroutine psb_dasumvs (res,x,desc_a, info)
end do
! compute global sum
call gsum2d(ictxt, 'A',asum)
call psb_sum(ictxt,asum)
else
asum=0.d0
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
end if
else
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_check_mod
use psb_error_mod
use psb_penv_mod
implicit none
real(kind(1.d0)), intent(in) :: x(:,:), y(:,:)
@ -145,8 +146,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
end if
! compute global sum
call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol)
call psb_sum(ictxt, dot_local)
psb_ddot = dot_local
@ -211,6 +211,7 @@ function psb_ddotv(x, y,desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_penv_mod
implicit none
real(kind(1.d0)), intent(in) :: x(:), y(:)
@ -288,8 +289,7 @@ function psb_ddotv(x, y,desc_a, info)
end if
! compute global sum
call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol)
call psb_sum(ictxt, 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_check_mod
use psb_error_mod
use psb_penv_mod
implicit none
real(kind(1.d0)), intent(in) :: x(:), y(:)
@ -429,8 +430,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
end if
! compute global sum
call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol)
call psb_sum(ictxt, dot_local)
res = dot_local
@ -500,6 +500,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_penv_mod
implicit none
real(kind(1.d0)), intent(in) :: x(:,:), y(:,:)
@ -587,8 +588,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
end if
! compute global sum
call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol)
call psb_sum(ictxt, 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_check_mod
use psb_error_mod
use psb_penv_mod
implicit none
type(psb_dspmat_type), intent(in) :: a
@ -54,7 +55,7 @@ function psb_dnrmi(a,desc_a,info)
! locals
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
character(len=20) :: name, ch_err
@ -66,7 +67,7 @@ function psb_dnrmi(a,desc_a,info)
ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
@ -111,12 +112,11 @@ function psb_dnrmi(a,desc_a,info)
goto 9999
end if
! compute global max
call dgamx2d(ictxt, 'A', ' ', ione, ione, nrmi, ione,&
&temp ,temp,-ione ,-ione,-ione)
else
nrmi = 0.d0
end if
! compute global max
call psb_amx(ictxt, nrmi)
psb_dnrmi = nrmi

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

@ -44,7 +44,7 @@
! jx - integer(optional). The column offset.
!
function psb_zamax (x,desc_a, info, jx)
use psb_blacs_mod
use psb_penv_mod
use psb_serial_mod
use psb_descriptor_type
use psb_check_mod
@ -118,7 +118,7 @@ function psb_zamax (x,desc_a, info, jx)
end if
! compute global max
call gamx2d(ictxt, 'A', amax)
call psb_amx(ictxt, amax)
psb_zamax=amax
@ -179,7 +179,7 @@ end function psb_zamax
! info - integer. Eventually returns an error code.
!
function psb_zamaxv (x,desc_a, info)
use psb_blacs_mod
use psb_penv_mod
use psb_serial_mod
use psb_descriptor_type
use psb_check_mod
@ -250,7 +250,7 @@ function psb_zamaxv (x,desc_a, info)
end if
! compute global max
call gamx2d(ictxt, 'A', amax)
call psb_amx(ictxt, amax)
psb_zamaxv=amax
@ -313,7 +313,7 @@ end function psb_zamaxv
! jx - integer(optional). The column offset.
!
subroutine psb_zamaxvs (res,x,desc_a, info)
use psb_blacs_mod
use psb_penv_mod
use psb_serial_mod
use psb_descriptor_type
use psb_check_mod
@ -384,7 +384,7 @@ subroutine psb_zamaxvs (res,x,desc_a, info)
end if
! compute global max
call gamx2d(ictxt, 'A', amax)
call psb_amx(ictxt, amax)
res = amax
@ -445,7 +445,7 @@ end subroutine psb_zamaxvs
! info - integer. Eventually returns an error code.
!
subroutine psb_zmamaxs (res,x,desc_a, info,jx)
use psb_blacs_mod
use psb_penv_mod
use psb_serial_mod
use psb_descriptor_type
use psb_check_mod
@ -524,7 +524,7 @@ subroutine psb_zmamaxs (res,x,desc_a, info,jx)
end if
! compute global max
call gamx2d(ictxt, 'A', res(1:k))
call psb_amx(ictxt, res(1:k))
call psb_erractionrestore(err_act)
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_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
complex(kind(1.d0)), intent(in) :: x(:,:)
@ -130,12 +130,12 @@ function psb_zasum (x,desc_a, info, jx)
end do
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
else
asum=0.d0
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
end if
else
asum=0.d0
@ -204,7 +204,7 @@ function psb_zasumv (x,desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
complex(kind(1.d0)), intent(in) :: x(:)
@ -280,12 +280,12 @@ function psb_zasumv (x,desc_a, info)
end do
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
else
asum=0.d0
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
end if
else
asum=0.d0
@ -354,7 +354,7 @@ subroutine psb_zasumvs (res,x,desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
complex(kind(1.d0)), intent(in) :: x(:)
@ -430,12 +430,12 @@ subroutine psb_zasumvs (res,x,desc_a, info)
end do
! compute global sum
call gsum2d(ictxt, 'A',asum)
call psb_sum(ictxt,asum)
else
asum=0.d0
! compute global sum
call gsum2d(ictxt, 'A', asum)
call psb_sum(ictxt, asum)
end if
else
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_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
complex(kind(1.d0)), intent(in) :: x(:,:), y(:,:)
@ -146,7 +146,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy)
end if
! compute global sum
call gsum2d(ictxt, 'A', dot_local)
call psb_sum(ictxt, dot_local)
psb_zdot = dot_local
@ -211,7 +211,7 @@ function psb_zdotv(x, y,desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
complex(kind(1.d0)), intent(in) :: x(:), y(:)
@ -289,7 +289,7 @@ function psb_zdotv(x, y,desc_a, info)
end if
! compute global sum
call gsum2d(ictxt, 'A', dot_local)
call psb_sum(ictxt, 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_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
complex(kind(1.d0)), intent(in) :: x(:), y(:)
@ -430,7 +430,7 @@ subroutine psb_zdotvs(res, x, y,desc_a, info)
end if
! compute global sum
call gsum2d(ictxt, 'A', dot_local)
call psb_sum(ictxt, dot_local)
res = dot_local
@ -500,7 +500,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info)
use psb_descriptor_type
use psb_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
complex(kind(1.d0)), intent(in) :: x(:,:), y(:,:)
@ -588,7 +588,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info)
end if
! 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)

52
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_check_mod
use psb_error_mod
use psb_blacs_mod
use psb_penv_mod
implicit none
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_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
call psb_info(ictxt, myrow, nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
@ -86,38 +86,38 @@ function psb_znrmi(a,desc_a,info)
call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja)
if(info.ne.0) then
info=4010
ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if ((iia.ne.1).or.(jja.ne.1)) then
info=3040
call psb_errpush(info,name)
goto 9999
info=3040
call psb_errpush(info,name)
goto 9999
end if
if ((m.ne.0).and.(n.ne.0)) then
mdim = desc_a%matrix_data(psb_n_row_)
ndim = desc_a%matrix_data(psb_n_col_)
nrmi = zcsnmi('N',mdim,ndim,a%fida,&
& a%descra,a%aspk,a%ia1,a%ia2,&
& a%infoa,info)
mdim = desc_a%matrix_data(psb_n_row_)
ndim = desc_a%matrix_data(psb_n_col_)
nrmi = zcsnmi('N',mdim,ndim,a%fida,&
& a%descra,a%aspk,a%ia1,a%ia2,&
& a%infoa,info)
if(info.ne.0) then
info=4010
ch_err='dcsnmi'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
! compute global max
call gamx2d(ictxt, 'A', nrmi)
if(info.ne.0) then
info=4010
ch_err='dcsnmi'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
else
nrmi = 0.d0
nrmi = 0.d0
end if
! compute global max
call psb_amx(ictxt, nrmi)
psb_znrmi = nrmi
call psb_erractionrestore(err_act)
@ -127,8 +127,8 @@ function psb_znrmi(a,desc_a,info)
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error(ictxt)
return
call psb_error(ictxt)
return
end if
return
end function psb_znrmi

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

@ -42,6 +42,7 @@ subroutine psb_cdasb(desc_a,info)
use psb_const_mod
use psi_mod
use psb_error_mod
use psb_penv_mod
implicit none
!...Parameters....
@ -55,7 +56,7 @@ subroutine psb_cdasb(desc_a,info)
integer :: i,err,nprow,npcol,me,mypcol,&
& lovrlap,lhalo,nhalo,novrlap,max_size,max_halo,n_col,ldesc_halo,&
& ldesc_ovrlap, dectype, err_act
integer :: ictxt,temp(1),n_row
integer :: ictxt,n_row
logical, parameter :: debug=.false., debugwrt=.false.
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_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
call psb_info(ictxt, me, nprow)
if (nprow == -1) then
info = 2010
call psb_errpush(info,name)
@ -97,14 +98,14 @@ subroutine psb_cdasb(desc_a,info)
! check if all local row are inserted
do i=1,desc_a%matrix_data(psb_n_col_)
if (desc_a%loc_to_glob(i) < 0) then
info=3100
info=3100
exit
endif
enddo
if (info /= no_err) then
call psb_errpush(info,name,i_err=int_err)
goto 9999
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
@ -134,8 +135,7 @@ subroutine psb_cdasb(desc_a,info)
itemp(1) = max_size
itemp(2) = max_halo
call igamx2d(ictxt, psb_all_, psb_topdef_, itwo, ione, itemp,&
& itwo,temp ,temp,-ione ,-ione,-ione)
call psb_amx(ictxt, itemp(1:2))
max_size = itemp(1)
max_halo = itemp(2)
@ -153,37 +153,37 @@ subroutine psb_cdasb(desc_a,info)
! compute necessary dimension of ovrlap index
ldesc_ovrlap = 2*lovrlap+1
! allocate OVRLAP_INDEX field
call psb_realloc(ldesc_ovrlap, desc_a%ovrlap_index, info)
! check on allocate
if (info /= no_err) then
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
info=4010
ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (debug) write(0,*) 'psb_cdasb: converting indexes',&
& nhalo,lhalo,halo_index(lhalo)
!.... convert comunication stuctures....
! first the halo index
call psi_crea_index(desc_a,halo_index,&
& desc_a%halo_index,.false.,info)
if(info.ne.0) then
call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999
call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999
end if
! then the overlap index
call psi_crea_index(desc_a,ovrlap_index,&
& desc_a%ovrlap_index,.true.,info)
if(info.ne.0) then
call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999
call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999
end if
! next is the ovrlap_elem index
@ -192,8 +192,8 @@ subroutine psb_cdasb(desc_a,info)
! finally bnd_elem
call psi_crea_bnd_elem(desc_a,info)
if(info.ne.0) then
call psb_errpush(4010,name,a_err='psi_crea_bnd_elem')
goto 9999
call psb_errpush(4010,name,a_err='psi_crea_bnd_elem')
goto 9999
end if
! Ok, register into MATRIX_DATA & free temporary work areas
@ -202,30 +202,30 @@ subroutine psb_cdasb(desc_a,info)
deallocate(ovrlap_index, stat=info)
deallocate(halo_index, stat=info)
if (info /= 0) then
info =4000
call psb_errpush(info,name)
goto 9999
info =4000
call psb_errpush(info,name)
goto 9999
end if
else
info = 600
call psb_errpush(info,name)
goto 9999
if (debug) write(0,*) 'dectype 2 :',dectype,psb_desc_bld_,&
&psb_desc_asb_,psb_desc_upd_
info = 600
call psb_errpush(info,name)
goto 9999
if (debug) write(0,*) 'dectype 2 :',dectype,psb_desc_bld_,&
&psb_desc_asb_,psb_desc_upd_
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error(ictxt)
call psb_error(ictxt)
end if
return
end subroutine psb_cdasb

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_const_mod
use psb_error_mod
use psb_penv_mod
implicit None
!....Parameters...
Integer, intent(in) :: nloc,ictxt
@ -129,7 +130,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info)
err=0
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
! ....verify blacs grid correctness..
if (npcol /= 1) then
@ -163,7 +164,7 @@ subroutine psb_cddec(nloc, ictxt, desc_a, info)
nlv(:) = 0
nlv(me) = nloc
call igsum2d(ictxt,'All',' ',nprow,1,nlv,nprow,-1,-1)
call psb_sum(ictxt,nlv(1:nprow))
m = sum(nlv)

42
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_const_mod
use psb_error_mod
use psb_penv_mod
implicit none
interface isaperm
@ -60,7 +61,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
!....locals....
integer :: i,j,err,nprow,npcol,myrow,mycol, n_col, kh, nh
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)
external mpi_wtime
logical, parameter :: debug=.false.
@ -77,25 +78,25 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
dectype=desc_a%matrix_data(psb_dec_type_)
n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_)
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
call psb_info(ictxt, myrow, nprow)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
goto 9999
info = 2010
call psb_errpush(info,name)
goto 9999
else if (npcol.ne.1) then
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
if (.not.psb_is_asb_dec(dectype)) then
info = 600
int_err(1) = dectype
call psb_errpush(info,name,int_err)
goto 9999
call psb_errpush(info,name,int_err)
goto 9999
endif
if (iperm(1) /= 0) then
@ -105,12 +106,12 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
call psb_errpush(info,name,int_err)
goto 9999
endif
endif
endif
if (debug) write (*, *) ' begin matrix assembly...'
!check on errors encountered in psdspins
if ((iperm(1) /= 0)) then
if (debug) write(0,*) 'spasb: here we go with ',iperm(1)
@ -202,19 +203,18 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
enddo
close(60+myrow)
end if
!!$ iperm(1) = 0
else
!!$ allocate(desc_a%lprm(1))
!!$ desc_a%lprm(1) = 0
endif
endif
time(4) = mpi_wtime()
time(4) = time(4) - time(3)
if (debug) then
call dgamx2d(ictxt, psb_all_, psb_topdef_, ione, ione, time(4),&
& ione,temp ,temp,-ione ,-ione,-ione)
call psb_amx(ictxt, time(4))
write (*, *) ' comm structs assembly: ', time(4)*1.d-3
end if
@ -224,11 +224,11 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then
return
return
else
call psb_error(ictxt)
call psb_error(ictxt)
end if
return

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_serial_mod
use psb_const_mod
use psb_penv_mod
! implicit none
interface dcsrp
@ -82,7 +83,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info)
& mypcol ,ierror ,n_col,l_dcsdp, iout, ipsize
integer :: dectype
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
real(kind(1.d0)) :: time(10), mpi_wtime
@ -102,7 +103,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info)
name = 'psd_csrp'
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
call psb_info(ictxt, me, nprow)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
@ -180,8 +181,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info)
time(4) = mpi_wtime()
time(4) = time(4) - time(3)
if (debug) then
call dgamx2d(ictxt, all, topdef, ione, ione, time(4),&
& ione,temp ,temp,-ione ,-ione,-ione)
call psb_amx(ictxt, time(4))
write (*, *) ' comm structs assembly: ', time(4)*1.d-3
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
endif
if (debug) write(*,*) 'got through igamx2d '
if (psb_is_bld_dec(desc_a%matrix_data(psb_dec_type_))) then
! Should do nothing, we are called redundantly

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

@ -44,19 +44,20 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
use psb_descriptor_type
use psb_serial_mod
use psb_const_mod
use psb_penv_mod
! implicit none
interface
subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,&
& infoa,p,work,lwork,ierror)
integer, intent(in) :: m, n, lwork
integer, intent(out) :: ierror
character, intent(in) :: trans
complex(kind(1.d0)), intent(inout) :: work(*)
integer, intent(in) :: p(*)
integer, intent(inout) :: ia1(*), ia2(*), infoa(*)
character, intent(in) :: fida*5, descra*11
end subroutine dcsrp
subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,&
& infoa,p,work,lwork,ierror)
integer, intent(in) :: m, n, lwork
integer, intent(out) :: ierror
character, intent(in) :: trans
complex(kind(1.d0)), intent(inout) :: work(*)
integer, intent(in) :: p(*)
integer, intent(inout) :: ia1(*), ia2(*), infoa(*)
character, intent(in) :: fida*5, descra*11
end subroutine zcsrp
end interface
@ -81,7 +82,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
& mypcol ,ierror ,n_col,l_dcsdp, iout, ipsize
integer :: dectype
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
real(kind(1.d0)) :: time(10), mpi_wtime
@ -94,23 +95,23 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
dectype=desc_a%matrix_data(psb_dec_type_)
n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_)
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psd_csrp'
! check on blacs grid
call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
call psb_info(ictxt, me, nprow)
if (nprow.eq.-1) then
info = 2010
call psb_errpush(info,name)
goto 9999
info = 2010
call psb_errpush(info,name)
goto 9999
else if (npcol.ne.1) then
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
info = 2030
int_err(1) = npcol
call psb_errpush(info,name,int_err)
goto 9999
endif
@ -119,7 +120,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
int_err(1) = dectype
call psb_errpush(info,name,int_err)
goto 9999
endif
endif
ipsize = size(iperm)
if (.not.((ipsize.eq.n_col).or.(ipsize.eq.n_row) )) then
@ -179,8 +180,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
time(4) = mpi_wtime()
time(4) = time(4) - time(3)
if (debug) then
call dgamx2d(ictxt, all, topdef, ione, ione, time(4),&
& ione,temp ,temp,-ione ,-ione,-ione)
call psb_amx(ictxt, time(4))
write (*, *) ' comm structs assembly: ', time(4)*1.d-3
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
endif
if (debug) write(*,*) 'got through igamx2d '
if (psb_is_bld_dec(desc_a%matrix_data(psb_dec_type_))) then
! Should do nothing, we are called redundantly

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

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

Write Preview
Loading…
Cancel
Save