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

Created new routines for environment handling, modified documentation accordingly.

Browse Source
psblas3-type-indexed
Salvatore Filippone 20 years ago
parent 045f80657f
commit b474f50151
142 changed files with 6552 additions and 5592 deletions
Show Stats Download Patch File Download Diff File

7
docs/pdf/datastruct.tex
Unescape Escape View File

@ -30,13 +30,14 @@ sparse matrix, however the definition of the descriptor is the
following. following.
\begin{description} \begin{description}
\item[{\bf matrix\_data}] includes general information about matrix and \item[{\bf matrix\_data}] includes general information about matrix and
BLACS grid. More precisely: process grid. More precisely:
\begin{description} \begin{description}
\item[matrix\_data[psb\_dec\_type\_\hbox{]}] Identifies the decomposition type \item[matrix\_data[psb\_dec\_type\_\hbox{]}] Identifies the decomposition type
(global); the actual values are internally defined, so they should (global); the actual values are internally defined, so they should
never be accessed directly. never be accessed directly.
\item[matrix\_data[psb\_ctxt\_\hbox{]}] Communication context as returned by the \item[matrix\_data[psb\_ctxt\_\hbox{]}] Communication context
BLACS (global). associated with the processes comprised in the virtual parallel
machine (global).
\item[matrix\_data[psb\_m\_\hbox{]}] Total number of equations (global). \item[matrix\_data[psb\_m\_\hbox{]}] Total number of equations (global).
\item[matrix\_data[psb\_n\_\hbox{]}] Total number of variables (global). \item[matrix\_data[psb\_n\_\hbox{]}] Total number of variables (global).
\item[matrix\_data[psb\_n\_row\_\hbox{]}] Number of grid variables owned by the \item[matrix\_data[psb\_n\_row\_\hbox{]}] Number of grid variables owned by the

13
docs/pdf/intro.tex
Unescape Escape View File

@ -75,10 +75,10 @@ Message Passing Interface code is encapsulated within the BLACS
layer. However, in some cases, MPI routines are directly used either layer. However, in some cases, MPI routines are directly used either
to improve efficiency or to implement communication patterns for which to improve efficiency or to implement communication patterns for which
the BLACS package doesn't provide any method. the BLACS package doesn't provide any method.
We assume that the user program has initialized a BLACS process grid %% We assume that the user program has initialized a BLACS process grid
with one column and as many rows as there are processes; the PSBLAS %% with one column and as many rows as there are processes; the PSBLAS
initialization routines will take the communication context for this %% initialization routines will take the communication context for this
grid and store internally for further use. %% grid and store internally for further use.
\begin{figure}[h] \begin{center} \begin{figure}[h] \begin{center}
\includegraphics[scale=0.45]{figures/psblas} \includegraphics[scale=0.45]{figures/psblas}
@ -101,6 +101,7 @@ systems solution for block diagonal matrices;
communications; communications;
\item[Data management and auxiliary routines] including: \item[Data management and auxiliary routines] including:
\begin{itemize} \begin{itemize}
\item Parallel environment management
\item Communication descriptors allocation; \item Communication descriptors allocation;
\item Dense and sparse matrix allocation; \item Dense and sparse matrix allocation;
\item Dense and sparse matrix build and update; \item Dense and sparse matrix build and update;
@ -188,7 +189,7 @@ A simple application structure will walk through the index space
allocation, matrix/vector creation and linear system solution as allocation, matrix/vector creation and linear system solution as
follows: follows:
\begin{enumerate} \begin{enumerate}
\item Initialize parallel environment with \verb|blacs_gridinit| \item Initialize parallel environment with \verb|psb_init|
\item Initialize index space with \verb|psb_cdall| \item Initialize index space with \verb|psb_cdall|
\item Allocate sparse matrix and dense vectors with \verb|psb_spall| \item Allocate sparse matrix and dense vectors with \verb|psb_spall|
and \verb|psb_geall| and \verb|psb_geall|
@ -210,7 +211,7 @@ This is the structure of the sample program
For a simulation in which the same discretization mesh is used over For a simulation in which the same discretization mesh is used over
multiple time steps, the following structure may be more appropriate: multiple time steps, the following structure may be more appropriate:
\begin{enumerate} \begin{enumerate}
\item Initialize parallel environment with \verb|blacs_gridinit| \item Initialize parallel environment with \verb|psb_init|
\item Initialize index space with \verb|psb_cdall| \item Initialize index space with \verb|psb_cdall|
\item Loop over the topology of the discretization mesh and build the \item Loop over the topology of the discretization mesh and build the
descriptor with \verb|psb_cdins| descriptor with \verb|psb_cdins|

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

@ -1,6 +1,122 @@
\section{Data management and initialization routines} \section{Data management and environment handling routines}
\label{sec:toolsrout} \label{sec:toolsrout}
\subroutine{psb\_init}{Initializes PSBLAS parallel environment}
\syntax{call psb\_init}{ictxt, np}
This subroutine initializes the PSBLAS parallel environment, defining
a virtual parallel machine.
\begin{description}
\item[\bf On Entry ]
\item[np] Number of processes in the PSBLAS virtual parallel machine.\\
Scope:{\bf global}.\\
Type:{\bf optional}.\\
Specified as: an integer value. \
Default: use all available processes provided by the underlying
parallel environment.
\end{description}
\begin{description}
\item[\bf On Return]
\item[icontxt] the communication context identifying the virtual
parallel machine.\\
Scope:{\bf global}.\\
Type:{\bf required}.\\
Specified as: an integer variable.
\end{description}
\section*{Notes}
\begin{enumerate}
\item A call to this routine must precede any other PSBLAS call.
\item It is an error to specify a value for $np$ greater than the
number of processes available in the underlying parallel execution
environment.
\end{enumerate}
\subroutine{psb\_info}{Return information about PSBLAS parallel environment}
\syntax{call psb\_info}{ictxt, iam, np}
This subroutine returns informantion about the PSBLAS parallel environment, defining
a virtual parallel machine.
\begin{description}
\item[\bf On Entry ]
\item[icontxt] the communication context identifying the virtual
parallel machine.\\
Scope:{\bf global}.\\
Type:{\bf required}.\\
Specified as: an integer variable.
\end{description}
\begin{description}
\item[\bf On Return]
\item[iam] Identifier of current process in the PSBLAS virtual parallel machine.\\
Scope:{\bf local}.\\
Type:{\bf required}.\\
Specified as: an integer value. $-1 \le iam \le np-1$\
\item[np] Number of processes in the PSBLAS virtual parallel machine.\\
Scope:{\bf global}.\\
Type:{\bf required}.\\
Specified as: an integer variable. \
\end{description}
\section*{Notes}
\begin{enumerate}
\item For processes in the virtual parallel machine the identifier
will satisfy $0 \le iam \le np-1$;
\item If the user has requested on \verb|psb_init| a number of
processes less than the total available in the parallel execution
environment, the remaining processes will have on return $iam=-1$;
any such process may only place a call to \verb|psb_exit|, and is
required to do so.
\end{enumerate}
\subroutine{psb\_exit}{Exit from PSBLAS parallel environment}
\syntax{call psb\_exit}{ictxt}
This subroutine exits from the PSBLAS parallel virtual machine.
\begin{description}
\item[\bf On Entry ]
\item[icontxt] the communication context identifying the virtual
parallel machine.\\
Scope:{\bf global}.\\
Type:{\bf required}.\\
Specified as: an integer variable.
\end{description}
\section*{Notes}
\begin{enumerate}
\item This routine may be called even if a previous call to
\verb|psb_info| has returned with $iam=-1$; indeed, it it is the ONLY
routine that may be called in this situation, and it is required to
do so.
\end{enumerate}
\subroutine{psb\_barrier}{Sinchronization point parallel environment}
\syntax{call psb\_barrier}{ictxt}
This subroutine acts as a synchronization point for the PSBLAS
parallel virtual machine. As such, it must be called by all
participating processes.
\begin{description}
\item[\bf On Entry ]
\item[icontxt] the communication context identifying the virtual
parallel machine.\\
Scope:{\bf global}.\\
Type:{\bf required}.\\
Specified as: an integer variable.
\end{description}
% %
%% psb_cdall %% %% psb_cdall %%

8098
docs/userguide.pdf
View File

File diff suppressed because one or more lines are too long

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

@ -61,7 +61,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,& & err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
real(kind(1.d0)),pointer :: tmpx(:) real(kind(1.d0)),pointer :: tmpx(:)
@ -72,10 +72,10 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -147,9 +147,9 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
end if end if
if (myrow == iiroot) then if (myrow == iiroot) then
call igebs2d(icontxt, 'all', ' ', 1, 1, k, 1) call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else else
call igebr2d(icontxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -186,7 +186,7 @@ subroutine psb_dgatherm(globx, locx, desc_a, info, iroot,&
end do end do
end do end do
call dgsum2d(icontxt,'a',' ',m,k,globx(1,jglobx),size(globx,1),root,mycol) call dgsum2d(ictxt,'a',' ',m,k,globx(1,jglobx),size(globx,1),root,mycol)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -195,7 +195,7 @@ 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -265,7 +265,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,& & err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, lock, maxk, globk, m, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, lock, maxk, globk, m, k, jlx, ilx, i, j, idx
real(kind(1.d0)),pointer :: tmpx(:) real(kind(1.d0)),pointer :: tmpx(:)
@ -276,10 +276,10 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -329,9 +329,9 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
k = 1 k = 1
if (myrow == root) then if (myrow == root) then
call igebs2d(icontxt, 'all', ' ', 1, 1, k, 1) call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else else
call igebr2d(icontxt, 'all', ' ', 1, 1, k, 1, root, 0) call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, root, 0)
end if end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -366,7 +366,7 @@ subroutine psb_dgatherv(globx, locx, desc_a, info, iroot,&
i=i+2 i=i+2
end do end do
call dgsum2d(icontxt,'a',' ',m,k,globx,size(globx),root,mycol) call dgsum2d(ictxt,'a',' ',m,k,globx,size(globx),root,mycol)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -375,7 +375,7 @@ subroutine psb_dgatherv(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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

20
src/comm/psb_dhalo.f90
Unescape Escape View File

@ -62,7 +62,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork, ncol & err, liwork, ncol
real(kind(1.d0)),pointer :: iwork(:), xp(:,:) real(kind(1.d0)),pointer :: iwork(:), xp(:,:)
@ -74,10 +74,10 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -137,7 +137,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
if(present(alpha)) then if(present(alpha)) then
@ -203,7 +203,7 @@ subroutine psb_dhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -273,7 +273,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork, ncol & err, liwork, ncol
real(kind(1.d0)),pointer :: iwork(:) real(kind(1.d0)),pointer :: iwork(:)
@ -285,10 +285,10 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -332,7 +332,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
if(present(alpha)) then if(present(alpha)) then
@ -389,7 +389,7 @@ subroutine psb_dhalov(x,desc_a,info,alpha,work,tran,mode)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

20
src/comm/psb_dovrl.f90
Unescape Escape View File

@ -58,7 +58,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update)
integer, intent(in), optional :: update,jx,ik integer, intent(in), optional :: update,jx,ik
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,&
& imode, err, liwork, i & imode, err, liwork, i
real(kind(1.d0)),pointer :: iwork(:), xp(:,:) real(kind(1.d0)),pointer :: iwork(:), xp(:,:)
@ -70,10 +70,10 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -132,7 +132,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
! check for presence/size of a work area ! check for presence/size of a work area
@ -208,7 +208,7 @@ subroutine psb_dovrlm(x,desc_a,info,jx,ik,work,update)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -275,7 +275,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update)
integer, intent(in), optional :: update integer, intent(in), optional :: update
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,&
& imode, err, liwork, i & imode, err, liwork, i
real(kind(1.d0)),pointer :: iwork(:) real(kind(1.d0)),pointer :: iwork(:)
@ -287,10 +287,10 @@ subroutine psb_dovrlv(x,desc_a,info,work,update)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -335,7 +335,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
! check for presence/size of a work area ! check for presence/size of a work area
@ -410,7 +410,7 @@ subroutine psb_dovrlv(x,desc_a,info,work,update)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

36
src/comm/psb_dscatter.f90
Unescape Escape View File

@ -65,7 +65,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,&
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,& & err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,&
& jlx, myrank, rootrank, c, pos & jlx, myrank, rootrank, c, pos
@ -79,10 +79,10 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -153,8 +153,8 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,&
k = maxk k = maxk
end if end if
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
myrank = blacs_pnum(icontxt,myrow,mycol) myrank = blacs_pnum(ictxt,myrow,mycol)
lda_globx = size(globx) lda_globx = size(globx)
lda_locx = size(locx) lda_locx = size(locx)
@ -163,9 +163,9 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,&
n = desc_a%matrix_data(psb_n_) n = desc_a%matrix_data(psb_n_)
if (myrow == iiroot) then if (myrow == iiroot) then
call igebs2d(icontxt, 'all', ' ', 1, 1, k, 1) call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else else
call igebr2d(icontxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -196,7 +196,7 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,&
end do end do
end do end do
else else
rootrank = blacs_pnum(icontxt,root,mycol) rootrank = blacs_pnum(ictxt,root,mycol)
end if end if
! root has to gather size information ! root has to gather size information
@ -258,7 +258,7 @@ subroutine psb_dscatterm(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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -326,7 +326,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,& & err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, root, k, maxk, icomm, myrank,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, root, k, maxk, icomm, myrank,&
& rootrank, c, pos, ilx, jlx & rootrank, c, pos, ilx, jlx
@ -340,10 +340,10 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -367,8 +367,8 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
root = -1 root = -1
end if end if
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
myrank = blacs_pnum(icontxt,myrow,mycol) myrank = blacs_pnum(ictxt,myrow,mycol)
lda_globx = size(globx) lda_globx = size(globx)
lda_locx = size(locx) lda_locx = size(locx)
@ -379,9 +379,9 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
k = 1 k = 1
if (myrow == iiroot) then if (myrow == iiroot) then
call igebs2d(icontxt, 'all', ' ', 1, 1, k, 1) call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else else
call igebr2d(icontxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -410,7 +410,7 @@ subroutine psb_dscatterv(globx, locx, desc_a, info, iroot)
locx(i)=globx(idx) locx(i)=globx(idx)
end do end do
else else
rootrank = blacs_pnum(icontxt,root,mycol) rootrank = blacs_pnum(ictxt,root,mycol)
end if end if
! root has to gather size information ! root has to gather size information
@ -454,7 +454,7 @@ subroutine psb_dscatterv(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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

20
src/comm/psb_ihalo.f90
Unescape Escape View File

@ -63,7 +63,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, liwork,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, liwork,&
& imode, err & imode, err
integer, pointer :: xp(:,:), iwork(:) integer, pointer :: xp(:,:), iwork(:)
@ -75,10 +75,10 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -138,7 +138,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
@ -199,7 +199,7 @@ subroutine psb_ihalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -269,7 +269,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, imode,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, imode,&
& err, liwork & err, liwork
integer,pointer :: iwork(:) integer,pointer :: iwork(:)
@ -281,10 +281,10 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -330,7 +330,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
!!$ if(present(alpha)) then !!$ if(present(alpha)) then
@ -386,7 +386,7 @@ subroutine psb_ihalov(x,desc_a,info,alpha,work,tran,mode)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -62,7 +62,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,&
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,& & err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, m, lock, globk, maxk, k, jlx, ilx, i, j, idx
complex(kind(1.d0)),pointer :: tmpx(:) complex(kind(1.d0)),pointer :: tmpx(:)
@ -73,10 +73,10 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -148,9 +148,9 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,&
end if end if
if (myrow == iiroot) then if (myrow == iiroot) then
call igebs2d(icontxt, 'all', ' ', 1, 1, k, 1) call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else else
call igebr2d(icontxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -187,7 +187,7 @@ subroutine psb_zgatherm(globx, locx, desc_a, info, iroot,&
end do end do
end do end do
call gsum2d(icontxt,'a',globx(:,jglobx),rrt=root) call gsum2d(ictxt,'a',globx(:,jglobx),rrt=root)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -196,7 +196,7 @@ subroutine psb_zgatherm(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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -267,7 +267,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,& & err_act, n, iix, jjx, temp(2), root, iiroot, ilocx, iglobx, jlocx,&
& jglobx, lda_locx, lda_globx, lock, maxk, globk, m, k, jlx, ilx, i, j, idx & jglobx, lda_locx, lda_globx, lock, maxk, globk, m, k, jlx, ilx, i, j, idx
complex(kind(1.d0)),pointer :: tmpx(:) complex(kind(1.d0)),pointer :: tmpx(:)
@ -278,10 +278,10 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -331,9 +331,9 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
k = 1 k = 1
if (myrow == root) then if (myrow == root) then
call igebs2d(icontxt, 'all', ' ', 1, 1, k, 1) call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else else
call igebr2d(icontxt, 'all', ' ', 1, 1, k, 1, root, 0) call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, root, 0)
end if end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -368,7 +368,7 @@ subroutine psb_zgatherv(globx, locx, desc_a, info, iroot,&
i=i+2 i=i+2
end do end do
call dgsum2d(icontxt,'a',' ',m,k,globx,size(globx),root,mycol) call dgsum2d(ictxt,'a',' ',m,k,globx,size(globx),root,mycol)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -377,7 +377,7 @@ subroutine psb_zgatherv(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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

20
src/comm/psb_zhalo.f90
Unescape Escape View File

@ -62,7 +62,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork, ncol & err, liwork, ncol
complex(kind(1.d0)),pointer :: iwork(:), xp(:,:) complex(kind(1.d0)),pointer :: iwork(:), xp(:,:)
@ -74,10 +74,10 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -137,7 +137,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
if(present(alpha)) then if(present(alpha)) then
@ -197,7 +197,7 @@ subroutine psb_zhalom(x,desc_a,info,alpha,jx,ik,work,tran,mode)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -267,7 +267,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode)
character, intent(in), optional :: tran character, intent(in), optional :: tran
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, k, maxk, nrow, imode, i,&
& err, liwork, ncol & err, liwork, ncol
complex(kind(1.d0)),pointer :: iwork(:) complex(kind(1.d0)),pointer :: iwork(:)
@ -279,10 +279,10 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -326,7 +326,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
if(present(alpha)) then if(present(alpha)) then
@ -383,7 +383,7 @@ subroutine psb_zhalov(x,desc_a,info,alpha,work,tran,mode)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

20
src/comm/psb_zovrl.f90
Unescape Escape View File

@ -58,7 +58,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update)
integer, intent(in), optional :: update,jx,ik integer, intent(in), optional :: update,jx,ik
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,&
& imode, err, liwork, i & imode, err, liwork, i
complex(kind(1.d0)),pointer :: iwork(:), xp(:,:) complex(kind(1.d0)),pointer :: iwork(:), xp(:,:)
@ -70,10 +70,10 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -132,7 +132,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
! check for presence/size of a work area ! check for presence/size of a work area
@ -208,7 +208,7 @@ subroutine psb_zovrlm(x,desc_a,info,jx,ik,work,update)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -275,7 +275,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update)
integer, intent(in), optional :: update integer, intent(in), optional :: update
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,& & err_act, m, n, iix, jjx, temp(2), ix, ijx, nrow, ncol, k, maxk, iupdate,&
& imode, err, liwork, i & imode, err, liwork, i
complex(kind(1.d0)),pointer :: iwork(:) complex(kind(1.d0)),pointer :: iwork(:)
@ -287,10 +287,10 @@ subroutine psb_zovrlv(x,desc_a,info,work,update)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -335,7 +335,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update)
end if end if
err=info err=info
call psb_errcomm(icontxt,err) call psb_errcomm(ictxt,err)
if(err.ne.0) goto 9999 if(err.ne.0) goto 9999
! check for presence/size of a work area ! check for presence/size of a work area
@ -411,7 +411,7 @@ subroutine psb_zovrlv(x,desc_a,info,work,update)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

36
src/comm/psb_zscatter.f90
Unescape Escape View File

@ -65,7 +65,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,&
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,& & err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, icomm, k, maxk, root, ilx,&
& jlx, myrank, rootrank, c, pos & jlx, myrank, rootrank, c, pos
@ -79,10 +79,10 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -153,8 +153,8 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,&
k = maxk k = maxk
end if end if
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
myrank = blacs_pnum(icontxt,myrow,mycol) myrank = blacs_pnum(ictxt,myrow,mycol)
lda_globx = size(globx) lda_globx = size(globx)
lda_locx = size(locx) lda_locx = size(locx)
@ -163,9 +163,9 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,&
n = desc_a%matrix_data(psb_n_) n = desc_a%matrix_data(psb_n_)
if (myrow == iiroot) then if (myrow == iiroot) then
call igebs2d(icontxt, 'all', ' ', 1, 1, k, 1) call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else else
call igebr2d(icontxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -196,7 +196,7 @@ subroutine psb_zscatterm(globx, locx, desc_a, info, iroot,&
end do end do
end do end do
else else
rootrank = blacs_pnum(icontxt,root,mycol) rootrank = blacs_pnum(ictxt,root,mycol)
end if end if
! root has to gather size information ! root has to gather size information
@ -258,7 +258,7 @@ subroutine psb_zscatterm(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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -326,7 +326,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,& & err_act, m, n, iix, jjx, temp(2), i, j, idx, nrow, iiroot, iglobx, jglobx,&
& ilocx, jlocx, lda_locx, lda_globx, lock, globk, root, k, maxk, icomm, myrank,& & ilocx, jlocx, lda_locx, lda_globx, lock, globk, root, k, maxk, icomm, myrank,&
& rootrank, c, pos, ilx, jlx & rootrank, c, pos, ilx, jlx
@ -340,10 +340,10 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -367,8 +367,8 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
root = -1 root = -1
end if end if
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
myrank = blacs_pnum(icontxt,myrow,mycol) myrank = blacs_pnum(ictxt,myrow,mycol)
lda_globx = size(globx) lda_globx = size(globx)
lda_locx = size(locx) lda_locx = size(locx)
@ -379,9 +379,9 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
k = 1 k = 1
if (myrow == iiroot) then if (myrow == iiroot) then
call igebs2d(icontxt, 'all', ' ', 1, 1, k, 1) call igebs2d(ictxt, 'all', ' ', 1, 1, k, 1)
else else
call igebr2d(icontxt, 'all', ' ', 1, 1, k, 1, iiroot, 0) call igebr2d(ictxt, 'all', ' ', 1, 1, k, 1, iiroot, 0)
end if end if
! there should be a global check on k here!!! ! there should be a global check on k here!!!
@ -410,7 +410,7 @@ subroutine psb_zscatterv(globx, locx, desc_a, info, iroot)
locx(i)=globx(idx) locx(i)=globx(idx)
end do end do
else else
rootrank = blacs_pnum(icontxt,root,mycol) rootrank = blacs_pnum(ictxt,root,mycol)
end if end if
! root has to gather size information ! root has to gather size information
@ -454,7 +454,7 @@ subroutine psb_zscatterv(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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

280
src/internals/ctof_blacs.h
Unescape Escape View File

@ -47,30 +47,30 @@ static int i1, i2, i3, i4, i5, i6, i7;
blacs_pinfo_(mypnum, nprocs) blacs_pinfo_(mypnum, nprocs)
#define Cblacs_setup(mypnum, nprocs) \ #define Cblacs_setup(mypnum, nprocs) \
blacs_setup_(mypnum, nprocs) blacs_setup_(mypnum, nprocs)
#define Cblacs_get(icontxt, what, val) \ #define Cblacs_get(ictxt, what, val) \
{i1 = icontxt; i2 = what; \ {i1 = ictxt; i2 = what; \
blacs_get_(&i1, &i2,val);} blacs_get_(&i1, &i2,val);}
#define Cblacs_set(icontxt, what, val) \ #define Cblacs_set(ictxt, what, val) \
{i1 = icontxt; i2 = what; \ {i1 = ictxt; i2 = what; \
blacs_set_(&i1, &i2, &val);} blacs_set_(&i1, &i2, &val);}
#define Cblacs_gridinit(icontxt, order, nprow, npcol) \ #define Cblacs_gridinit(ictxt, order, nprow, npcol) \
{i1 = nprow; i2 = npcol; \ {i1 = nprow; i2 = npcol; \
blacs_gridinit_(icontxt, order, &i1, &i2);} blacs_gridinit_(ictxt, order, &i1, &i2);}
#define Cblacs_gridmap(icontxt, pmap, ldpmap, nprow, npcol) \ #define Cblacs_gridmap(ictxt, pmap, ldpmap, nprow, npcol) \
{i1 = ldpmap; i2 = nprow; i3 = npcol; \ {i1 = ldpmap; i2 = nprow; i3 = npcol; \
blacs_gridmap_(icontxt, pmap, &i1, &i2, &i3);} blacs_gridmap_(ictxt, pmap, &i1, &i2, &i3);}
/* Support routines: /* Support routines:
Destruction */ Destruction */
#define Cblacs_freebuff(icontxt, wait) \ #define Cblacs_freebuff(ictxt, wait) \
{i1 = icontxt; i2 = wait; \ {i1 = ictxt; i2 = wait; \
blacs_freebuff_(&i1, &i2);} blacs_freebuff_(&i1, &i2);}
#define Cblacs_gridexit(icontxt) \ #define Cblacs_gridexit(ictxt) \
{i1 = icontxt; \ {i1 = ictxt; \
blacs_gridexit_(&i1);} blacs_gridexit_(&i1);}
#define Cblacs_abort(icontxt, errornum) \ #define Cblacs_abort(ictxt, errornum) \
{i1 = icontxt; i2 = errornum; \ {i1 = ictxt; i2 = errornum; \
blacs_abort_(&i1, &i2);} blacs_abort_(&i1, &i2);}
#define Cblacs_exit(doneflag) \ #define Cblacs_exit(doneflag) \
{i1 = doneflag; \ {i1 = doneflag; \
@ -79,17 +79,17 @@ static int i1, i2, i3, i4, i5, i6, i7;
/* Support routines: /* Support routines:
Informational and Miscellaneous */ Informational and Miscellaneous */
#define Cblacs_gridinfo(icontxt,nprow,npcol,myprow,mypcol) \ #define Cblacs_gridinfo(ictxt,nprow,npcol,myprow,mypcol) \
{i1 = icontxt; \ {i1 = ictxt; \
blacs_gridinfo_(&i1, nprow, npcol, myprow, mypcol);} blacs_gridinfo_(&i1, nprow, npcol, myprow, mypcol);}
#define Cblacs_pnum(icontxt, prow, pcol) \ #define Cblacs_pnum(ictxt, prow, pcol) \
{i1 = icontxt; i2 = prow; i3 = pcol; \ {i1 = ictxt; i2 = prow; i3 = pcol; \
blacs_pnum_(&i1, &i2, &i3);} blacs_pnum_(&i1, &i2, &i3);}
#define Cblacs_pcoord(icontxt, pnum, prow, pcol) \ #define Cblacs_pcoord(ictxt, pnum, prow, pcol) \
{i1 = icontxt; i2 = pnum; \ {i1 = ictxt; i2 = pnum; \
blacs_pcoord_(&i1, &i2, prow, pcol);} blacs_pcoord_(&i1, &i2, prow, pcol);}
#define Cblacs_barrier(icontxt, scope) \ #define Cblacs_barrier(ictxt, scope) \
{i1 = icontxt; \ {i1 = ictxt; \
blacs_barrier_(&i1, scope);} blacs_barrier_(&i1, scope);}
/* Support routines: /* Support routines:
@ -102,242 +102,242 @@ static int i1, i2, i3, i4, i5, i6, i7;
dcputime_() dcputime_()
#define Cdwalltime() \ #define Cdwalltime() \
dwalltime_() dwalltime_()
#define Cksendid(icontxt, rdest, cdest) \ #define Cksendid(ictxt, rdest, cdest) \
{i1 = icontxt; i2 = rdest; i3 = cdest; \ {i1 = ictxt; i2 = rdest; i3 = cdest; \
ksendid_(&i1, &i2, &i3);} ksendid_(&i1, &i2, &i3);}
#define Ckrecvid(icontxt, rsrc, csrc) \ #define Ckrecvid(ictxt, rsrc, csrc) \
{i1 = icontxt; i2 = rsrc; i3 = csrc; \ {i1 = ictxt; i2 = rsrc; i3 = csrc; \
krecvid_(&i1, &i2, &i3);} krecvid_(&i1, &i2, &i3);}
#define Ckbsid(icontxt, scope) \ #define Ckbsid(ictxt, scope) \
{i1 = icontxt; \ {i1 = ictxt; \
kbsid_(&i1, scope);} kbsid_(&i1, scope);}
#define Ckbrid(icontxt, scope, rsrc, csrc) \ #define Ckbrid(ictxt, scope, rsrc, csrc) \
{i1 = icontxt; i2 = rsrc; i3 = csrc; \ {i1 = ictxt; i2 = rsrc; i3 = csrc; \
kbrid_(&i1, scope, &i2, &i3);} kbrid_(&i1, scope, &i2, &i3);}
/* Point to Point : /* Point to Point :
Integer */ Integer */
#define Cigesd2d(icontxt, m, n, A, lda, rdest, cdest) \ #define Cigesd2d(ictxt, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
igesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} igesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Cigerv2d(icontxt, m, n, A, lda, rsrc, csrc) \ #define Cigerv2d(ictxt, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
igerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} igerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Citrsd2d(icontxt, uplo, diag, m, n, A, lda, rdest, cdest) \ #define Citrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
itrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} itrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
#define Citrrv2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Citrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
itrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} itrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Point to Point : /* Point to Point :
Single precision real */ Single precision real */
#define Csgesd2d(icontxt, m, n, A, lda, rdest, cdest) \ #define Csgesd2d(ictxt, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
sgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} sgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Csgerv2d(icontxt, m, n, A, lda, rsrc, csrc) \ #define Csgerv2d(ictxt, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
sgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} sgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Cstrsd2d(icontxt, uplo, diag, m, n, A, lda, rdest, cdest) \ #define Cstrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
strsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} strsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
#define Cstrrv2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Cstrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
strsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} strsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Point to Point : /* Point to Point :
Double precision real */ Double precision real */
#define Cdgesd2d(icontxt, m, n, A, lda, rdest, cdest) \ #define Cdgesd2d(ictxt, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
dgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} dgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Cdgerv2d(icontxt, m, n, A, lda, rsrc, csrc) \ #define Cdgerv2d(ictxt, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
dgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} dgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Cdtrsd2d(icontxt, uplo, diag, m, n, A, lda, rdest, cdest) \ #define Cdtrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
dtrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} dtrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
#define Cdtrrv2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Cdtrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
dtrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} dtrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Point to Point : /* Point to Point :
Single precision complex */ Single precision complex */
#define Ccgesd2d(icontxt, m, n, A, lda, rdest, cdest) \ #define Ccgesd2d(ictxt, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
cgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} cgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Ccgerv2d(icontxt, m, n, A, lda, rsrc, csrc) \ #define Ccgerv2d(ictxt, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
cgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} cgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Cctrsd2d(icontxt, uplo, diag, m, n, A, lda, rdest, cdest) \ #define Cctrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
ctrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} ctrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
#define Cctrrv2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Cctrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
ctrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} ctrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Point to Point : /* Point to Point :
Double precision complex */ Double precision complex */
#define Czgesd2d(icontxt, m, n, A, lda, rdest, cdest) \ #define Czgesd2d(ictxt, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
zgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} zgesd2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Czgerv2d(icontxt, m, n, A, lda, rsrc, csrc) \ #define Czgerv2d(ictxt, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
zgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);} zgerv2d_(&i1, &i2, &i3, A, &i4, &i5, &i6);}
#define Cztrsd2d(icontxt, uplo, diag, m, n, A, lda, rdest, cdest) \ #define Cztrsd2d(ictxt, uplo, diag, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
ztrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} ztrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
#define Cztrrv2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Cztrrv2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
ztrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} ztrsd2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Broadcasts : /* Broadcasts :
Integer */ Integer */
#define Cigebs2d(icontxt, scope, top, m, n, A, lda) \ #define Cigebs2d(ictxt, scope, top, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
igebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} igebs2d_(&i1, scope, top, &i2, &i3, A, &i4);}
#define Cigebr2d(icontxt, scope, top, m, n, A, lda, rsrc, csrc) \ #define Cigebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
igebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} igebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Citrbs2d(icontxt, scope, top, uplo, diag, m, n, A, lda) \ #define Citrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
itrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} itrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);}
#define Citrbr2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Citrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
igebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} igebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Broadcasts : /* Broadcasts :
Single precision real */ Single precision real */
#define Csgebs2d(icontxt, scope, top, m, n, A, lda) \ #define Csgebs2d(ictxt, scope, top, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
sgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} sgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);}
#define Csgebr2d(icontxt, scope, top, m, n, A, lda, rsrc, csrc) \ #define Csgebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
sgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} sgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Cstrbs2d(icontxt, scope, top, uplo, diag, m, n, A, lda) \ #define Cstrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
strbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} strbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);}
#define Cstrbr2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Cstrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
sgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} sgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Broadcasts : /* Broadcasts :
Double precision real */ Double precision real */
#define Cdgebs2d(icontxt, scope, top, m, n, A, lda) \ #define Cdgebs2d(ictxt, scope, top, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
dgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} dgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);}
#define Cdgebr2d(icontxt, scope, top, m, n, A, lda, rsrc, csrc) \ #define Cdgebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
dgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} dgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Cdtrbs2d(icontxt, scope, top, uplo, diag, m, n, A, lda) \ #define Cdtrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
dtrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} dtrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);}
#define Cdtrbr2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Cdtrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
dgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} dgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Broadcasts : /* Broadcasts :
Single precision complex */ Single precision complex */
#define Ccgebs2d(icontxt, scope, top, m, n, A, lda) \ #define Ccgebs2d(ictxt, scope, top, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
cgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} cgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);}
#define Ccgebr2d(icontxt, scope, top, m, n, A, lda, rsrc, csrc) \ #define Ccgebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
cgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} cgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Cctrbs2d(icontxt, scope, top, uplo, diag, m, n, A, lda) \ #define Cctrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
ctrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} ctrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);}
#define Cctrbr2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Cctrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
cgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} cgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Broadcasts : /* Broadcasts :
Double precision complex */ Double precision complex */
#define Czgebs2d(icontxt, scope, top, m, n, A, lda) \ #define Czgebs2d(ictxt, scope, top, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
zgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);} zgebs2d_(&i1, scope, top, &i2, &i3, A, &i4);}
#define Czgebr2d(icontxt, scope, top, m, n, A, lda, rsrc, csrc) \ #define Czgebr2d(ictxt, scope, top, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
zgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} zgebr2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Cztrbs2d(icontxt, scope, top, uplo, diag, m, n, A, lda) \ #define Cztrbs2d(ictxt, scope, top, uplo, diag, m, n, A, lda) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; \
ztrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);} ztrbs2d_(&i1, scope, top, uplo, diag, &i2, &i3, A, &i4);}
#define Cztrbr2d(icontxt, uplo, diag, m, n, A, lda, rsrc, csrc) \ #define Cztrbr2d(ictxt, uplo, diag, m, n, A, lda, rsrc, csrc) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rsrc; i6 = csrc; \
zgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);} zgebr2d_(&i1, uplo, diag, &i2, &i3, A, &i4, &i5, &i6);}
/* Combines: /* Combines:
Integer */ Integer */
#define Cigsum2d(icontxt, scope, top, m, n, A, lda, rdest, cdest) \ #define Cigsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
igsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} igsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Cigamx2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Cigamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
igamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} igamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}
#define Cigamn2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Cigamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
igamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} igamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}
/* Combines: /* Combines:
Single precision real */ Single precision real */
#define Csgsum2d(icontxt, scope, top, m, n, A, lda, rdest, cdest) \ #define Csgsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
sgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} sgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Csgamx2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Csgamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
sgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} sgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}
#define Csgamn2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Csgamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
sgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} sgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}
/* Combines: /* Combines:
Double precision real */ Double precision real */
#define Cdgsum2d(icontxt, scope, top, m, n, A, lda, rdest, cdest) \ #define Cdgsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
dgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} dgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Cdgamx2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Cdgamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
dgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} dgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}
#define Cdgamn2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Cdgamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
dgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} dgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}
/* Combines: /* Combines:
Single precision complex */ Single precision complex */
#define Ccgsum2d(icontxt, scope, top, m, n, A, lda, rdest, cdest) \ #define Ccgsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
cgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} cgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Ccgamx2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Ccgamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
cgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} cgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}
#define Ccgamn2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Ccgamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
cgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} cgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}
/* Combines: /* Combines:
Double precision complex */ Double precision complex */
#define Czgsum2d(icontxt, scope, top, m, n, A, lda, rdest, cdest) \ #define Czgsum2d(ictxt, scope, top, m, n, A, lda, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = rdest; i6 = cdest; \
zgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);} zgsum2d_(&i1, scope, top, &i2, &i3, A, &i4, &i5, &i6);}
#define Czgamx2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Czgamx2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
zgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} zgamx2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}
#define Czgamn2d(icontxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \ #define Czgamn2d(ictxt, scope, top, m, n, A, lda, RA, CA, RCflag, rdest, cdest) \
{i1 = icontxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \ {i1 = ictxt; i2 = m; i3 = n; i4 = lda; i5 = RCflag; i6 = rdest; i7 = cdest; \
zgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);} zgamn2d_(&i1, scope, top, &i2, &i3, A, &i4, RA, CA, &i5, &i6, &i7);}

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

@ -41,7 +41,7 @@ subroutine psi_compute_size(desc_data,&
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,counter, max_index
integer :: icontxt, err, err_act, np integer :: ictxt, err, err_act, np
! ...local array... ! ...local array...
integer :: exch(2) integer :: exch(2)
integer :: int_err(5) integer :: int_err(5)
@ -55,9 +55,9 @@ subroutine psi_compute_size(desc_data,&
call psb_get_erraction(err_act) call psb_get_erraction(err_act)
info = 0 info = 0
icontxt = desc_data(psb_ctxt_) ictxt = desc_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -113,7 +113,7 @@ subroutine psi_compute_size(desc_data,&
enddo enddo
! computing max global value of dl_lda ! computing max global value of dl_lda
call igamx2d(icontxt, psb_all_, psb_topdef_, 1, ione, dl_lda, & call igamx2d(ictxt, psb_all_, psb_topdef_, 1, ione, dl_lda, &
&1, counter, counter, -ione ,-ione,-ione) &1, counter, counter, -ione ,-ione,-ione)
if (debug) then if (debug) then
@ -126,7 +126,7 @@ 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

8
src/internals/psi_crea_index.f90
Unescape Escape View File

@ -44,7 +44,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
! ....local scalars... ! ....local scalars...
integer :: me,npcol,mycol,nprow,i,j,k,& integer :: me,npcol,mycol,nprow,i,j,k,&
& mode, int_err(5), err, err_act, np,& & mode, int_err(5), err, err_act, np,&
& dl_lda, icontxt, proc, nerv, nesd & dl_lda, ictxt, proc, nerv, nesd
! ...parameters... ! ...parameters...
integer, pointer :: dep_list(:,:), length_dl(:) integer, pointer :: dep_list(:,:), length_dl(:)
integer,parameter :: root=0,no_comm=-1 integer,parameter :: root=0,no_comm=-1
@ -88,8 +88,8 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
name='psi_crea_index' name='psi_crea_index'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,np,npcol,me,mycol) call blacs_gridinfo(ictxt,np,npcol,me,mycol)
if (np == -1) then if (np == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -159,7 +159,7 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

20
src/internals/psi_desc_index.f90
Unescape Escape View File

@ -47,7 +47,7 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,&
!c ....local scalars... !c ....local scalars...
integer :: j,me,np,npcol,mycol,i,proc,dim integer :: j,me,np,npcol,mycol,i,proc,dim
!c ...parameters... !c ...parameters...
integer :: icontxt integer :: ictxt
integer :: no_comm,err integer :: no_comm,err
parameter (no_comm=-1) parameter (no_comm=-1)
!c ...local arrays.. !c ...local arrays..
@ -67,8 +67,8 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,&
!c if mode == 1 then we can use glob_to_loc array !c if mode == 1 then we can use glob_to_loc array
!c else we can't utilize it !c else we can't utilize it
icontxt=desc_data(psb_ctxt_) ictxt=desc_data(psb_ctxt_)
call blacs_gridinfo(icontxt,np,npcol,me,mycol) call blacs_gridinfo(ictxt,np,npcol,me,mycol)
if (np == -1) then if (np == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -82,10 +82,10 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,&
if (debug) then if (debug) then
write(0,*) me,'start desc_index' write(0,*) me,'start desc_index'
call blacs_barrier(icontxt,'all') call blacs_barrier(ictxt,'all')
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
!c !c
!c first, find out the total sizes to be exchanged. !c first, find out the total sizes to be exchanged.
!c note: things marked here as sndbuf/rcvbuf (for mpi) corresponds to things !c note: things marked here as sndbuf/rcvbuf (for mpi) corresponds to things
@ -136,7 +136,7 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,&
end if end if
if (debug) then if (debug) then
write(0,*) me,'computed sizes ',iszr,iszs write(0,*) me,'computed sizes ',iszr,iszs
call blacs_barrier(icontxt,'all') call blacs_barrier(ictxt,'all')
endif endif
ntot = (3*(max(count(sdsz>0),count(rvsz>0)))+ iszs + iszr) + 1 ntot = (3*(max(count(sdsz>0),count(rvsz>0)))+ iszs + iszr) + 1
@ -153,7 +153,7 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,&
if (debug) then if (debug) then
write(0,*) me,'computed allocated workspace ',iszr,iszs write(0,*) me,'computed allocated workspace ',iszr,iszs
call blacs_barrier(icontxt,'all') call blacs_barrier(ictxt,'all')
endif endif
allocate(sndbuf(iszs),rcvbuf(iszr),stat=info) allocate(sndbuf(iszs),rcvbuf(iszr),stat=info)
if(info /= 0) then if(info /= 0) then
@ -190,7 +190,7 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,&
if (debug) then if (debug) then
write(0,*) me,' prepared send buffer ' write(0,*) me,' prepared send buffer '
call blacs_barrier(icontxt,'all') call blacs_barrier(ictxt,'all')
endif endif
!c !c
!c now have to regenerate bsdindx !c now have to regenerate bsdindx
@ -245,7 +245,7 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,&
if (debug) then if (debug) then
write(0,*) me,'end desc_index' write(0,*) me,'end desc_index'
call blacs_barrier(icontxt,'all') call blacs_barrier(ictxt,'all')
endif endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -254,7 +254,7 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,&
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

56
src/internals/psi_dswapdata.f90
Unescape Escape View File

@ -43,7 +43,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -99,8 +99,8 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
name='psi_dswap_data' name='psi_dswap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -112,7 +112,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
@ -152,7 +152,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -240,20 +240,20 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call dgesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I receive ! Then I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call dgerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call dgerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call dgesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
@ -297,7 +297,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
@ -328,7 +328,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -435,7 +435,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call dgesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -451,7 +451,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call dgerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
@ -484,7 +484,7 @@ subroutine psi_dswapdatam(flag,n,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -536,7 +536,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -593,8 +593,8 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
name='psi_dswap_datav' name='psi_dswap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -606,7 +606,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
@ -648,7 +648,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -735,20 +735,20 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
call dgesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I receive ! Then I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call dgerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call dgerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
call dgesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
@ -792,7 +792,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
@ -822,7 +822,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -930,7 +930,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
call dgesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -946,7 +946,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call dgerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
@ -979,7 +979,7 @@ subroutine psi_dswapdatav(flag,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

56
src/internals/psi_dswaptran.f90
Unescape Escape View File

@ -43,7 +43,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -100,8 +100,8 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
name='psi_dswaptranm' name='psi_dswaptranm'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -113,7 +113,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
@ -153,7 +153,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -241,20 +241,20 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
call dgesd2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I receive ! Then I receive
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call dgerv2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call dgerv2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
call dgesd2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
@ -299,7 +299,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call mpi_irecv(sndbuf(rcv_pt),sdsz(proc_to_comm),& call mpi_irecv(sndbuf(rcv_pt),sdsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
@ -329,7 +329,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -436,7 +436,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
call dgesd2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -452,7 +452,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call dgerv2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y)
@ -484,7 +484,7 @@ subroutine psi_dswaptranm(flag,n,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -541,7 +541,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -598,8 +598,8 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
name='psi_dswaptranv' name='psi_dswaptranv'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -611,7 +611,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
@ -652,7 +652,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -739,20 +739,20 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
call dgesd2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I receive ! Then I receive
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call dgerv2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call dgerv2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
call dgesd2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
@ -797,7 +797,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
@ -827,7 +827,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_double_precision,prcid(proc_to_comm),& & mpi_double_precision,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -934,7 +934,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
call dgesd2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call dgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -950,7 +950,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call dgerv2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call dgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
@ -983,7 +983,7 @@ subroutine psi_dswaptranv(flag,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -135,7 +135,7 @@ c .....local arrays....
c .....local scalars... c .....local scalars...
integer i,nprow,npcol,me,mycol,pointer_dep_list,proc,j,err_act integer i,nprow,npcol,me,mycol,pointer_dep_list,proc,j,err_act
integer icontxt, err, icomm integer ictxt, err, icomm
logical debug logical debug
parameter (debug=.false.) parameter (debug=.false.)
character name*20 character name*20
@ -143,10 +143,10 @@ c .....local scalars...
call fcpsb_get_erraction(err_act) call fcpsb_get_erraction(err_act)
info = 0 info = 0
icontxt = desc_data(psb_ctxt_) ictxt = desc_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
do i=0,np do i=0,np
length_dl(i) = 0 length_dl(i) = 0
enddo enddo
@ -244,14 +244,14 @@ 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(icontxt, all, topdef, ione, ione, err, ione, c$$$ call igamx2d(ictxt, all, topdef, ione, ione, err, ione,
c$$$ + i, i, -ione ,-ione,-ione) c$$$ + i, i, -ione ,-ione,-ione)
if (err.ne.0) goto 9999 if (err.ne.0) goto 9999
if (.true.) then if (.true.) then
call igsum2d(icontxt,'all',' ',np+1,1,length_dl,np+1,-1,-1) call igsum2d(ictxt,'all',' ',np+1,1,length_dl,np+1,-1,-1)
call blacs_get(icontxt,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)
@ -266,11 +266,11 @@ c$$$ + i, i, -ione ,-ione,-ione)
if (proc.ne.psb_root_) then if (proc.ne.psb_root_) then
if (debug) write(0,*) 'receiving from: ',proc if (debug) write(0,*) 'receiving from: ',proc
c ...receive from proc length of its dependence list.... c ...receive from proc length of its dependence list....
call igerv2d(icontxt,1,1,length_dl(proc),1, call igerv2d(ictxt,1,1,length_dl(proc),1,
+ proc,mycol) + proc,mycol)
c ...receive from proc its dependence list.... c ...receive from proc its dependence list....
call igerv2d(icontxt,length_dl(proc),1, call igerv2d(ictxt,length_dl(proc),1,
+ dep_list(1,proc),length_dl(proc),proc,mycol) + dep_list(1,proc),length_dl(proc),proc,mycol)
endif endif
@ -278,10 +278,10 @@ c ...receive from proc its dependence list....
else if (me.ne.psb_root_) then else if (me.ne.psb_root_) then
c ...send to root dependence list length..... c ...send to root dependence list length.....
if (debug) write(0,*) 'sending to: ',me,psb_root_ if (debug) write(0,*) 'sending to: ',me,psb_root_
call igesd2d(icontxt,1,1,length_dl(me),1,psb_root_,mycol) call igesd2d(ictxt,1,1,length_dl(me),1,psb_root_,mycol)
if (debug) write(0,*) 'sending to: ',me,psb_root_ if (debug) write(0,*) 'sending to: ',me,psb_root_
c ...send to root dependence list.... c ...send to root dependence list....
call igesd2d(icontxt,length_dl(me),1,dep_list(1,me), call igesd2d(ictxt,length_dl(me),1,dep_list(1,me),
+ length_dl(me),psb_root_,mycol) + length_dl(me),psb_root_,mycol)
endif endif
@ -292,7 +292,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(icontxt) call fcpsb_perror(ictxt)
endif endif
return return

56
src/internals/psi_iswapdata.f90
Unescape Escape View File

@ -43,7 +43,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -99,8 +99,8 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
name='psi_dswap_data' name='psi_dswap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -112,7 +112,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
@ -152,7 +152,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -240,20 +240,20 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call igesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call igesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I receive ! Then I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call igesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call igesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
@ -297,7 +297,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_integer,prcid(proc_to_comm),& & mpi_integer,prcid(proc_to_comm),&
@ -328,7 +328,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_integer,prcid(proc_to_comm),& & mpi_integer,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -435,7 +435,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call igesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call igesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -451,7 +451,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
@ -484,7 +484,7 @@ subroutine psi_iswapdatam(flag,n,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -536,7 +536,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -593,8 +593,8 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
name='psi_dswap_datav' name='psi_dswap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -606,7 +606,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
@ -648,7 +648,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -735,20 +735,20 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
call igesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call igesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I receive ! Then I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
call igesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call igesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
@ -792,7 +792,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_integer,prcid(proc_to_comm),& & mpi_integer,prcid(proc_to_comm),&
@ -822,7 +822,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_integer,prcid(proc_to_comm),& & mpi_integer,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -930,7 +930,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
call igesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call igesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -946,7 +946,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
@ -979,7 +979,7 @@ subroutine psi_iswapdatav(flag,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

56
src/internals/psi_iswaptran.f90
Unescape Escape View File

@ -43,7 +43,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -100,8 +100,8 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
name='psi_dswaptranm' name='psi_dswaptranm'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -113,7 +113,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
@ -153,7 +153,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -241,20 +241,20 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
call igesd2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I receive ! Then I receive
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call igerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call igerv2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call igerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
call igesd2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
@ -299,7 +299,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call mpi_irecv(sndbuf(rcv_pt),sdsz(proc_to_comm),& call mpi_irecv(sndbuf(rcv_pt),sdsz(proc_to_comm),&
& mpi_integer,prcid(proc_to_comm),& & mpi_integer,prcid(proc_to_comm),&
@ -329,7 +329,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_integer,prcid(proc_to_comm),& & mpi_integer,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -436,7 +436,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
call igesd2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -452,7 +452,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call igerv2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call igerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y)
@ -484,7 +484,7 @@ subroutine psi_iswaptranm(flag,n,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -538,7 +538,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -595,8 +595,8 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
name='psi_dswaptranv' name='psi_dswaptranv'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -608,7 +608,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
@ -649,7 +649,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -736,20 +736,20 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
call igesd2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I receive ! Then I receive
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call igerv2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call igerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call igerv2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call igerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
call igesd2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
@ -794,7 +794,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_integer,prcid(proc_to_comm),& & mpi_integer,prcid(proc_to_comm),&
@ -824,7 +824,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_integer,prcid(proc_to_comm),& & mpi_integer,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -931,7 +931,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
call igesd2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call igesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -947,7 +947,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call igerv2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call igerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
@ -980,7 +980,7 @@ subroutine psi_iswaptranv(flag,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

56
src/internals/psi_zswapdata.f90
Unescape Escape View File

@ -43,7 +43,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -115,8 +115,8 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
name='psi_zswap_data' name='psi_zswap_data'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -128,7 +128,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
@ -168,7 +168,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -256,20 +256,20 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call zgesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I receive ! Then I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call zgerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call zgerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call zgesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
@ -313,7 +313,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_double_complex,prcid(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),&
@ -344,7 +344,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_double_complex,prcid(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -451,7 +451,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd*n-1)) & y,sndbuf(snd_pt:snd_pt+nesd*n-1))
call zgesd2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgesd2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -467,7 +467,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call zgerv2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgerv2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_sct(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
@ -500,7 +500,7 @@ subroutine psi_zswapdatam(flag,n,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -552,7 +552,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -625,8 +625,8 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
name='psi_zswap_datav' name='psi_zswap_datav'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -638,7 +638,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
@ -680,7 +680,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -767,20 +767,20 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
call zgesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I receive ! Then I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call zgerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call zgerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
call zgesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
@ -824,7 +824,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_irecv(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_double_complex,prcid(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),&
@ -854,7 +854,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_send(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_double_complex,prcid(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -962,7 +962,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_gth(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
& y,sndbuf(snd_pt:snd_pt+nesd-1)) & y,sndbuf(snd_pt:snd_pt+nesd-1))
call zgesd2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgesd2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -978,7 +978,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call zgerv2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgerv2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_sct(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
@ -1011,7 +1011,7 @@ subroutine psi_zswapdatav(flag,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

56
src/internals/psi_zswaptran.f90
Unescape Escape View File

@ -43,7 +43,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -116,8 +116,8 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
name='psi_zswaptranm' name='psi_zswaptranm'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -129,7 +129,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
@ -169,7 +169,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -257,20 +257,20 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
call zgesd2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I receive ! Then I receive
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call zgerv2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call zgerv2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
call zgesd2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
@ -315,7 +315,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call mpi_irecv(sndbuf(rcv_pt),sdsz(proc_to_comm),& call mpi_irecv(sndbuf(rcv_pt),sdsz(proc_to_comm),&
& mpi_double_complex,prcid(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),&
@ -345,7 +345,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_double_complex,prcid(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -452,7 +452,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,n,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv*n-1))
call zgesd2d(icontxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgesd2d(ictxt,nerv,n,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -468,7 +468,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call zgerv2d(icontxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgerv2d(ictxt,nesd,n,sndbuf(snd_pt),nesd,proc_to_comm,0)
idx_pt = point_to_proc+nerv+psb_elem_send_ idx_pt = point_to_proc+nerv+psb_elem_send_
call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),& call psi_sct(nesd,n,d_idx(idx_pt:idx_pt+nesd-1),&
& sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y) & sndbuf(snd_pt:snd_pt+n*nesd-1),beta,y)
@ -500,7 +500,7 @@ subroutine psi_zswaptranm(flag,n,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -557,7 +557,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
integer, optional :: data integer, optional :: data
! locals ! locals
integer :: icontxt, nprow, npcol, myrow,& integer :: ictxt, nprow, npcol, myrow,&
& mycol, point_to_proc, nesd, nerv,& & mycol, point_to_proc, nesd, nerv,&
& proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),& & proc_to_comm, p2ptag, icomm, p2pstat(mpi_status_size),&
& idxs, idxr, iret, errlen, ifcomm, rank,& & idxs, idxr, iret, errlen, ifcomm, rank,&
@ -630,8 +630,8 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
name='psi_zswaptranv' name='psi_zswaptranv'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,myrow,mycol) call blacs_gridinfo(ictxt,nprow,npcol,myrow,mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -643,7 +643,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
goto 9999 goto 9999
endif endif
call blacs_get(icontxt,10,icomm) call blacs_get(ictxt,10,icomm)
allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),& allocate(sdsz(0:nprow-1), rvsz(0:nprow-1), bsdidx(0:nprow-1),&
& brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),& & brvidx(0:nprow-1), rvhd(0:nprow-1), prcid(0:nprow-1),&
@ -684,7 +684,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
nerv = d_idx(point_to_proc+psb_n_elem_recv_) nerv = d_idx(point_to_proc+psb_n_elem_recv_)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
prcid(proc_to_comm) = blacs_pnum(icontxt,proc_to_comm,mycol) prcid(proc_to_comm) = blacs_pnum(ictxt,proc_to_comm,mycol)
ptp(proc_to_comm) = point_to_proc ptp(proc_to_comm) = point_to_proc
brvidx(proc_to_comm) = idxr brvidx(proc_to_comm) = idxr
@ -771,20 +771,20 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
call zgesd2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
! Then I receive ! Then I receive
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call zgerv2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
else if (proc_to_comm .gt. myrow) then else if (proc_to_comm .gt. myrow) then
! First I receive ! First I receive
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call zgerv2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
! Then I send ! Then I send
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
call zgesd2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
else if (proc_to_comm .eq. myrow) then else if (proc_to_comm .eq. myrow) then
! I send to myself ! I send to myself
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
@ -829,7 +829,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_) nesd = d_idx(point_to_proc+nerv+psb_n_elem_send_)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
p2ptag = krecvid(icontxt,proc_to_comm,myrow) p2ptag = krecvid(ictxt,proc_to_comm,myrow)
snd_pt = brvidx(proc_to_comm) snd_pt = brvidx(proc_to_comm)
call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),& call mpi_irecv(sndbuf(snd_pt),sdsz(proc_to_comm),&
& mpi_double_complex,prcid(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),&
@ -859,7 +859,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
if(proc_to_comm .ne. myrow) then if(proc_to_comm .ne. myrow) then
p2ptag=ksendid(icontxt,proc_to_comm,myrow) p2ptag=ksendid(ictxt,proc_to_comm,myrow)
call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),& call mpi_send(rcvbuf(rcv_pt),rvsz(proc_to_comm),&
& mpi_double_complex,prcid(proc_to_comm),& & mpi_double_complex,prcid(proc_to_comm),&
& p2ptag,icomm,iret) & p2ptag,icomm,iret)
@ -966,7 +966,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),& call psi_gth(nerv,d_idx(idx_pt:idx_pt+nerv-1),&
& y,rcvbuf(rcv_pt:rcv_pt+nerv-1)) & y,rcvbuf(rcv_pt:rcv_pt+nerv-1))
call zgesd2d(icontxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0) call zgesd2d(ictxt,nerv,1,rcvbuf(rcv_pt),nerv,proc_to_comm,0)
point_to_proc = point_to_proc+nerv+nesd+3 point_to_proc = point_to_proc+nerv+nesd+3
proc_to_comm = d_idx(point_to_proc+psb_proc_id_) proc_to_comm = d_idx(point_to_proc+psb_proc_id_)
@ -982,7 +982,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,data)
if(proc_to_comm.ne.myrow) then if(proc_to_comm.ne.myrow) then
snd_pt = bsdidx(proc_to_comm) snd_pt = bsdidx(proc_to_comm)
call zgerv2d(icontxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0) call zgerv2d(ictxt,nesd,1,sndbuf(snd_pt),nesd,proc_to_comm,0)
idx_pt = point_to_proc+psb_elem_recv_ idx_pt = point_to_proc+psb_elem_recv_
rcv_pt = brvidx(proc_to_comm) rcv_pt = brvidx(proc_to_comm)
call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),& call psi_sct(nesd,d_idx(idx_pt:idx_pt+nesd-1),&
@ -1015,7 +1015,7 @@ subroutine psi_zswaptranv(flag,beta,y,desc_a,work,info,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

14
src/methd/extra_env.f90
Unescape Escape View File

@ -1,11 +1,11 @@
subroutine psb_set_coher(icontxt,isvch) subroutine psb_set_coher(ictxt,isvch)
integer :: icontxt, isvch integer :: ictxt, isvch
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
Call blacs_get(icontxt,16,isvch) Call blacs_get(ictxt,16,isvch)
Call blacs_set(icontxt,16,1) Call blacs_set(ictxt,16,1)
end subroutine psb_set_coher end subroutine psb_set_coher
subroutine psb_restore_coher(icontxt,isvch) subroutine psb_restore_coher(ictxt,isvch)
integer :: icontxt, isvch integer :: ictxt, isvch
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
Call blacs_set(icontxt,16,isvch) Call blacs_set(ictxt,16,isvch)
end subroutine psb_restore_coher end subroutine psb_restore_coher

14
src/methd/extra_env_essl.f90
Unescape Escape View File

@ -1,13 +1,13 @@
subroutine psb_set_coher(icontxt,isvch) subroutine psb_set_coher(ictxt,isvch)
integer :: icontxt, isvch integer :: ictxt, isvch
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
! Do nothing: ESSL does coherence by default, ! Do nothing: ESSL does coherence by default,
! and does not handle req=16 ! and does not handle req=16
!!$ Call blacs_get(icontxt,16,isvch) !!$ Call blacs_get(ictxt,16,isvch)
!!$ Call blacs_set(icontxt,16,1) !!$ Call blacs_set(ictxt,16,1)
end subroutine psb_set_coher end subroutine psb_set_coher
subroutine psb_restore_coher(icontxt,isvch) subroutine psb_restore_coher(ictxt,isvch)
integer :: icontxt, isvch integer :: ictxt, isvch
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
!!$ Call blacs_set(icontxt,16,isvch) !!$ Call blacs_set(ictxt,16,isvch)
end subroutine psb_restore_coher end subroutine psb_restore_coher

10
src/methd/psb_dbicg.f90
Unescape Escape View File

@ -108,7 +108,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
logical, parameter :: debug = .false. logical, parameter :: debug = .false.
logical, parameter :: exchange=.true., noexchange=.false. logical, parameter :: exchange=.true., noexchange=.false.
integer, parameter :: irmax = 8 integer, parameter :: irmax = 8
integer :: itx, i, isvch, ich, icontxt integer :: itx, i, isvch, ich, ictxt
logical :: do_renum_left logical :: do_renum_left
real(kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,& real(kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,&
& sigma, omega, tau,bn2 & sigma, omega, tau,bn2
@ -119,8 +119,8 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (debug) write(*,*) 'entering psb_dbicg' if (debug) write(*,*) 'entering psb_dbicg'
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,me,mecol) call blacs_gridinfo(ictxt,nprows,npcols,me,mecol)
if (debug) write(*,*) 'psb_dbicg: from gridinfo',nprows,npcols,me if (debug) write(*,*) 'psb_dbicg: from gridinfo',nprows,npcols,me
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
@ -128,7 +128,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
n_col = desc_a%matrix_data(psb_n_col_) n_col = desc_a%matrix_data(psb_n_col_)
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(icontxt,isvch) call psb_set_coher(ictxt,isvch)
if (present(istop)) then if (present(istop)) then
@ -344,7 +344,7 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
call psb_gefree(wwrk,desc_a,info) call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour ! restore external global coherence behaviour
call psb_restore_coher(icontxt,isvch) call psb_restore_coher(ictxt,isvch)
if(info/=0) then if(info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)

10
src/methd/psb_dcg.f90
Unescape Escape View File

@ -103,7 +103,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
real(kind(1.d0)) ::alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& real(kind(1.d0)) ::alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,&
& sigma & sigma
integer :: litmax, liter, istop_, naux, m, mglob, it, itx, itrace_,& integer :: litmax, liter, istop_, naux, m, mglob, it, itx, itrace_,&
& nprows,npcols,me,mecol, n_col, isvch, ich, icontxt, n_row,err_act, int_err(5) & nprows,npcols,me,mecol, n_col, isvch, ich, ictxt, n_row,err_act, int_err(5)
character ::diagl, diagu character ::diagl, diagu
logical, parameter :: exchange=.true., noexchange=.false. logical, parameter :: exchange=.true., noexchange=.false.
character(len=20) :: name,ch_err character(len=20) :: name,ch_err
@ -113,8 +113,8 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,me,mecol) call blacs_gridinfo(ictxt,nprows,npcols,me,mecol)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
n_row = desc_a%matrix_data(psb_n_row_) n_row = desc_a%matrix_data(psb_n_row_)
@ -178,7 +178,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
itx=0 itx=0
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(icontxt,isvch) call psb_set_coher(ictxt,isvch)
restart: do restart: do
!!$ !!$
@ -274,7 +274,7 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
call psb_gefree(wwrk,desc_a,info) call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour ! restore external global coherence behaviour
call psb_restore_coher(icontxt,isvch) call psb_restore_coher(ictxt,isvch)
if (info.ne.0) then if (info.ne.0) then
call psb_errpush(info,name) call psb_errpush(info,name)

10
src/methd/psb_dcgs.f90
Unescape Escape View File

@ -105,7 +105,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
Character ::diagl, diagu Character ::diagl, diagu
Logical, Parameter :: exchange=.True., noexchange=.False. Logical, Parameter :: exchange=.True., noexchange=.False.
Integer, Parameter :: irmax = 8 Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt Integer :: itx, i, isvch, ich, ictxt
Logical :: do_renum_left Logical :: do_renum_left
Logical, Parameter :: debug = .false. Logical, Parameter :: debug = .false.
Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,&
@ -117,8 +117,8 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
If (debug) Write(*,*) 'entering psb_dcgs' If (debug) Write(*,*) 'entering psb_dcgs'
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
Call blacs_gridinfo(icontxt,nprows,npcols,me,mecol) Call blacs_gridinfo(ictxt,nprows,npcols,me,mecol)
If (debug) Write(*,*) 'psb_dcgs: from gridinfo',nprows,npcols,me If (debug) Write(*,*) 'psb_dcgs: from gridinfo',nprows,npcols,me
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
@ -186,7 +186,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
End If End If
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(icontxt,isvch) call psb_set_coher(ictxt,isvch)
diagl = 'u' diagl = 'u'
diagu = 'u' diagu = 'u'
@ -335,7 +335,7 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
Call psb_gefree(wwrk,desc_a,info) Call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour ! restore external global coherence behaviour
call psb_restore_coher(icontxt,isvch) call psb_restore_coher(ictxt,isvch)
if(info/=0) then if(info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)

16
src/methd/psb_dcgstab.f90
Unescape Escape View File

@ -106,7 +106,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
Logical, Parameter :: debug = .false. Logical, Parameter :: debug = .false.
Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False. Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False.
Integer, Parameter :: irmax = 8 Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt, err_act, int_err(5),ii Integer :: itx, i, isvch, ich, ictxt, err_act, int_err(5),ii
Integer :: istop_ Integer :: istop_
Logical :: do_renum_left Logical :: do_renum_left
Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,& Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,&
@ -120,8 +120,8 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
If (debug) Write(*,*) 'Entering PSB_DCGSTAB',present(istop) If (debug) Write(*,*) 'Entering PSB_DCGSTAB',present(istop)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
CALL blacs_gridinfo(icontxt,nprows,npcols,myrow,mycol) CALL blacs_gridinfo(ictxt,nprows,npcols,myrow,mycol)
if (debug) write(*,*) 'PSB_DCGSTAB: From GRIDINFO',nprows,npcols,myrow if (debug) write(*,*) 'PSB_DCGSTAB: From GRIDINFO',nprows,npcols,myrow
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
@ -191,7 +191,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
diagu = 'U' diagu = 'U'
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(icontxt,isvch) call psb_set_coher(ictxt,isvch)
itx = 0 itx = 0
@ -278,9 +278,9 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
If (debug) Write(*,*) 'Iteration: ',itx If (debug) Write(*,*) 'Iteration: ',itx
rho_old = rho rho_old = rho
rho = psb_gedot(q,r,desc_a,info) rho = psb_gedot(q,r,desc_a,info)
!!$ call blacs_barrier(icontxt,'All') ! to be removed !!$ call blacs_barrier(ictxt,'All') ! to be removed
!!$ write(0,'(i2," rho old ",2(f,2x))')myrow,rho,rho_old !!$ write(0,'(i2," rho old ",2(f,2x))')myrow,rho,rho_old
!!$ call blacs_barrier(icontxt,'All') ! to be removed !!$ call blacs_barrier(ictxt,'All') ! to be removed
If (rho==dzero) Then If (rho==dzero) Then
If (debug) Write(0,*) 'Bi-CGSTAB Itxation breakdown R',rho If (debug) Write(0,*) 'Bi-CGSTAB Itxation breakdown R',rho
Exit iteration Exit iteration
@ -388,7 +388,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
Deallocate(aux) Deallocate(aux)
Call psb_gefree(wwrk,desc_a,info) Call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour ! restore external global coherence behaviour
call psb_restore_coher(icontxt,isvch) call psb_restore_coher(ictxt,isvch)
!!$ imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" ) !!$ imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" )
if(info/=0) then if(info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)
@ -401,7 +401,7 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

10
src/methd/psb_dcgstabl.f90
Unescape Escape View File

@ -114,7 +114,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
Character ::diagl, diagu Character ::diagl, diagu
Logical, Parameter :: exchange=.True., noexchange=.False. Logical, Parameter :: exchange=.True., noexchange=.False.
Integer, Parameter :: irmax = 8 Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt,istop_,j, int_err(5) Integer :: itx, i, isvch, ich, ictxt,istop_,j, int_err(5)
Logical :: do_renum_left Logical :: do_renum_left
Logical, Parameter :: debug = .False. Logical, Parameter :: debug = .False.
Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,&
@ -126,8 +126,8 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
If (debug) Write(0,*) 'entering psb_dbicgstabl' If (debug) Write(0,*) 'entering psb_dbicgstabl'
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
Call blacs_gridinfo(icontxt,nprows,npcols,me,mecol) Call blacs_gridinfo(ictxt,nprows,npcols,me,mecol)
If (debug) Write(0,*) 'psb_dbicgstabl: from gridinfo',nprows,npcols,me If (debug) Write(0,*) 'psb_dbicgstabl: from gridinfo',nprows,npcols,me
@ -207,7 +207,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
rt0 => wwrk(:,10) rt0 => wwrk(:,10)
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(icontxt,isvch) call psb_set_coher(ictxt,isvch)
if (istop_ == 1) then if (istop_ == 1) then
ani = psb_spnrmi(a,desc_a,info) ani = psb_spnrmi(a,desc_a,info)
@ -394,7 +394,7 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
Call psb_gefree(rh,desc_a,info) Call psb_gefree(rh,desc_a,info)
! restore external global coherence behaviour ! restore external global coherence behaviour
call psb_restore_coher(icontxt,isvch) call psb_restore_coher(ictxt,isvch)
if(info/=0) then if(info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)

10
src/methd/psb_dgmresr.f90
Unescape Escape View File

@ -116,7 +116,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
Character ::diagl, diagu Character ::diagl, diagu
Logical, Parameter :: exchange=.True., noexchange=.False. Logical, Parameter :: exchange=.True., noexchange=.False.
Integer, Parameter :: irmax = 8 Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt,istop_, err_act Integer :: itx, i, isvch, ich, ictxt,istop_, err_act
Logical :: do_renum_left,inner_stop Logical :: do_renum_left,inner_stop
Logical, Parameter :: debug = .false. Logical, Parameter :: debug = .false.
Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,& Real(Kind(1.d0)) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,&
@ -129,8 +129,8 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
If (debug) Write(0,*) 'entering psb_dgmres' If (debug) Write(0,*) 'entering psb_dgmres'
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
Call blacs_gridinfo(icontxt,nprows,npcols,me,mecol) Call blacs_gridinfo(ictxt,nprows,npcols,me,mecol)
If (debug) Write(0,*) 'psb_dgmres: from gridinfo',nprows,npcols,me If (debug) Write(0,*) 'psb_dgmres: from gridinfo',nprows,npcols,me
@ -195,7 +195,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
&size(w),size(w,1), size(v(:,1)) &size(w),size(w,1), size(v(:,1))
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(icontxt,isvch) call psb_set_coher(ictxt,isvch)
if (istop_ == 1) then if (istop_ == 1) then
ani = psb_spnrmi(a,desc_a,info) ani = psb_spnrmi(a,desc_a,info)
@ -338,7 +338,7 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
Call psb_gefree(w,desc_a,info) Call psb_gefree(w,desc_a,info)
! restore external global coherence behaviour ! restore external global coherence behaviour
call psb_restore_coher(icontxt,isvch) call psb_restore_coher(ictxt,isvch)
if (info /= 0) then if (info /= 0) then
info=4011 info=4011

10
src/methd/psb_zcgs.f90
Unescape Escape View File

@ -105,7 +105,7 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,&
Character ::diagl, diagu Character ::diagl, diagu
Logical, Parameter :: exchange=.True., noexchange=.False. Logical, Parameter :: exchange=.True., noexchange=.False.
Integer, Parameter :: irmax = 8 Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt Integer :: itx, i, isvch, ich, ictxt
Logical :: do_renum_left Logical :: do_renum_left
Logical, Parameter :: debug = .false. Logical, Parameter :: debug = .false.
Real(Kind(1.d0)) :: rni, xni, bni, ani,bn2 Real(Kind(1.d0)) :: rni, xni, bni, ani,bn2
@ -117,8 +117,8 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
If (debug) Write(*,*) 'entering psb_zcgs' If (debug) Write(*,*) 'entering psb_zcgs'
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
Call blacs_gridinfo(icontxt,nprows,npcols,me,mecol) Call blacs_gridinfo(ictxt,nprows,npcols,me,mecol)
If (debug) Write(*,*) 'psb_zcgs: from gridinfo',nprows,npcols,me If (debug) Write(*,*) 'psb_zcgs: from gridinfo',nprows,npcols,me
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
@ -186,7 +186,7 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,&
End If End If
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(icontxt,isvch) call psb_set_coher(ictxt,isvch)
diagl = 'u' diagl = 'u'
diagu = 'u' diagu = 'u'
@ -331,7 +331,7 @@ Subroutine psb_zcgs(a,prec,b,x,eps,desc_a,info,&
Call psb_gefree(wwrk,desc_a,info) Call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour ! restore external global coherence behaviour
call psb_restore_coher(icontxt,isvch) call psb_restore_coher(ictxt,isvch)
if(info/=0) then if(info/=0) then
call psb_errpush(info,name) call psb_errpush(info,name)

12
src/methd/psb_zcgstab.f90
Unescape Escape View File

@ -106,7 +106,7 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,&
Logical, Parameter :: debug = .false. Logical, Parameter :: debug = .false.
Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False. Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False.
Integer, Parameter :: irmax = 8 Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt, err_act, int_err(5),ii Integer :: itx, i, isvch, ich, ictxt, err_act, int_err(5),ii
Integer :: istop_ Integer :: istop_
Logical :: do_renum_left Logical :: do_renum_left
complex(Kind(1.d0)) :: alpha, beta, rho, rho_old, sigma, omega, tau complex(Kind(1.d0)) :: alpha, beta, rho, rho_old, sigma, omega, tau
@ -120,8 +120,8 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,&
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
If (debug) Write(*,*) 'Entering PSB_ZCGSTAB',present(istop) If (debug) Write(*,*) 'Entering PSB_ZCGSTAB',present(istop)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
CALL blacs_gridinfo(icontxt,nprows,npcols,myrow,mycol) CALL blacs_gridinfo(ictxt,nprows,npcols,myrow,mycol)
if (debug) write(*,*) 'PSB_ZCGSTAB: From GRIDINFO',nprows,npcols,myrow if (debug) write(*,*) 'PSB_ZCGSTAB: From GRIDINFO',nprows,npcols,myrow
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
@ -182,7 +182,7 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,&
diagu = 'U' diagu = 'U'
! Ensure global coherence for convergence checks. ! Ensure global coherence for convergence checks.
call psb_set_coher(icontxt,isvch) call psb_set_coher(ictxt,isvch)
itx = 0 itx = 0
@ -373,7 +373,7 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,info,&
Call psb_gefree(wwrk,desc_a,info) Call psb_gefree(wwrk,desc_a,info)
! restore external global coherence behaviour ! restore external global coherence behaviour
call psb_restore_coher(icontxt,isvch) call psb_restore_coher(ictxt,isvch)
!!$ imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" ) !!$ imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" )
if(info/=0) then if(info/=0) then
@ -387,7 +387,7 @@ Subroutine psb_zcgstab(a,prec,b,x,eps,desc_a,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -32,12 +32,12 @@
! Wrapper subroutines to provide error tools to F77 and C code ! Wrapper subroutines to provide error tools to F77 and C code
! !
subroutine FCpsb_errcomm(icontxt, err) subroutine FCpsb_errcomm(ictxt, err)
use psb_error_mod use psb_error_mod
integer, intent(in) :: icontxt integer, intent(in) :: ictxt
integer, intent(inout):: err integer, intent(inout):: err
call psb_errcomm(icontxt, err) call psb_errcomm(ictxt, err)
end subroutine FCpsb_errcomm end subroutine FCpsb_errcomm
@ -67,13 +67,13 @@ end subroutine FCpsb_serror
subroutine FCpsb_perror(icontxt) subroutine FCpsb_perror(ictxt)
use psb_error_mod use psb_error_mod
implicit none implicit none
integer, intent(in) :: icontxt integer, intent(in) :: ictxt
call psb_error(icontxt) call psb_error(ictxt)
end subroutine FCpsb_perror end subroutine FCpsb_perror

738
src/modules/psb_blacs_mod.f90
View File

File diff suppressed because it is too large Load Diff

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

@ -104,13 +104,13 @@ contains
! checks wether an error has occurred on one of the porecesses in the execution pool ! checks wether an error has occurred on one of the porecesses in the execution pool
subroutine psb_errcomm(icontxt, err) subroutine psb_errcomm(ictxt, err)
integer, intent(in) :: icontxt integer, intent(in) :: ictxt
integer, intent(inout):: err integer, intent(inout):: err
integer :: temp(2) integer :: temp(2)
integer, parameter :: ione=1 integer, parameter :: ione=1
call igamx2d(icontxt, '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
@ -192,16 +192,16 @@ contains
! handles the occurence of an error in a parallel routine ! handles the occurence of an error in a parallel routine
subroutine psb_perror(icontxt) subroutine psb_perror(ictxt)
integer, intent(in) :: icontxt integer, intent(in) :: ictxt
integer :: err_c integer :: err_c
character(len=20) :: r_name, a_e_d character(len=20) :: r_name, a_e_d
integer :: i_e_d(5) integer :: i_e_d(5)
integer :: nprow, npcol, me, mypcol, temp(2) integer :: nprow, npcol, me, mypcol, temp(2)
integer, parameter :: ione=1, izero=0 integer, parameter :: ione=1, izero=0
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
if(error_status.gt.0) then if(error_status.gt.0) then
if(verbosity_level.gt.1) then if(verbosity_level.gt.1) then
@ -212,7 +212,7 @@ contains
call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me) call psb_errmsg(err_c, r_name, i_e_d, a_e_d,me)
! write(0,'(50("="))') ! write(0,'(50("="))')
end do end do
call blacs_abort(icontxt,-1) call blacs_abort(ictxt,-1)
else else
call psb_errpop(err_c, r_name, i_e_d, a_e_d) call psb_errpop(err_c, r_name, i_e_d, a_e_d)
@ -220,12 +220,12 @@ contains
do while (error_stack%n_elems.gt.0) do while (error_stack%n_elems.gt.0)
call psb_errpop(err_c, r_name, i_e_d, a_e_d) call psb_errpop(err_c, r_name, i_e_d, a_e_d)
end do end do
call blacs_abort(icontxt,-1) call blacs_abort(ictxt,-1)
end if end if
end if end if
if(error_status.gt.izero) then if(error_status.gt.izero) then
call blacs_abort(icontxt,err_c) call blacs_abort(ictxt,err_c)
end if end if
@ -384,6 +384,8 @@ contains
write (0,'("computational error. code: ",i0)')err_c write (0,'("computational error. code: ",i0)')err_c
case(2010) case(2010)
write (0,'("BLACS error. Number of processes=-1")') write (0,'("BLACS error. Number of processes=-1")')
case(2011)
write (0,'("Initialization error: not enough processes available in the parallel environment")')
case(2025) case(2025)
write (0,'("Cannot allocate ",i0," bytes")')i_e_d(1) write (0,'("Cannot allocate ",i0," bytes")')i_e_d(1)
case(2030) case(2030)

39
src/modules/psb_tools_mod.f90
Unescape Escape View File

@ -358,16 +358,16 @@ Module psb_tools_mod
interface psb_cdall interface psb_cdall
subroutine psb_cdall(m, n, parts, icontxt, desc_a, info) subroutine psb_cdall(m, n, parts, ictxt, desc_a, info)
use psb_descriptor_type use psb_descriptor_type
include 'parts.fh' include 'parts.fh'
Integer, intent(in) :: m,n,icontxt Integer, intent(in) :: m,n,ictxt
Type(psb_desc_type), intent(out) :: desc_a Type(psb_desc_type), intent(out) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_cdall end subroutine psb_cdall
subroutine psb_cdalv(m, v, icontxt, desc_a, info, flag) subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag)
use psb_descriptor_type use psb_descriptor_type
Integer, intent(in) :: m,icontxt, v(:) Integer, intent(in) :: m,ictxt, v(:)
integer, intent(in), optional :: flag integer, intent(in), optional :: flag
integer, intent(out) :: info integer, intent(out) :: info
Type(psb_desc_type), intent(out) :: desc_a Type(psb_desc_type), intent(out) :: desc_a
@ -615,22 +615,45 @@ Module psb_tools_mod
interface psb_cdrep interface psb_cdrep
subroutine psb_cdrep(m, icontxt, desc_a,info) subroutine psb_cdrep(m, ictxt, desc_a,info)
use psb_descriptor_type use psb_descriptor_type
Integer, intent(in) :: m,icontxt Integer, intent(in) :: m,ictxt
Type(psb_desc_type), intent(out) :: desc_a Type(psb_desc_type), intent(out) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_cdrep end subroutine psb_cdrep
end interface end interface
interface psb_cddec interface psb_cddec
subroutine psb_cddec(nloc, icontxt, desc_a,info) subroutine psb_cddec(nloc, ictxt, desc_a,info)
use psb_descriptor_type use psb_descriptor_type
Integer, intent(in) :: nloc,icontxt Integer, intent(in) :: nloc,ictxt
Type(psb_desc_type), intent(out) :: desc_a Type(psb_desc_type), intent(out) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
end subroutine psb_cddec end subroutine psb_cddec
end interface end interface
interface psb_init
subroutine psb_init(ictxt,np)
integer, intent(out) :: ictxt
integer, intent(in), optional :: np
end subroutine psb_init
end interface
interface psb_exit
subroutine psb_exit(ictxt)
integer, intent(in) :: ictxt
end subroutine psb_exit
end interface
interface psb_info
subroutine psb_info(ictxt,iam,np)
integer, intent(in) :: ictxt
integer, intent(out) :: iam, np
end subroutine psb_info
end interface
interface psb_barrier
subroutine psb_barrier(ictxt)
integer, intent(in) :: ictxt
end subroutine psb_barrier
end interface
end module psb_tools_mod end module psb_tools_mod

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

@ -79,7 +79,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! .. Local Scalars .. ! .. Local Scalars ..
Integer :: k, tot_elem,proc,& Integer :: k, tot_elem,proc,&
& point,nprow,npcol, me, mycol, start,m,nnzero,& & point,nprow,npcol, me, mycol, start,m,nnzero,&
& icontxt, lovr, n_col, linp,ier,n,int_err(5),& & ictxt, lovr, n_col, linp,ier,n,int_err(5),&
& tot_recv, ircode, n_row, nztot,nhalo, nrow_a,err_act & tot_recv, ircode, n_row, nztot,nhalo, nrow_a,err_act
Logical,Parameter :: debug=.false., debugprt=.false. Logical,Parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -89,7 +89,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
If(debug) Write(0,*)'IN DASMATBLD ', upd If(debug) Write(0,*)'IN DASMATBLD ', upd
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
tot_recv=0 tot_recv=0
nrow_a = desc_data%matrix_data(psb_n_row_) nrow_a = desc_data%matrix_data(psb_n_row_)
@ -133,7 +133,7 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! !
! !
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
if (novr < 0) then if (novr < 0) then
info=3 info=3
@ -171,9 +171,9 @@ Subroutine psb_dasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
return return
endif endif
call blacs_get(icontxt,10,icomm ) call blacs_get(ictxt,10,icomm )
Call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) Call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr
t1 = mpi_wtime() t1 = mpi_wtime()

6
src/prec/psb_dbaseprc_aply.f90
Unescape Escape View File

@ -60,7 +60,7 @@ subroutine psb_dbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info)
integer :: n_row,n_col, int_err(5) integer :: n_row,n_col, int_err(5)
real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:) real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:)
character ::diagl, diagu character ::diagl, diagu
integer :: icontxt,nprow,npcol,me,mycol,i, isz, nrg, err_act integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg, err_act
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
logical,parameter :: debug=.false., debugprt=.false. logical,parameter :: debug=.false., debugprt=.false.
external mpi_wtime external mpi_wtime
@ -84,8 +84,8 @@ subroutine psb_dbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info)
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
diagl='U' diagl='U'
diagu='U' diagu='U'

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

@ -110,7 +110,7 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
end interface end interface
! Local scalars ! Local scalars
Integer :: err, nnzero, n_row, n_col,I,j,k,icontxt,& Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,&
& me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act & me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5) real(kind(1.d0)) :: temp, real_err(5)
real(kind(1.d0)),pointer :: gd(:), work(:) real(kind(1.d0)),pointer :: gd(:), work(:)
@ -130,12 +130,12 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
if (debug) write(0,*) 'Entering baseprc_bld' if (debug) write(0,*) 'Entering baseprc_bld'
info = 0 info = 0
int_err(1) = 0 int_err(1) = 0
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
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_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
if (present(upd)) then if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd if (debug) write(0,*) 'UPD ', upd
@ -195,14 +195,14 @@ subroutine psb_dbaseprc_bld(a,desc_a,p,info,upd)
& f_ilu_n_,is_legal_ml_fact) & f_ilu_n_,is_legal_ml_fact)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD' if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
select case(p%iprcparm(f_type_)) select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_) case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info) call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld' if(debug) write(0,*)me,': out of psb_ilu_bld'
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_ilu_bld' ch_err='psb_ilu_bld'

6
src/prec/psb_dbjac_aply.f90
Unescape Escape View File

@ -62,7 +62,7 @@ subroutine psb_dbjac_aply(prec,x,beta,y,desc_data,trans,work,info)
integer :: n_row,n_col integer :: n_row,n_col
real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:),tb(:) real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:),tb(:)
character ::diagl, diagu character ::diagl, diagu
integer :: icontxt,nprow,npcol,me,mycol,i, isz, nrg, err_act, int_err(5) integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg, err_act, int_err(5)
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
logical,parameter :: debug=.false., debugprt=.false. logical,parameter :: debug=.false., debugprt=.false.
external mpi_wtime external mpi_wtime
@ -72,8 +72,8 @@ subroutine psb_dbjac_aply(prec,x,beta,y,desc_data,trans,work,info)
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
diagl='U' diagl='U'
diagu='U' diagu='U'

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

@ -52,15 +52,15 @@ subroutine psb_dbldaggrmat(a,desc_a,ac,p,desc_p,info)
integer, intent(out) :: info integer, intent(out) :: info
logical, parameter :: aggr_dump=.false. logical, parameter :: aggr_dump=.false.
integer ::icontxt,nprow,npcol,me,mycol, err_act integer ::ictxt,nprow,npcol,me,mycol, err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dbldaggrmat' name='psb_dbldaggrmat'
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)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
select case (p%iprcparm(smth_kind_)) select case (p%iprcparm(smth_kind_))
case (no_smth_) case (no_smth_)
@ -112,7 +112,7 @@ contains
type(psb_dspmat_type), pointer :: bg type(psb_dspmat_type), pointer :: bg
type(psb_dspmat_type) :: b, tmp type(psb_dspmat_type) :: b, tmp
integer, pointer :: nzbr(:), idisp(:) integer, pointer :: nzbr(:), idisp(:)
integer :: icontxt, 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, err_act
name='raw_aggregate' name='raw_aggregate'
@ -123,8 +123,8 @@ contains
bg => ac bg => ac
call psb_nullify_sp(b) call psb_nullify_sp(b)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol) call blacs_gridinfo(ictxt,nprows,npcols,myprow,mypcol)
np = nprows*npcols np = nprows*npcols
nglob = desc_a%matrix_data(psb_m_) nglob = desc_a%matrix_data(psb_m_)
nrow = desc_a%matrix_data(psb_n_row_) nrow = desc_a%matrix_data(psb_n_row_)
@ -244,11 +244,11 @@ contains
if (p%iprcparm(coarse_mat_) == mat_repl_) then if (p%iprcparm(coarse_mat_) == mat_repl_) then
call psb_cdrep(ntaggr,icontxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
nzbr(:) = 0 nzbr(:) = 0
nzbr(myprow+1) = irs nzbr(myprow+1) = irs
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1) call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
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
@ -256,7 +256,7 @@ contains
goto 9999 goto 9999
end if end if
call blacs_get(icontxt,10,icomm ) call blacs_get(ictxt,10,icomm )
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -293,7 +293,7 @@ contains
else if (p%iprcparm(coarse_mat_) == mat_distr_) then else if (p%iprcparm(coarse_mat_) == mat_distr_) then
call psb_cddec(naggr,icontxt,desc_p,info) call psb_cddec(naggr,ictxt,desc_p,info)
call psb_sp_clone(b,bg,info) call psb_sp_clone(b,bg,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='spclone') call psb_errpush(4010,name,a_err='spclone')
@ -342,7 +342,7 @@ contains
type(psb_dspmat_type), pointer :: bg type(psb_dspmat_type), pointer :: bg
type(psb_dspmat_type) :: b type(psb_dspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:), ivall(:) integer, pointer :: nzbr(:), idisp(:), ivall(:)
integer :: icontxt, 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,itemp(1),jtemp(1)
type(psb_dspmat_type), pointer :: am1,am2 type(psb_dspmat_type), pointer :: am1,am2
@ -360,8 +360,8 @@ contains
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol) call blacs_gridinfo(ictxt,nprows,npcols,myprow,mypcol)
bg => ac bg => ac
call psb_nullify_sp(b) call psb_nullify_sp(b)
@ -522,7 +522,7 @@ contains
anorm = max(anorm,tmp/dg) anorm = max(anorm,tmp/dg)
enddo enddo
call dgamx2d(icontxt,'All',' ',1,1,anorm,1,itemp,jtemp,-1,-1,-1) call dgamx2d(ictxt,'All',' ',1,1,anorm,1,itemp,jtemp,-1,-1,-1)
else else
anorm = psb_spnrmi(am3,desc_a,info) anorm = psb_spnrmi(am3,desc_a,info)
endif endif
@ -730,7 +730,7 @@ contains
i = i + 1 i = i + 1
end do end do
end do end do
call psb_cdall(ntaggr,ivall,icontxt,desc_p,info,flag=1) call psb_cdall(ntaggr,ivall,ictxt,desc_p,info,flag=1)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall') call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999 goto 9999
@ -804,7 +804,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 igsum2d(ictxt,'All',' ',1,1,k,1,-1,-1)
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
@ -852,15 +852,15 @@ contains
nzbr(:) = 0 nzbr(:) = 0
nzbr(myprow+1) = b%infoa(psb_nnz_) nzbr(myprow+1) = b%infoa(psb_nnz_)
call psb_cdrep(ntaggr,icontxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1) call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
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
call blacs_get(icontxt,10,icomm ) call blacs_get(ictxt,10,icomm )
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -906,7 +906,7 @@ contains
call psb_errpush(4010,name,a_err='spclone') call psb_errpush(4010,name,a_err='spclone')
goto 9999 goto 9999
end if end if
call psb_cddec(naggr,icontxt,desc_p,info) call psb_cddec(naggr,ictxt,desc_p,info)
call psb_sp_free(b,info) call psb_sp_free(b,info)
if(info /= 0) then if(info /= 0) then
@ -921,10 +921,10 @@ contains
nzbr(:) = 0 nzbr(:) = 0
nzbr(myprow+1) = b%infoa(psb_nnz_) nzbr(myprow+1) = b%infoa(psb_nnz_)
call psb_cdrep(ntaggr,icontxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1) call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
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
@ -932,7 +932,7 @@ contains
goto 9999 goto 9999
end if end if
call blacs_get(icontxt,10,icomm ) call blacs_get(ictxt,10,icomm )
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo

6
src/prec/psb_ddiagsc_bld.f90
Unescape Escape View File

@ -55,7 +55,7 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
! Local scalars ! Local scalars
Integer :: err, nnzero, n_row, n_col,I,j,k,icontxt,& Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,&
& me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act & me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5) real(kind(1.d0)) :: temp, real_err(5)
real(kind(1.d0)),pointer :: gd(:), work(:) real(kind(1.d0)),pointer :: gd(:), work(:)
@ -75,12 +75,12 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
if (debug) write(0,*) 'Entering diagsc_bld' if (debug) write(0,*) 'Entering diagsc_bld'
info = 0 info = 0
int_err(1) = 0 int_err(1) = 0
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
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_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
if (debug) write(0,*) 'Precond: Diagonal scaling' if (debug) write(0,*) 'Precond: Diagonal scaling'
! diagonal scaling ! diagonal scaling

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

@ -51,7 +51,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
logical :: recovery logical :: recovery
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
integer ::icontxt,nprow,npcol,me,mycol,err_act integer ::ictxt,nprow,npcol,me,mycol,err_act
integer :: nrow, ncol, n_ne integer :: nrow, ncol, n_ne
integer, parameter :: one=1, two=2 integer, parameter :: one=1, two=2
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -65,8 +65,8 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! so that we only have local decoupled aggregation. This might ! so that we only have local decoupled aggregation. This might
! change in the future. ! change in the future.
! !
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
nrow = desc_a%matrix_data(psb_n_row_) nrow = desc_a%matrix_data(psb_n_row_)
ncol = desc_a%matrix_data(psb_n_col_) ncol = desc_a%matrix_data(psb_n_col_)
@ -279,7 +279,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nlaggr(:) = 0 nlaggr(:) = 0
nlaggr(me+1) = naggr nlaggr(me+1) = naggr
call igsum2d(icontxt,'All',' ',nprow,1,nlaggr,nprow,-1,-1) call igsum2d(ictxt,'All',' ',nprow,1,nlaggr,nprow,-1,-1)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

24
src/prec/psb_dilu_bld.f90
Unescape Escape View File

@ -81,7 +81,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,& integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,&
& nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, & & nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, &
& ind, iind, pi,nr,ns & ind, iind, pi,nr,ns
integer ::icontxt,nprow,npcol,me,mycol integer ::ictxt,nprow,npcol,me,mycol
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
interface psb_ilu_fct interface psb_ilu_fct
@ -132,8 +132,8 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
name='psb_ilu_bld' name='psb_ilu_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
m = a%m m = a%m
if (m < 0) then if (m < 0) then
@ -153,17 +153,17 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
goto 9999 goto 9999
endif endif
! call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) ! call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call psb_nullify_sp(blck) call psb_nullify_sp(blck)
call psb_nullify_sp(atmp) call psb_nullify_sp(atmp)
t1= mpi_wtime() t1= mpi_wtime()
if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info) & blck,desc_a,upd,p%desc_data,info)
if(info/=0) then if(info/=0) then
@ -174,7 +174,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
end if end if
t2= mpi_wtime() t2= mpi_wtime()
if (debug) write(0,*)me,': out of psb_asmatbld' if (debug) write(0,*)me,': out of psb_asmatbld'
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
if (associated(p%av)) then if (associated(p%av)) then
if (size(p%av) < bp_ilu_avsz) then if (size(p%av) < bp_ilu_avsz) then
@ -195,7 +195,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
goto 9999 goto 9999
end if end if
if (debug) write(0,*)me,': out spinfo',nztota if (debug) write(0,*)me,': out spinfo',nztota
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
n_col = desc_a%matrix_data(psb_n_col_) n_col = desc_a%matrix_data(psb_n_col_)
nhalo = n_col-nrow_a nhalo = n_col-nrow_a
@ -231,7 +231,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
if (debug) then if (debug) then
write(0,*) me,'Done psb_asmatbld' write(0,*) me,'Done psb_asmatbld'
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
@ -264,7 +264,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
t3 = mpi_wtime() t3 = mpi_wtime()
if (debugprt) then if (debugprt) then
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
open(40+me) open(40+me)
call psb_csprt(40+me,atmp,head='% Local matrix') call psb_csprt(40+me,atmp,head='% Local matrix')
close(40+me) close(40+me)
@ -301,7 +301,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
if (debugprt) then if (debugprt) then
open(40+me) open(40+me)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,& call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,&
& head='% Local matrix') & head='% Local matrix')
if (p%iprcparm(p_type_)==asm_) then if (p%iprcparm(p_type_)==asm_) then
@ -313,7 +313,7 @@ subroutine psb_dilu_bld(a,desc_a,p,upd,info)
t5= mpi_wtime() t5= mpi_wtime()
if (debug) write(0,*) me,' Going for dilu_fct' if (debug) write(0,*) me,' Going for dilu_fct'
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck) call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
if(info/=0) then if(info/=0) then
info=4010 info=4010

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

@ -63,7 +63,7 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
real(kind(1.d0)), allocatable :: tx(:),ty(:),t2l(:),w2l(:),& real(kind(1.d0)), allocatable :: tx(:),ty(:),t2l(:),w2l(:),&
& x2l(:),b2l(:),tz(:),tty(:) & x2l(:),b2l(:),tz(:),tty(:)
character ::diagl, diagu character ::diagl, diagu
integer :: icontxt,nprow,npcol,me,mycol,i, isz, nrg,nr2l,err_act, iptype, int_err(5) integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg,nr2l,err_act, iptype, int_err(5)
real(kind(1.d0)) :: omega real(kind(1.d0)) :: omega
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
logical, parameter :: debug=.false., debugprt=.false. logical, parameter :: debug=.false., debugprt=.false.
@ -90,8 +90,8 @@ subroutine psb_dmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
omega=baseprecv(2)%dprcparm(smooth_omega_) omega=baseprecv(2)%dprcparm(smooth_omega_)
ismth=baseprecv(2)%iprcparm(smth_kind_) ismth=baseprecv(2)%iprcparm(smth_kind_)
@ -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(icontxt,'All',t2l(1:nrg)) call gsum2d(ictxt,'All',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(icontxt,'All',t2l(1:nrg)) call gsum2d(ictxt,'All',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(icontxt,'All',t2l(1:nrg)) call gsum2d(ictxt,'All',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(icontxt,'All',t2l(1:nrg)) call gsum2d(ictxt,'All',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_)

2
src/prec/psb_dmlprc_bld.f90
Unescape Escape View File

@ -96,7 +96,7 @@ subroutine psb_dmlprc_bld(a,desc_a,p,info)
end subroutine psb_dbldaggrmat end subroutine psb_dbldaggrmat
end interface end interface
integer :: icontxt, nprow, npcol, me, mycol integer :: ictxt, nprow, npcol, me, mycol
name='psb_mlprec_bld' name='psb_mlprec_bld'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return

12
src/prec/psb_dprc_aply.f90
Unescape Escape View File

@ -54,7 +54,7 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work)
! Local variables ! Local variables
character :: trans_ character :: trans_
real(kind(1.d0)), pointer :: work_(:) real(kind(1.d0)), pointer :: work_(:)
integer :: icontxt,nprow,npcol,me,mycol,err_act, int_err(5) integer :: ictxt,nprow,npcol,me,mycol,err_act, int_err(5)
logical,parameter :: debug=.false., debugprt=.false. logical,parameter :: debug=.false., debugprt=.false.
external mpi_wtime external mpi_wtime
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -91,8 +91,8 @@ subroutine psb_dprc_aply(prec,x,y,desc_data,info,trans, work)
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
if (present(trans)) then if (present(trans)) then
trans_=trans trans_=trans
@ -218,7 +218,7 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans)
! Local variables ! Local variables
character :: trans_ character :: trans_
integer :: icontxt,nprow,npcol,me,mycol,i, isz, err_act, int_err(5) integer :: ictxt,nprow,npcol,me,mycol,i, isz, err_act, int_err(5)
real(kind(1.d0)), pointer :: WW(:), w1(:) real(kind(1.d0)), pointer :: WW(:), w1(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_dprec1' name='psb_dprec1'
@ -226,8 +226,8 @@ subroutine psb_dprc_aply1(prec,x,desc_data,info,trans)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
if (present(trans)) then if (present(trans)) then
trans_=trans trans_=trans
else else

6
src/prec/psb_dprecbld.f90
Unescape Escape View File

@ -82,7 +82,7 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd)
end interface end interface
! Local scalars ! Local scalars
Integer :: err, nnzero, I,j,k,icontxt,& Integer :: err, nnzero, I,j,k,ictxt,&
& me,mycol,nprow,npcol,lw, mtype, nrg, nzg, err_act & me,mycol,nprow,npcol,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5) real(kind(1.d0)) :: temp, real_err(5)
integer :: int_err(5) integer :: int_err(5)
@ -101,10 +101,10 @@ subroutine psb_dprecbld(a,desc_a,p,info,upd)
if (debug) write(0,*) 'Entering precbld',P%prec,desc_a%matrix_data(:) if (debug) write(0,*) 'Entering precbld',P%prec,desc_a%matrix_data(:)
info = 0 info = 0
int_err(1) = 0 int_err(1) = 0
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
if (present(upd)) then if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd if (debug) write(0,*) 'UPD ', upd

2
src/prec/psb_dprecfree.f90
Unescape Escape View File

@ -52,7 +52,7 @@ subroutine psb_dprecfree(p,info)
integer :: int_err(5) integer :: int_err(5)
integer :: temp(1), me integer :: temp(1), me
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
integer :: icontxt,err_act,i integer :: ictxt,err_act,i
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return

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

@ -51,7 +51,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
type(psb_dspmat_type) :: blck, atmp type(psb_dspmat_type) :: blck, atmp
character(len=5) :: fmt character(len=5) :: fmt
character :: upd='F' character :: upd='F'
integer :: i,j,nza,nzb,nzt,icontxt, me,mycol,nprow,npcol,err_act integer :: i,j,nza,nzb,nzt,ictxt, me,mycol,nprow,npcol,err_act
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -76,8 +76,8 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
name='psb_slu_bld' name='psb_slu_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_A%matrix_data(psb_ctxt_) ictxt = desc_A%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
fmt = 'COO' fmt = 'COO'
@ -87,7 +87,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
atmp%fida='COO' atmp%fida='COO'
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Calling csdp' write(0,*) me, 'SPLUBLD: Calling csdp'
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_csdp(a,atmp,info) call psb_csdp(a,atmp,info)
@ -100,7 +100,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
nza = atmp%infoa(psb_nnz_) nza = atmp%infoa(psb_nnz_)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=fmt) & blck,desc_a,upd,p%desc_data,info,outfmt=fmt)
@ -114,7 +114,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
nzb = blck%infoa(psb_nnz_) nzb = blck%infoa(psb_nnz_)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
if (nzb > 0 ) then if (nzb > 0 ) then
if (size(atmp%aspk)<nza+nzb) then if (size(atmp%aspk)<nza+nzb) then
@ -128,7 +128,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
endif endif
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
do j=1,nzb do j=1,nzb
@ -174,7 +174,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
if (Debug) then if (Debug) then
write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,& write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,&
& atmp%k,p%desc_data%matrix_data(psb_n_row_) & atmp%k,p%desc_data%matrix_data(psb_n_row_)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_dslu_factor(atmp%m,nzt,& call psb_dslu_factor(atmp%m,nzt,&
@ -188,7 +188,7 @@ subroutine psb_dslu_bld(a,desc_a,p,info)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_) write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_sp_free(blck,info) call psb_sp_free(blck,info)

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

@ -57,7 +57,7 @@ subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info)
integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,& integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,&
& nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, & & nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, &
& ind, iind, pi,nr,ns,i,j,jj,k,kk & ind, iind, pi,nr,ns,i,j,jj,k,kk
integer ::icontxt,nprow,npcol,me,mycol integer ::ictxt,nprow,npcol,me,mycol
integer, pointer :: itmp(:), itmp2(:) integer, pointer :: itmp(:), itmp2(:)
real(kind(1.d0)), pointer :: rtmp(:) real(kind(1.d0)), pointer :: rtmp(:)
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,mpi_wtime, t7, t8 real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,mpi_wtime, t7, t8
@ -68,8 +68,8 @@ subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info)
name='apply_renum' name='apply_renum'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
!!!!!!!!!!!!!!!! CHANGE FOR NON-CSR A !!!!!!!!!!!!!!!! CHANGE FOR NON-CSR A
! !
@ -245,7 +245,7 @@ subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info)
itmp(1:8) = 0 itmp(1:8) = 0
! write(0,*) me,' Renumbering: Calling Metis' ! write(0,*) me,' Renumbering: Calling Metis'
! call blacs_barrier(icontxt,'All') ! call blacs_barrier(ictxt,'All')
! write(0,*) size(p%av(u_pr_)%pl),size(p%av(l_pr_)%pr) ! write(0,*) size(p%av(u_pr_)%pl),size(p%av(l_pr_)%pr)
call gps_reduction(atmp%m,atmp%ia2,atmp%ia1,p%perm,p%invperm,info) call gps_reduction(atmp%m,atmp%ia2,atmp%ia1,p%perm,p%invperm,info)
@ -257,7 +257,7 @@ subroutine psb_dsp_renum(a,desc_a,blck,p,atmp,info)
end if end if
! write(0,*) me,' Renumbering: Done GPS' ! write(0,*) me,' Renumbering: Done GPS'
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
do i=1, atmp%m do i=1, atmp%m
if (p%perm(i) /= i) then if (p%perm(i) /= i) then
write(0,*) me,' permutation is not identity ' write(0,*) me,' permutation is not identity '

18
src/prec/psb_dumf_bld.f90
Unescape Escape View File

@ -51,7 +51,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
type(psb_dspmat_type) :: blck, atmp type(psb_dspmat_type) :: blck, atmp
character(len=5) :: fmt character(len=5) :: fmt
character :: upd='F' character :: upd='F'
integer :: i,j,nza,nzb,nzt,icontxt, me,mycol,nprow,npcol,err_act integer :: i,j,nza,nzb,nzt,ictxt, me,mycol,nprow,npcol,err_act
integer :: i_err(5) integer :: i_err(5)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -76,8 +76,8 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
name='psb_umf_bld' name='psb_umf_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_A%matrix_data(psb_ctxt_) ictxt = desc_A%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
fmt = 'COO' fmt = 'COO'
@ -87,7 +87,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
atmp%fida='COO' atmp%fida='COO'
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Calling csdp' write(0,*) me, 'UMFBLD: Calling csdp'
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_dcsdp(a,atmp,info) call psb_dcsdp(a,atmp,info)
@ -101,7 +101,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
if (Debug) then if (Debug) then
call psb_spinfo(psb_nztotreq_,a,nzb,info) call psb_spinfo(psb_nztotreq_,a,nzb,info)
write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k,nzb write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k,nzb
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=fmt) & blck,desc_a,upd,p%desc_data,info,outfmt=fmt)
@ -115,7 +115,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
call psb_spinfo(psb_nztotreq_,blck,nzb,info) call psb_spinfo(psb_nztotreq_,blck,nzb,info)
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done asmatbld',info,nzb,blck%fida write(0,*) me, 'UMFBLD: Done asmatbld',info,nzb,blck%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
if (nzb > 0 ) then if (nzb > 0 ) then
if (size(atmp%aspk)<nza+nzb) then if (size(atmp%aspk)<nza+nzb) then
@ -129,7 +129,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
endif endif
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done realloc',info,nza+nzb,atmp%fida write(0,*) me, 'UMFBLD: Done realloc',info,nza+nzb,atmp%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
do j=1,nzb do j=1,nzb
@ -178,7 +178,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
open(80+me) open(80+me)
call psb_csprt(80+me,atmp) call psb_csprt(80+me,atmp)
close(80+me) close(80+me)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_dumf_factor(atmp%m,nzt,& call psb_dumf_factor(atmp%m,nzt,&
@ -194,7 +194,7 @@ subroutine psb_dumf_bld(a,desc_a,p,info)
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done umf_Factor',info,p%iprcparm(umf_numptr_) write(0,*) me, 'UMFBLD: Done umf_Factor',info,p%iprcparm(umf_numptr_)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_sp_free(blck,info) call psb_sp_free(blck,info)
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)

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

@ -79,7 +79,7 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! .. Local Scalars .. ! .. Local Scalars ..
Integer :: k, tot_elem,proc,& Integer :: k, tot_elem,proc,&
& point,nprow,npcol, me, mycol, start,m,nnzero,& & point,nprow,npcol, me, mycol, start,m,nnzero,&
& icontxt, lovr, n_col, linp,ier,n,int_err(5),& & ictxt, lovr, n_col, linp,ier,n,int_err(5),&
& tot_recv, ircode, n_row, nztot,nhalo, nrow_a,err_act & tot_recv, ircode, n_row, nztot,nhalo, nrow_a,err_act
Logical,Parameter :: debug=.false., debugprt=.false. Logical,Parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -89,7 +89,7 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
If(debug) Write(0,*)'IN DASMATBLD ', upd If(debug) Write(0,*)'IN DASMATBLD ', upd
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
tot_recv=0 tot_recv=0
nrow_a = desc_data%matrix_data(psb_n_row_) nrow_a = desc_data%matrix_data(psb_n_row_)
@ -133,7 +133,7 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! !
! !
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
if (novr < 0) then if (novr < 0) then
info=3 info=3
@ -171,9 +171,9 @@ Subroutine psb_zasmatbld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
return return
endif endif
call blacs_get(icontxt,10,icomm ) call blacs_get(ictxt,10,icomm )
Call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) Call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr
t1 = mpi_wtime() t1 = mpi_wtime()

6
src/prec/psb_zbaseprc_aply.f90
Unescape Escape View File

@ -60,7 +60,7 @@ subroutine psb_zbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info)
integer :: n_row,n_col, int_err(5) integer :: n_row,n_col, int_err(5)
complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:) complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:)
character ::diagl, diagu character ::diagl, diagu
integer :: icontxt,nprow,npcol,me,mycol,i, isz, nrg, err_act integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg, err_act
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
logical,parameter :: debug=.false., debugprt=.false. logical,parameter :: debug=.false., debugprt=.false.
external mpi_wtime external mpi_wtime
@ -84,8 +84,8 @@ subroutine psb_zbaseprc_aply(prec,x,beta,y,desc_data,trans,work,info)
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
diagl='U' diagl='U'
diagu='U' diagu='U'

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

@ -110,7 +110,7 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
end interface end interface
! Local scalars ! Local scalars
Integer :: err, nnzero, n_row, n_col,I,j,k,icontxt,& Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,&
& me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act & me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5) real(kind(1.d0)) :: temp, real_err(5)
real(kind(1.d0)),pointer :: gd(:), work(:) real(kind(1.d0)),pointer :: gd(:), work(:)
@ -130,12 +130,12 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
if (debug) write(0,*) 'Entering baseprc_bld' if (debug) write(0,*) 'Entering baseprc_bld'
info = 0 info = 0
int_err(1) = 0 int_err(1) = 0
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
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_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
if (present(upd)) then if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd if (debug) write(0,*) 'UPD ', upd
@ -195,14 +195,14 @@ subroutine psb_zbaseprc_bld(a,desc_a,p,info,upd)
& f_ilu_n_,is_legal_ml_fact) & f_ilu_n_,is_legal_ml_fact)
if (debug) write(0,*)me, ': Calling PSB_ILU_BLD' if (debug) write(0,*)me, ': Calling PSB_ILU_BLD'
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
select case(p%iprcparm(f_type_)) select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_) case(f_ilu_n_,f_ilu_e_)
call psb_ilu_bld(a,desc_a,p,iupd,info) call psb_ilu_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of psb_ilu_bld' if(debug) write(0,*)me,': out of psb_ilu_bld'
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_ilu_bld' ch_err='psb_ilu_bld'

6
src/prec/psb_zbjac_aply.f90
Unescape Escape View File

@ -62,7 +62,7 @@ subroutine psb_zbjac_aply(prec,x,beta,y,desc_data,trans,work,info)
integer :: n_row,n_col integer :: n_row,n_col
complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:),tb(:) complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:),tb(:)
character ::diagl, diagu character ::diagl, diagu
integer :: icontxt,nprow,npcol,me,mycol,i, isz, nrg, err_act, int_err(5) integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg, err_act, int_err(5)
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
logical,parameter :: debug=.false., debugprt=.false. logical,parameter :: debug=.false., debugprt=.false.
external mpi_wtime external mpi_wtime
@ -72,8 +72,8 @@ subroutine psb_zbjac_aply(prec,x,beta,y,desc_data,trans,work,info)
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
diagl='U' diagl='U'
diagu='U' diagu='U'

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

@ -52,15 +52,15 @@ subroutine psb_zbldaggrmat(a,desc_a,ac,p,desc_p,info)
integer, intent(out) :: info integer, intent(out) :: info
logical, parameter :: aggr_dump=.false. logical, parameter :: aggr_dump=.false.
integer ::icontxt,nprow,npcol,me,mycol, err_act integer ::ictxt,nprow,npcol,me,mycol, err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_zbldaggrmat' name='psb_zbldaggrmat'
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)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
select case (p%iprcparm(smth_kind_)) select case (p%iprcparm(smth_kind_))
case (no_smth_) case (no_smth_)
@ -112,7 +112,7 @@ contains
type(psb_zspmat_type), pointer :: bg type(psb_zspmat_type), pointer :: bg
type(psb_zspmat_type) :: b, tmp type(psb_zspmat_type) :: b, tmp
integer, pointer :: nzbr(:), idisp(:) integer, pointer :: nzbr(:), idisp(:)
integer :: icontxt, 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, err_act
name='raw_aggregate' name='raw_aggregate'
@ -123,8 +123,8 @@ contains
bg => ac bg => ac
call psb_nullify_sp(b) call psb_nullify_sp(b)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol) call blacs_gridinfo(ictxt,nprows,npcols,myprow,mypcol)
np = nprows*npcols np = nprows*npcols
nglob = desc_a%matrix_data(psb_m_) nglob = desc_a%matrix_data(psb_m_)
nrow = desc_a%matrix_data(psb_n_row_) nrow = desc_a%matrix_data(psb_n_row_)
@ -244,11 +244,11 @@ contains
if (p%iprcparm(coarse_mat_) == mat_repl_) then if (p%iprcparm(coarse_mat_) == mat_repl_) then
call psb_cdrep(ntaggr,icontxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
nzbr(:) = 0 nzbr(:) = 0
nzbr(myprow+1) = irs nzbr(myprow+1) = irs
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1) call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
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
@ -256,7 +256,7 @@ contains
goto 9999 goto 9999
end if end if
call blacs_get(icontxt,10,icomm ) call blacs_get(ictxt,10,icomm )
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -293,7 +293,7 @@ contains
else if (p%iprcparm(coarse_mat_) == mat_distr_) then else if (p%iprcparm(coarse_mat_) == mat_distr_) then
call psb_cddec(naggr,icontxt,desc_p,info) call psb_cddec(naggr,ictxt,desc_p,info)
call psb_sp_clone(b,bg,info) call psb_sp_clone(b,bg,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='spclone') call psb_errpush(4010,name,a_err='spclone')
@ -342,7 +342,7 @@ contains
type(psb_zspmat_type), pointer :: bg type(psb_zspmat_type), pointer :: bg
type(psb_zspmat_type) :: b type(psb_zspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:), ivall(:) integer, pointer :: nzbr(:), idisp(:), ivall(:)
integer :: icontxt, 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,itemp(1),jtemp(1)
type(psb_zspmat_type), pointer :: am1,am2 type(psb_zspmat_type), pointer :: am1,am2
@ -360,8 +360,8 @@ contains
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprows,npcols,myprow,mypcol) call blacs_gridinfo(ictxt,nprows,npcols,myprow,mypcol)
bg => ac bg => ac
call psb_nullify_sp(b) call psb_nullify_sp(b)
@ -522,7 +522,7 @@ contains
anorm = max(anorm,tmp/dg) anorm = max(anorm,tmp/dg)
enddo enddo
call dgamx2d(icontxt,'All',' ',1,1,anorm,1,itemp,jtemp,-1,-1,-1) call dgamx2d(ictxt,'All',' ',1,1,anorm,1,itemp,jtemp,-1,-1,-1)
else else
anorm = psb_spnrmi(am3,desc_a,info) anorm = psb_spnrmi(am3,desc_a,info)
endif endif
@ -730,7 +730,7 @@ contains
i = i + 1 i = i + 1
end do end do
end do end do
call psb_cdall(ntaggr,ivall,icontxt,desc_p,info,flag=1) call psb_cdall(ntaggr,ivall,ictxt,desc_p,info,flag=1)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall') call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999 goto 9999
@ -804,7 +804,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 igsum2d(ictxt,'All',' ',1,1,k,1,-1,-1)
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
@ -852,15 +852,15 @@ contains
nzbr(:) = 0 nzbr(:) = 0
nzbr(myprow+1) = b%infoa(psb_nnz_) nzbr(myprow+1) = b%infoa(psb_nnz_)
call psb_cdrep(ntaggr,icontxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1) call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
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
call blacs_get(icontxt,10,icomm ) call blacs_get(ictxt,10,icomm )
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo
@ -906,7 +906,7 @@ contains
call psb_errpush(4010,name,a_err='spclone') call psb_errpush(4010,name,a_err='spclone')
goto 9999 goto 9999
end if end if
call psb_cddec(naggr,icontxt,desc_p,info) call psb_cddec(naggr,ictxt,desc_p,info)
call psb_sp_free(b,info) call psb_sp_free(b,info)
if(info /= 0) then if(info /= 0) then
@ -921,10 +921,10 @@ contains
nzbr(:) = 0 nzbr(:) = 0
nzbr(myprow+1) = b%infoa(psb_nnz_) nzbr(myprow+1) = b%infoa(psb_nnz_)
call psb_cdrep(ntaggr,icontxt,desc_p,info) call psb_cdrep(ntaggr,ictxt,desc_p,info)
call igsum2d(icontxt,'All',' ',np,1,nzbr,np,-1,-1) call igsum2d(ictxt,'All',' ',np,1,nzbr,np,-1,-1)
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
@ -932,7 +932,7 @@ contains
goto 9999 goto 9999
end if end if
call blacs_get(icontxt,10,icomm ) call blacs_get(ictxt,10,icomm )
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
enddo enddo

6
src/prec/psb_zdiagsc_bld.f90
Unescape Escape View File

@ -55,7 +55,7 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info)
! Local scalars ! Local scalars
Integer :: err, nnzero, n_row, n_col,I,j,k,icontxt,& Integer :: err, nnzero, n_row, n_col,I,j,k,ictxt,&
& me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act & me,mycol,nprow,npcol,mglob,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5) real(kind(1.d0)) :: temp, real_err(5)
complex(kind(1.d0)),pointer :: gd(:), work(:) complex(kind(1.d0)),pointer :: gd(:), work(:)
@ -75,12 +75,12 @@ subroutine psb_zdiagsc_bld(a,desc_a,p,upd,info)
if (debug) write(0,*) 'Entering diagsc_bld' if (debug) write(0,*) 'Entering diagsc_bld'
info = 0 info = 0
int_err(1) = 0 int_err(1) = 0
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
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_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
if (debug) write(0,*) 'Precond: Diagonal scaling' if (debug) write(0,*) 'Precond: Diagonal scaling'
! diagonal scaling ! diagonal scaling

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

@ -51,7 +51,7 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
logical :: recovery logical :: recovery
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
integer ::icontxt,nprow,npcol,me,mycol,err_act integer ::ictxt,nprow,npcol,me,mycol,err_act
integer :: nrow, ncol, n_ne integer :: nrow, ncol, n_ne
integer, parameter :: one=1, two=2 integer, parameter :: one=1, two=2
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -65,8 +65,8 @@ subroutine psb_zgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! so that we only have local decoupled aggregation. This might ! so that we only have local decoupled aggregation. This might
! change in the future. ! change in the future.
! !
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
nrow = desc_a%matrix_data(psb_n_row_) nrow = desc_a%matrix_data(psb_n_row_)
ncol = desc_a%matrix_data(psb_n_col_) ncol = desc_a%matrix_data(psb_n_col_)
@ -279,7 +279,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(icontxt,'All',' ',nprow,1,nlaggr,nprow,-1,-1) call igsum2d(ictxt,'All',' ',nprow,1,nlaggr,nprow,-1,-1)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

24
src/prec/psb_zilu_bld.f90
Unescape Escape View File

@ -80,7 +80,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,& integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,&
& nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, & & nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, &
& ind, iind, pi,nr,ns & ind, iind, pi,nr,ns
integer ::icontxt,nprow,npcol,me,mycol integer ::ictxt,nprow,npcol,me,mycol
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
interface psb_ilu_fct interface psb_ilu_fct
@ -131,8 +131,8 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
name='psb_ilu_bld' name='psb_ilu_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
m = a%m m = a%m
if (m < 0) then if (m < 0) then
@ -152,17 +152,17 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
goto 9999 goto 9999
endif endif
! call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) ! call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call psb_nullify_sp(blck) call psb_nullify_sp(blck)
call psb_nullify_sp(atmp) call psb_nullify_sp(atmp)
t1= mpi_wtime() t1= mpi_wtime()
if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_) if(debug) write(0,*)me,': calling psb_asmatbld',p%iprcparm(p_type_),p%iprcparm(n_ovr_)
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info) & blck,desc_a,upd,p%desc_data,info)
if(info/=0) then if(info/=0) then
@ -173,7 +173,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
end if end if
t2= mpi_wtime() t2= mpi_wtime()
if (debug) write(0,*)me,': out of psb_asmatbld' if (debug) write(0,*)me,': out of psb_asmatbld'
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
if (associated(p%av)) then if (associated(p%av)) then
if (size(p%av) < bp_ilu_avsz) then if (size(p%av) < bp_ilu_avsz) then
@ -194,7 +194,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
goto 9999 goto 9999
end if end if
if (debug) write(0,*)me,': out spinfo',nztota if (debug) write(0,*)me,': out spinfo',nztota
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
n_col = desc_a%matrix_data(psb_n_col_) n_col = desc_a%matrix_data(psb_n_col_)
nhalo = n_col-nrow_a nhalo = n_col-nrow_a
@ -230,7 +230,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
if (debug) then if (debug) then
write(0,*) me,'Done psb_asmatbld' write(0,*) me,'Done psb_asmatbld'
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
@ -263,7 +263,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
t3 = mpi_wtime() t3 = mpi_wtime()
if (debugprt) then if (debugprt) then
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
open(40+me) open(40+me)
call psb_csprt(40+me,atmp,head='% Local matrix') call psb_csprt(40+me,atmp,head='% Local matrix')
close(40+me) close(40+me)
@ -300,7 +300,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
if (debugprt) then if (debugprt) then
open(40+me) open(40+me)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,& call psb_csprt(40+me,a,iv=p%desc_data%loc_to_glob,&
& head='% Local matrix') & head='% Local matrix')
if (p%iprcparm(p_type_)==asm_) then if (p%iprcparm(p_type_)==asm_) then
@ -312,7 +312,7 @@ subroutine psb_zilu_bld(a,desc_a,p,upd,info)
t5= mpi_wtime() t5= mpi_wtime()
if (debug) write(0,*) me,' Going for ilu_fct' if (debug) write(0,*) me,' Going for ilu_fct'
if (debug) call blacs_barrier(icontxt,'All') if (debug) call blacs_barrier(ictxt,'All')
call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck) call psb_ilu_fct(a,p%av(l_pr_),p%av(u_pr_),p%d,info,blck=blck)
if(info/=0) then if(info/=0) then
info=4010 info=4010

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

@ -63,7 +63,7 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
complex(kind(1.d0)), allocatable :: tx(:),ty(:),t2l(:),w2l(:),& complex(kind(1.d0)), allocatable :: tx(:),ty(:),t2l(:),w2l(:),&
& x2l(:),b2l(:),tz(:),tty(:) & x2l(:),b2l(:),tz(:),tty(:)
character ::diagl, diagu character ::diagl, diagu
integer :: icontxt,nprow,npcol,me,mycol,i, isz, nrg,nr2l,err_act, iptype, int_err(5) integer :: ictxt,nprow,npcol,me,mycol,i, isz, nrg,nr2l,err_act, iptype, int_err(5)
real(kind(1.d0)) :: omega real(kind(1.d0)) :: omega
real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime real(kind(1.d0)) :: t1, t2, t3, t4, t5, t6, t7, mpi_wtime
logical, parameter :: debug=.false., debugprt=.false. logical, parameter :: debug=.false., debugprt=.false.
@ -90,8 +90,8 @@ subroutine psb_zmlprc_aply(baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
omega=baseprecv(2)%dprcparm(smooth_omega_) omega=baseprecv(2)%dprcparm(smooth_omega_)
ismth=baseprecv(2)%iprcparm(smth_kind_) ismth=baseprecv(2)%iprcparm(smth_kind_)
@ -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(icontxt,'All',t2l(1:nrg)) call gsum2d(ictxt,'All',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(icontxt,'All',t2l(1:nrg)) call gsum2d(ictxt,'All',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(icontxt,'All',t2l(1:nrg)) call gsum2d(ictxt,'All',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(icontxt,'All',t2l(1:nrg)) call gsum2d(ictxt,'All',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_)

2
src/prec/psb_zmlprc_bld.f90
Unescape Escape View File

@ -96,7 +96,7 @@ subroutine psb_zmlprc_bld(a,desc_a,p,info)
end subroutine psb_zbldaggrmat end subroutine psb_zbldaggrmat
end interface end interface
integer :: icontxt, nprow, npcol, me, mycol integer :: ictxt, nprow, npcol, me, mycol
name='psb_mlprec_bld' name='psb_mlprec_bld'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return

12
src/prec/psb_zprc_aply.f90
Unescape Escape View File

@ -54,7 +54,7 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
! Local variables ! Local variables
character :: trans_ character :: trans_
complex(kind(1.d0)), pointer :: work_(:) complex(kind(1.d0)), pointer :: work_(:)
integer :: icontxt,nprow,npcol,me,mycol,err_act, int_err(5) integer :: ictxt,nprow,npcol,me,mycol,err_act, int_err(5)
logical,parameter :: debug=.false., debugprt=.false. logical,parameter :: debug=.false., debugprt=.false.
external mpi_wtime external mpi_wtime
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -91,8 +91,8 @@ subroutine psb_zprc_aply(prec,x,y,desc_data,info,trans, work)
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
if (present(trans)) then if (present(trans)) then
trans_=trans trans_=trans
@ -218,7 +218,7 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans)
! Local variables ! Local variables
character :: trans_ character :: trans_
integer :: icontxt,nprow,npcol,me,mycol,i, isz, err_act, int_err(5) integer :: ictxt,nprow,npcol,me,mycol,i, isz, err_act, int_err(5)
complex(kind(1.d0)), pointer :: WW(:), w1(:) complex(kind(1.d0)), pointer :: WW(:), w1(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='psb_zprec1' name='psb_zprec1'
@ -226,8 +226,8 @@ subroutine psb_zprc_aply1(prec,x,desc_data,info,trans)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_data%matrix_data(psb_ctxt_) ictxt=desc_data%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
if (present(trans)) then if (present(trans)) then
trans_=trans trans_=trans
else else

6
src/prec/psb_zprecbld.f90
Unescape Escape View File

@ -82,7 +82,7 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd)
end interface end interface
! Local scalars ! Local scalars
Integer :: err, nnzero, I,j,k,icontxt,& Integer :: err, nnzero, I,j,k,ictxt,&
& me,mycol,nprow,npcol,lw, mtype, nrg, nzg, err_act & me,mycol,nprow,npcol,lw, mtype, nrg, nzg, err_act
real(kind(1.d0)) :: temp, real_err(5) real(kind(1.d0)) :: temp, real_err(5)
integer :: int_err(5) integer :: int_err(5)
@ -101,10 +101,10 @@ subroutine psb_zprecbld(a,desc_a,p,info,upd)
if (debug) write(0,*) 'Entering precbld',P%prec,desc_a%matrix_data(:) if (debug) write(0,*) 'Entering precbld',P%prec,desc_a%matrix_data(:)
info = 0 info = 0
int_err(1) = 0 int_err(1) = 0
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo' if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
if (present(upd)) then if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd if (debug) write(0,*) 'UPD ', upd

2
src/prec/psb_zprecfree.f90
Unescape Escape View File

@ -52,7 +52,7 @@ subroutine psb_zprecfree(p,info)
integer :: int_err(5) integer :: int_err(5)
integer :: temp(1), me integer :: temp(1), me
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
integer :: icontxt,err_act,i integer :: ictxt,err_act,i
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return

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

@ -51,7 +51,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
type(psb_zspmat_type) :: blck, atmp type(psb_zspmat_type) :: blck, atmp
character(len=5) :: fmt character(len=5) :: fmt
character :: upd='F' character :: upd='F'
integer :: i,j,nza,nzb,nzt,icontxt, me,mycol,nprow,npcol,err_act integer :: i,j,nza,nzb,nzt,ictxt, me,mycol,nprow,npcol,err_act
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -76,8 +76,8 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
name='psb_slu_bld' name='psb_slu_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_A%matrix_data(psb_ctxt_) ictxt = desc_A%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
fmt = 'COO' fmt = 'COO'
@ -87,7 +87,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
atmp%fida='COO' atmp%fida='COO'
if (Debug) then if (Debug) then
write(0,*) me, 'ZSLUBLD: Calling csdp' write(0,*) me, 'ZSLUBLD: Calling csdp'
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_csdp(a,atmp,info) call psb_csdp(a,atmp,info)
@ -100,7 +100,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
nza = atmp%infoa(psb_nnz_) nza = atmp%infoa(psb_nnz_)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k write(0,*) me, 'SPLUBLD: Done csdp',info,nza,atmp%m,atmp%k
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=fmt) & blck,desc_a,upd,p%desc_data,info,outfmt=fmt)
@ -114,7 +114,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
nzb = blck%infoa(psb_nnz_) nzb = blck%infoa(psb_nnz_)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida write(0,*) me, 'SPLUBLD: Done asmatbld',info,nzb,blck%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
if (nzb > 0 ) then if (nzb > 0 ) then
if (size(atmp%aspk)<nza+nzb) then if (size(atmp%aspk)<nza+nzb) then
@ -128,7 +128,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
endif endif
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida write(0,*) me, 'SPLUBLD: Done realloc',info,nza+nzb,atmp%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
do j=1,nzb do j=1,nzb
@ -174,7 +174,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
if (Debug) then if (Debug) then
write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,& write(0,*) me,'Calling psb_slu_factor ',nzt,atmp%m,&
& atmp%k,p%desc_data%matrix_data(psb_n_row_) & atmp%k,p%desc_data%matrix_data(psb_n_row_)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_zslu_factor(atmp%m,nzt,& call psb_zslu_factor(atmp%m,nzt,&
@ -188,7 +188,7 @@ subroutine psb_zslu_bld(a,desc_a,p,info)
if (Debug) then if (Debug) then
write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_) write(0,*) me, 'SPLUBLD: Done slu_Factor',info,p%iprcparm(slu_ptr_)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_sp_free(blck,info) call psb_sp_free(blck,info)

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

@ -57,7 +57,7 @@ subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info)
integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,& integer istpb, istpe, ifctb, ifcte, err_act, irank, icomm, nztota, nztotb,&
& nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, & & nztmp, nzl, nnr, ir, mglob, mtype, n_row, nrow_a,n_col, nhalo,lovr, &
& ind, iind, pi,nr,ns,i,j,jj,k,kk & ind, iind, pi,nr,ns,i,j,jj,k,kk
integer ::icontxt,nprow,npcol,me,mycol integer ::ictxt,nprow,npcol,me,mycol
integer, pointer :: itmp(:), itmp2(:) integer, pointer :: itmp(:), itmp2(:)
complex(kind(1.d0)), pointer :: ztmp(:) complex(kind(1.d0)), pointer :: ztmp(:)
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,mpi_wtime, t7, t8 real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,mpi_wtime, t7, t8
@ -68,8 +68,8 @@ subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info)
name='apply_renum' name='apply_renum'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt,nprow,npcol,me,mycol) call blacs_gridinfo(ictxt,nprow,npcol,me,mycol)
!!!!!!!!!!!!!!!! CHANGE FOR NON-CSR A !!!!!!!!!!!!!!!! CHANGE FOR NON-CSR A
! !
@ -245,7 +245,7 @@ subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info)
itmp(1:8) = 0 itmp(1:8) = 0
! write(0,*) me,' Renumbering: Calling Metis' ! write(0,*) me,' Renumbering: Calling Metis'
! call blacs_barrier(icontxt,'All') ! call blacs_barrier(ictxt,'All')
! write(0,*) size(p%av(u_pr_)%pl),size(p%av(l_pr_)%pr) ! write(0,*) size(p%av(u_pr_)%pl),size(p%av(l_pr_)%pr)
call gps_reduction(atmp%m,atmp%ia2,atmp%ia1,p%perm,p%invperm,info) call gps_reduction(atmp%m,atmp%ia2,atmp%ia1,p%perm,p%invperm,info)
@ -257,7 +257,7 @@ subroutine psb_zsp_renum(a,desc_a,blck,p,atmp,info)
end if end if
! write(0,*) me,' Renumbering: Done GPS' ! write(0,*) me,' Renumbering: Done GPS'
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
do i=1, atmp%m do i=1, atmp%m
if (p%perm(i) /= i) then if (p%perm(i) /= i) then
write(0,*) me,' permutation is not identity ' write(0,*) me,' permutation is not identity '

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

@ -51,7 +51,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
type(psb_zspmat_type) :: blck, atmp type(psb_zspmat_type) :: blck, atmp
character(len=5) :: fmt character(len=5) :: fmt
character :: upd='F' character :: upd='F'
integer :: i,j,nza,nzb,nzt,icontxt, me,mycol,nprow,npcol,err_act integer :: i,j,nza,nzb,nzt,ictxt, me,mycol,nprow,npcol,err_act
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -75,8 +75,8 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
name='psb_umf_bld' name='psb_umf_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_A%matrix_data(psb_ctxt_) ictxt = desc_A%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mycol) call blacs_gridinfo(ictxt, nprow, npcol, me, mycol)
fmt = 'COO' fmt = 'COO'
@ -86,7 +86,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
atmp%fida='COO' atmp%fida='COO'
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Calling csdp' write(0,*) me, 'UMFBLD: Calling csdp'
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_zcsdp(a,atmp,info) call psb_zcsdp(a,atmp,info)
@ -99,7 +99,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
call psb_spinfo(psb_nztotreq_,atmp,nza,info) call psb_spinfo(psb_nztotreq_,atmp,nza,info)
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k write(0,*) me, 'UMFBLD: Done csdp',info,nza,atmp%m,atmp%k
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,& call psb_asmatbld(p%iprcparm(p_type_),p%iprcparm(n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=fmt) & blck,desc_a,upd,p%desc_data,info,outfmt=fmt)
@ -113,7 +113,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
call psb_spinfo(psb_nztotreq_,blck,nzb,info) call psb_spinfo(psb_nztotreq_,blck,nzb,info)
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done asmatbld',info,nzb,blck%fida write(0,*) me, 'UMFBLD: Done asmatbld',info,nzb,blck%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
if (nzb > 0 ) then if (nzb > 0 ) then
if (size(atmp%aspk)<nza+nzb) then if (size(atmp%aspk)<nza+nzb) then
@ -127,7 +127,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
endif endif
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done realloc',info,nza+nzb,atmp%fida write(0,*) me, 'UMFBLD: Done realloc',info,nza+nzb,atmp%fida
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
do j=1,nzb do j=1,nzb
@ -173,7 +173,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
if (Debug) then if (Debug) then
write(0,*) me,'Calling psb_umf_factor ',nzt,atmp%m,& write(0,*) me,'Calling psb_umf_factor ',nzt,atmp%m,&
& atmp%k,p%desc_data%matrix_data(psb_n_row_) & atmp%k,p%desc_data%matrix_data(psb_n_row_)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_zumf_factor(atmp%m,nzt,& call psb_zumf_factor(atmp%m,nzt,&
@ -189,7 +189,7 @@ subroutine psb_zumf_bld(a,desc_a,p,info)
if (Debug) then if (Debug) then
write(0,*) me, 'UMFBLD: Done umf_Factor',info,p%iprcparm(umf_numptr_) write(0,*) me, 'UMFBLD: Done umf_Factor',info,p%iprcparm(umf_numptr_)
call blacs_barrier(icontxt,'All') call blacs_barrier(ictxt,'All')
endif endif
call psb_sp_free(blck,info) call psb_sp_free(blck,info)
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)

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

@ -58,7 +58,7 @@ function psb_damax (x,desc_a, info, jx)
real(kind(1.d0)) :: psb_damax real(kind(1.d0)) :: psb_damax
! locals ! locals
integer :: int_err(5), icontxt, 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, temp(2), 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
@ -70,10 +70,10 @@ function psb_damax (x,desc_a, info, jx)
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -115,7 +115,7 @@ function psb_damax (x,desc_a, info, jx)
end if end if
! compute global max ! compute global max
call dgamx2d(icontxt, 'A', ' ', ione, ione, amax, ione,& call dgamx2d(ictxt, 'A', ' ', ione, ione, amax, ione,&
&temp ,temp,-ione ,-ione,-ione) &temp ,temp,-ione ,-ione,-ione)
psb_damax=amax psb_damax=amax
@ -127,7 +127,7 @@ function psb_damax (x,desc_a, info, jx)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -190,7 +190,7 @@ function psb_damaxv (x,desc_a, info)
real(kind(1.d0)) :: psb_damaxv real(kind(1.d0)) :: psb_damaxv
! locals ! locals
integer :: int_err(5), err, icontxt, 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, temp(2), 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
@ -202,10 +202,10 @@ function psb_damaxv (x,desc_a, info)
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -243,7 +243,7 @@ function psb_damaxv (x,desc_a, info)
end if end if
! compute global max ! compute global max
call gamx2d(icontxt, 'A', amax) call gamx2d(ictxt, 'A', amax)
psb_damaxv=amax psb_damaxv=amax
@ -254,7 +254,7 @@ function psb_damaxv (x,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -319,7 +319,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
real(kind(1.D0)), intent(out) :: res real(kind(1.D0)), intent(out) :: res
! locals ! locals
integer :: int_err(5), icontxt, 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, temp(2), 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
@ -331,10 +331,10 @@ subroutine psb_damaxvs (res,x,desc_a, info)
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -372,7 +372,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
end if end if
! compute global max ! compute global max
call gamx2d(icontxt, 'A', amax) call gamx2d(ictxt, 'A', amax)
res = amax res = amax
@ -383,7 +383,7 @@ subroutine psb_damaxvs (res,x,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -447,7 +447,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
real(kind(1.d0)), intent(out) :: res(:) real(kind(1.d0)), intent(out) :: res(:)
! locals ! locals
integer :: int_err(5), icontxt, 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, temp(2), 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
@ -459,10 +459,10 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -507,7 +507,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
end if end if
! compute global max ! compute global max
call gamx2d(icontxt, 'A', res(1:k)) call gamx2d(ictxt, 'A', res(1:k))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -516,7 +516,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -59,7 +59,7 @@ function psb_dasum (x,desc_a, info, jx)
real(kind(1.d0)) :: psb_dasum real(kind(1.d0)) :: psb_dasum
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, m, i & err_act, n, iix, jjx, temp(2), ix, ijx, m, i
real(kind(1.d0)) :: asum, dasum real(kind(1.d0)) :: asum, dasum
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -71,10 +71,10 @@ function psb_dasum (x,desc_a, info, jx)
asum=0.d0 asum=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -125,12 +125,12 @@ function psb_dasum (x,desc_a, info, jx)
end do end do
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -146,7 +146,7 @@ function psb_dasum (x,desc_a, info, jx)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -208,7 +208,7 @@ function psb_dasumv (x,desc_a, info)
real(kind(1.d0)) :: psb_dasumv real(kind(1.d0)) :: psb_dasumv
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), jx, ix, ijx, m, i & err_act, n, iix, jjx, temp(2), jx, ix, ijx, m, i
real(kind(1.d0)) :: asum, dasum real(kind(1.d0)) :: asum, dasum
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -220,10 +220,10 @@ function psb_dasumv (x,desc_a, info)
asum=0.d0 asum=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -270,12 +270,12 @@ function psb_dasumv (x,desc_a, info)
end do end do
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -290,7 +290,7 @@ function psb_dasumv (x,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -353,7 +353,7 @@ subroutine psb_dasumvs (res,x,desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, jx, ijx, m, i & err_act, n, iix, jjx, temp(2), ix, jx, ijx, m, i
real(kind(1.d0)) :: asum, dasum real(kind(1.d0)) :: asum, dasum
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -365,10 +365,10 @@ subroutine psb_dasumvs (res,x,desc_a, info)
asum=0.d0 asum=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -415,12 +415,12 @@ subroutine psb_dasumvs (res,x,desc_a, info)
end do end do
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A',asum) call gsum2d(ictxt, 'A',asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -436,7 +436,7 @@ subroutine psb_dasumvs (res,x,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -64,7 +64,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
real(kind(1.D0)), intent(inout) :: y(:,:) real(kind(1.D0)), intent(inout) :: y(:,:)
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, iix, jjx, temp(2), ix, iy, ijx, ijy, m, iiy, in, jjy & err_act, iix, jjx, temp(2), ix, iy, ijx, ijy, m, iiy, in, jjy
real(kind(1.d0)),pointer :: tmpx(:) real(kind(1.d0)),pointer :: tmpx(:)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -74,10 +74,10 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -153,7 +153,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -221,7 +221,7 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info)
real(kind(1.D0)), intent(inout) :: y(:) real(kind(1.D0)), intent(inout) :: y(:)
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, iy, ijx, m, iiy, in, jjy & err_act, n, iix, jjx, temp(2), ix, iy, ijx, m, iiy, in, jjy
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
@ -231,10 +231,10 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -285,7 +285,7 @@ subroutine psb_daxpbyv(alpha, x, beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -60,7 +60,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
real(kind(1.D0)) :: psb_ddot real(kind(1.D0)) :: psb_ddot
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
real(kind(1.D0)) :: dot_local real(kind(1.D0)) :: dot_local
real(kind(1.d0)) :: ddot real(kind(1.d0)) :: ddot
@ -71,10 +71,10 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -145,7 +145,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
end if end if
! compute global sum ! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,& call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol) & ione, mone ,mycol)
psb_ddot = dot_local psb_ddot = dot_local
@ -157,7 +157,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -219,7 +219,7 @@ function psb_ddotv(x, y,desc_a, info)
real(kind(1.D0)) :: psb_ddotv real(kind(1.D0)) :: psb_ddotv
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, jx, iy, jy, iiy, jjy, i, m, j, k & err_act, n, iix, jjx, temp(2), ix, jx, iy, jy, iiy, jjy, i, m, j, k
real(kind(1.D0)) :: dot_local real(kind(1.D0)) :: dot_local
real(kind(1.d0)) :: ddot real(kind(1.d0)) :: ddot
@ -230,10 +230,10 @@ function psb_ddotv(x, y,desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -288,7 +288,7 @@ function psb_ddotv(x, y,desc_a, info)
end if end if
! compute global sum ! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,& call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol) & ione, mone ,mycol)
psb_ddotv = dot_local psb_ddotv = dot_local
@ -300,7 +300,7 @@ function psb_ddotv(x, y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -362,7 +362,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
real(kind(1.D0)) :: dot_local real(kind(1.D0)) :: dot_local
real(kind(1.d0)) :: ddot real(kind(1.d0)) :: ddot
@ -373,10 +373,10 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -429,7 +429,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
end if end if
! compute global sum ! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,& call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol) & ione, mone ,mycol)
res = dot_local res = dot_local
@ -441,7 +441,7 @@ subroutine psb_ddotvs(res, x, y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -508,7 +508,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
real(kind(1.d0)),allocatable :: dot_local(:) real(kind(1.d0)),allocatable :: dot_local(:)
real(kind(1.d0)) :: ddot real(kind(1.d0)) :: ddot
@ -519,10 +519,10 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -587,7 +587,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
end if end if
! compute global sum ! compute global sum
call dgsum2d(icontxt, 'A', ' ', ione, ione, dot_local,& call dgsum2d(ictxt, 'A', ' ', ione, ione, dot_local,&
& ione, mone ,mycol) & ione, mone ,mycol)
res(1:k) = dot_local(1:k) res(1:k) = dot_local(1:k)
@ -599,7 +599,7 @@ subroutine psb_dmdots(res, x, y, 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

30
src/psblas/psb_dnrm2.f90
Unescape Escape View File

@ -56,7 +56,7 @@ function psb_dnrm2(x, desc_a, info, jx)
real(kind(1.D0)) :: psb_dnrm2 real(kind(1.D0)) :: psb_dnrm2
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ndim, ix, ijx, i, m, id & err_act, n, iix, jjx, temp(2), ndim, ix, ijx, i, m, id
real(kind(1.d0)) :: nrm2, dnrm2, dd real(kind(1.d0)) :: nrm2, dnrm2, dd
real(kind(1.d0)),pointer :: tmpx(:) real(kind(1.d0)),pointer :: tmpx(:)
@ -68,10 +68,10 @@ function psb_dnrm2(x, desc_a, info, jx)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -128,7 +128,7 @@ function psb_dnrm2(x, desc_a, info, jx)
nrm2 = dzero nrm2 = dzero
end if end if
call pdtreecomb(icontxt,'All',1,nrm2,-1,-1,dcombnrm2) call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2)
psb_dnrm2 = nrm2 psb_dnrm2 = nrm2
@ -139,7 +139,7 @@ function psb_dnrm2(x, desc_a, info, jx)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -199,7 +199,7 @@ function psb_dnrm2v(x, desc_a, info)
real(kind(1.D0)) :: psb_dnrm2v real(kind(1.D0)) :: psb_dnrm2v
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id & err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id
real(kind(1.d0)) :: nrm2, dnrm2, dd real(kind(1.d0)) :: nrm2, dnrm2, dd
real(kind(1.d0)),pointer :: tmpx(:) real(kind(1.d0)),pointer :: tmpx(:)
@ -211,10 +211,10 @@ function psb_dnrm2v(x, desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -268,7 +268,7 @@ function psb_dnrm2v(x, desc_a, info)
nrm2 = dzero nrm2 = dzero
end if end if
call pdtreecomb(icontxt,'All',1,nrm2,-1,-1,dcombnrm2) call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2)
psb_dnrm2v = nrm2 psb_dnrm2v = nrm2
@ -279,7 +279,7 @@ function psb_dnrm2v(x, 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -341,7 +341,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id & err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id
real(kind(1.d0)) :: nrm2, dnrm2, dd real(kind(1.d0)) :: nrm2, dnrm2, dd
real(kind(1.d0)),pointer :: tmpx(:) real(kind(1.d0)),pointer :: tmpx(:)
@ -353,10 +353,10 @@ subroutine psb_dnrm2vs(res, x, desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -408,7 +408,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info)
nrm2 = dzero nrm2 = dzero
end if end if
call pdtreecomb(icontxt,'All',1,nrm2,-1,-1,dcombnrm2) call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2)
res = nrm2 res = nrm2
@ -419,7 +419,7 @@ subroutine psb_dnrm2vs(res, x, 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -53,7 +53,7 @@ function psb_dnrmi(a,desc_a,info)
real(kind(1.d0)) :: psb_dnrmi real(kind(1.d0)) :: psb_dnrmi
! locals ! locals
integer :: int_err(5), icontxt, 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, temp(2), 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
@ -63,10 +63,10 @@ function psb_dnrmi(a,desc_a,info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -112,7 +112,7 @@ function psb_dnrmi(a,desc_a,info)
end if end if
! compute global max ! compute global max
call dgamx2d(icontxt, 'A', ' ', ione, ione, nrmi, ione,& call dgamx2d(ictxt, 'A', ' ', ione, ione, nrmi, ione,&
&temp ,temp,-ione ,-ione,-ione) &temp ,temp,-ione ,-ione,-ione)
else else
nrmi = 0.d0 nrmi = 0.d0
@ -127,7 +127,7 @@ function psb_dnrmi(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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -101,7 +101,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
integer, intent(in), optional :: k, jx, jy,doswap integer, intent(in), optional :: k, jx, jy,doswap
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,&
& idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, iiy, jjy,& & idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, iiy, jjy,&
& i, ib, ib1 & i, ib, ib1
@ -116,10 +116,10 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -355,7 +355,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -441,7 +441,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
integer, intent(in), optional :: doswap integer, intent(in), optional :: doswap
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,&
& idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, jx, jy, iiy, jjy,& & idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, jx, jy, iiy, jjy,&
& i, ib, ib1 & i, ib, ib1
@ -456,10 +456,10 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -660,7 +660,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -97,7 +97,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
integer, intent(in), optional :: k, jx, jy integer, intent(in), optional :: k, jx, jy
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,&
& ix, iy, ik, ijx, ijy, i, lld,& & ix, iy, ik, ijx, ijy, i, lld,&
& idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy & idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy
@ -114,10 +114,10 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -312,7 +312,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -403,7 +403,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
integer, intent(in), optional :: choice integer, intent(in), optional :: choice
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,&
& ix, iy, ik, jx, jy, i, lld,& & ix, iy, ik, jx, jy, i, lld,&
& idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy & idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy
@ -420,10 +420,10 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -606,7 +606,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -58,7 +58,7 @@ function psb_zamax (x,desc_a, info, jx)
real(kind(1.d0)) :: psb_zamax real(kind(1.d0)) :: psb_zamax
! locals ! locals
integer :: int_err(5), icontxt, 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, izamax & err_act, n, iix, jjx, temp(2), ix, ijx, m, i, k, imax, izamax
real(kind(1.d0)) :: amax real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -73,10 +73,10 @@ function psb_zamax (x,desc_a, info, jx)
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -118,7 +118,7 @@ function psb_zamax (x,desc_a, info, jx)
end if end if
! compute global max ! compute global max
call gamx2d(icontxt, 'A', amax) call gamx2d(ictxt, 'A', amax)
psb_zamax=amax psb_zamax=amax
@ -129,7 +129,7 @@ function psb_zamax (x,desc_a, info, jx)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -192,7 +192,7 @@ function psb_zamaxv (x,desc_a, info)
real(kind(1.d0)) :: psb_zamaxv real(kind(1.d0)) :: psb_zamaxv
! locals ! locals
integer :: int_err(5), err, icontxt, 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, izamax & err_act, n, iix, jjx, jx, temp(2), ix, ijx, m, imax, izamax
real(kind(1.d0)) :: amax real(kind(1.d0)) :: amax
complex(kind(1.d0)) :: cmax complex(kind(1.d0)) :: cmax
@ -208,10 +208,10 @@ function psb_zamaxv (x,desc_a, info)
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -250,7 +250,7 @@ function psb_zamaxv (x,desc_a, info)
end if end if
! compute global max ! compute global max
call gamx2d(icontxt, 'A', amax) call gamx2d(ictxt, 'A', amax)
psb_zamaxv=amax psb_zamaxv=amax
@ -261,7 +261,7 @@ function psb_zamaxv (x,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -326,7 +326,7 @@ subroutine psb_zamaxvs (res,x,desc_a, info)
real(kind(1.D0)), intent(out) :: res real(kind(1.D0)), intent(out) :: res
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, m, imax, izamax & err_act, n, iix, jjx, temp(2), ix, ijx, m, imax, izamax
real(kind(1.d0)) :: amax real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -342,10 +342,10 @@ subroutine psb_zamaxvs (res,x,desc_a, info)
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -384,7 +384,7 @@ subroutine psb_zamaxvs (res,x,desc_a, info)
end if end if
! compute global max ! compute global max
call gamx2d(icontxt, 'A', amax) call gamx2d(ictxt, 'A', amax)
res = amax res = amax
@ -395,7 +395,7 @@ subroutine psb_zamaxvs (res,x,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -459,7 +459,7 @@ subroutine psb_zmamaxs (res,x,desc_a, info,jx)
real(kind(1.d0)), intent(out) :: res(:) real(kind(1.d0)), intent(out) :: res(:)
! locals ! locals
integer :: int_err(5), icontxt, 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, izamax & err_act, n, iix, jjx, ix, temp(2), ijx, m, imax, i, k, izamax
real(kind(1.d0)) :: amax real(kind(1.d0)) :: amax
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -475,10 +475,10 @@ subroutine psb_zmamaxs (res,x,desc_a, info,jx)
amax=0.d0 amax=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -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(icontxt, 'A', res(1:k)) call gamx2d(ictxt, 'A', res(1:k))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -533,7 +533,7 @@ subroutine psb_zmamaxs (res,x,desc_a, info,jx)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -59,7 +59,7 @@ function psb_zasum (x,desc_a, info, jx)
real(kind(1.d0)) :: psb_zasum real(kind(1.d0)) :: psb_zasum
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, m, i & err_act, n, iix, jjx, temp(2), ix, ijx, m, i
real(kind(1.d0)) :: asum, dzasum real(kind(1.d0)) :: asum, dzasum
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -75,10 +75,10 @@ function psb_zasum (x,desc_a, info, jx)
asum=0.d0 asum=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -130,12 +130,12 @@ function psb_zasum (x,desc_a, info, jx)
end do end do
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -151,7 +151,7 @@ function psb_zasum (x,desc_a, info, jx)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -213,7 +213,7 @@ function psb_zasumv (x,desc_a, info)
real(kind(1.d0)) :: psb_zasumv real(kind(1.d0)) :: psb_zasumv
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), jx, ix, ijx, m, i & err_act, n, iix, jjx, temp(2), jx, ix, ijx, m, i
real(kind(1.d0)) :: asum, dzasum real(kind(1.d0)) :: asum, dzasum
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -229,10 +229,10 @@ function psb_zasumv (x,desc_a, info)
asum=0.d0 asum=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -280,12 +280,12 @@ function psb_zasumv (x,desc_a, info)
end do end do
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -300,7 +300,7 @@ function psb_zasumv (x,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -363,7 +363,7 @@ subroutine psb_zasumvs (res,x,desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, jx, ijx, m, i & err_act, n, iix, jjx, temp(2), ix, jx, ijx, m, i
real(kind(1.d0)) :: asum, dzasum real(kind(1.d0)) :: asum, dzasum
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -379,10 +379,10 @@ subroutine psb_zasumvs (res,x,desc_a, info)
asum=0.d0 asum=0.d0
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -430,12 +430,12 @@ subroutine psb_zasumvs (res,x,desc_a, info)
end do end do
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A',asum) call gsum2d(ictxt, 'A',asum)
else else
asum=0.d0 asum=0.d0
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', asum) call gsum2d(ictxt, 'A', asum)
end if end if
else else
asum=0.d0 asum=0.d0
@ -451,7 +451,7 @@ subroutine psb_zasumvs (res,x,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -64,7 +64,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
complex(kind(1.D0)), intent(inout) :: y(:,:) complex(kind(1.D0)), intent(inout) :: y(:,:)
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, iix, jjx, temp(2), ix, iy, ijx, ijy, m, iiy, in, jjy & err_act, iix, jjx, temp(2), ix, iy, ijx, ijy, m, iiy, in, jjy
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -73,10 +73,10 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -152,7 +152,7 @@ subroutine psb_zaxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -220,7 +220,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info)
complex(kind(1.D0)), intent(inout) :: y(:) complex(kind(1.D0)), intent(inout) :: y(:)
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, iy, ijx, m, iiy, in, jjy & err_act, n, iix, jjx, temp(2), ix, iy, ijx, m, iiy, in, jjy
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
@ -230,10 +230,10 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,desc_a,info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -284,7 +284,7 @@ subroutine psb_zaxpbyv(alpha, x, beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -61,7 +61,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy)
complex(kind(1.D0)) :: psb_zdot complex(kind(1.D0)) :: psb_zdot
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
complex(kind(1.D0)) :: dot_local complex(kind(1.D0)) :: dot_local
complex(kind(1.d0)) :: zdotc complex(kind(1.d0)) :: zdotc
@ -72,10 +72,10 @@ function psb_zdot(x, y,desc_a, info, jx, jy)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -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(icontxt, 'A', dot_local) call gsum2d(ictxt, 'A', dot_local)
psb_zdot = dot_local psb_zdot = dot_local
@ -157,7 +157,7 @@ function psb_zdot(x, y,desc_a, info, jx, jy)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -220,7 +220,7 @@ function psb_zdotv(x, y,desc_a, info)
complex(kind(1.D0)) :: psb_zdotv complex(kind(1.D0)) :: psb_zdotv
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, jx, iy, jy, iiy, jjy, i, m, j, k & err_act, n, iix, jjx, temp(2), ix, jx, iy, jy, iiy, jjy, i, m, j, k
complex(kind(1.D0)) :: dot_local complex(kind(1.D0)) :: dot_local
complex(kind(1.d0)) :: zdotc complex(kind(1.d0)) :: zdotc
@ -231,10 +231,10 @@ function psb_zdotv(x, y,desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -289,7 +289,7 @@ function psb_zdotv(x, y,desc_a, info)
end if end if
! compute global sum ! compute global sum
call gsum2d(icontxt, 'A', dot_local) call gsum2d(ictxt, 'A', dot_local)
psb_zdotv = dot_local psb_zdotv = dot_local
@ -300,7 +300,7 @@ function psb_zdotv(x, y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -363,7 +363,7 @@ subroutine psb_zdotvs(res, x, y,desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
complex(kind(1.D0)) :: dot_local complex(kind(1.D0)) :: dot_local
complex(kind(1.d0)) :: zdotc complex(kind(1.d0)) :: zdotc
@ -374,10 +374,10 @@ subroutine psb_zdotvs(res, x, y,desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -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(icontxt, 'A', dot_local) call gsum2d(ictxt, 'A', dot_local)
res = dot_local res = dot_local
@ -441,7 +441,7 @@ subroutine psb_zdotvs(res, x, y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -509,7 +509,7 @@ subroutine psb_zmdots(res, x, y, desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k & err_act, n, iix, jjx, temp(2), ix, ijx, iy, ijy, iiy, jjy, i, m, j, k
complex(kind(1.d0)),allocatable :: dot_local(:) complex(kind(1.d0)),allocatable :: dot_local(:)
complex(kind(1.d0)) :: zdotc complex(kind(1.d0)) :: zdotc
@ -520,10 +520,10 @@ subroutine psb_zmdots(res, x, y, desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -ione) then if (nprow == -ione) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -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(icontxt, 'A', dot_local(1:k)) call gsum2d(ictxt, 'A', dot_local(1:k))
res(1:k) = dot_local(1:k) res(1:k) = dot_local(1:k)
@ -600,7 +600,7 @@ subroutine psb_zmdots(res, x, y, 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

30
src/psblas/psb_znrm2.f90
Unescape Escape View File

@ -56,7 +56,7 @@ function psb_znrm2(x, desc_a, info, jx)
real(kind(1.D0)) :: psb_znrm2 real(kind(1.D0)) :: psb_znrm2
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ndim, ix, ijx, i, m, id & err_act, n, iix, jjx, temp(2), ndim, ix, ijx, i, m, id
real(kind(1.d0)) :: nrm2, dznrm2, dd real(kind(1.d0)) :: nrm2, dznrm2, dd
@ -68,10 +68,10 @@ function psb_znrm2(x, desc_a, info, jx)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -127,7 +127,7 @@ function psb_znrm2(x, desc_a, info, jx)
nrm2 = dzero nrm2 = dzero
end if end if
call pdtreecomb(icontxt,'All',1,nrm2,-1,-1,dcombnrm2) call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2)
psb_znrm2 = nrm2 psb_znrm2 = nrm2
@ -138,7 +138,7 @@ function psb_znrm2(x, desc_a, info, jx)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -198,7 +198,7 @@ function psb_znrm2v(x, desc_a, info)
real(kind(1.D0)) :: psb_znrm2v real(kind(1.D0)) :: psb_znrm2v
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id & err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id
real(kind(1.d0)) :: nrm2, dznrm2, dd real(kind(1.d0)) :: nrm2, dznrm2, dd
@ -210,10 +210,10 @@ function psb_znrm2v(x, desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -266,7 +266,7 @@ function psb_znrm2v(x, desc_a, info)
nrm2 = dzero nrm2 = dzero
end if end if
call pdtreecomb(icontxt,'All',1,nrm2,-1,-1,dcombnrm2) call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2)
psb_znrm2v = nrm2 psb_znrm2v = nrm2
@ -277,7 +277,7 @@ function psb_znrm2v(x, 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -339,7 +339,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id & err_act, n, iix, jjx, temp(2), ndim, ix, jx, ijx, i, m, id
real(kind(1.d0)) :: nrm2, dznrm2, dd real(kind(1.d0)) :: nrm2, dznrm2, dd
@ -351,10 +351,10 @@ subroutine psb_znrm2vs(res, x, desc_a, info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -403,7 +403,7 @@ subroutine psb_znrm2vs(res, x, desc_a, info)
nrm2 = dzero nrm2 = dzero
end if end if
call pdtreecomb(icontxt,'All',1,nrm2,-1,-1,dcombnrm2) call pdtreecomb(ictxt,'All',1,nrm2,-1,-1,dcombnrm2)
res = nrm2 res = nrm2
@ -414,7 +414,7 @@ subroutine psb_znrm2vs(res, x, 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -54,7 +54,7 @@ function psb_znrmi(a,desc_a,info)
real(kind(1.d0)) :: psb_znrmi real(kind(1.d0)) :: psb_znrmi
! locals ! locals
integer :: int_err(5), icontxt, 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, temp(2), mdim, ndim, m
real(kind(1.d0)) :: nrmi, zcsnmi real(kind(1.d0)) :: nrmi, zcsnmi
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -64,10 +64,10 @@ function psb_znrmi(a,desc_a,info)
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -113,7 +113,7 @@ function psb_znrmi(a,desc_a,info)
end if end if
! compute global max ! compute global max
call gamx2d(icontxt, 'A', nrmi) call gamx2d(ictxt, 'A', nrmi)
else else
nrmi = 0.d0 nrmi = 0.d0
end if end if
@ -127,7 +127,7 @@ 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -100,7 +100,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,&
integer, intent(in), optional :: k, jx, jy,doswap integer, intent(in), optional :: k, jx, jy,doswap
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,&
& idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, iiy, jjy,& & idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, iiy, jjy,&
& i, ib, ib1 & i, ib, ib1
@ -115,10 +115,10 @@ subroutine psb_zspmm(alpha,a,x,beta,y,desc_a,info,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -350,7 +350,7 @@ subroutine psb_zspmm(alpha,a,x,beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -435,7 +435,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,&
integer, intent(in), optional :: doswap integer, intent(in), optional :: doswap
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), ix, iy, ik, ijx, ijy,&
& idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, jx, jy, iiy, jjy,& & idoswap, m, nrow, ncol, lldx, lldy, liwork, llwork, jx, jy, iiy, jjy,&
& i, ib, ib1 & i, ib, ib1
@ -450,10 +450,10 @@ subroutine psb_zspmv(alpha,a,x,beta,y,desc_a,info,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -650,7 +650,7 @@ subroutine psb_zspmv(alpha,a,x,beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -96,7 +96,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,&
integer, intent(in), optional :: k, jx, jy integer, intent(in), optional :: k, jx, jy
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,&
& ix, iy, ik, ijx, ijy, i, lld,& & ix, iy, ik, ijx, ijy, i, lld,&
& idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy & idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy
@ -113,10 +113,10 @@ subroutine psb_zspsm(alpha,a,x,beta,y,desc_a,info,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -315,7 +315,7 @@ subroutine psb_zspsm(alpha,a,x,beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -406,7 +406,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,&
integer, intent(in), optional :: choice integer, intent(in), optional :: choice
! locals ! locals
integer :: int_err(5), icontxt, nprow, npcol, myrow, mycol,& integer :: int_err(5), ictxt, nprow, npcol, myrow, mycol,&
& err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,& & err_act, n, iix, jjx, ia, ja, iia, jja, temp(2), lldx,lldy, lchoice,&
& ix, iy, ik, jx, jy, i, lld,& & ix, iy, ik, jx, jy, i, lld,&
& idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy & idoswap, m, nrow, ncol, liwork, llwork, iiy, jjy
@ -423,10 +423,10 @@ subroutine psb_zspsv(alpha,a,x,beta,y,desc_a,info,&
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -605,7 +605,7 @@ subroutine psb_zspsv(alpha,a,x,beta,y,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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

3
src/tools/Makefile
Unescape Escape View File

@ -11,7 +11,8 @@ FOBJS = psb_dallc.o psb_dasb.o psb_dcsrp.o psb_cdprt.o \
psb_ifree.o psb_iins.o psb_loc_to_glob.o\ psb_ifree.o psb_iins.o psb_loc_to_glob.o\
psb_zallc.o psb_zasb.o psb_zfree.o psb_zins.o \ psb_zallc.o psb_zasb.o psb_zfree.o psb_zins.o \
psb_zspalloc.o psb_zspasb.o psb_zspcnv.o psb_zspfree.o\ psb_zspalloc.o psb_zspasb.o psb_zspcnv.o psb_zspfree.o\
psb_zspins.o psb_zsprn.o psb_zcdovr.o psb_zgelp.o psb_zspins.o psb_zsprn.o psb_zcdovr.o psb_zgelp.o\
psb_init.o psb_exit.o psb_info.o psb_barrier.o
MPFOBJS = psb_dcdovrbld.o psb_dsphalo.o psb_zcdovrbld.o psb_zsphalo.o MPFOBJS = psb_dcdovrbld.o psb_dsphalo.o psb_zcdovrbld.o psb_zsphalo.o

6
src/tools/psb_barrier.f90
Unescape Escape View File

@ -0,0 +1,6 @@
subroutine psb_barrier(ictxt)
integer, intent(in) :: ictxt
call blacs_barrier(ictxt,'All')
end subroutine psb_barrier

18
src/tools/psb_cdall.f90
Unescape Escape View File

@ -38,10 +38,10 @@
! m - integer. The number of rows. ! m - integer. The number of rows.
! n - integer. The number of columns. ! n - integer. The number of columns.
! parts - external subroutine. The routine that contains the partitioning scheme. ! parts - external subroutine. The routine that contains the partitioning scheme.
! icontxt - integer. The communication context. ! ictxt - integer. The communication context.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(<psb_desc_type>). The communication descriptor.
! info - integer. Eventually returns an error code ! info - integer. Eventually returns an error code
subroutine psb_cdall(m, n, parts, icontxt, desc_a, info) subroutine psb_cdall(m, n, parts, ictxt, desc_a, info)
use psb_error_mod use psb_error_mod
use psb_descriptor_type use psb_descriptor_type
use psb_realloc_mod use psb_realloc_mod
@ -50,7 +50,7 @@ subroutine psb_cdall(m, n, parts, icontxt, desc_a, info)
implicit None implicit None
include 'parts.fh' include 'parts.fh'
!....Parameters... !....Parameters...
Integer, intent(in) :: M,N,ICONTXT Integer, intent(in) :: M,N,ictxt
Type(psb_desc_type), intent(out) :: desc_a Type(psb_desc_type), intent(out) :: desc_a
integer, intent(out) :: info integer, intent(out) :: info
@ -70,7 +70,7 @@ subroutine psb_cdall(m, n, parts, icontxt, desc_a, info)
name = 'psb_cdall' name = 'psb_cdall'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (debug) write(*,*) 'psb_cdall: ',nprow,npcol,myrow,mycol if (debug) write(*,*) 'psb_cdall: ',nprow,npcol,myrow,mycol
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (npcol /= 1) then if (npcol /= 1) then
@ -105,9 +105,9 @@ subroutine psb_cdall(m, n, parts, icontxt, desc_a, info)
if (myrow.eq.psb_root_) then if (myrow.eq.psb_root_) then
exch(1)=m exch(1)=m
exch(2)=n exch(2)=n
call igebs2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo) call igebs2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo)
else else
call igebr2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,& call igebr2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,&
& 0) & 0)
if (exch(1) /= m) then if (exch(1) /= m) then
err=550 err=550
@ -314,8 +314,8 @@ subroutine psb_cdall(m, n, parts, icontxt, desc_a, info)
desc_a%matrix_data(psb_m_) = m desc_a%matrix_data(psb_m_) = m
desc_a%matrix_data(psb_n_) = n desc_a%matrix_data(psb_n_) = n
desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_
desc_a%matrix_data(psb_ctxt_) = icontxt desc_a%matrix_data(psb_ctxt_) = ictxt
call blacs_get(icontxt,10,desc_a%matrix_data(psb_mpi_c_)) call blacs_get(ictxt,10,desc_a%matrix_data(psb_mpi_c_))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -323,7 +323,7 @@ subroutine psb_cdall(m, n, parts, icontxt, desc_a, 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

18
src/tools/psb_cdalv.f90
Unescape Escape View File

@ -37,18 +37,18 @@
! Parameters: ! Parameters:
! m - integer. The number of rows. ! m - integer. The number of rows.
! v - integer, dimension(:). The array containg the partitioning scheme. ! v - integer, dimension(:). The array containg the partitioning scheme.
! icontxt - integer. The communication context. ! ictxt - integer. The communication context.
! desc_a - type(<psb_desc_type>). The communication descriptor. ! desc_a - type(<psb_desc_type>). The communication descriptor.
! info - integer. Eventually returns an error code ! info - integer. Eventually returns an error code
! flag - integer. ??? ! flag - integer. ???
subroutine psb_cdalv(m, v, icontxt, desc_a, info, flag) subroutine psb_cdalv(m, v, ictxt, desc_a, info, flag)
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_error_mod use psb_error_mod
implicit None implicit None
!....Parameters... !....Parameters...
Integer, intent(in) :: m,icontxt, v(:) Integer, intent(in) :: m,ictxt, v(:)
integer, intent(in), optional :: flag integer, intent(in), optional :: flag
integer, intent(out) :: info integer, intent(out) :: info
type(psb_desc_type), intent(out) :: desc_a type(psb_desc_type), intent(out) :: desc_a
@ -68,7 +68,7 @@ subroutine psb_cdalv(m, v, icontxt, desc_a, info, flag)
err=0 err=0
name = 'psb_cdalv' name = 'psb_cdalv'
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (debug) write(*,*) 'psb_cdall: ',nprow,npcol,myrow,mycol if (debug) write(*,*) 'psb_cdall: ',nprow,npcol,myrow,mycol
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (npcol /= 1) then if (npcol /= 1) then
@ -104,9 +104,9 @@ subroutine psb_cdalv(m, v, icontxt, desc_a, info, flag)
if (myrow.eq.psb_root_) then if (myrow.eq.psb_root_) then
exch(1)=m exch(1)=m
exch(2)=n exch(2)=n
call igebs2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo) call igebs2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo)
else else
call igebr2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,& call igebr2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,&
& 0) & 0)
if (exch(1) /= m) then if (exch(1) /= m) then
info=550 info=550
@ -282,8 +282,8 @@ subroutine psb_cdalv(m, v, icontxt, desc_a, info, flag)
desc_a%matrix_data(psb_m_) = m desc_a%matrix_data(psb_m_) = m
desc_a%matrix_data(psb_n_) = n desc_a%matrix_data(psb_n_) = n
desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_ desc_a%matrix_data(psb_dec_type_) = psb_desc_bld_
desc_a%matrix_data(psb_ctxt_) = icontxt desc_a%matrix_data(psb_ctxt_) = ictxt
call blacs_get(icontxt,10,desc_a%matrix_data(psb_mpi_c_)) call blacs_get(ictxt,10,desc_a%matrix_data(psb_mpi_c_))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -291,7 +291,7 @@ subroutine psb_cdalv(m, v, icontxt, desc_a, info, flag)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -55,7 +55,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 :: icontxt,temp(1),n_row integer :: ictxt,temp(1),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
@ -65,13 +65,13 @@ subroutine psb_cdasb(desc_a,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
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(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
if (nprow == -1) then if (nprow == -1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -134,7 +134,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(icontxt, psb_all_, psb_topdef_, itwo, ione, itemp,& call igamx2d(ictxt, psb_all_, psb_topdef_, itwo, ione, itemp,&
& itwo,temp ,temp,-ione ,-ione,-ione) & itwo,temp ,temp,-ione ,-ione,-ione)
max_size = itemp(1) max_size = itemp(1)
max_halo = itemp(2) max_halo = itemp(2)
@ -224,7 +224,7 @@ subroutine psb_cdasb(desc_a,info)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(ictxt)
end if end if
return return

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

@ -54,7 +54,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info)
!locals !locals
integer :: nprow,npcol,me,mypcol,& integer :: nprow,npcol,me,mypcol,&
& icontxt, isz, dectype, err_act, err & ictxt, isz, dectype, err_act, err
integer :: int_err(5),temp(1) integer :: int_err(5),temp(1)
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
logical, parameter :: debug=.false.,debugprt=.false. logical, parameter :: debug=.false.,debugprt=.false.
@ -65,9 +65,9 @@ subroutine psb_cdcpy(desc_in, desc_out, info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
name = 'psb_cdcpy' name = 'psb_cdcpy'
icontxt=desc_in%matrix_data(psb_ctxt_) ictxt=desc_in%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
if (debug) write(0,*) me,'Entered CDCPY' if (debug) write(0,*) me,'Entered CDCPY'
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
@ -234,7 +234,7 @@ subroutine psb_cdcpy(desc_in, desc_out, info)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(ictxt)
end if end if
return return

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

@ -28,7 +28,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ POSSIBILITY OF SUCH DAMAGE.
!!$ !!$
!!$ !!$
subroutine psb_cddec(nloc, icontxt, desc_a, info) subroutine psb_cddec(nloc, ictxt, desc_a, info)
! Purpose ! Purpose
! ======= ! =======
@ -43,7 +43,7 @@ subroutine psb_cddec(nloc, icontxt, desc_a, info)
! Number of local indices ! Number of local indices
! required. ! required.
! !
! ICONTXT : (Global Input)Integer BLACS context for an NPx1 grid ! ictxt : (Global Input)Integer BLACS context for an NPx1 grid
! required. ! required.
! !
! OUTPUT ! OUTPUT
@ -109,7 +109,7 @@ subroutine psb_cddec(nloc, icontxt, desc_a, info)
use psb_error_mod use psb_error_mod
implicit None implicit None
!....Parameters... !....Parameters...
Integer, intent(in) :: nloc,icontxt Integer, intent(in) :: nloc,ictxt
integer, intent(out) :: info integer, intent(out) :: info
Type(psb_desc_type), intent(out) :: desc_a Type(psb_desc_type), intent(out) :: desc_a
@ -129,7 +129,7 @@ subroutine psb_cddec(nloc, icontxt, desc_a, info)
err=0 err=0
name = 'psb_cddec' name = 'psb_cddec'
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
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 +163,7 @@ subroutine psb_cddec(nloc, icontxt, desc_a, info)
nlv(:) = 0 nlv(:) = 0
nlv(me) = nloc nlv(me) = nloc
call igsum2d(icontxt,'All',' ',nprow,1,nlv,nprow,-1,-1) call igsum2d(ictxt,'All',' ',nprow,1,nlv,nprow,-1,-1)
m = sum(nlv) m = sum(nlv)
@ -216,8 +216,8 @@ subroutine psb_cddec(nloc, icontxt, desc_a, info)
desc_a%matrix_data(psb_n_row_) = nloc desc_a%matrix_data(psb_n_row_) = nloc
desc_a%matrix_data(psb_n_col_) = nloc desc_a%matrix_data(psb_n_col_) = nloc
desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_ desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_
desc_a%matrix_data(psb_ctxt_) = icontxt desc_a%matrix_data(psb_ctxt_) = ictxt
call blacs_get(icontxt,10,desc_a%matrix_data(psb_mpi_c_)) call blacs_get(ictxt,10,desc_a%matrix_data(psb_mpi_c_))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -225,7 +225,7 @@ subroutine psb_cddec(nloc, icontxt, desc_a, 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -49,7 +49,7 @@ subroutine psb_cdfree(desc_a,info)
integer :: int_err(5) integer :: int_err(5)
integer :: temp(1) integer :: temp(1)
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
integer :: icontxt,nprow,npcol,me,mypcol, err_act integer :: ictxt,nprow,npcol,me,mypcol, err_act
character(len=20) :: name, char_err character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -64,9 +64,9 @@ subroutine psb_cdfree(desc_a,info)
return return
end if end if
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
deallocate(desc_a%matrix_data) deallocate(desc_a%matrix_data)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
@ -177,7 +177,7 @@ subroutine psb_cdfree(desc_a,info)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(ictxt)
end if end if
return return

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

@ -54,7 +54,7 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info)
!LOCALS..... !LOCALS.....
integer :: i,icontxt,nprocs ,glob_row,row,k,start_row,end_row,& integer :: i,ictxt,nprocs ,glob_row,row,k,start_row,end_row,&
& first_loc_row,j, ierror,locix,locjx,& & first_loc_row,j, ierror,locix,locjx,&
& dectype,mglob, nnza, nglob,err & dectype,mglob, nnza, nglob,err
integer,pointer :: tia1(:),tia2(:), temp(:) integer,pointer :: tia1(:),tia2(:), temp(:)
@ -68,7 +68,7 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info)
name = 'psb_cdins' name = 'psb_cdins'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt = desc_a%matrix_data(psb_ctxt_) ictxt = desc_a%matrix_data(psb_ctxt_)
dectype = desc_a%matrix_data(psb_dec_type_) dectype = desc_a%matrix_data(psb_dec_type_)
mglob = desc_a%matrix_data(psb_m_) mglob = desc_a%matrix_data(psb_m_)
nglob = desc_a%matrix_data(psb_n_) nglob = desc_a%matrix_data(psb_n_)
@ -76,7 +76,7 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info)
ncol = desc_a%matrix_data(psb_n_col_) ncol = desc_a%matrix_data(psb_n_col_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
if (npcol.ne.1) then if (npcol.ne.1) then
info = 2030 info = 2030
call psb_errpush(info,name) call psb_errpush(info,name)
@ -180,7 +180,7 @@ subroutine psb_cdins(nz,ia,ja,desc_a,info)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(ictxt)
end if end if
return return

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

@ -60,7 +60,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 :: icontxt,temp(1),n_row, int_err(5), err_act integer :: ictxt,temp(1),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.
@ -73,13 +73,13 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
time(1) = mpi_wtime() time(1) = mpi_wtime()
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
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(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
call psb_errpush(info,name) call psb_errpush(info,name)
@ -213,7 +213,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
time(4) = mpi_wtime() time(4) = mpi_wtime()
time(4) = time(4) - time(3) time(4) = time(4) - time(3)
if (debug) then if (debug) then
call dgamx2d(icontxt, psb_all_, psb_topdef_, ione, ione, time(4),& call dgamx2d(ictxt, psb_all_, psb_topdef_, ione, ione, time(4),&
& ione,temp ,temp,-ione ,-ione,-ione) & ione,temp ,temp,-ione ,-ione,-ione)
write (*, *) ' comm structs assembly: ', time(4)*1.d-3 write (*, *) ' comm structs assembly: ', time(4)*1.d-3
@ -228,7 +228,7 @@ subroutine psb_cdren(trans,iperm,desc_a,info)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(ictxt)
end if end if
return return

18
src/tools/psb_cdrep.f90
Unescape Escape View File

@ -28,7 +28,7 @@
!!$ POSSIBILITY OF SUCH DAMAGE. !!$ POSSIBILITY OF SUCH DAMAGE.
!!$ !!$
!!$ !!$
subroutine psb_cdrep(m, icontxt, desc_a, info) subroutine psb_cdrep(m, ictxt, desc_a, info)
! Purpose ! Purpose
! ======= ! =======
@ -43,7 +43,7 @@ subroutine psb_cdrep(m, icontxt, desc_a, info)
! Total number of equations ! Total number of equations
! required. ! required.
! !
! ICONTXT : (Global Input)Integer BLACS context for an NPx1 grid ! ictxt : (Global Input)Integer BLACS context for an NPx1 grid
! required. ! required.
! !
! OUTPUT ! OUTPUT
@ -109,7 +109,7 @@ subroutine psb_cdrep(m, icontxt, desc_a, info)
use psb_error_mod use psb_error_mod
implicit None implicit None
!....Parameters... !....Parameters...
Integer, intent(in) :: m,icontxt Integer, intent(in) :: m,ictxt
integer, intent(out) :: info integer, intent(out) :: info
Type(psb_desc_type), intent(out) :: desc_a Type(psb_desc_type), intent(out) :: desc_a
@ -128,7 +128,7 @@ subroutine psb_cdrep(m, icontxt, desc_a, info)
err=0 err=0
name = 'psb_cdrep' name = 'psb_cdrep'
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
if (debug) write(*,*) 'psb_cdrep: ',nprow,npcol,myrow,mycol if (debug) write(*,*) 'psb_cdrep: ',nprow,npcol,myrow,mycol
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (npcol /= 1) then if (npcol /= 1) then
@ -160,9 +160,9 @@ subroutine psb_cdrep(m, icontxt, desc_a, info)
if (myrow.eq.psb_root_) then if (myrow.eq.psb_root_) then
exch(1)=m exch(1)=m
exch(2)=n exch(2)=n
call igebs2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo) call igebs2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo)
else else
call igebr2d(icontxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,& call igebr2d(ictxt,psb_all_,psb_topdef_, itwo,ione, exch, itwo, psb_root_,&
& 0) & 0)
if (exch(1) /= m) then if (exch(1) /= m) then
info=550 info=550
@ -212,8 +212,8 @@ subroutine psb_cdrep(m, icontxt, desc_a, info)
desc_a%matrix_data(psb_n_row_) = m desc_a%matrix_data(psb_n_row_) = m
desc_a%matrix_data(psb_n_col_) = n desc_a%matrix_data(psb_n_col_) = n
desc_a%matrix_data(psb_dec_type_) = psb_desc_repl_ desc_a%matrix_data(psb_dec_type_) = psb_desc_repl_
desc_a%matrix_data(psb_ctxt_) = icontxt desc_a%matrix_data(psb_ctxt_) = ictxt
call blacs_get(icontxt,10,desc_a%matrix_data(psb_mpi_c_)) call blacs_get(ictxt,10,desc_a%matrix_data(psb_mpi_c_))
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -221,7 +221,7 @@ subroutine psb_cdrep(m, icontxt, desc_a, 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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

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

@ -54,7 +54,7 @@ subroutine psb_cdtransfer(desc_in, desc_out, info)
!locals !locals
integer :: nprow,npcol,me,mypcol,& integer :: nprow,npcol,me,mypcol,&
& icontxt, isz, dectype, err_act, err & ictxt, isz, dectype, err_act, err
integer :: int_err(5),temp(1) integer :: int_err(5),temp(1)
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
logical, parameter :: debug=.false.,debugprt=.false. logical, parameter :: debug=.false.,debugprt=.false.
@ -65,9 +65,9 @@ subroutine psb_cdtransfer(desc_in, desc_out, info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
name = 'psb_cdtransfer' name = 'psb_cdtransfer'
icontxt=desc_in%matrix_data(psb_ctxt_) ictxt=desc_in%matrix_data(psb_ctxt_)
! check on blacs grid ! check on blacs grid
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
if (debug) write(0,*) me,'Entered CDTRANSFER' if (debug) write(0,*) me,'Entered CDTRANSFER'
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
@ -103,7 +103,7 @@ subroutine psb_cdtransfer(desc_in, desc_out, info)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(ictxt)
end if end if
return return

20
src/tools/psb_dallc.f90
Unescape Escape View File

@ -56,7 +56,7 @@ subroutine psb_dalloc(x, desc_a, info, n)
!locals !locals
integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,i,j,jj,err_act integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,i,j,jj,err_act
integer :: icontxt,dectype,n_ integer :: ictxt,dectype,n_
integer :: int_err(5),temp(1),exch(3) integer :: int_err(5),temp(1),exch(3)
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -68,9 +68,9 @@ subroutine psb_dalloc(x, desc_a, info, n)
int_err(1)=0 int_err(1)=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
@ -99,9 +99,9 @@ subroutine psb_dalloc(x, desc_a, info, n)
!global check on n parameters !global check on n parameters
if (myrow.eq.psb_root_) then if (myrow.eq.psb_root_) then
exch(1)=n_ exch(1)=n_
call igebs2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione) call igebs2d(ictxt,psb_all_,psb_topdef_, ione,ione, exch, ione)
else else
call igebr2d(icontxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0) call igebr2d(ictxt,psb_all_,psb_topdef_, ione,ione, exch, ione, psb_root_, 0)
if (exch(1).ne.n_) then if (exch(1).ne.n_) then
info=550 info=550
int_err(1)=1 int_err(1)=1
@ -147,7 +147,7 @@ subroutine psb_dalloc(x, desc_a, info, n)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return
@ -209,7 +209,7 @@ subroutine psb_dallocv(x, desc_a,info,n)
!locals !locals
integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,dectype,i,err_act integer :: nprow,npcol,myrow,mycol,err,n_col,n_row,dectype,i,err_act
integer :: icontxt, n_ integer :: ictxt, n_
integer :: int_err(5),temp(1),exch integer :: int_err(5),temp(1),exch
real(kind(1.d0)) :: real_err(5) real(kind(1.d0)) :: real_err(5)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
@ -220,9 +220,9 @@ subroutine psb_dallocv(x, desc_a,info,n)
name='psb_dallcv' name='psb_dallcv'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
call blacs_gridinfo(icontxt, nprow, npcol, myrow, mycol) call blacs_gridinfo(ictxt, nprow, npcol, myrow, mycol)
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (nprow.eq.-1) then if (nprow.eq.-1) then
info = 2010 info = 2010
@ -281,7 +281,7 @@ subroutine psb_dallocv(x, desc_a,info,n)
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(icontxt) call psb_error(ictxt)
return return
end if end if
return return

18
src/tools/psb_dasb.f90
Unescape Escape View File

@ -51,7 +51,7 @@ subroutine psb_dasb(x, desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! local variables ! local variables
integer :: err, icontxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act integer :: err, ictxt,nprow,npcol,me,mypcol,temp,lwork,nrow,ncol, err_act
integer :: int_err(5), i1sz, i2sz, dectype, i,j integer :: int_err(5), i1sz, i2sz, dectype, i,j
double precision :: real_err(5) double precision :: real_err(5)
real(kind(1.d0)),parameter :: one=1 real(kind(1.d0)),parameter :: one=1
@ -63,10 +63,10 @@ subroutine psb_dasb(x, desc_a, info)
name='psb_dasb' name='psb_dasb'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
dectype=desc_a%matrix_data(psb_dec_type_) dectype=desc_a%matrix_data(psb_dec_type_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
if ((.not.associated(desc_a%matrix_data))) then if ((.not.associated(desc_a%matrix_data))) then
info=3110 info=3110
@ -95,7 +95,7 @@ subroutine psb_dasb(x, desc_a, info)
endif endif
! check size ! check size
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
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_)
i1sz = size(x,dim=1) i1sz = size(x,dim=1)
@ -129,7 +129,7 @@ subroutine psb_dasb(x, desc_a, info)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(ictxt)
end if end if
return return
@ -187,7 +187,7 @@ subroutine psb_dasbv(x, desc_a, info)
integer, intent(out) :: info integer, intent(out) :: info
! local variables ! local variables
integer :: err, icontxt,nprow,npcol,me,mypcol,temp,lwork integer :: err, ictxt,nprow,npcol,me,mypcol,temp,lwork
integer :: int_err(5), i1sz,nrow,ncol, dectype, i, err_act integer :: int_err(5), i1sz,nrow,ncol, dectype, i, err_act
double precision :: real_err(5) double precision :: real_err(5)
real(kind(1.d0)),parameter :: one=1 real(kind(1.d0)),parameter :: one=1
@ -198,10 +198,10 @@ subroutine psb_dasbv(x, desc_a, info)
int_err(1) = 0 int_err(1) = 0
name = 'psb_dasbv' name = 'psb_dasbv'
icontxt=desc_a%matrix_data(psb_ctxt_) ictxt=desc_a%matrix_data(psb_ctxt_)
dectype=desc_a%matrix_data(psb_dec_type_) dectype=desc_a%matrix_data(psb_dec_type_)
call blacs_gridinfo(icontxt, nprow, npcol, me, mypcol) call blacs_gridinfo(ictxt, nprow, npcol, me, mypcol)
! ....verify blacs grid correctness.. ! ....verify blacs grid correctness..
if (nprow.eq.-1) then if (nprow.eq.-1) then
@ -252,7 +252,7 @@ subroutine psb_dasbv(x, desc_a, info)
if (err_act.eq.act_ret) then if (err_act.eq.act_ret) then
return return
else else
call psb_error(icontxt) call psb_error(ictxt)
end if end if
return return

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

Write Preview
Loading…
Cancel
Save