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}

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_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(:,:)
@ -88,42 +89,42 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
endif endif
if (present(iroot)) then if (present(iroot)) then
root = iroot root = iroot
if((root.lt.-1).or.(root.gt.nprow)) then if((root.lt.-1).or.(root.gt.nprow)) then
info=30 info=30
int_err(1:2)=(/5,root/) int_err(1:2)=(/5,root/)
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
end if end if
else else
root = -1 root = -1
end if end if
if (root==-1) then if (root==-1) then
iiroot=0 iiroot=0
endif endif
if (present(iiglobx)) then if (present(iiglobx)) then
iglobx = iiglobx iglobx = iiglobx
else else
iglobx = 1 iglobx = 1
end if end if
if (present(ijglobx)) then if (present(ijglobx)) then
jglobx = ijglobx jglobx = ijglobx
else else
jglobx = 1 jglobx = 1
end if end if
if (present(iilocx)) then if (present(iilocx)) then
ilocx = iilocx ilocx = iilocx
else else
ilocx = 1 ilocx = 1
end if end if
if (present(ijlocx)) then if (present(ijlocx)) then
jlocx = ijlocx jlocx = ijlocx
else else
jlocx = 1 jlocx = 1
end if end if
lda_globx = size(globx,1) 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_) m = desc_a%matrix_data(psb_m_)
n = desc_a%matrix_data(psb_n_) n = desc_a%matrix_data(psb_n_)
lock=size(locx,2)-jlocx+1 lock=size(locx,2)-jlocx+1
globk=size(globx,2)-jglobx+1 globk=size(globx,2)-jglobx+1
maxk=min(lock,globk) maxk=min(lock,globk)
if(present(ik)) then if(present(ik)) then
if(ik.gt.maxk) then if(ik.gt.maxk) then
k=maxk k=maxk
else else
k=ik k=ik
end if end if
else else
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!!!
call psb_chkglobvect(m,n,size(globx,1),iglobx,jglobx,desc_a%matrix_data,info) 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) call psb_chkvect(m,n,size(locx,1),ilocx,jlocx,desc_a%matrix_data,info,ilx,jlx)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chk(glob)vect' ch_err='psb_chk(glob)vect'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if ((ilx.ne.1).or.(iglobx.ne.1)) then if ((ilx.ne.1).or.(iglobx.ne.1)) then
info=3040 info=3040
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
globx(:,:)=0.d0 globx(:,:)=0.d0
do j=1,k do j=1,k
do i=1,desc_a%matrix_data(psb_n_row_) do i=1,desc_a%matrix_data(psb_n_row_)
idx = desc_a%loc_to_glob(i) idx = desc_a%loc_to_glob(i)
globx(idx,jglobx+j-1) = locx(i,jlx+j-1) globx(idx,jglobx+j-1) = locx(i,jlx+j-1)
end do end do
! adjust overlapped elements ! adjust overlapped elements
i=0 i=0
do while (desc_a%ovrlap_elem(i).ne.-1) do while (desc_a%ovrlap_elem(i).ne.-1)
idx=desc_a%ovrlap_elem(i+psb_ovrlp_elem_) idx=desc_a%ovrlap_elem(i+psb_ovrlp_elem_)
idx=desc_a%loc_to_glob(idx) 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_) globx(idx,jglobx+j-1) = globx(idx,jglobx+j-1)/desc_a%ovrlap_elem(i+psb_n_dom_ovr_)
i=i+2 i=i+2
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
@ -195,8 +192,8 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(ictxt) call psb_error(ictxt)
return return
end if end if
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

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_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,8 +356,8 @@ 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

69
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,16 +57,16 @@ 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)
goto 9999 goto 9999
else if (npcol /= 1) then else if (npcol /= 1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
np=nprow np=nprow
@ -78,28 +78,28 @@ subroutine psi_compute_size(desc_data,&
! ..initialize counters... ! ..initialize counters...
do i=0,np-1 do i=0,np-1
counter_recv(i)=0 counter_recv(i)=0
counter_dl(i)=0 counter_dl(i)=0
enddo enddo
! ....verify local correctness of halo_in.... ! ....verify local correctness of halo_in....
i=1 i=1
do while (index_in(i).ne.-1) do while (index_in(i).ne.-1)
proc=index_in(i) proc=index_in(i)
if ((proc.gt.np-1).or.(proc.lt.0)) then if ((proc.gt.np-1).or.(proc.lt.0)) then
info = 115 info = 115
int_err(1) = 11 int_err(1) = 11
int_err(2) = proc int_err(2) = proc
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
counter_dl(proc)=1 counter_dl(proc)=1
! ..update no of elements to receive from proc proc.. ! ..update no of elements to receive from proc proc..
counter_recv(proc)=counter_recv(proc)+& counter_recv(proc)=counter_recv(proc)+&
& index_in(i+1) & index_in(i+1)
i=i+index_in(i+1)+2 i=i+index_in(i+1)+2
enddo enddo
! ...computing max_halo: max halo points to be received from ! ...computing max_halo: max halo points to be received from
@ -108,16 +108,15 @@ subroutine psi_compute_size(desc_data,&
dl_lda=0 dl_lda=0
do i=0,np-1 do i=0,np-1
if (counter_recv(i).gt.max_index) max_index = counter_recv(i) 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_dl(i).eq.1) dl_lda = dl_lda+1
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
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -126,8 +125,8 @@ subroutine psi_compute_size(desc_data,&
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(ictxt) call psb_error(ictxt)
return return
end if end if
return 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 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,13 +146,13 @@ 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
i=1 i=1
if (debug) write(0,*) 'extract: info ',info, if (debug) write(0,*) 'extract: info ',info,
+ desc_data(psb_dec_type_) + desc_data(psb_dec_type_)
pointer_dep_list=1 pointer_dep_list=1
if (desc_data(psb_dec_type_).eq.psb_desc_bld_) then if (desc_data(psb_dec_type_).eq.psb_desc_bld_) then
do while (desc_str(i).ne.-1) do while (desc_str(i).ne.-1)
@ -244,47 +244,18 @@ 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 itmp(1:dl_lda) = dep_list(1:dl_lda,me)
itmp(1:dl_lda) = dep_list(1:dl_lda,me) call mpi_allgather(itmp,dl_lda,mpi_integer,
call mpi_allgather(itmp,dl_lda,mpi_integer, + dep_list,dl_lda,mpi_integer,icomm,info)
+ dep_list,dl_lda,mpi_integer,icomm,info) deallocate(itmp)
deallocate(itmp)
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
@ -292,7 +263,7 @@ c ...send to root dependence list....
9999 continue 9999 continue
call fcpsb_errpush(info,name,int_err) call fcpsb_errpush(info,name,int_err)
if(err_act.eq.act_abort) then if(err_act.eq.act_abort) then
call fcpsb_perror(ictxt) call fcpsb_perror(ictxt)
endif endif
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

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

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)

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_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)
@ -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) call psb_chkmat(m,n,ia,ja,desc_a%matrix_data,info,iia,jja)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='psb_chkmat' ch_err='psb_chkmat'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if ((iia.ne.1).or.(jja.ne.1)) then if ((iia.ne.1).or.(jja.ne.1)) then
info=3040 info=3040
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if ((m.ne.0).and.(n.ne.0)) then if ((m.ne.0).and.(n.ne.0)) then
mdim = desc_a%matrix_data(psb_n_row_) mdim = desc_a%matrix_data(psb_n_row_)
ndim = desc_a%matrix_data(psb_n_col_) ndim = desc_a%matrix_data(psb_n_col_)
nrmi = zcsnmi('N',mdim,ndim,a%fida,& nrmi = zcsnmi('N',mdim,ndim,a%fida,&
& a%descra,a%aspk,a%ia1,a%ia2,& & a%descra,a%aspk,a%ia1,a%ia2,&
& a%infoa,info) & a%infoa,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
ch_err='dcsnmi' ch_err='dcsnmi'
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)
@ -127,8 +127,8 @@ function psb_znrmi(a,desc_a,info)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act.eq.act_abort) then
call psb_error(ictxt) call psb_error(ictxt)
return return
end if end if
return return
end function psb_znrmi 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 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)
@ -97,14 +98,14 @@ subroutine psb_cdasb(desc_a,info)
! check if all local row are inserted ! check if all local row are inserted
do i=1,desc_a%matrix_data(psb_n_col_) do i=1,desc_a%matrix_data(psb_n_col_)
if (desc_a%loc_to_glob(i) < 0) then if (desc_a%loc_to_glob(i) < 0) then
info=3100 info=3100
exit exit
endif endif
enddo enddo
if (info /= no_err) then if (info /= no_err) then
call psb_errpush(info,name,i_err=int_err) call psb_errpush(info,name,i_err=int_err)
goto 9999 goto 9999
endif endif
@ -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)
@ -153,37 +153,37 @@ subroutine psb_cdasb(desc_a,info)
! compute necessary dimension of ovrlap index ! compute necessary dimension of ovrlap index
ldesc_ovrlap = 2*lovrlap+1 ldesc_ovrlap = 2*lovrlap+1
! allocate OVRLAP_INDEX field ! allocate OVRLAP_INDEX field
call psb_realloc(ldesc_ovrlap, desc_a%ovrlap_index, info) call psb_realloc(ldesc_ovrlap, desc_a%ovrlap_index, info)
! check on allocate ! check on allocate
if (info /= no_err) then if (info /= no_err) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
if (debug) write(0,*) 'psb_cdasb: converting indexes',& if (debug) write(0,*) 'psb_cdasb: converting indexes',&
& nhalo,lhalo,halo_index(lhalo) & nhalo,lhalo,halo_index(lhalo)
!.... convert comunication stuctures.... !.... convert comunication stuctures....
! first the halo index ! first the halo index
call psi_crea_index(desc_a,halo_index,& call psi_crea_index(desc_a,halo_index,&
& desc_a%halo_index,.false.,info) & desc_a%halo_index,.false.,info)
if(info.ne.0) then if(info.ne.0) then
call psb_errpush(4010,name,a_err='psi_crea_index') call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999 goto 9999
end if end if
! then the overlap index ! then the overlap index
call psi_crea_index(desc_a,ovrlap_index,& call psi_crea_index(desc_a,ovrlap_index,&
& desc_a%ovrlap_index,.true.,info) & desc_a%ovrlap_index,.true.,info)
if(info.ne.0) then if(info.ne.0) then
call psb_errpush(4010,name,a_err='psi_crea_index') call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999 goto 9999
end if end if
! next is the ovrlap_elem index ! next is the ovrlap_elem index
@ -192,8 +192,8 @@ subroutine psb_cdasb(desc_a,info)
! finally bnd_elem ! finally bnd_elem
call psi_crea_bnd_elem(desc_a,info) call psi_crea_bnd_elem(desc_a,info)
if(info.ne.0) then if(info.ne.0) then
call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') call psb_errpush(4010,name,a_err='psi_crea_bnd_elem')
goto 9999 goto 9999
end if end if
! Ok, register into MATRIX_DATA & free temporary work areas ! 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(ovrlap_index, stat=info)
deallocate(halo_index, stat=info) deallocate(halo_index, stat=info)
if (info /= 0) then if (info /= 0) then
info =4000 info =4000
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
else else
info = 600 info = 600
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
if (debug) write(0,*) 'dectype 2 :',dectype,psb_desc_bld_,& if (debug) write(0,*) 'dectype 2 :',dectype,psb_desc_bld_,&
&psb_desc_asb_,psb_desc_upd_ &psb_desc_asb_,psb_desc_upd_
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(ictxt) call psb_error(ictxt)
end if end if
return return
end subroutine psb_cdasb 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_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)

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_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.
@ -77,25 +78,25 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
dectype=desc_a%matrix_data(psb_dec_type_) dectype=desc_a%matrix_data(psb_dec_type_)
n_row = desc_a%matrix_data(psb_n_row_) n_row = desc_a%matrix_data(psb_n_row_)
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)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
if (.not.psb_is_asb_dec(dectype)) then if (.not.psb_is_asb_dec(dectype)) then
info = 600 info = 600
int_err(1) = dectype int_err(1) = dectype
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
if (iperm(1) /= 0) then if (iperm(1) /= 0) then
@ -105,12 +106,12 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
endif endif
if (debug) write (*, *) ' begin matrix assembly...' if (debug) write (*, *) ' begin matrix assembly...'
!check on errors encountered in psdspins !check on errors encountered in psdspins
if ((iperm(1) /= 0)) then if ((iperm(1) /= 0)) then
if (debug) write(0,*) 'spasb: here we go with ',iperm(1) if (debug) write(0,*) 'spasb: here we go with ',iperm(1)
@ -202,19 +203,18 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
enddo enddo
close(60+myrow) close(60+myrow)
end if end if
!!$ iperm(1) = 0 !!$ iperm(1) = 0
else else
!!$ allocate(desc_a%lprm(1)) !!$ allocate(desc_a%lprm(1))
!!$ desc_a%lprm(1) = 0 !!$ desc_a%lprm(1) = 0
endif endif
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
@ -224,11 +224,11 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(ictxt) call psb_error(ictxt)
end if end if
return 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_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

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_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
subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,& subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,&
& infoa,p,work,lwork,ierror) & infoa,p,work,lwork,ierror)
integer, intent(in) :: m, n, lwork integer, intent(in) :: m, n, lwork
integer, intent(out) :: ierror integer, intent(out) :: ierror
character, intent(in) :: trans character, intent(in) :: trans
complex(kind(1.d0)), intent(inout) :: work(*) complex(kind(1.d0)), intent(inout) :: work(*)
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
@ -94,23 +95,23 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
dectype=desc_a%matrix_data(psb_dec_type_) dectype=desc_a%matrix_data(psb_dec_type_)
n_row = desc_a%matrix_data(psb_n_row_) n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_) n_col = desc_a%matrix_data(psb_n_col_)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
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)
goto 9999 goto 9999
else if (npcol.ne.1) then else if (npcol.ne.1) then
info = 2030 info = 2030
int_err(1) = npcol int_err(1) = npcol
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
@ -119,7 +120,7 @@ subroutine psb_zcsrp(trans,iperm,a, desc_a, info)
int_err(1) = dectype int_err(1) = dectype
call psb_errpush(info,name,int_err) call psb_errpush(info,name,int_err)
goto 9999 goto 9999
endif endif
ipsize = size(iperm) ipsize = size(iperm)
if (.not.((ipsize.eq.n_col).or.(ipsize.eq.n_row) )) then 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) = 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